{ }
unit teapro91; { Copyright (c) 1997-2007 by D La Pierre Ballard }
{ Teapro9 uses the OpenTea technology to be simple and solid. }
{ Teapro9 uses the teaquad technology to find larger prime numbers. }
{ In today's world, we need computer software that actually works. }
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, Menus, StdCtrls, Math;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
btn_start: TButton;
menu_help: TMenuItem;
edit_input: TEdit;
menu_file: TMenuItem;
menu_view: TMenuItem;
menu_About: TMenuItem;
menu_Variables: TMenuItem;
menu_ProgramCode: TMenuItem;
menu_debug: TMenuItem;
menu_open: TMenuItem;
menu_exit: TMenuItem;
label_show: TLabel;
Pause1: TMenuItem;
menu_generalhelp: TMenuItem;
menu_help_commands: TMenuItem;
menu_help_running: TMenuItem;
{ programmer functions }
function fnd_modulus(
const dp_number : double;
const dp_divisor : double) : double;
function fnb_comm_dift : boolean;
function fnb_comm_sift : boolean;
function fnb_more(const ps1 : string) : boolean;
function fnd_decimal_eval(const pbyte_1 : byte) : double;
function fni_decimal_eval(const pbyte_1 : byte) : integer;
function fns_eliminate_blanks(const ps_rec : string) : string;
function fns_from_double(
const pd_num : double;
const pbyte_commas : byte) : string;
function fns_link_literal_numbers(const ps_rec : string) : string;
function fns_link_literal_strings(const ps_rec : string) : string;
function fni_link_last_endi(const pi_rec : integer) : integer;
function fns_blank_escapes(const ps1 : string) : string;
function fni_pattern(const pi_char : integer) : integer;
function fns_string_eval(const pbyte_1 : byte) : string;
function fns_string_parse(const ps1 : string) : string;
function fns_subroutine(const pi_line : integer) : string;
function fns_tpline_format(const ps1 : string) : string;
function fns_tplines_to_show(const pi1, pi2 : integer) : string;
function fni_yesnocancel(const ps1 : string) : integer;
{ programmer procedures }
procedure sub_about;
procedure sub_commands_to_int;
procedure sub_debug;
procedure sub_double_from_string(
const ps1 : string;
var pe2 : double;
var pb3 : boolean);
procedure sub_error_in_prog_line(const ps1 : string;
const pi2 : integer);
procedure sub_more_or_halt(const ps1 : string);
procedure sub_get_program_name;
procedure sub_help_commands;
procedure sub_help_general;
procedure sub_help_running;
procedure sub_initialize;
procedure sub_tpprog_build_array;
procedure sub_tpline_perform_new;
procedure sub_tpline_process;
procedure sub_tpline_split(var s_rec1, s_rec2 : string);
procedure sub_format_lines;
procedure sub_link_first_parameter;
procedure sub_link_dift_sift;
procedure sub_link_variable_names;
procedure sub_link_subroutines;
procedure sub_memo_show(const ps1 : string; const pbyte_2 : byte);
procedure sub_old_to_new;
procedure sub_prog_process;
procedure sub_program_error(const ps1 : string);
procedure sub_store_decimal(const pbyte_1 : byte; const pd_1 : double);
procedure sub_store_string(const pbyte_1 : byte; const ps_1 : string);
procedure sub_terminate;
procedure sub_view_code;
procedure sub_validate_commands;
procedure sub_validate_variables;
procedure sub_validate_semicolon(const pbyte_1 : byte);
procedure sub_validate_variable(
const pi1 : integer;
const ps2 : string);
procedure sub_validate_append(const pi1 : integer);
procedure sub_variables;
procedure sub_variables_info;
{ command procedures below }
procedure sub_comm_array(const pbyte_1 : byte);
procedure sub_comm_dchs;
procedure sub_comm_dfac;
procedure sub_comm_dfak;
procedure sub_comm_dpks;
procedure sub_comm_dpow;
procedure sub_comm_dset;
procedure sub_comm_dsin(const pbyte_1 : byte);
procedure sub_comm_dsys;
procedure sub_comm_dtof;
procedure sub_comm_dtos(const pbyte_1 : byte);
procedure sub_comm_dtoi(const pbyte_1 : byte);
procedure sub_comm_ends;
procedure sub_comm_evar;
procedure sub_comm_file(const pbyte_1 : byte);
procedure sub_comm_finp;
procedure sub_comm_fout;
procedure sub_comm_frea;
procedure sub_comm_fwri;
procedure sub_comm_fsip;
procedure sub_comm_fapp(const pbyte_1 : byte);
procedure sub_comm_sapp;
procedure sub_comm_sbak;
procedure sub_comm_schd;
procedure sub_comm_schs;
procedure sub_comm_scnt;
procedure sub_comm_scod;
procedure sub_comm_sdat;
procedure sub_comm_sdel;
procedure sub_comm_sdot;
procedure sub_comm_scut;
procedure sub_comm_sfix(const pbyte_1 : byte);
procedure sub_comm_sinp(const pbyte_1 : byte);
procedure sub_comm_sins;
procedure sub_comm_sisc;
procedure sub_comm_sisd;
procedure sub_comm_sist;
procedure sub_comm_slen(const pbyte_1 : byte);
procedure sub_comm_slok;
procedure sub_comm_soff;
procedure sub_comm_sout(const pbyte_1 : byte);
procedure sub_comm_spar;
procedure sub_comm_spkd;
procedure sub_comm_sisp;
procedure sub_comm_srep;
procedure sub_comm_sset;
procedure sub_comm_ssor;
procedure sub_comm_ssys;
procedure sub_comm_sswp;
procedure sub_comm_stod;
procedure sub_comm_stoe;
procedure sub_comm_stoi(const pbyte_1 : byte);
procedure sub_comm_itod;
procedure sub_comm_itos;
{ end programmer functions and subroutines }
procedure menu_exitClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure btn_startClick(Sender: TObject);
procedure edit_inputKeyPress(Sender: TObject; var Key: Char);
procedure About1Click(Sender: TObject);
procedure menu_ProgramCodeClick(Sender: TObject);
procedure menu_VariablesClick(Sender: TObject);
procedure menu_debugClick(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure menu_openClick(Sender: TObject);
procedure Pause1Click(Sender: TObject);
procedure menu_generalhelpClick(Sender: TObject);
procedure menu_help_commandsClick(Sender: TObject);
procedure menu_help_runningClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
const
{ programmer defined constants }
nl = Chr(10);
var
Form1: TForm1;
fs_tpprog_name : string;
fi_tpline_last : integer;
fd_total_lines : double;
fs_subr_name : string;
fi_max_length : integer;
fi_comment_ct : integer;
fi_subroutine_ct : integer;
fi_line : integer;
{ for input from edit_input }
fi_input : integer;
fs_input : string;
fb_string_input : boolean;
fb_program_loop : boolean;
fb_terminate : boolean;
fb_error : boolean;
{ debug }
fb_debug : boolean;
fsa_debug : array[1..16] of string;
{ these hold the variables for tpprog }
fea_var : array[1..2000] of double;
fsa_var : array[1..4000] of string;
fi_max_dvar : integer;
fi_max_svar : integer;
fea_array : array[1..8000] of double;
fsa_array : array[1..2000] of string;
fi_max_darray : integer;
fi_max_sarray : integer;
fi_dvar : integer;
fi_svar : integer;
fd_begin_time : double;
{ show on memo_show stack }
fsa_show : array[1..35] of string;
fi_show_lines : integer;
fb_show : boolean;
{ these hold the program and the linking }
fsa_tpline : array[1..15000] of string;
fs_tpline : string;
fi_tpline : integer;
fbytea_command : array[0..15000] of byte;
fia_link : array[1..15000] of integer;
fi_link : integer;
{ subroutine stack }
fia_sub : array[1..1000] of integer;
fii_sub : integer;
fi_max_sub : integer;
fia_primes : array[1..1000] of integer;
{ string dynamic memory stack }
fia_delta_s : array[1..1000] of integer;
fii_delta_s : integer;
fi_delta_s : integer;
fi_max_delta_s : integer;
{ decimal dynamic memory stack }
fia_delta_d : array[1..1000] of integer;
fii_delta_d : integer;
fi_delta_d : integer;
fi_max_delta_d : integer;
{ these hold the program information }
fi_prog_lines : integer;
fi_global_strings : integer;
fi_global_decimals : integer;
fi_literal_strings : integer;
fi_literal_decimals : integer;
{ untyped file processing }
fs_filename_1 : string;
fi_file_byte : integer;
implementation
{$R *.DFM}
procedure TForm1.sub_about;
{ updated 2007/01/20, 2007/01/19, 2006/08/24,
2005/09/07, 2005/04/29, 2005/03/29, 2005/03/22, 2004/04/17 }
var
sz : string;
begin
sz := '';
sz := sz
+ 'This computer program is the Teapro9 interpreter, '
+ 'teapro9.exe, build 364, 2007/10/16. '
+ 'which interprets the Teapro programming language. '
+ 'The Teapro programming language, '
+ 'was invented on 14-DEC-1997 and utilizes the '
+ 'OpenTea Technology. '
+ 'The Teapro9 interpreter was begun on 14-DEC-1997.' + nl + nl
+ 'The Teapro9 interpreter was programmed in '
+ 'Delphi 2.01, Developer Edition, '
+ 'copyright (c) 1983-1996, Borland International, Inc.' + nl + nl
+ 'The Teapro9 interpreter, teapro9.exe, may be used for free '
+ 'by anyone, but there is no warranty of any kind whatsoever '
+ 'on teapro9.exe.' + nl + nl
+ 'The Teapro programming language may be used for free '
+ 'by anyone, but there is no warranty of any kind whatsoever '
+ 'on Teapro.' + nl + nl
+ 'The Teapro programming language, teapro9.exe, '
+ 'the OpenTea Technology, and the teaquad method '
+ 'are all copyright (c) 1997-2007 '
+ 'by D La Pierre Ballard.' + nl + nl
+ 'Per the OpenTea technology Teapro is simple and solid. ' + nl + nl
+ 'In today''s world, we need computer software that actually works.'
+ nl + nl
+ 'Please e-mail your comments to: dlb@teapro.com' + nl + nl
+ 'Time at start='
+ DateTimeToStr(fd_begin_time) + nl
+ 'Lines done='
+ FloatToStrF(fd_total_lines, ffNumber, 16, 0) + nl
+ Application.Exename;
ShowMessage(sz);
end; { sub_about }
procedure TForm1.sub_tpline_process;
{ updated 2007/04/20, 2007/01/20, 2007/01/19 }
{ 2006/04/28, 2006/04/14, 2005/04/29, 2005/03/22, 2003/09/15 }
{ process the Teapro program }
var
iz : integer;
begin
{ if in input mode process the input }
if fb_string_input then sub_comm_sinp(5);
{ this is set to false when sub_terminate is called }
iz := 0;
fb_program_loop := true;
while fb_program_loop do
begin
{ inner loop }
Inc(iz);
if (iz > 1000) then
begin
Application.ProcessMessages;
iz := 0;
end;
fd_total_lines := fd_total_lines + 1;
if fb_debug then sub_debug;
{ perform the program line }
sub_tpline_perform_new;
{ increment to the next fi_tpline }
Inc(fi_tpline);
end; { fb_program_loop }
{ clear the edit_input }
edit_input.text := '';
end; { sub_tpline_process }
procedure TForm1.sub_tpline_perform_new;
{ updated 2007/04/15, 2007/04/14, 2007/01/19, 2006/06/02, 2006/05/12 }
{ 2006/04/29, 2006/04/14, 2005/06/20, 2005/03/22, 2004/10/19 }
{ perform the action, the new version }
var
s_string : string;
byte_command : byte;
begin
{ 12345678901234567890123 }
{ MOVE 12345n12345n12345n }
fs_tpline := fsa_tpline[fi_tpline];
byte_command := fbytea_command[fi_tpline];
fi_link := fia_link[fi_tpline];
{ Showmessage(fs_tpline + ' ' + IntToStr(byte_command)); }
{ s_commands := ''
+ 'DABS,DARC,DCH$,DDEC,DED$,DFAC,DIF1,'
+ 'DIFT,DINC,DLOG,DPK$,DPOW,DRAN,DROU,'
+ 'DSEC,DSET,DSIN,DTO$,DTOF,DTOI,DTRU,DWHI,'
+ 'ELSE,ENDI,ENDP,ENDS,ENDW,ESUB,XXXX,EVAR,'
+ 'ITO$,ITOD,'
+ '$APP,$BAK,$BES,$CH$,$CHD,$CLO,$CNT,$COD,$CUP,'
+ '$CUT,$DAT,$DEL,$DOT,$IF1,$IFT,$INP,$INS,$ISC,'
+ '$ISD,$ISP,$IST,$LEN,$LOK,$OFF,$OUT,$PAR,$PKD,'
+ '$REP,$SET,$SHO,$SOR,$SWP,$SYS,$TLO,$TOD,$TOI,'
+ '$TRB,$TRL,$TRR,$TUP,$WHI,'
+ 'FDAT,FDEL,FLEN,FREN,'
+ 'FINP,FOUT,'
+ 'FSIP,FAPP,FADD,'
+ 'FREA,FWRI,'
+ 'QAPP,QINP,QOUT,QSET,QTOI,'
+ 'XXXX,XXXX,XXXX,XXXX,XXXX,'
+ 'ARRZ,ARRB,ADDI,DSYS,DBAD,'
+ '$TOE,$HSH,DBUG,DFAK,GOTO,'
+ 'GTAG,SUBR,VARI';
}
Case byte_command of
1 : sub_store_decimal(6, Abs(fnd_decimal_eval(13))); { DABS }
2 : sub_comm_dsin(4); { DARC arc sine }
3 : sub_comm_dchs;
4 : { DDEC }
begin
if (fs_tpline[11] = 'D') then Inc(fi_link, fi_delta_d);
fea_var[fi_link] := fea_var[fi_link] - 1;
end;
5 : sub_comm_dtos(1); { DED$ }
6 : sub_comm_dfac;
7 : { DIF1 }
begin
if not fnb_comm_dift then Inc(fi_tpline);
end;
8 : { DIFT }
begin
if not fnb_comm_dift then fi_tpline := fi_link;
end;
9 : { DINC }
begin
if (fs_tpline[11] = 'D') then Inc(fi_link, fi_delta_d);
fea_var[fi_link] := fea_var[fi_link] + 1;
end;
10 : sub_comm_dsin(5); { log10 }
11 : sub_comm_dpks;
12 : sub_comm_dpow;
13 : sub_store_decimal(6, Random); { DRAN }
14 : sub_comm_dsin(1); { drou }
15 : { DSEC }
begin
{ 86400 = 60 * 60 * 24 and is the seconds / day }
sub_store_decimal(6, Now * 86400);
end;
16 : sub_comm_dset;
17 : sub_comm_dsin(3); { DSIN sine }
18 : sub_comm_dtos(0); { DTO$ }
19 : sub_comm_dtof; { DTOF }
20 : sub_comm_dtoi(1); { DTOI }
21 : sub_comm_dsin(2); { dtru }
22 : { DWHI }
begin
if not fnb_comm_dift then fi_tpline := fi_link;
end;
23 : { ELSE }
begin
fi_tpline := fi_link;
end;
24 : { ENDI }
begin
fi_tpline := fi_link;
end;
25 : sub_terminate;
26 : sub_comm_ends;
27 : { ENDW }
begin
fi_tpline := fi_link;
end;
28 : { ESUB }
begin
{ push into the sub stack where we have come from }
Inc(fii_sub);
if (fii_sub > fi_max_sub) then fi_max_sub := fii_sub;
fia_sub[fii_sub] := fi_tpline;
fi_tpline := fia_link[fi_tpline];
end;
30 : sub_comm_evar; { EVAR }
31 : sub_comm_itos;
32 : sub_comm_itod;
33 : sub_comm_sapp;
34 : sub_comm_sbak;
35 : sub_comm_sfix(3); { $BES }
36 : sub_comm_schs;
37 : sub_comm_schd;
38 : sub_comm_sfix(1); { $CLO }
39 : sub_comm_scnt;
40 : sub_comm_scod;
41 : sub_comm_sfix(2); { $CUP }
42 : sub_comm_scut;
43 : sub_comm_sdat;
44 : sub_comm_sdel;
45 : sub_comm_sdot;
46 : { $IF1 }
begin
if not fnb_comm_sift then Inc(fi_tpline);
end;
47 : { $IFT }
begin
if not fnb_comm_sift then fi_tpline := fi_link;
end;
48 : sub_comm_sinp(1); { $INP }
49 : sub_comm_sins;
50 : sub_comm_sisc;
51 : sub_comm_sisd;
52 : sub_comm_sisp;
53 : sub_comm_sist;
54 : sub_comm_slen(1); { $LEN }
55 : sub_comm_slok;
56 : sub_comm_soff;
57 : sub_comm_sout(1); { $OUT }
58 : sub_comm_spar;
59 : sub_comm_spkd;
60 : sub_comm_srep;
61 : sub_comm_sset;
62 : sub_comm_sout(2); { $SHO }
63 : sub_comm_ssor; { $SOR }
64 : sub_comm_sswp; { $SWP }
65 : sub_comm_ssys;
66 : sub_comm_sfix(7); { $TLO }
67 : sub_comm_stod;
68 : sub_comm_stoi(1); { $TOI }
69 : sub_comm_sfix(4); { $TRB }
70 : sub_comm_sfix(5); { $TRL }
71 : sub_comm_sfix(6); { $TRR }
72 : sub_comm_sfix(8); { $TUP }
73 : { $WHI }
begin
if not fnb_comm_sift then fi_tpline := fi_link;
end;
74 : sub_comm_file(1); { FDAT }
75 : sub_comm_file(2); { FDEL }
76 : sub_comm_file(3); { FLEN }
77 : sub_comm_file(4); { FREN }
78 : sub_comm_finp;
79 : sub_comm_fout;
80 : sub_comm_fsip;
81 : sub_comm_fapp(1); { FAPP }
82 : sub_comm_fapp(2); { FADD }
83 : sub_comm_frea;
84 : sub_comm_fwri;
95 : sub_comm_array(1); { ARRZ }
96 : sub_comm_array(2); { ARRB }
97 : sub_comm_dtoi(2); { ADDI }
98 : sub_comm_dsys; { DSYS }
99 : { DBAD }
begin
if fnb_comm_dift then
sub_program_error('bad data error');
end;
100: sub_comm_stoe; { $TOE }
101: sub_comm_slen(2); { $HSH }
102 : { DBUG }
begin
if fb_debug then fb_debug := false
else fb_debug := true;
end;
103: sub_comm_dfak; { DFAK }
104: fi_tpline := fi_link; { GOTO }
105: ;{ GTAG }
{ SUBR,VARI should not occur }
else
sub_debug;
end;
end; { sub_tpline_perform_new }
procedure TForm1.sub_debug;
{ updated 2003/12/15 }
var
s_out : string;
b_good : boolean;
iz, iy, ix : integer;
sz : string;
begin
if (fi_tpline < 1) then fi_tpline := 1;
{ move lines performed up one twice }
for iz := 1 to 15 do fsa_debug[iz] := fsa_debug[Succ(iz)];
fsa_debug[15] := IntToStr(fi_tpline) + ': '
+ fsa_tpline[fi_tpline];
{ prep dialog box output }
s_out := '';
for iz := 1 to 16 do
begin
if (Length(fsa_debug[iz]) > 0) then
s_out := s_out + fsa_debug[iz] + nl;
end;
{ get variables in fsa_tpline }
s_out := s_out + nl;
fs_tpline := fsa_tpline[fi_tpline];
for iz := 1 to Length(fs_tpline) do
begin
sz := Copy(fs_tpline, iz, 5);
b_good := true;
for iy := 1 to 5 do
begin
if (Pos(sz[iy], '0123456789') = 0) then b_good := false;
end;
if b_good then
begin
sz := fns_string_eval(iz);
if (Length(sz) > 50) then sz := Copy(sz, 1, 50);
s_out := s_out + Copy(fs_tpline, iz, 6) + '=' + sz + nl;
end;
end;
{ add on other information }
s_out := s_out
+ nl
+ fns_subroutine(fi_tpline)
+ ', fi_tpline=' + IntToStr(fi_tpline)
+ ', fi_link=' + IntToStr(fia_link[fi_tpline])
+ ', fi_delta_d=' + IntToStr(fi_delta_d)
+ ', fi_delta_s=' + IntToStr(fi_delta_s) + nl
+ 'global decimals='
+ IntToStr(fi_global_decimals + fi_literal_decimals)
+ ', global strings='
+ IntToStr(fi_global_strings + fi_literal_strings)
+ ', Lines done = '
+ FloatToStrF(fd_total_lines, ffNumber, 16, 0)
+ nl + nl
+ 'Yes=Continue, No=Variables, Ok=Code, Cancel=Debug off, '
+ 'Abort=End Program';
iz := MessageDlg(s_out, mtCustom, [mbYes,mbNo,mbOk,mbCancel,mbAbort], 0);
if (iz = mrNo) then sub_variables;
if (iz = mrOk) then sub_view_code;
if (iz = mrCancel) then fb_debug := false;
if (iz = mrAbort) then sub_terminate;
end; { sub_debug }
procedure TForm1.sub_program_error(const ps1 : string);
{ updated 2004/05/17 }
var
i_beg, i_end : integer;
iz : integer;
sz : string;
begin
sz := 'program error: ' + ps1 + ' in following line.' + nl
+ IntToStr(fi_tpline) + ': '
+ fsa_tpline[fi_tpline] + nl;
i_beg := fi_tpline - 8;
i_end := fi_tpline + 8;
sz := sz + nl + fns_tplines_to_show(i_beg, i_end);
sz := sz
+ 'ok = skip this line, '
+ 'yes = debug, '
+ 'abort = terminate the program.';
iz := MessageDlg(sz, mtCustom, [mbOk,mbYes,mbAbort], 0);
fb_error := true;
if (iz = mrAbort) then sub_terminate;
if (iz = mrYes) then sub_debug;
end; { sub_program_error }
procedure TForm1.sub_help_general;
{ updated 2006/06/11, 2006/06/09, 2004/04/24 }
var
iz : integer;
s_dashline : string;
sz : string;
b_more : boolean;
begin
s_dashline := nl + StringOfChar('-', 20) + nl;
b_more := true;
sz := '';
sz := sz
+ 'A Teapro program is a text file which has been '
+ 'created using any editor or word processor. '
+ 'The extension on the name of a Teapro program can be .tea '
+ 'or since it is a text file .txt will work too. '
+ 'The Teapro programming language is an extremely small '
+ 'and simple language which is '
+ 'interpreted rather than compiled. '
+ 'The Teapro9 interpreter, teapro9.exe, is small and uses '
+ 'few resources. '
+ 'However, complex programming can be done easily in '
+ 'Teapro since Teapro has very powerful '
+ 'string, number, file handling and control commands. '
+ 'A Teapro program may have as many as a total of '
+ '15000 lines of code. '
+ 'The Teapro language follows the OpenTea technology '
+ 'of simplicity, safety, and solidity.';
if b_more then b_more := fnb_more(sz);
sz := '';
sz := sz
+ 'A Teapro program consists of lines each of which '
+ 'has a Teapro command which is usually '
+ 'followed by some comma separated parameters. '
+ 'The parameters are variables, constants and operators. '
+ 'Variables can either be global or local. '
+ 'A global variable '
+ 'can be seen by all of the subroutines in the Teapro '
+ 'program. '
+ 'Local variables can be seen only in the subroutine '
+ 'in which they are defined. '
+ 'Global variables are defined at the top of a Teapro '
+ 'program. '
+ 'Local variables are defined at the top of the '
+ 'subroutine in which they are used. '
+ 'In both cases the '
+ 'command used to create the variables is VARI. '
+ s_dashline
+ 'There are two types of variables: string and decimal. '
+ 'Global string variables begin with "sg_" while global '
+ 'decimal variables begin with "dg_". '
+ 'Local string variables begin with "s_", '
+ 'and local decimal variables '
+ 'begin with "d_". '
+ 'In each case, the rest of the variable name can be '
+ 'letters or numbers. '
+ 'A variable name must be from 5 to '
+ '64 long. '
+ 'Variable names which overlap within a subroutine '
+ 'are not allowed. For example: d_byte and d_bytes '
+ 'cannot both be used in the same subroutine. '
+ s_dashline
+ 'In Teapro programs '
+ 'commands and variables may be upper or lower case since '
+ 'case is not significant. '
+ 'In the examples which follow upper case is used for '
+ 'emphasis for Teapro commands but variables are in lower case. '
+ 'Most Teapro programmers use all lower case. '
+ 'Spaces may be placed between the parameters to '
+ 'make the lines more readable. '
+ 'Indentation may be used for lines inside of control structures '
+ 'to make the appearance of the program better.';
if b_more then b_more := fnb_more(sz);
sz := '';
sz := sz
+ 'Here is a small Teapro program that uses the global decimal '
+ 'variable dg_count to count the number of times that the '
+ 'local variable string s_line is shown on the screen. '
+ 'The variable s_line is set to the string "Hello there" '
+ 'and is shown three '
+ 'times each time the subroutine sub_show is called. '
+ 'In the subroutine sub_show the local '
+ 'decimal variable d_decimal '
+ 'is used to count the number of times the while loop loops. '
+ 'The string is shown a total of six times and then the '
+ 'count is shown also. ' + nl + nl
+ 'VARI dg_count' + nl
+ 'sub_main' + nl
+ 'ENDP' + nl
+ 'SUBR sub_main' + nl
+ ' VARI s_string' + nl
+ ' dg_count = 0' + nl
+ ' sub_show' + nl
+ ' sub_show' + nl
+ ' $INP s_string, "The count is=" + dg_count' + nl
+ 'ENDS sub_main' + nl
+ 'SUBR sub_show' + nl
+ ' VARI s_line, d_decimal' + nl
+ ' s_line = "Hello there"' + nl
+ ' d_decimal = 0' + nl
+ ' DWHI d_decimal < 3' + nl
+ ' $OUT s_line' + nl
+ ' DINC d_decimal' + nl
+ ' DINC dg_count' + nl
+ ' ENDW' + nl
+ 'ENDS sub_show';
if b_more then b_more := fnb_more(sz);
sz := '';
sz := sz
+ 'In the examples and help showing the different '
+ 'commands in the Teapro programming language some rather general '
+ 'names are used for variables. '
+ 'Names like s_string, s_whole, s_part, s_new, and s_old '
+ 'are used for string variables. '
+ 'Names like d_decimal, d_long and d_byte '
+ 'are used for decimal variables. '
+ 'In some cases a variable used as a parameter in a Teapro '
+ 'command gives a value to be used when the command '
+ 'is performed, '
+ 'in some cases a variable recieves a value when '
+ 'the command is performed, and in '
+ 'some cases a variable both gives '
+ 'and recieves a value.'
+ s_dashline
+ 'String variables may be upto 60,000,000 bytes in length, '
+ 'if the memory of your computer will handle that. '
+ 'Trying to create a string longer than that will '
+ 'cause an error.'
+ s_dashline
+ 'Decimal numbers may be positive or negative with up to '
+ '15 digits and with the decimal point '
+ 'almost anywhere. '
+ 'Decimal literals ie. 123.45 or 5 or +1.5 or -12 etc. '
+ 'may be preceded by a plus + sign or a negative - sign. '
+ 'The + or - sign is considered to be part of the literal '
+ 'number. '
+ 'A numeric variable cannot be preceded by a + or - sign '
+ 'to change its sign.' + nl
+ 'proper is: d_any = d_any * d_dot * -1' + nl
+ 'improper is: d_any = d_any * - d_dot'
+ s_dashline
+ 'A literal value may be used for a parameter instead of a '
+ 'variable if that parameter '
+ 'gives a value to be used by the Teapro command rather '
+ 'than that that parameter receives a value.' + nl
+ 'String literals are enclosed in either double quotes '
+ 'ie. "string" or number signs ie. #string#.';
if b_more then b_more := fnb_more(sz);
sz := '';
sz := sz
+ 'Notice in the Teapro commands that in the command '
+ 'name movement is usually left to right. '
+ 'However, in the parameters of the '
+ 'command, movement is usually right to left. '
+ 'For example, consider the command $TOD.'
+ 'In the command name, it is string to decimal, left to right. '
+ 'In the parameters, $TOD d_decimal, s_string, '
+ 'the movement is from s_string to d_decimal '
+ 'or from right to left. '
+ 'This rule will help you '
+ 'to understand many of the Teapro commands.'
+ s_dashline
+ 'If the command is $APP,$OUT,$SHO, or $INP then the right '
+ 'most parameter may be a string append expression. '
+ 'A string assignment command is the same. '
+ 'A string append expression example is to use "c" + "at" '
+ 'instead of "cat". The terms in a string append expression '
+ 'may be string literals, string variables, decimal literals, '
+ 'or decimal variables.';
if b_more then b_more := fnb_more(sz);
sz := '';
sz := sz
+ 'One thing is very different in Teapro than in other '
+ 'languages: numerical assignment commands are evaluated '
+ 'strictly left to right in Teapro whereas in other languages '
+ 'the are evaluated as though they were algebraic expressions. '
+ 'In a decimal assigment line the terms on the right side of '
+ 'the equal sign may be literal decimals or variable decimals. '
+ 'A literal decimal number may have a plus sign '
+ 'or a minus sign '
+ 'in front to denote its sign.'
+ s_dashline
+ 'Comment lines can be added to a Teapro program by beginning '
+ 'them with a apostrophe, ie. ''. '
+ 'Blank lines can be used '
+ 'to make the Teapro program more readable. '
+ 'Comment lines and blank lines '
+ 'are completely ignored by the Teapro interpreter. '
+ s_dashline
+ 'In Teapro a serious program error such as a zero '
+ 'divide will bring up a dialog box to inform the '
+ 'user and to give the user the choice of trying to '
+ 'continue or aborting.';
if b_more then b_more := fnb_more(sz);
end; { sub_help_general }
procedure TForm1.sub_help_commands;
{ updated 2007/06/16, 2007/05/06 }
{ 2007/04/28, 2007/04/16, 2007/04/14, 2007/03/04, 2007/01/19 }
{ 2006/06/11, 2006/06/09, 2006/06/02, 2006/05/23, 2006/05/14 }
{ 2006/05/12, 2006/04/30, 2006/04/29, 2006/04/28, 2006/04/14 }
{ 2005/06/20, 2005/04/18, 2005/04/16, 2005/03/23, 2004/10/20 }
var
s_heading : string;
s_dashline : string;
sz : string;
b_more : boolean;
begin
s_dashline := nl + StringOfChar('-', 20) + nl;
s_heading := 'Teapro string commands';
b_more := true;
sz := s_heading;
sz := sz
+ s_dashline
+ 's_str1 = s_str2 + "string" + d_dec1 + -3' + nl
+ 'String assignment command. Append s_str2 and "string" '
+ 'and d_dec1 and -3 and put into s_str1. In the string '
+ 'assignment command the part to the right of the equal '
+ 'sign is a string append expression. '
+ 'Strings may be 60,000,000 bytes long.'
+ s_dashline
+ '$APP s_string1, s_string2 + s_string3' + nl
+ 'String append. In the string append command, the part '
+ 'to the right of the comma is a string append expression. '
+ 'Evaluate it and append it to the right side of s_string1.'
+ s_dashline
+ '$BAK d_byte, s_whole, d_start, s_part' + nl
+ 'Lookup string s_part in string s_whole starting at byte '
+ 'd_start looking backwardly and put the result in d_byte. '
+ 'If not found put zero in d_byte.'
+ s_dashline
+ '$BES s_new, s_old' + nl
+ 'Blank escape characters in s_old '
+ 'and store in s_new. '
+ 'Escape characters are < 32.'
+ s_dashline
+ '$CH$ s_new, s_char, d_long' + nl
+ 'Make string s_new from d_long of the first character '
+ 'of string s_char.'
+ s_dashline
+ '$CHD d_char, s_char' + nl
+ 'Put char number of first character of s_char into d_char.';
if b_more then b_more := fnb_more(sz);
sz := s_heading;
sz := sz
+ s_dashline
+ '$CLO s_new, s_old' + nl
+ 'Make s_old lower case and store in s_new.'
+ s_dashline
+ '$CNT d_count, s_string, s_find' + nl
+ 'Put count of occurrences of s_find in s_string into '
+ 'd_count. Occurrences cannot overlap.'
+ s_dashline
+ '$COD s_new, s_old' + nl
+ 'Code s_old to s_new. Code and decode are the same.'
+ s_dashline
+ '$CUP s_new, s_old' + nl
+ 'Make s_old upper case and store in s_new.'
+ s_dashline
+ '$CUT s_part, s_whole, d_start, d_long' + nl
+ 'Cut from s_whole at d_start for length d_long and '
+ 'put in s_part.'
+ s_dashline
+ '$DAT s_date' + nl
+ 'Put date and time string into s_date in format:' + nl
+ '25-SEP-1998 20:20:36 19980925202036';
if b_more then b_more := fnb_more(sz);
sz := s_heading;
sz := sz
+ s_dashline
+ '$DEL s_whole, d_start, d_long' + nl
+ 'Delete d_long bytes from s_whole at d_start'
+ s_dashline
+ '$DOT d_dot, s_string1, s_string2, d_count' + nl
+ 'Find dot = byte of occurrence d_count of s_string2 '
+ 'in s_string1. Occurrences cannot overlap. If not found '
+ 'put zero into d_dot.'
+ s_dashline
+ '$HSH d_hash, s_string' + nl
+ 'Find hash number d_hash for string s_string.'
+ s_dashline
+ '$IFT s_str1 > s_str2' + nl
+ '$IFT s_str1 > s_str2: d_dec1 = 3' + nl
+ 'If s_str1 is greater than s_str2 then perform the '
+ 'lines of the program until the matching ELSE or ENDi is found. '
+ 'Or, in the second case if the condition is true '
+ 'perform the non-control command beyond the colon.'
+ s_dashline
+ '$INP s_input, s_output' + nl
+ 'Output s_output and then input line from user into s_input. '
+ 'For security the maximum length of s_input is 100 bytes.'
+ s_dashline
+ '$INS s_whole, d_byte, s_part' + nl
+ 'Insert s_part into s_whole starting at d_byte. If d_byte '
+ '< 1 or d_byte > 1 plus length of s_whole then error.'
+ s_dashline
+ '$ISC d_yesno, s_string, s_char' + nl
+ 'String is made up of certain char. If s_string is made up of '
+ 'the first char of s_char then put 1 in d_yesno else 2.';
if b_more then b_more := fnb_more(sz);
sz := s_heading;
sz := sz
+ s_dashline
+ '$ISD d_yesno, s_number' + nl
+ 'If s_number can be converted to a decimal value put 1 '
+ 'in d_yesno. Otherwise put 2 in d_yesno.'
+ s_dashline
+ '$ISP d_yesno, s_string, s_pattern' + nl
+ 'String pattern char type compare of s_string and s_pattern. '
+ 'Char types: escapes, blank, punctuation, numbers, uppers, '
+ 'lowers, char > 126. If match put 1 in d_yesno else 2. '
+ '"123x?" matches "999z.". Lengths of the two must match too.'
+ s_dashline
+ '$IST d_yesno, s_string, s_type' + nl
+ 'String is made up of char type of first character of s_type. '
+ 'Char types: escapes, blank, punctuation, numbers, uppers, '
+ 'lowers, char > 126. If match put 1 in d_yesno else 2. '
+ '"12345" matches "9" and ",./[}" matches "*".'
+ s_dashline
+ '$LEN d_long, s_string' + nl
+ 'Put length of s_string into d_long.'
+ s_dashline
+ '$LOK d_byte, s_whole, d_start, s_part' + nl
+ 'Lookup string s_part in s_whole starting at byte '
+ 'd_start looking forward. If found put which byte in d_byte. '
+ 'If not found put zero in d_byte.'
+ s_dashline
+ '$OFF s_result, s_string, d_long' + nl
+ 'Cut off string end, put string of length d_long '
+ 'from end of s_string into s_result.';
if b_more then b_more := fnb_more(sz);
sz := s_heading;
sz := sz
+ s_dashline
+ '$OUT s_output' + nl
+ 'Output s_output which may be an append string. '
+ '$OUT drops to the next line before outputting. '
+ 'Characters < 32 are replaced with blanks.'
+ s_dashline
+ '$PAR s_toextract, s_csv, s_char, d_which' + nl
+ 'String parse. '
+ 'Extract string s_toextract from the character separated value '
+ 'string s_csv as indicated by number d_which. '
+ 'Strings in s_csv are separated by occurrences of s_char. '
+ 'The length of s_char must be 1. '
+ 'If d_which=1 return the string ending with the first '
+ 'occurrence of s_char in s_csv. '
+ 'if d_which=6 return the string ending with the sixth s_char.'
+ s_dashline
+ '$PKD d_yesno, d_number, s_packed' + nl
+ 'String packed to decimal. Change s_packed in '
+ 'packed decimal format to d_number. Decimal '
+ 'd_number will be a whole number. '
+ 'A packed number is also called BCD or binary coded decimal. '
+ 'If s_packed is valid put 1 in d_yesno else 2.'
+ s_dashline
+ '$REP s_whole, d_byte, s_part' + nl
+ 'Replace part of s_whole starting at d_byte with s_part. '
+ 'If d_byte < 1 '
+ 'or d_byte > 1 plus length of s_whole or s_part will not fit '
+ 'in s_whole then error.'
+ s_dashline
+ '$SHO s_output' + nl
+ 'Output s_output which may be a string append expression. '
+ '$SHO does not drop to the next line before outputting. '
+ 'Characters < 32 are replaced with blanks.';
if b_more then b_more := fnb_more(sz);
sz := s_heading;
sz := sz
+ s_dashline
+ '$SOR s_new, s_old, d_long' + nl
+ 'Sort lengths of d_long in s_old and put into s_new.'
+ s_dashline
+ '$SWP s_string, s_old, s_new' + nl
+ 'String swap. In s_string replace each occurrence of s_old with '
+ 's_new.'
+ s_dashline
+ '$SYS s_info, d_which' + nl
+ 'System or program information into s_info depending on d_which.'
+ nl
+ '1 = path and filename of this running Teapro9 interpreter' + nl
+ '2 = current subroutine'
+ s_dashline
+ '$TLO s_new, s_old' + nl
+ 'Trim low. Trim s_old and make lower case. Put into s_new.'
+ s_dashline
+ '$TOD d_number, s_number' + nl
+ 'String to decimal number. '
+ 'If string s_number can be converted to a valid decimal '
+ 'number put that number in d_number. If not give an error.'
+ s_dashline
+ '$TOE s_new, s_old, s_key, d_which' + nl
+ 'String to encoded. '
+ 'Encode s_old to s_new using keyword s_key. If d_which=1 '
+ 'encode, else decode.'
+ s_dashline
+ '$TOI d_index, s_string' + nl
+ 'String to index. Store the string s_string in the '
+ 'string array at index d_index. The string array has '
+ '2000 elements ranging from index 1 to index 2000.';
if b_more then b_more := fnb_more(sz);
sz := s_heading;
sz := sz
+ s_dashline
+ '$TRB s_new, s_old' + nl
+ 'Trim blanks and escape characters from both sides '
+ 'of s_old and store in s_new.'
+ s_dashline
+ '$TRL s_new, s_old' + nl
+ 'Trim blanks and escape characters from left side '
+ 'of s_old and store in s_new.'
+ s_dashline
+ '$TRR s_new, s_old' + nl
+ 'Trim blanks and escape characters from right side '
+ 'of s_old and store in s_new.'
+ s_dashline
+ '$TUP s_new, s_old' + nl
+ 'Trim upper case. Trim and make upper case s_old '
+ 'and store in s_new.'
+ s_dashline
+ '$WHI s_string1 > s_string2' + nl
+ 'String while. The while loop ends with ENDW. '
+ 'It continues looping while the comparison is true.'
+ s_dashline
+ 'ITO$ s_string, d_index' + nl
+ 'Index to string. Get the string at the index d_index '
+ 'from the string array and store it in s_string. '
+ 'The string array has 2000 elements ranging from index '
+ '1 to index 2000.'
+ s_dashline
+ 'ARRB' + nl
+ 'Blank string array of 2000 indexed strings. '
+ 'Use command ARRZ to zero the decimal array.';
if b_more then b_more := fnb_more(sz);
s_heading := 'Teapro decimal commands';
sz := s_heading;
sz := sz
+ s_dashline
+ 'd_dec1 = + d_dec2 - d_dec3 ? 3 * d_dec4 / d_dec5 % d_dec6 * -1 '
+ '@ 2'
+ nl + nl
+ 'Start with d_dec2, subtract d_dec3, truncate to 3 decimals, '
+ 'multiply by d_dec4, '
+ 'divide by d_dec5, do mod d_dec6, multiply by -1, '
+ 'round to 2 decimals '
+ 'and put the result in d_dec1.' + nl
+ 'Assignment arithmetic is evaluated left to right. '
+ 'Decimal variables or numeric literals are used. '
+ 'Decimal number literals may have a + or - sign. '
+ 'A data error brings up the Data Error dialog box.'
+ s_dashline
+ 'DABS d_result, d_number' + nl
+ 'Absolute value. Put absolute value of d_number '
+ 'into d_result.'
+ s_dashline
+ 'DARC d_radians, d_sine' + nl
+ 'Sine to radians. An sine of an angle is in '
+ 'd_sine. Put the angle in radians in d_radians.';
if b_more then b_more := fnb_more(sz);
sz := s_heading;
sz := sz
+ s_dashline
+ 'DBAD d_num1 > d_num2' + nl
+ 'Bad decimal variable value test. '
+ 'If the condition is true then bad. '
+ 'If bad then show the data error dialog box.'
+ s_dashline
+ 'DBUG' + nl
+ 'Toggles DEBUG on and off.'
+ s_dashline
+ 'DCH$ s_string, d_char, d_long' + nl
+ 'Make s_string from character d_char of length d_long.'
+ s_dashline
+ 'DDEC d_decimal' + nl
+ 'Decrement d_decimal by 1.';
if b_more then b_more := fnb_more(sz);
sz := s_heading;
sz := sz
+ s_dashline
+ 'DED$ s_number, d_number, d_long, d_places' + nl
+ 'Edit decimal number d_number into string of at least '
+ 'length d_long. The number of decimal places is d_places. '
+ 'The number is right justified in the string. '
+ 'Commas are inserted.'
+ s_dashline
+ 'DFAC d_factor, d_number' + nl
+ 'Factor or test for prime. '
+ 'Round d_number to an integer. '
+ 'Test d_number for its lowest integer factor. '
+ 'Put the lowest factor in d_factor. '
+ 'If d_factor is 1 then d_number is prime.'
+ s_dashline
+ 'DFAK d_factor, d_1quadpart, d_1quadmult' + nl
+ 'Factor or test for prime. '
+ 'Test d_number = d_1quadpart + d_1quadmult * d_1quadnum '
+ 'where d_1quadnum is 1 quadrillion or 1E15. '
+ 'Put the lowest factor in d_factor. '
+ 'If d_factor is 1 then d_number is prime. '
+ 'The teaquad method is used here.'
+ s_dashline
+ 'DIFT d_dec1 < d_dec2' + nl
+ 'DIFT d_dec1 < d_dec2: d_dec3 = 4' + nl
+ 'Begin an if block of lines which will end with endi. '
+ 'Or, put a colon and one non-control command to do if '
+ 'the if is true.'
+ s_dashline
+ 'DINC d_decimal' + nl
+ 'Increment d_decimal by 1.'
+ s_dashline
+ 'DLOG d_log, d_decimal' + nl
+ 'Find common logarithm base=10 of '
+ 'd_decimal and put into d_log.'
+ s_dashline
+ 'DPK$ s_packed, d_decimal, d_long' + nl
+ 'Decimal to packed format in string. Change d_decimal to '
+ 'a zero filled packed decimal string s_packed '
+ 'of length d_long. Decimal d_decimal is rounded to '
+ 'a whole number first. '
+ 'A packed number is also called BCD or binary coded decimal.';
if b_more then b_more := fnb_more(sz);
sz := s_heading;
sz := sz
+ s_dashline
+ 'DPOW d_result, d_number, d_power' + nl
+ 'Raise d_number to power d_power and put in d_result. '
+ 'd_number must be greater than zero.'
+ s_dashline
+ 'DRAN d_decimal' + nl
+ 'Put random decimal number between 0 and 1 in d_decimal.'
+ s_dashline
+ 'DROU d_dec1, d_dec2' + nl
+ 'Round d_dec2 and put into d_dec1. Round a decimal '
+ 'value of .5 away from zero.'
+ s_dashline
+ 'DSEC d_sec' + nl
+ 'Seconds since midnight of 30-DEC-1899 go into d_sec.'
+ s_dashline
+ 'DSIN d_sine, d_radians' + nl
+ 'Radians to the sine. An angle in radians is in '
+ 'd_radians. Put sine of that angle in d_sine.'
+ s_dashline
+ 'DSYS d_info, d_which' + nl
+ 'Decimal system info to d_info depending on d_which. '
+ 'If d_which=1 put total of string lengths in d_info. '
+ 'If d_which=2 put total lines run into d_info.'
+ s_dashline
+ 'DTO$ s_number, d_decimal, d_long, d_places' + nl
+ 'Make decimal d_decimal into a string of at least length '
+ 'd_long with the number of decimal places as d_places. '
+ 'The number is right justified in the string. '
+ 'No commas are inserted.';
if b_more then b_more := fnb_more(sz);
sz := s_heading;
sz := sz
+ s_dashline
+ 'DTOF s_field, d_decimal, d_long' + nl
+ 'Decimal to field. Convert decimal d_decimal to a string '
+ 'of length d_long beginning with + or -, right justified '
+ 'and zero filled.'
+ s_dashline
+ 'DTOI d_index, d_dec2' + nl
+ 'Decimal to index. Store the decimal d_dec2 in the '
+ 'decimal array at index d_index. The decimal array has '
+ '8000 elements ranging from index 1 to index 8000.'
+ s_dashline
+ 'DTRU d_dec1, d_dec2' + nl
+ 'Truncate d_dec2 and put in d_dec1. Variable d_dec1 '
+ 'will be an integer closer to zero than d_dec1.'
+ s_dashline
+ 'DWHI d_dec1 < d_dec2' + nl
+ 'Begin a while loop which will end with endw.'
+ s_dashline
+ 'ITOD d_dec1, d_index' + nl
+ 'Index to decimal. Get the decimal at the index '
+ 'd_index from the decimal array and store it in '
+ 'd_dec1. The decimal array has 8000 elements ranging '
+ 'from index 1 to index 8000.'
+ s_dashline
+ 'ADDI d_index, d_decimal' + nl
+ 'Decimal add to decimal array at index. '
+ 'Add the decimal d_decimal to the '
+ 'decimal array at index d_index. The decimal array has '
+ '8000 elements ranging from index 1 to index 8000.'
+ s_dashline
+ 'ARRZ' + nl
+ 'Zero the decimal array of 8000 indexed decimals. '
+ 'Use command ARRB to blank the string array.';
if b_more then b_more := fnb_more(sz);
sz := 'Teapro control commands';
sz := sz
+ s_dashline
+ 'DIFT, DWHI, $IFT, and $WHI' + nl
+ 'See these decimal and string commands.' + nl
+ 'ELSE : else is used in DIFT or $IFT blocks.' + nl
+ 'ENDI : ends an DIFT or a $IFT block.' + nl
+ 'ENDP : end of the program.' + nl
+ 'ENDS : end of the subroutine.' + nl
+ 'ENDW : end of a DWHI or $WHI block.' + nl
+ 'GOTO tag_loop : goto where GTAG tag_loop is.' + nl
+ 'GTAG tag_loop : line where GOTO tag_loop goes.' + nl
+ 'sub_main : exit to subroutine sub_main.' + nl
+ 'SUBR sub_main : beginning line of sub_main.';
if b_more then b_more := fnb_more(sz);
sz := 'Teapro file commands';
sz := sz
+ s_dashline
+ 'FDAT d_date, s_date, s_filename' + nl
+ 'Put the decimal file date in d_date. '
+ 'Put the string file date in s_date. '
+ 'If the file does not exist put in a 0 '
+ 'and a nothing.'
+ s_dashline
+ 'FDEL d_yes, s_filename' + nl
+ 'Delete the file named in s_filename. If deleted put '
+ '1 in d_yes else put 2 in d_yes.'
+ s_dashline
+ 'FLEN d_long, s_filename' + nl
+ 'Put the length of file s_filename into d_long. '
+ 'If the file cannot be accessed in -1.'
+ s_dashline
+ 'FREN d_yes, s_newname, s_oldname' + nl
+ 'Rename file s_oldname to s_newname. If renamed put'
+ '1 in d_yes else put 2 in d_yes.';
if b_more then b_more := fnb_more(sz);
sz := 'Teapro file processing commands';
sz := sz
+ s_dashline
+ 'FINP s_string, s_filename' + nl
+ 'File input, read the whole file s_filename '
+ 'into the string s_string.'
+ s_dashline
+ 'FOUT d_bytes, s_filename, s_string' + nl
+ 'File output, write the string s_string '
+ 'to make the whole file s_filename. The number of '
+ 'bytes written is put in d_bytes.'
+ s_dashline
+ 'FREA s_record, s_filename, d_byte, d_long' + nl
+ 'File get record, read s_filename at d_byte for '
+ 'length d_long and put in string s_record. '
+ 'Files begin at byte 1. d_long cannot be over 4096. '
+ 'String s_record may be shorter than d_long. '
+ 'Determine the success of FREA by the length of s_record. '
+ 'FREA and FWRI work well on any type of file.'
+ s_dashline
+ 'FWRI d_length, s_filename, d_byte, s_record' + nl
+ 'File put record, write s_record to file s_filename '
+ 'at d_byte and put the '
+ 'length written into d_length. Files begin '
+ 'at byte 1. s_record cannot be longer than 4096.';
if b_more then b_more := fnb_more(sz);
sz := 'Teapro file processing commands';
sz := sz
+ s_dashline
+ 'FSIP s_record, s_filename, d_byte' + nl
+ 'File sip, read variable length record s_record '
+ 'from file s_filename beginning at byte d_byte, '
+ 'remove LF or CRLF at end and put beginning of '
+ 'next record in d_byte. Length of record cannot '
+ 'be over 4096. If no record read put 0 in d_byte, '
+ 'but records can be zero length. '
+ 'You should put 1 in d_byte for first read. '
+ 'FSIP works only with files that have a '
+ 'LF or CRLF at the end of each record. '
+ 'LR means a line feed or char 10. '
+ 'CRLF means a char 13 and a char 10.'
+ s_dashline
+ 'FADD d_length, s_filename, s_line' + nl
+ 'Append line to file, write line s_line to end of file '
+ 's_filename putting on a LF. Total length written '
+ 'goes into d_length and cannot be over 4096.'
+ s_dashline
+ 'FAPP d_length, s_filename, s_line' + nl
+ 'Append line to file, write line s_line to end of file '
+ 's_filename putting on a CRLF. Total length written '
+ 'goes into d_length and cannot be over 4096.';
if b_more then b_more := fnb_more(sz);
sz := '';
sz := sz
+ 'the Teapro decimal assignment command and operators'
+ s_dashline
+ 'd_dec1 = 5 + d_dec2 / -3.14 - d_dec3 * 15.2' + nl
+ 'First, remember that the decimal assignment command '
+ 'evaluates the expression to the right of the equal sign '
+ 'strictly in left to right order and not as an algebraic '
+ 'expression as in other languages. '
+ 'Literal numbers may be preceded by a + or - sign. '
+ 'The following operators tell what to do with '
+ 'the term to the right '
+ 'of the operator with respect to the answer '
+ 'being calculated.'
+ s_dashline
+ '+ means to add the right term to the answer.' + nl
+ '- means to subtract the right term from the answer.' + nl
+ '* means to multiply the right term times the answer.' + nl
+ '/ means to divide the answer by the right term.' + nl
+ '% means to round the answer and the right term '
+ 'and find the mod which has the sign of the answer.' + nl
+ '\ means to round the answer and the right term '
+ 'and do an integer divide.' + nl
+ '@ means to round term1 to number of places in term2.' + nl
+ '? means to truncate term1 to number of places in term2.' + nl
+ 'A data error brings up the Data Error dialog box.';
if b_more then b_more := fnb_more(sz);
end; { sub_help_commands }
procedure TForm1.sub_help_running;
{ updated 2000/01/01 }
var
sz : string;
b_more : boolean;
begin
b_more := true;
sz := '';
sz := sz
+ 'This program is teapro9.exe. '
+ 'It is the Teapro9 interpreter Program that you must use to run '
+ 'a program written in the Teapro programming language. '
+ 'Both the Teapro9 interpreter program and the Teapro program should '
+ 'be in the same directory. '
+ 'Use any word processor to write your Teapro program. '
+ 'Save the program as a text file with the extension .tea. '
+ 'There are two ways to get this interpreter program to run '
+ 'that Teapro program. ' + nl + nl
+ '1. Run this Teapro9 interpreter Program '
+ 'and click File on the menu bar. '
+ 'Then choose: Open a Teapro Program. '
+ 'Then type in the name of the Teapro program and click Ok. '
+ 'Then click the Start Program button '
+ 'and this interpreter program '
+ 'will run that Teapro program. ' + nl + nl
+ '2. Setup this Teapro9 interpreter Program, teapro9.exe, on your '
+ 'Start Menu or as a Short Cut '
+ 'with the name of the Teapro program you wish to run as a '
+ 'parameter. '
+ 'For example, use for your command line the following: ' + nl
+ 'c:\test\teapro9.exe yourprog.tea' + nl
+ 'where both files are in the directory c:\test. '
+ 'Then use the Start Menu or the Short Cut '
+ 'to run this Teapro9 interpreter Program with the '
+ 'name of the Teapro program as a parameter as above. '
+ 'Click on the Start Program button to start the Teapro program.';
if b_more then b_more := fnb_more(sz);
end; { sub_help_running }
procedure TForm1.sub_comm_dchs;
{ updated 2003/04/26 }
{ to perform the command DCH$ }
var
sz : string;
i_parm2, i_parm3 : integer;
begin
{ 1234567890123456789012345 }
{ DCHS 00101n,00099n,00032n }
{ get parm2 and parm3 }
i_parm2 := fni_decimal_eval(13);
i_parm3 := fni_decimal_eval(20);
if (i_parm2 < 0) then i_parm3 := 0;
if (i_parm2 > 256) then i_parm3 := 0;
if (i_parm3 < 0) then i_parm3 := 0;
if (i_parm3 > fi_max_length) then
begin
sub_program_error('string too long');
end
else
begin
{ make the string }
sz := StringOfChar(Chr(i_parm2), i_parm3);
sub_store_string(6, sz);
end;
end; { sub_comm_dchs }
function TForm1.fnb_comm_dift : boolean;
{ updated 2003/09/15 }
{ perform command DIFT and DWHI }
var
char_op : char;
e_parm1, e_parm2 : double;
begin
{ get next Teapro program line }
fs_tpline := fsa_tpline[fi_tpline];
{ 123456789012345678901 }
{ DWHI 12345n>>12345n,3 }
e_parm1 := fnd_decimal_eval(6);
e_parm2 := fnd_decimal_eval(14);
Result := false;
char_op := fs_tpline[21];
Case char_op of
'1' : if (e_parm1 = e_parm2) then Result := true;
'2' : if (e_parm1 <> e_parm2) then Result := true;
'3' : if (e_parm1 < e_parm2) then Result := true;
'4' : if (e_parm1 > e_parm2) then Result := true;
'5' : if (e_parm1 >= e_parm2) then Result := true;
'6' : if (e_parm1 <= e_parm2) then Result := true;
end;
end; { fnb_comm_dift }
procedure TForm1.sub_comm_dset;
{ updated 2007/07/23 }
{ 2007/07/08, 2007/05/06, 2007/04/28, 2007/04/14, 2004/04/21 }
{ perform command DSET }
var
c_1 : comp;
c_2 : comp;
e_answer : double;
e_term : double;
char_op : char;
iy, iz : integer;
b_loop : boolean;
begin
{ dset 00201n=+00001n*00301p-00302p/00303p*00005n; }
{ 12345678901234567890123456789012345678901234567890 }
fb_error := false;
e_answer := 0;
iz := 13;
b_loop := true;
while b_loop do
begin
{ evaluate the decimal, iz is where the operator is }
iy := StrToIntDef(Copy(fs_tpline, Succ(iz), 5), -1);
if (iy = -1) then
begin
sub_program_error('bad variable link');
end
else
begin
if (fs_tpline[iz + 6] = 'D')
then e_term := fea_var[iy + fi_delta_d]
else if (fs_tpline[iz + 6] = 'G')
then e_term := fea_var[iy]
else e_term := iy;
char_op := fs_tpline[iz];
case char_op of
'%' : { modulus }
begin
{ the sign of e_answer prevails }
c_1 := e_answer;
c_2 := e_term;
if (c_2 > 0) then
begin
{ find mod }
e_answer := c_1 - Int(c_1 / c_2) * c_2;
end
else sub_program_error('zero mod');
end;
'*' : e_answer := e_answer * e_term;
'+' : e_answer := e_answer + e_term;
'-' : e_answer := e_answer - e_term;
'/' : { regular divide }
begin
{ division using decimals }
if (e_term <> 0) then e_answer := e_answer / e_term
else sub_program_error('zero divide');
end;
'\' : { integer divide }
begin
c_1 := e_answer;
c_2 := e_term;
if (c_2 <> 0) then e_answer := Int(c_1 / c_2)
else sub_program_error('zero integer divide');
end;
'^' : { exponentiation }
begin
{ if e_answer negative then e_term must be integer }
if (e_answer < 0) and (e_term <> floor(e_term)) then
e_answer := abs(e_answer);
if (e_answer = 0) or (e_term = 0) then
begin
e_answer := 1;
e_term := 1;
end;
e_answer := power(e_answer, e_term);
end;
'@' : { round to number of places }
begin
c_2 := power(10, int(abs(e_term) + 0.001));
c_1 := e_answer * c_2 + 0.499;
e_answer := c_1 / c_2;
end;
'?' : { truncate to number of places }
begin
c_2 := power(10, int(abs(e_term) + 0.001));
c_1 := int(e_answer * c_2 + 0.001);
e_answer := c_1 / c_2;
end;
end;
end;
Inc(iz, 7);
if fb_error or (fs_tpline[iz] = ';') then b_loop := false;
end;
{ store the answer }
if not fb_error then sub_store_decimal(6, e_answer);
end; { sub_comm_dset }
procedure TForm1.sub_comm_dfac;
{ updated 2007/01/19, 2005/04/29, 2005/03/22, 2004/10/11 }
{ find lowest factor greater than 1 }
var
d_parm2 : double;
d_try : double;
d_divisor : double;
c_answer : comp;
cz : comp;
b_error : boolean;
b_loop : boolean;
begin
{ 123456789012345678 }
{ DFAC 00101d,00102d }
cz := fnd_decimal_eval(13);
d_parm2 := cz;
Application.ProcessMessages;
b_error := false;
b_loop := true;
if (d_parm2 < 1) or (d_parm2 >= Power(10, 16)) then
begin
{ number out of range }
sub_program_error('dfac range is > 0 and < 9.0E15');
b_error := true;
b_loop := false;
end;
if b_loop then
begin
d_divisor := 1;
if (d_parm2 < 4) then b_loop := false;
end;
if b_loop then
begin
{ is c_answer even }
c_answer := d_parm2 / 2;
if (d_parm2 = c_answer * 2) then
begin
{ even number not prime }
b_loop := false;
d_divisor := 2;
end;
d_try := 3;
end;
while b_loop and fb_program_loop do
begin
{ dfac }
c_answer := d_parm2 / d_try;
if (d_parm2 <> c_answer * d_try) then
begin
d_try := d_try + 2;
{ prime? }
if (sqr(d_try) > d_parm2) then b_loop := false;
end
else
begin
{ not prime }
d_divisor := d_try;
b_loop := false;
end;
end;
if not b_error then sub_store_decimal(6, d_divisor);
end; { sub_comm_dfac }
procedure TForm1.sub_comm_dfak;
{ updated 2007/03/04, 2007/01/20 }
{ 2007/01/19, 2007/01/18, 2005/04/29, 2005/03/22, 2004/10/11 }
{ find lowest factor of parm2 + parm3 * 9quadrillion }
var
d_1quadpart : double;
d_1quadmult : double;
d_1quadnum : double;
d_factor : double;
d_root : double;
d_divisor : double;
d_modulus : double;
i_loop : integer;
cz : comp;
dz : double;
begin
{ 1234567890123456789012345 }
{ DFAK 00101d,00102d,00103d }
{ 1234567890123456 }
d_1quadnum := 1000000000000000.0;
d_factor := 1;
i_loop := 1;
Application.ProcessMessages;
cz := fnd_decimal_eval(13);
d_1quadpart := Abs(cz);
cz := fnd_decimal_eval(20);
d_1quadmult := Abs(cz);
{ d_1quadnum is factored by 2 }
dz := fnd_modulus(d_1quadpart, 2);
if (dz = 0) then
begin
d_factor := 2;
inc(i_loop);
end;
if (i_loop = 1) then
d_root := sqrt(d_1quadpart + d_1quadmult * d_1quadnum);
d_divisor := 3;
while (i_loop = 1) do
begin
d_modulus := fnd_modulus(fnd_modulus(d_1quadpart, d_divisor)
+ d_1quadmult * fnd_modulus(d_1quadnum, d_divisor), d_divisor);
if (d_modulus = 0) then
begin
Inc(i_loop);
d_factor := d_divisor;
end
else
begin
d_divisor := d_divisor + 2;
if (d_divisor > d_root) then Inc(i_loop);
end;
end;
sub_store_decimal(6, d_factor);
end; { sub_comm_dfak }
procedure TForm1.sub_comm_dpow;
{ updated 2007/07/23, 2007/07/08, 2004/04/21 }
var
d_number : double;
d_power : double;
d_result : double;
begin
{ 1234567890123456789012345 }
{ DPOW 00101d,00102d,12345d }
d_number := fnd_decimal_eval(13);
d_power := fnd_decimal_eval(20);
{ if d_number negative then d_power must be integer }
if (d_number < 0) and (d_power <> floor(d_power)) then
d_number := abs(d_number);
if (d_number = 0) or (d_power = 0) then
begin
d_number := 1;
d_power := 1;
end;
d_result := Power(d_number, d_power);
sub_store_decimal(6, d_result);
end; { sub_comm_dpow }
procedure TForm1.sub_comm_dsin(const pbyte_1 : byte);
{ updated 2003/09/14 }
var
b_negative : boolean;
dz : double;
cz : comp;
e_parm2 : double;
d_result : double;
b_error : boolean;
begin
{ 123456789012345678 }
{ DSIN 00101d,00102d }
e_parm2 := fnd_decimal_eval(13);
b_error := false;
if (pbyte_1 = 1) then
begin
{ drou round }
if (e_parm2 < 0) then
begin
b_negative := true;
e_parm2 := - e_parm2;
end
else b_negative := false;
cz := e_parm2;
if ((e_parm2 - cz) = 0.5) then cz := cz + 1;
if b_negative then cz := - cz;
d_result := cz;
end
else if (pbyte_1 = 2) then d_result := Int(e_parm2) { dtru truncate }
else if (pbyte_1 = 3) then d_result := Sin(e_parm2) { dsin sine }
else if (pbyte_1 = 4) then
begin
{ darc finding arcsine }
if (e_parm2 = 1) then d_result := PI / 2
else if (e_parm2 = -1) then d_result := -PI / 2
else if (e_parm2 < 1) and (e_parm2 > -1) then
d_result := ArcTan(e_parm2/sqrt(1-sqr(e_parm2)))
else
begin
sub_program_error('bad numbers in DSIN');
b_error := true;
end;
end
else if (pbyte_1 = 5) then
begin
{ dlog finding log10 }
if (e_parm2 > 0) then d_result := Log10(e_parm2)
else b_error := true;
end;
if not b_error then sub_store_decimal(6, d_result);
end; { sub_comm_dsin }
procedure TForm1.sub_comm_dtos(const pbyte_1 : byte);
{ updated 2006/05/02, 2004/09/25 }
{ perform decimal to string DTO$, DED$ }
var
e_number : double;
i_length : integer;
i_decimals : integer;
i_dot : integer;
i_right : integer;
s_number : string;
i_long : integer;
iy, iz : integer;
b_process : boolean;
begin
{ do we need to put commas in, pbyte_1=1 means DED$ }
{ 12345678901234567890123456789012 }
{ DTO$ 00101n,00401p,00010n,00011n }
e_number := fnd_decimal_eval(13);
i_length := fni_decimal_eval(20);
i_decimals := fni_decimal_eval(27);
if (i_length < 0) then i_length := 0;
if (i_decimals < 0) then i_decimals := 0;
if (i_decimals > 16) then i_decimals := 16;
if (i_decimals = 0) and (i_length = 0) then i_decimals := 16;
{ change number to string }
if (pbyte_1 = 1) then
begin
{ with commas }
s_number := Trim(FloatToStrF(e_number, ffNumber, 16, i_decimals))
end
else
begin
{ without commas }
s_number := Trim(FloatToStrF(e_number, ffFixed, 16, i_decimals));
end;
b_process := true;
{ do we have an E for exponential notation }
if (Pos('E', s_number) > 0) then
begin
{ add leading blanks if not long enought }
if (i_length > Length(s_number)) then
begin
iz := i_length - Length(s_number);
s_number := StringOfChar(' ', iz) + s_number;
end;
b_process := false;
end;
if b_process then
begin
{ make sure we have a decimal }
if (Pos('.', s_number) = 0) then
s_number := s_number + '.';
{ remove trailing zeros }
iz := Length(s_number);
while (s_number[iz] = '0') do Dec(iz);
s_number := Copy(s_number, 1, iz);
i_dot := Pos('.', s_number);
i_long := Length(s_number);
i_right := i_long - i_dot;
if (i_decimals > i_right) and (i_length > i_long) then
begin
iz := i_length - i_long;
iy := i_decimals - i_right;
if (iz > iy) then iz := iy;
{ add zeros on the right side }
s_number := s_number + StringOfChar('0', iz);
end;
{ remove a trailing decimal if needed }
i_long := Length(s_number);
if (s_number[i_long] = '.') then
s_number := Copy(s_number, 1, Pred(i_long));
{ make the string i_length long by adding blanks to the left }
if (Length(s_number) < i_length) then
begin
iz := i_length - Length(s_number);
s_number := StringOfChar(' ', iz) + s_number;
end;
end;
sub_store_string(6, s_number);
end; { sub_comm_dtos }
procedure TForm1.sub_comm_dtof;
{ updated 2004/05/17 }
{ decimal to field format ie. +00000137 }
var
e_parm2 : double;
i_parm3 : integer;
i_long : integer;
s_field : string;
co_number : comp;
iz : integer;
b_negative : boolean;
begin
fb_error := false;
{ 1234567890123456789012345 }
{ DPK$ 00101n,00401p,00010n }
e_parm2 := fnd_decimal_eval(13);
i_parm3 := fni_decimal_eval(20);
if (i_parm3 < 2) then sub_program_error('bad length DTOF');
if not fb_error then
begin
co_number := e_parm2;
if (co_number < 0) then
begin
b_negative := true;
co_number := - co_number;
end
else b_negative := false;
s_field := Trim(FloatToStrF(co_number, ffGeneral, 16, 4));
end;
{ is it too long }
if not fb_error then
if (Length(s_field) > Pred(i_parm3)) then
sub_program_error('bad length DTOF');
if not fb_error then
begin
{ make left part of string zero-filled }
s_field := StringOfChar('0', i_parm3 - Length(s_field))
+ s_field;
if b_negative then s_field[1] := '-'
else s_field[1] := '+';
sub_store_string(6, s_field);
end;
end; { sub_comm_dtof }
procedure TForm1.sub_comm_dpks;
{ updated 2003/10/05 }
{ perform decimal to packed format zero filled to string DPK$ }
{ packed format is also called BCD or binary coded decimal }
var
e_parm2 : double;
i_parm3 : integer;
i_long : integer;
s_packed : string;
co_number : comp;
iz : integer;
b_negative : boolean;
begin
fb_error := false;
{ 1234567890123456789012345 }
{ DPK$ 00101n,00401p,00010n }
e_parm2 := fnd_decimal_eval(13);
i_parm3 := fni_decimal_eval(20);
if (i_parm3 < 1) then sub_program_error('bad numbers DPK$');
if not fb_error then
begin
co_number := e_parm2;
if (co_number < 0) then
begin
b_negative := true;
co_number := - co_number;
end
else b_negative := false;
s_packed := Trim(FloatToStrF(co_number, ffGeneral, 16, 4));
end;
{ is it too long }
if not fb_error then
if (Length(s_packed) > i_parm3) then
sub_program_error('bad numbers DPK$');
if not fb_error then
begin
{ make left part of string zero-filled }
s_packed := StringOfChar('0', i_parm3 - Length(s_packed))
+ s_packed;
if b_negative then
begin
{ change to packed format }
i_long := Length(s_packed);
{ 1 at 49 changes to J at 74 }
iz := Ord(s_packed[i_long]) + 25;
{ I is 73 and a right brace is 125 }
if (iz = 73) then iz := 125;
s_packed[i_long] := Chr(iz);
end;
sub_store_string(6, s_packed);
end;
end; { sub_comm_dpks }
procedure TForm1.sub_comm_dtoi(const pbyte_1 : byte);
{ updated 2007/06/16, 2004/02/02 }
{ put or add a decimal into a pointed to address }
var
i_parm1 : integer;
e_parm2 : double;
begin
{ 123456789012345678 }
{ DTOI 00701D,00401D }
{ ADDI 00701d,00401d }
i_parm1 := fni_decimal_eval(6);
e_parm2 := fnd_decimal_eval(13);
{ validate and put }
{ put the value into the array at the index }
if (i_parm1 >= 1) and (i_parm1 <= fi_max_darray) then
begin
if (pbyte_1 = 1) then fea_array[i_parm1] := e_parm2
else fea_array[i_parm1] := fea_array[i_parm1] + e_parm2;
end
else sub_program_error('bad index=' + IntToStr(i_parm1));
end; { sub_comm_dtoi }
procedure TForm1.sub_comm_itod;
{ updated 2007/06/16, 2004/01/24 }
{ get a decimal by an index from an array }
var
i_parm2 : integer;
begin
{ 123456789012345678 }
{ ITOD 00701D,00401D }
i_parm2 := fni_decimal_eval(13);
{ get the decimal from the array by index }
if (i_parm2 >= 1) and (i_parm2 <= fi_max_darray) then
sub_store_decimal(6, fea_array[i_parm2])
else sub_program_error('bad index=' + IntToStr(i_parm2));
end; { sub_comm_itod }
procedure TForm1.sub_comm_sdat;
{ updated 2002/09/05 }
var
s_date : string;
begin
{ 12345678901 }
{ SDAT 00601D }
{ s_date }
s_date := UpperCase(FormatDateTime('dd-mmm-yyyy hh:nn:ss', Now))
+ ' ' + FormatDateTime('yyyymmddhhnnss', Now);
sub_store_string(6, s_date);
end; { sub_comm_sdat }
function TForm1.fnb_comm_sift : boolean;
{ updated 2000/01/01 }
var
char_op : char;
s_parm1, s_parm2 : string;
begin
{ get next Teapro program line }
fs_tpline := fsa_tpline[fi_tpline];
{ 123456789012345678901 }
{ $IFT 00101n<>00201n,1 }
{ get s1 }
s_parm1 := fns_string_eval(6);
{ get s2 }
s_parm2 := fns_string_eval(14);
Result := false;
char_op := fs_tpline[21];
Case char_op of
'1' : if (s_parm1 = s_parm2) then Result := true;
'2' : if (s_parm1 <> s_parm2) then Result := true;
'3' : if (s_parm1 < s_parm2) then Result := true;
'4' : if (s_parm1 > s_parm2) then Result := true;
'5' : if (s_parm1 >= s_parm2) then Result := true;
'6' : if (s_parm1 <= s_parm2) then Result := true;
end;
end; { fnb_comm_sift }
procedure TForm1.sub_comm_sout(const pbyte_1 : byte);
{ updated 2000/01/01 }
{ perform the $OUT command }
var
s_parm1 : string;
begin
{ 12345678901 }
{ $OUT 00101n }
{ $OUT "string" }
{ get the output string }
s_parm1 := fns_string_parse(Copy(fs_tpline, 6, 200));
{ show in memo_show }
sub_memo_show(s_parm1, pbyte_1);
end; { sub_comm_sout }
procedure TForm1.sub_comm_sisd;
{ updated 2004/09/25 }
{ $ISD, returns 1 if the string is a decimal value }
var
i_result : integer;
ez : double;
sz : string;
b_error : boolean;
begin
{ 123456789012345678 }
{ $ISD 00901D,00101S }
sz := Trim(fns_string_eval(13));
sub_double_from_string(sz, ez, b_error);
if b_error then i_result := 2
else i_result := 1;
sub_store_decimal(6, i_result);
end; { sub_comm_sisd }
procedure TForm1.sub_comm_stod;
{ updated 2003/11/23 }
{ perform the command $TOD, string to decimal }
var
b_error : boolean;
e_number : double;
s_number : string;
begin
{ 123456789012345678 }
{ $TOD 00901D,00101S }
s_number := fns_string_eval(13);
sub_double_from_string(s_number, e_number, b_error);
if not b_error then
sub_store_decimal(6, e_number)
else sub_program_error('$TOD not number="' + s_number + '"');
end; { sub_comm_stod }
procedure TForm1.sub_comm_spkd;
{ updated 2005/11/02, 2003/10/05 }
{ perform the command $PKD, packed formatted string to decimal }
{ packed format is also called BCD or binary coded decimal }
var
e_number : double;
s_parm3 : string;
i_long : integer;
b_negative : boolean;
b_error : boolean;
i_good : integer;
iz : integer;
begin
{ 1234567890123456789012345 }
{ $PKD 00901D,00101S,00101S }
s_parm3 := fns_string_eval(20);
s_parm3 := Trim(s_parm3);
i_long := Length(s_parm3);
if (i_long = 0) then
begin
s_parm3 := '0';
i_long := 1;
end;
{ what is the last char and do we need to change it }
iz := Ord(s_parm3[i_long]);
{ 48 is 0 and 57 is 9 }
b_negative := true;
if (iz >= 48) and (iz <= 57) then b_negative := false
{ 65 is A and 73 is I }
else if (iz >= 65) and (iz <= 73) then
begin
b_negative := false;
iz := iz - 16;
s_parm3[i_long] := Chr(iz);
end
{ 74 is J and 82 is R }
else if (iz >= 74) and (iz <= 82) then
begin
b_negative := true;
iz := iz - 25;
s_parm3[i_long] := Chr(iz);
end
{ a right brace is 125 which is negative zero }
else if (iz = 125) then
begin
b_negative := true;
s_parm3[i_long] := '0';
end
{ a left brace is 123 which is positive zero }
else if (iz = 123) then
begin
b_negative := false;
s_parm3[i_long] := '0';
end;
b_error := false;
if (i_long > 15) then b_error := true;
for iz := 1 to i_long do
begin
if (s_parm3[iz] < '0') or (s_parm3[iz] > '9') then
b_error := true;
end;
i_good := 2;
e_number := 0;
if not b_error then
begin
i_good := 1;
e_number := StrToFloat(s_parm3);
if b_negative then e_number := - e_number;
end;
sub_store_decimal(6, i_good);
if not b_error then sub_store_decimal(13, e_number);
end; { sub_comm_spkd }
procedure TForm1.sub_comm_stoi(const pbyte_1 : byte);
{ updated 2007/06/16, 2006/06/11, 2006/06/09, 2004/01/24 }
{ perform $toi, string to an array by index }
var
i_parm1 : integer;
s_parm2 : string;
begin
{ 123456789012345678 }
{ $TOI 00401D,00101S }
i_parm1 := fni_decimal_eval(6);
s_parm2 := fns_string_parse(Copy(fs_tpline, 13, 200));
{ validate and put }
{ put the string into the string array by index }
if (i_parm1 >= 1) and (i_parm1 <= fi_max_sarray) then
fsa_array[i_parm1] := s_parm2
else sub_program_error('bad index=' + IntToStr(i_parm1));
end; { sub_comm_stoi }
procedure TForm1.sub_comm_itos;
{ updated 2007/06/16, 2004/01/24 }
{ ito$, index to string }
var
{ 05-SEP-2002 }
i_parm2 : integer;
begin
{ 123456789012345678 }
{ ITO$ 00101S,00401D }
i_parm2 := fni_decimal_eval(13);
{ put the string from the string array by index into a string variable }
{ the string variable to put the string into may need fi_delta_s }
if (i_parm2 >= 1) and (i_parm2 <= fi_max_sarray) then
sub_store_string(6, fsa_array[i_parm2])
else sub_program_error('bad index=' + IntToStr(i_parm2));
end; { sub_comm_itos }
procedure TForm1.sub_comm_array(const pbyte_1 : byte);
{ updated 2007/06/16, 2004/01/24 }
{ either zero decimal array or blank string array }
var
iz : integer;
begin
if (pbyte_1 = 1) then
begin
{ ARRZ }
for iz := 1 to fi_max_darray do fea_array[iz] := 0;
end
else
begin
{ ARRB }
for iz := 1 to fi_max_sarray do fsa_array[iz] := '';
end;
end; { sub_comm_array }
procedure TForm1.sub_comm_sset;
{ updated 2002/11/22 }
{ perform the command $SET }
var
s_string : string;
begin
{ 1234567890123456789012345 }
{ $SET 00101n,00201n+00202s }
s_string := fns_string_parse(Copy(fs_tpline, 13, 99999));
sub_store_string(6, s_string);
end; { sub_comm_sset }
procedure TForm1.sub_comm_sapp;
{ updated 2003/10/10 }
{ append a string to another string }
var
s_parm1, s_parm2 : string;
begin
{ 123456789012345678 }
{ $APP 00101S,00401D }
{ get parm1 }
s_parm1 := fns_string_eval(6);
{ get parm2 }
s_parm2 := fns_string_parse(Copy(fs_tpline, 13, 99999));
if (Length(s_parm1) + Length(s_parm2) > fi_max_length) then
begin
sub_program_error('too long');
end
else sub_store_string(6, s_parm1 + s_parm2);
end; { sub_comm_sapp }
procedure TForm1.sub_comm_srep;
{ updated 2003/10/09 }
{ perform the command $REP to replace bytes in a string }
var
iz : integer;
i_parm2 : integer;
s_parm1, s_parm3 : string;
i_long1, i_long3 : integer;
b_error : boolean;
begin
{ 1234567890123456789012345 }
{ $REP 00101S,00401D,00201S }
{ get parm1 }
s_parm1 := fns_string_eval(6);
{ get parm2 }
i_parm2 := fni_decimal_eval(13);
{ get parm3 }
s_parm3 := fns_string_eval(20);
i_long1 := Length(s_parm1);
i_long3 := Length(s_parm3);
b_error := false;
if (i_parm2 < 1) or (i_parm2 > i_long1) then b_error := true;
if ((i_parm2 + i_long3 - 1) > i_long1) then b_error := true;
if not b_error then
begin
iz := 1;
while (iz <= i_long3) do
begin
s_parm1[i_parm2 + iz - 1] := s_parm3[iz];
Inc(iz);
end;
sub_store_string(6, s_parm1);
end
else sub_program_error('bad $REP');
end; { sub_comm_srep }
procedure TForm1.sub_comm_sswp;
{ updated 2007/01/19, 2005/04/29, 2005/03/22, 2004/06/29 }
{ string swap in s_parm1 replace each s_parm2 with s_parm3 }
var
s_parm1, s_parm2, s_parm3 : string;
i_long1, i_long2, i_long3 : integer;
i_byte : integer;
i_diff : integer;
b_loop : boolean;
b_changed : boolean;
begin
{ 1234567890123456789012345 }
{ $SWP 00101S,00401S,00201S }
{ get parm1 }
s_parm1 := fns_string_eval(6);
{ get parm2 }
s_parm2 := fns_string_eval(13);
{ get parm3 }
s_parm3 := fns_string_eval(20);
i_long1 := Length(s_parm1);
i_long2 := Length(s_parm2);
i_long3 := Length(s_parm3);
i_diff := i_long3 - i_long2;
b_changed := false;
b_loop := true;
if (i_long1 = 0) or (i_long2 = 0)
or (i_long1 < i_long2) then b_loop := false;
i_byte := 1;
while b_loop do
begin
if (Copy(s_parm1, i_byte, i_long2) = s_parm2) then
begin
if ((Length(s_parm1) + i_diff) > fi_max_length) then
begin
b_loop := false;
b_changed := false;
sub_program_error('too long');
end
else
begin
Application.ProcessMessages;
Delete(s_parm1, i_byte, i_long2);
if (i_long3 > 0) then Insert(s_parm3, s_parm1, i_byte);
i_byte := i_byte + i_long3 - 1;
b_changed := true;
end;
end;
Inc(i_byte);
if (i_byte > Length(s_parm1)) then b_loop := false;
end;
if b_changed then sub_store_string(6, s_parm1);
end; { sub_comm_sswp }
procedure TForm1.sub_comm_sins;
{ updated 2003/10/09 }
{ perform the command $INS to insert a string into another }
var
{ 26-APR-2003 }
s_parm1, s_parm3 : string;
i_parm2 : integer;
i_long1, i_long3 : integer;
s_result : string;
b_error : boolean;
begin
{ 1234567890123456789012345 }
{ $INS 00101S,00401D,00201S }
{ get parm1 }
s_parm1 := fns_string_eval(6);
{ get parm2 which is where to insert }
i_parm2 := fni_decimal_eval(13);
{ get parm3 which is the string to insert }
s_parm3 := fns_string_eval(20);
b_error := false;
i_long1 := Length(s_parm1);
i_long3 := Length(s_parm3);
if ((i_long1 + i_long3) > fi_max_length) then b_error := true
else if (i_parm2 > (i_long1 + 1)) then b_error := true
else if (i_parm2 < 1) then b_error := true
else if (i_long1 = 0) then s_result := s_parm3
else if (i_long3 = 0) then s_result := s_parm1
else if (i_parm2 = (i_long1 + 1)) then s_result := s_parm1 + s_parm3
else if (i_parm2 = 1) then s_result := s_parm3 + s_parm1
else
begin
s_result := s_parm1;
Insert(s_parm3, s_result, i_parm2);
end;
if b_error then sub_program_error('bad $ins')
else sub_store_string(6, s_result);
end; { sub_comm_sins }
procedure TForm1.sub_comm_sdel;
{ updated 2002/09/05 }
{ perform the command $DEL to delete a string from another string }
var
s_parm1 : string;
i_parm2, i_parm3 : integer;
begin
{ 1234567890123456789012345 }
{ $DEL 00101S,00401D,00402D }
{ get parm1 }
s_parm1 := fns_string_eval(6);
{ get parm2 which is where to begin to delete }
i_parm2 := fni_decimal_eval(13);
{ get parm3 which is how many bytes to delete }
i_parm3 := fni_decimal_eval(20);
{ delete }
if (i_parm2 > 0) and (i_parm2 <= Length(s_parm1)) then
begin
Delete(s_parm1, i_parm2, i_parm3);
sub_store_string(6, s_parm1);
end
else sub_program_error('bad number $DEL');
end; { sub_comm_sdel }
procedure TForm1.sub_comm_slen(const pbyte_1 : byte);
{ updated 2006/06/02, 2002/09/05 }
{ find length or hash of string }
var
s_parm2 : string;
i_long : integer;
i_byte : integer;
ix, iy, iz : integer;
d_result : double;
begin
{ 123456789012345678 }
{ $LEN 00401n,00101n }
{ get the string whose length we want }
s_parm2 := fns_string_eval(13);
i_long := Length(s_parm2);
{ 1=$LEN }
if (pbyte_1 = 1) then d_result := i_long
else
begin
{ 2=$HSH }
ix := 0;
iy := 0;
for i_byte := 1 to i_long do
begin
iz := Ord(s_parm2[i_byte]) + 1;
{ 1,000,000,000 }
ix := (ix + iz) mod 1000000000;
{ 701 is prime, 1,000,000 }
iy := (iy + ((i_byte - 1) mod 701 + 1) * iz) mod 1000000;
end;
{ 1,000,000 }
d_result := ix * 1000000.0 + iy;
end;
{ store the string length }
sub_store_decimal(6, d_result);
end; { sub_comm_slen }
procedure TForm1.sub_comm_sfix(const pbyte_1 : byte);
{ updated 2004/11/06 }
{ make a string in op3 upper or lower case put in op2 }
var
iz : integer;
sz : string;
begin
{ 123456789012345678 }
{ $CLO 00102S,00101S }
{ get the string we want to fix }
sz := fns_string_eval(13);
{ $CLO = 1
$CUP = 2
$BES = 3
$TRB = 4
$TRL = 5
$TRR = 6
$TLO = 7
$TUP = 8
}
if (pbyte_1 = 1) then sz := LowerCase(sz)
else if (pbyte_1 = 2) then sz := UpperCase(sz)
else if (pbyte_1 = 3) then sz := fns_blank_escapes(sz)
else if (pbyte_1 = 4) then sz := Trim(sz)
else if (pbyte_1 = 5) then sz := TrimLeft(sz)
else if (pbyte_1 = 6) then sz := TrimRight(sz)
else if (pbyte_1 = 7) then sz := Trim(LowerCase(sz))
else if (pbyte_1 = 8) then sz := Trim(UpperCase(sz));
{ store the new string }
sub_store_string(6, sz);
end; { sub_comm_sfix }
procedure TForm1.sub_comm_ssor;
{ updated 2007/01/19, 2005/04/29, 2005/03/22, 2003/09/15 }
{ string sort by lengths }
var
s_parm2 : string;
i_parm3 : integer;
s_1, s_2 : string;
i_1, i_2 : integer;
i_length : integer;
iz : integer;
b_sort : boolean;
begin
fb_error := false;
{ 1234567890123456789012345 }
{ $SOR 00401S,00001S,00101D }
{ get the sort length }
i_parm3 := fni_decimal_eval(20);
{ get the string we want to sort }
s_parm2 := fns_string_eval(13);
b_sort := true;
i_length := Length(s_parm2);
if (i_length mod i_parm3 > 0) then fb_error := true;
if (i_length <= i_parm3) then b_sort := false;
if b_sort and not fb_error then
begin
i_1 := 1;
while (i_1 < i_length) do
begin
{ $sor }
Application.ProcessMessages;
s_1 := Copy(s_parm2, i_1, i_parm3);
i_2 := i_1 + i_parm3;
while (i_2 <= i_length) do
begin
s_2 := Copy(s_parm2, i_2, i_parm3);
if (s_1 > s_2) then
begin
{ put s_2 into i_1 the position }
for iz := 1 to i_parm3 do
begin
s_parm2[i_1 + iz - 1] := s_2[iz];
s_parm2[i_2 + iz - 1] := s_1[iz];
end;
s_1 := s_2;
end;
Inc(i_2, i_parm3);
end;
Inc(i_1, i_parm3);
end;
end;
if fb_error then sub_program_error('bad numbers $SOR')
else
begin
{ store the sorted string }
sub_store_string(6, s_parm2);
end;
end; { sub_comm_ssor }
procedure TForm1.sub_comm_slok;
{ updated 2002/09/02 }
{ lookup string op5 in string op4 starting at op3 and put in op2 }
var
s_parm2, s_parm4 : string;
i_parm3 : integer;
i_long4, i_long2 : integer;
i_max2 : integer;
i_spot : integer;
iw, ix, iz : integer;
b_loop : boolean;
b_match : boolean;
b_process : boolean;
begin
{ 12345678901234567890123456789012 }
{ $LOK 00401D,00001S,00001N,00102S }
{ get the string we want to find }
s_parm4 := fns_string_eval(27);
{ get the starting point }
i_parm3 := fni_decimal_eval(20);
{ get the string we want to look in }
s_parm2 := fns_string_eval(13);
b_process := true;
i_long4 := Length(s_parm4);
i_long2 := Length(s_parm2);
i_max2 := Succ(i_long2 - i_long4);
if (i_parm3 < 1) or (i_parm3 > i_max2) then b_process := false;
if (i_long4 = 0) or (i_long4 > i_long2) then b_process := false;
i_spot := 0;
if b_process then
begin
{ ix is what we are looking for }
ix := i_parm3;
b_match := false;
b_loop := true;
while b_loop do
begin
if (s_parm4[1] = s_parm2[ix]) then
begin
b_match := true;
iw := Pred(ix);
for iz := 2 to i_long4 do
begin
if (s_parm4[iz] <> s_parm2[iw + iz])
then b_match := false;
end;
if b_match then
begin
b_loop := false;
i_spot := ix;
end;
end;
if not b_match then
begin
Inc(ix);
if (ix > i_max2) then b_loop := false;
end;
end;
end;
{ store the find answer }
sub_store_decimal(6, i_spot);
end; { sub_comm_slok }
procedure TForm1.sub_comm_scnt;
{ updated 2003/11/07 }
{ find count of occurrences of string in other string }
var
s_parm2, s_parm3 : string;
i_long3, i_long2 : integer;
i_max : integer;
i_count : integer;
iw, ix, iz : integer;
b_loop : boolean;
b_match : boolean;
b_process : boolean;
begin
{ 1234567890123456789012345 }
{ $CNT 00401D,00001S,00102S }
{ get the string we want to look in }
s_parm2 := fns_string_eval(13);
{ get the string we want to find }
s_parm3 := fns_string_eval(20);
b_process := true;
i_long3 := Length(s_parm3);
i_long2 := Length(s_parm2);
if (i_long3 = 0) or (i_long3 > i_long2) then b_process := false;
i_count := 0;
if b_process then
begin
{ ix is where we are looking }
ix := 1;
{ i_max is the maximum that ix can be }
i_max := Succ(i_long2 - i_long3);
b_match := false;
b_loop := true;
while b_loop do
begin
if (s_parm3[1] = s_parm2[ix]) then
begin
b_match := true;
iw := Pred(ix);
for iz := 2 to i_long3 do
begin
if (s_parm3[iz] <> s_parm2[iw + iz])
then b_match := false;
end;
if b_match then
begin
Inc(i_count);
{ so that occurrences cannot overlap }
ix := ix + Pred(i_long3);
end;
end;
Inc(ix);
if (ix > i_max) then b_loop := false;
end;
end;
{ store the count }
sub_store_decimal(6, i_count);
end; { sub_comm_scnt }
procedure TForm1.sub_comm_sbak;
{ updated 2002/09/05 }
{ lookup string op5 in string op4 starting at op3 and put in op2 }
var
s_parm2, s_parm4 : string;
i_parm3 : integer;
i_long4, i_long2 : integer;
ix, iz : integer;
b_loop : boolean;
b_match : boolean;
b_process : boolean;
begin
{ 12345678901234567890123456789012 }
{ $BAK 00401D,00001S,00001N,00102S }
{ get the string we want to find }
s_parm4 := fns_string_eval(27);
{ get the starting point }
i_parm3 := fni_decimal_eval(20);
{ get the string we want to look in }
s_parm2 := fns_string_eval(13);
b_process := true;
i_long4 := Length(s_parm4);
i_long2 := Length(s_parm2);
if (i_parm3 < 1) or (i_long4 = 0) then b_process := false;
if (i_long4 > i_long2) then b_process := false;
if b_process then
begin
{ ix must be small enough for s_parm2 to hold s_parm4 }
ix := Succ(i_long2 - i_long4);
if (ix > i_parm3) then ix := i_parm3;
b_match := false;
b_loop := true;
while b_loop do
begin
if (s_parm4[1] = s_parm2[ix]) then
begin
b_match := true;
for iz := 2 to i_long4 do
begin
if (s_parm4[iz] <> s_parm2[Pred(ix + iz)])
then b_match := false;
end;
if b_match then b_loop := false;
end;
if not b_match then
begin
Dec(ix);
if (ix < 1) then b_loop := false;
end;
end;
end
else ix := 0;
{ store the find answer }
sub_store_decimal(6, ix);
end; { sub_comm_sbak }
procedure TForm1.sub_comm_sinp(const pbyte_1 : byte);
{ updated 2006/06/11, 2005/03/23, 2004/01/18 }
{ perform the command $INP }
var
iz : integer;
sz : string;
begin
fb_string_input := false;
if (pbyte_1 = 1) then
begin
{ 123456789012345678 }
{ $INP 00101S,00201S }
{ get the input location into fi_input }
fi_input := StrToIntDef(Copy(fs_tpline, 6, 5), -1);
if (fi_input = -1) then
begin
sub_program_error('bad variable link');
end
else
begin
if (fs_tpline[11] = 'S') then Inc(fi_input, fi_delta_s);
{ output the prompt string }
sz := fns_string_parse(Copy(fs_tpline, 13, 200));
sub_memo_show(sz, 1);
{ set the values to drop out and to return to processing }
fb_program_loop := false;
fb_string_input := true;
edit_input.setfocus;
end;
end
else
begin
{ make sure there are no escape characters in fs_input }
fs_input := fns_blank_escapes(fs_input);
{ store the user input fs_input in fi_input }
fsa_var[fi_input] := fs_input;
{ add the user input to the memo_show }
iz := Length(Trim(fs_input));
if (iz > 0) then sub_memo_show(fs_input, 1);
end;
Application.ProcessMessages;
end; { sub_comm_sinp }
procedure TForm1.sub_comm_sisc;
{ updated 2003/10/28 }
{ is string made up of certain char }
var
i_result : integer;
s_parm2, s_parm3 : string;
i_long2, i_long3 : integer;
sz : string;
begin
{ 1234567890123456789012345 }
{ $isc 00101n,00099n,00032n }
{ parm2, parm3 }
s_parm2 := fns_string_eval(13);
s_parm3 := fns_string_eval(20);
i_long2 := Length(s_parm2);
i_long3 := Length(s_parm3);
i_result := 2;
if (i_long2 > 0) and (i_long3 > 0) then
begin
sz := StringOfChar(s_parm3[1], i_long2);
if (s_parm2 = sz) then i_result := 1;
end;
sub_store_decimal(6, i_result);
end; { sub_comm_sisc }
procedure TForm1.sub_comm_schs;
{ updated 2003/04/26 }
{ to perform the command $CH$ }
var
s_parm2 : string;
i_parm3 : integer;
i_char : integer;
sz : string;
begin
{ 1234567890123456789012345 }
{ $CH$ 00101n,00099n,00065n }
s_parm2 := fns_string_eval(13);
i_parm3 := fni_decimal_eval(20);
i_char := 32;
if (Length(s_parm2) = 0) then i_parm3 := 0
else i_char := Ord(s_parm2[1]);
if (i_parm3 < 0) then i_parm3 := 0;
if (i_parm3 > fi_max_length) then
begin
sub_program_error('string too long');
end
else
begin
{ make the string }
sz := StringOfChar(Chr(i_char), i_parm3);
sub_store_string(6, sz);
end;
end; { sub_comm_schs }
procedure TForm1.sub_comm_schd;
{ updated 2002/09/05 }
var
sz : string;
begin
{ 123456789012345678 }
{ $CHD 00401D,00101S }
sz := fns_string_eval(13);
if (Length(sz) = 0) then sz := Chr(0);
sub_store_decimal(6, Ord(sz[1]));
end; { sub_comm_schn }
procedure TForm1.sub_comm_scod;
{ updated 2006/01/17, 2003/12/25 }
{ encode a string }
var
s_parm2 : string;
i_char : integer;
i_long : integer;
iz : integer;
begin
{ 123456789012345678 }
{ $COD 00101n,00099n }
s_parm2 := fns_string_eval(13);
{ forty-seven }
i_long := Length(s_parm2);
for iz := 1 to i_long do
begin
i_char := Ord(s_parm2[iz]);
if (i_char > 32) and (i_char < 127) then
begin
Inc(i_char, 47);
if (i_char > 126) then Dec(i_char, 94);
s_parm2[iz] := Chr(i_char);
end;
end;
sub_store_string(6, s_parm2);
end; { sub_comm_scod }
procedure TForm1.sub_comm_stoe;
{ updated 2006/08/24, 2006/04/14 }
{ old toe a string }
var
s_parm2 : string;
s_parm3 : string;
i_bigprime : integer;
i_number : integer;
i_char : integer;
i_long : integer;
i_slip : integer;
i_which : integer;
cz : char;
iz : integer;
begin
{ 12345678901234567890123456789012 }
{ $TOE 00101n,00099n,00001n,00002n }
s_parm2 := fns_string_eval(13);
s_parm3 := fns_string_eval(20);
i_which := fni_decimal_eval(27);
if (i_which <> 1) then i_which := 2;
i_bigprime := 700000001;
s_parm3 := UpperCase(s_parm3);
if (Length(s_parm3) > 16) then s_parm3 := Copy(s_parm3, 1, 16);
{ change key to i_number }
i_number := 0;
i_long := Length(s_parm3);
for iz := 1 to i_long do
begin
cz := s_parm3[iz];
i_char := Ord(cz);
if ((cz >= '0') and (cz <= '9'))
or ((cz >= 'A') and (cz <= 'Z')) then
i_number := i_number * 10 + i_char;
if (i_number > i_bigprime) then i_number := i_number - i_bigprime;
end;
{ old toe }
i_long := Length(s_parm2);
for iz := 1 to i_long do
begin
{ get the next i_number }
i_number := (i_number * 3 + 35731) mod i_bigprime;
i_slip := (i_number div 103) mod 95 + 1;
i_char := Ord(s_parm2[iz]);
if (i_char >= 32) and (i_char <= 126) then
begin
if (i_which = 1) then i_char := i_char + i_slip
else i_char := i_char - i_slip;
if (i_char > 126) then Dec(i_char, 95)
else if (i_char < 32) then Inc(i_char, 95);
s_parm2[iz] := Chr(i_char);
end;
end;
sub_store_string(6, s_parm2);
end; { sub_comm_stoe }
procedure TForm1.sub_comm_spar;
{ updated 2002/09/05 }
{ extract a string from a character separated variable }
var
s_result : string;
s_parm2, s_parm3 : string;
i_parm4 : integer;
char_parm3 : char;
i_long : integer;
i_count : integer;
i_beg, i_end : integer;
iz : integer;
b_loop : boolean;
b_good : boolean;
begin
{ 12345678901234567890123456789012 }
{ spar 00101n,00099n,00032n,00022n }
{ parm2, parm3 and parm4 }
s_parm2 := fns_string_eval(13);
s_parm3 := fns_string_eval(20);
i_parm4 := fni_decimal_eval(27);
s_result := '';
b_good := true;
if (Length(s_parm2) = 0) then b_good := false;
if (Length(s_parm3) = 0) then b_good := false;
if b_good then
begin
char_parm3 := s_parm3[1];
i_long := Length(s_parm2);
if (s_parm2[i_long] <> char_parm3) then
begin
s_parm2 := s_parm2 + char_parm3;
Inc(i_long);
end;
i_beg := 1;
i_end := 0;
i_count := 0;
iz := 1;
b_loop := true;
while b_loop do
begin
if (s_parm2[iz] = char_parm3) then
begin
i_beg := Succ(i_end);
i_end := iz;
Inc(i_count);
if (i_count = i_parm4) then
begin
s_result := Copy(s_parm2, i_beg, i_end - i_beg);
b_loop := false;
end;
end;
Inc(iz);
if (iz > i_long) then b_loop := false;
end;
end;
sub_store_string(6, s_result);
end; { sub_comm_spar }
procedure TForm1.sub_comm_sdot;
{ updated 2006/05/12, 2003/11/07 }
{ find dot=byte of counted occurrence of string in other string }
var
s_parm2, s_parm3 : string;
i_parm4 : integer;
i_long3, i_long2 : integer;
i_max : integer;
i_count : integer;
i_dot : integer;
iw, ix, iz : integer;
b_loop : boolean;
b_match : boolean;
b_process : boolean;
begin
{ 12345678901234567890123456789012 }
{ $DOT 00401D,00001S,00001N,00102S }
{ get the string we want to look in }
s_parm2 := fns_string_eval(13);
{ get the string we want to find }
s_parm3 := fns_string_eval(20);
{ get the occurrence count of the string }
i_parm4 := fni_decimal_eval(27);
b_process := true;
i_long3 := Length(s_parm3);
i_long2 := Length(s_parm2);
if (i_parm4 < 1) or (i_parm4 > i_long2) then b_process := false;
if (i_long3 = 0) or (i_long3 > i_long2) then b_process := false;
i_dot := 0;
if b_process then
begin
{ ix is what we are looking for }
ix := 1;
{ i_max is the maximum that ix can be }
i_max := Succ(i_long2 - i_long3);
i_count := 0;
b_match := false;
b_loop := true;
while b_loop do
begin
if (s_parm3[1] = s_parm2[ix]) then
begin
b_match := true;
iw := Pred(ix);
for iz := 2 to i_long3 do
begin
if (s_parm3[iz] <> s_parm2[iw + iz])
then b_match := false;
end;
if b_match then
begin
Inc(i_count);
if (i_count = i_parm4) then
begin
b_loop := false;
i_dot := ix;
end;
{ so that occurrences cannot overlap }
ix := ix + Pred(i_long3);
end;
end;
Inc(ix);
if (ix > i_max) then b_loop := false;
end;
end;
{ store the find answer }
sub_store_decimal(6, i_dot);
end; { sub_comm_sdot }
procedure TForm1.sub_comm_sisp;
{ updated 2004/01/02 }
{ string is pattern of types }
var
i_result : integer;
s_parm2, s_parm3 : string;
i_long : integer;
i_byte : integer;
i_char1, i_char2 : integer;
iz : integer;
b_loop : boolean;
b_good : boolean;
begin
{ 1234567890123456789012345 }
{ $ISP 00101n,00099n,00032n }
{ parm2, parm3 and parm4 }
s_parm2 := fns_string_eval(13);
s_parm3 := fns_string_eval(20);
{ if i_result = 1 the strings have the same pattern }
i_result := 2;
b_good := true;
i_long := Length(s_parm2);
if (i_long <> Length(s_parm3)) then b_good := false;
if (i_long < 1) then b_good := false;
if b_good then
begin
i_result := 1;
i_byte := 1;
b_loop := true;
while b_loop do
begin
i_char1 := Ord(s_parm2[i_byte]);
i_char1 := fni_pattern(i_char1);
i_char2 := Ord(s_parm3[i_byte]);
i_char2 := fni_pattern(i_char2);
if (i_char1 <> i_char2) then
begin
i_result := 2;
b_loop := false;
end;
Inc(i_byte);
if (i_byte > i_long) then b_loop := false;
end;
end;
sub_store_decimal(6, i_result);
end; { sub_comm_sisp }
procedure TForm1.sub_comm_sist;
{ updated 2004/01/02 }
{ string is type of character }
var
i_result : integer;
s_parm2, s_parm3 : string;
i_long : integer;
i_byte : integer;
i_char1, i_char2 : integer;
iz : integer;
b_loop : boolean;
b_good : boolean;
begin
{ 1234567890123456789012345 }
{ $ist 00101n,00099n,00032n }
{ parm2, parm3 and parm4 }
s_parm2 := fns_string_eval(13);
s_parm3 := fns_string_eval(20);
{ if i_result = 1 the string is the same type }
i_result := 2;
b_good := true;
i_long := Length(s_parm2);
if (Length(s_parm3) < 1) then b_good := false;
if (i_long < 1) then b_good := false;
if b_good then
begin
i_char2 := Ord(s_parm3[1]);
i_char2 := fni_pattern(i_char2);
i_result := 1;
i_byte := 1;
b_loop := true;
while b_loop do
begin
i_char1 := Ord(s_parm2[i_byte]);
i_char1 := fni_pattern(i_char1);
if (i_char1 <> i_char2) then
begin
i_result := 2;
b_loop := false;
end;
Inc(i_byte);
if (i_byte > i_long) then b_loop := false;
end;
end;
sub_store_decimal(6, i_result);
end; { sub_comm_sist }
function TForm1.fni_pattern(const pi_char : integer) : integer;
{ updated 2002/11/07 }
var
i_result : integer;
begin
Case pi_char of
0 .. 31 : i_result := 1;
32 : i_result := 2;
33 .. 47 : i_result := 3;
48 .. 57 : i_result := 4;
58 .. 64 : i_result := 3;
65 .. 90 : i_result := 5;
91 .. 96 : i_result := 3;
97 .. 122 : i_result := 6;
123 .. 126 : i_result := 3;
else
i_result := 7;
end;
Result := i_result;
end; { fni_pattern }
procedure TForm1.sub_comm_scut;
{ updated 2004/03/04 }
{ cut part of a string to make another string }
var
s_parm2 : string;
i_parm3, i_parm4 : integer;
s_result : string;
i_length : integer;
b_good : boolean;
begin
{ 12345678901234567890123456789012 }
{ $CUT 00101n,00099n,00032n,00005n }
{ parm2, parm3 and parm4 }
s_parm2 := fns_string_eval(13);
i_parm3 := fni_decimal_eval(20);
i_parm4 := fni_decimal_eval(27);
s_result := '';
b_good := true;
i_length := Length(s_parm2);
if (i_length < 1) or (i_parm4 < 1) or (i_parm3 > i_length)
then b_good := false;
if (i_parm3 < 1) then i_parm3 := 1;
if b_good then s_result := Copy(s_parm2, i_parm3, i_parm4);
sub_store_string(6, s_result);
end; { sub_comm_scut }
procedure TForm1.sub_comm_soff;
{ updated 2003/05/27 }
{ cut off end of a string by length to make another string }
var
i_beg : integer;
i_length : integer;
s_parm2 : string;
i_parm3, i_parm4 : integer;
begin
{ 1234567890123456789012345 }
{ $OFF 00101n,00099n,00032n }
{ parm2 and parm3 }
s_parm2 := fns_string_eval(13);
i_parm3 := fni_decimal_eval(20);
i_beg := Length(s_parm2) - i_parm3 + 1;
if (i_beg < 1) then i_beg := 1;
i_length := Length(s_parm2) - i_beg + 1;
sub_store_string(6, Copy(s_parm2, i_beg, i_length));
end; { sub_comm_soff }
procedure TForm1.sub_comm_evar;
{ updated 2007/06/16, 2004/01/24 }
{ initialize variables, this line happens after last VARI command }
var
i_var_ct : integer;
begin
{ 123456789012345678 }
{ EVAR,00000N,00000N }
{ decimals }
{ i_var_ct is how many local decimals are in this subroutine }
i_var_ct := StrToIntDef(Copy(fs_tpline, 6, 5), 0);
{ fi_delta_d is how many decimals there are before this subroutine }
fi_delta_d := fia_delta_d[fii_delta_d];
Inc(fii_delta_d);
Inc(i_var_ct, fi_delta_d);
if (i_var_ct > fi_max_delta_d) then fi_max_delta_d := i_var_ct;
if (i_var_ct > fi_max_dvar) or (fii_delta_d > 1000) then
sub_program_error('too many decimals')
else fia_delta_d[fii_delta_d] := i_var_ct;
{ fii_delta_d is the index for fia_delta_d }
{ strings }
{ i_var_ct is how many local strings are in this subroutine }
i_var_ct := StrToIntDef(Copy(fs_tpline, 13, 5), 0);
{ fi_delta_s is how many strings there are before this subroutine }
fi_delta_s := fia_delta_s[fii_delta_s];
Inc(fii_delta_s);
Inc(i_var_ct, fi_delta_s);
if (i_var_ct > fi_max_delta_s) then fi_max_delta_s := i_var_ct;
if (i_var_ct > fi_max_svar) or (fii_delta_s > 1000) then
sub_program_error('too many strings')
else fia_delta_s[fii_delta_s] := i_var_ct;
{ fii_delta_s is the index for fia_delta_s }
end; { sub_comm_evar }
procedure TForm1.sub_comm_ends;
{ updated 2000/01/01 }
var
i_beg, i_end : integer;
iz : integer;
begin
{ decimals }
{ fi_delta_d is how many decimals there are before this subroutine }
i_beg := Succ(fi_delta_d);
i_end := fia_delta_d[fii_delta_d];
{ zero the places where the variables were }
for iz := i_beg to i_end do fea_var[iz] := 0;
Dec(fii_delta_d);
fi_delta_d := fia_delta_d[Pred(fii_delta_d)];
{ strings }
{ fi_delta_s is how many strings there are before this subroutine }
i_beg := Succ(fi_delta_s);
i_end := fia_delta_s[fii_delta_s];
{ set to nothing the strings where the variables were }
for iz := i_beg to i_end do fsa_var[iz] := '';
Dec(fii_delta_s);
fi_delta_s := fia_delta_s[Pred(fii_delta_s)];
{ pop from the stack where we return to }
fi_tpline := fia_sub[fii_sub];
Dec(fii_sub);
end; { sub_comm_ends }
procedure TForm1.sub_comm_ssys;
{ updated 2003/12/15 }
{ get various string program information }
var
i_parm2 : integer;
s_info : string;
begin
{ 123456789012345678 }
{ $SYS,00000N,00000N }
i_parm2 := fni_decimal_eval(13);
s_info := 'none';
{ application name and path }
if (i_parm2 = 1) then s_info := LowerCase(Application.ExeName);
{ current program subroutine }
if (i_parm2 = 2) then s_info := fns_subroutine(fi_tpline);
sub_store_string(6, s_info);
end; { sub_comm_ssys }
procedure TForm1.sub_comm_dsys;
{ updated 2007/06/16, 2006/04/30, 2004/06/19 }
{ get various numeric program information }
var
i_parm2 : integer;
d_info : double;
d_total : double;
i_long : integer;
iz : integer;
begin
{ 123456789012345678 }
{ $SYS,00000N,00000N }
i_parm2 := fni_decimal_eval(13);
d_info := 0;
{ memory used by strings }
if (i_parm2 = 1) then
begin
d_total := 0;
{ total string variables }
for iz := 1 to fi_max_svar do
begin
d_total := d_total + Length(fsa_var[iz]);
end;
{ total string array }
for iz := 1 to fi_max_sarray do
begin
d_total := d_total + Length(fsa_array[iz]);
end;
{ total run program and actual program strings }
for iz := 1 to 15000 do
begin
d_total := d_total + Length(fsa_tpline[iz]);
end;
d_info := d_total;
end;
{ total lines run }
if (i_parm2 = 2) then d_info := fd_total_lines;
sub_store_decimal(6, d_info);
end; { sub_comm_dsys }
function TForm1.fns_subroutine(const pi_line : integer) : string;
{ updated 2003/12/15 }
var
s_result : string;
sz : string;
i_line : integer;
iz : integer;
b_loop : boolean;
begin
s_result := 'none';
i_line := pi_line;
b_loop := true;
if (i_line < 1) or (i_line > fi_tpline_last) then b_loop := false;
while b_loop do
begin
sz := Copy(fsa_tpline[i_line], 1, 4);
if (sz = 'SUBR') then
begin
s_result := LowerCase(Copy(fsa_tpline[i_line], 6, 99));
iz := Pos(';', s_result);
if (iz > 0) then s_result := Copy(s_result, 1, Pred(iz));
b_loop := false;
end;
Dec(i_line);
if (i_line < 1) then b_loop := false;
end;
Result := s_result;
end; { fns_subroutine }
procedure TForm1.sub_comm_file(const pbyte_1 : byte);
{ updated 2006/06/02, 2006/05/23, 2004/04/08 }
{ put length of file in bytes in variable }
var
file_1 : file;
i_parm2 : integer;
s_filename1, s_filename2 : string;
i_long : integer;
ez : double;
sz : string;
iz : integer;
bz : boolean;
begin
if (pbyte_1 = 1) then { FDAT }
begin
{ 1234567890123456789012345 }
{ FDAT 00401n,00402n,00101n }
i_parm2 := StrToIntDef(Copy(fs_tpline, 13, 5), -1);
if (i_parm2 = -1) then
begin
sub_program_error('bad variable link');
end
else
begin
s_filename1 := fns_string_eval(20);
{ both parm1 and parm2 must receive values }
if (fs_tpline[18] = 'S') then Inc(i_parm2, fi_delta_s);
if (fs_tpline[11] = 'D') then Inc(fi_link, fi_delta_d);
ez := 0;
sz := '';
if FileExists(s_filename1) then
begin
ez := FileDateToDateTime(FileAge(s_filename1));
sz := UpperCase(FormatDateTime('dd-mmm-yyyy hh:nn:ss', ez));
end;
fea_var[fi_link] := ez;
fsa_var[i_parm2] := sz;
end;
end
else if (pbyte_1 = 2) then { FDEL }
begin
{ 123456789012345678 }
{ FDEL 00001n,00101n }
s_filename1 := fns_string_eval(13);
s_filename1 := Trim(s_filename1);
iz := Pos('*', s_filename1);
if (iz = 0) then iz := Pos('?', s_filename1);
{ get the name and delete the file }
bz := false;
if (iz = 0) then bz := DeleteFile(s_filename1);
if bz then iz := 1 else iz := 2;
{ save the results of fdel }
sub_store_decimal(6, iz);
end
else if (pbyte_1 = 3) then { FLEN }
begin
{ 123456789012345678 }
{ FLEN 00901p,00101n }
s_filename1 := fns_string_eval(13);
i_long := -1;
if FileExists(s_filename1) then
begin
AssignFile(file_1, s_filename1);
{$I-}
Reset(file_1, 1);
{ get the length of the file in bytes }
i_long := FileSize(file_1);
CloseFile(file_1);
{$I+}
if (IOResult <> 0) then i_long := -1;
end;
{ save the length of the file in bytes }
sub_store_decimal(6, i_long);
end
else if (pbyte_1 = 4) then { FREN }
begin
{ rename the file s_filename2 to s_filename1 }
{ 1234567890123456789012345 }
{ FREN 00001n,00101n,00102n }
s_filename1 := fns_string_eval(13);
s_filename2 := fns_string_eval(20);
s_filename1 := LowerCase(s_filename1);
bz := RenameFile(s_filename2, s_filename1);
if bz then iz := 1 else iz := 2;
{ save the results of fren }
sub_store_decimal(6, iz);
end;
end; { sub_comm_file }
procedure TForm1.sub_comm_frea;
{ updated 2003/09/15 }
{ record input from file fs_filename_1 }
var
file_1 : file;
chara_4096 : array[1..4096] of char;
i_bytes_read : integer;
i_byte : integer;
i_long : integer;
s_filename : string;
s_record : string;
iz : integer;
begin
{ 12345678901234567890123456789012 }
{ FREA 00901p,00101n,00902p,00072n }
{ FREA 00101n,00401p,00402p,00102n }
{ FREA s_rec1,s_filename1,nbyte1,nlong1 }
s_filename := fns_string_eval(13);
i_byte := fni_decimal_eval(20);
i_long := fni_decimal_eval(27);
s_record := '';
{ in Teapro the first byte 1 in Delphi it is 0 }
{ set FileMode to zero to make sure the file is read only }
if FileExists(s_filename) then
begin
AssignFile(file_1, s_filename);
{$I-}
FileMode := 0;
Reset(file_1, 1);
Seek(file_1, Pred(i_byte));
BlockRead(file_1, chara_4096, i_long, i_bytes_read);
CloseFile(file_1);
{$I+}
{ if no IO error }
if (IOResult = 0) then
begin
if (i_bytes_read < i_long) then i_long := i_bytes_read;
s_record := StringOfChar(' ', i_long);
for iz := 1 to i_long do s_record[iz] := chara_4096[iz];
end;
end;
sub_store_string(6, s_record);
end; { sub_comm_frea }
procedure TForm1.sub_comm_fwri;
{ updated 2003/09/15 }
{ record out to file file_1 }
var
file_1 : file;
chara_4096 : array[1..4096] of char;
i_file_length : integer;
i_bytes_written : integer;
i_byte : integer;
s_record : string;
s_filename : string;
iz : integer;
b_exists : boolean;
begin
{ 1234567890123456789012345 }
{ FWRI 00401p,00101n,00102n }
s_filename := fns_string_eval(13);
i_byte := fni_decimal_eval(20);
s_record := fns_string_eval(27);
{
showmessage('file=' + s_filename + '@');
showmessage(inttostr(i_byte) + ' @' + s_record + '@');
showmessage('record length=' + inttostr(length(s_record)));
}
{ in Teapro the first byte is 1 in Delphi it is 0 }
i_bytes_written := 0;
for iz := 1 to Length(s_record) do
chara_4096[iz] := s_record[iz];
s_filename := LowerCase(s_filename);
b_exists := FileExists(s_filename);
{ set FileMode to 1 for write only }
AssignFile(file_1, s_filename);
{$I-}
FileMode := 1;
if b_exists then Reset(file_1, 1)
else Rewrite(file_1, 1);
{ we cannot write beyond the length + 1 }
i_file_length := FileSize(file_1);
if (i_byte > Succ(i_file_length)) then i_byte := Succ(i_file_length);
Seek(file_1, Pred(i_byte));
BlockWrite(file_1, chara_4096, Length(s_record), i_bytes_written);
CloseFile(file_1);
{$I+}
{ faux line to get rid of IOResult }
if (IOResult <> 0) then iz := 0;
{ save the length written }
sub_store_decimal(6, i_bytes_written);
end; { sub_comm_fwri }
procedure TForm1.sub_comm_finp;
{ updated 2003/09/15 }
{ entire file input }
var
file_1 : file;
chara_4096 : array[1..4096] of char;
i_bytes_read : integer;
i_file_byte : integer;
i_file_length : integer;
s_filename : string;
s_data : string;
iz : integer;
b_loop : boolean;
b_open : boolean;
b_good : boolean;
begin
{ 123456789012345678 }
{ FINP 00901p,00101n }
s_filename := fns_string_eval(13);
s_data := '';
b_open := false;
b_good := FileExists(s_filename);
if b_good then
begin
{ open the file as an existing file }
{ set FileMode to zero to make sure the file is read only }
AssignFile(file_1, s_filename);
{$I-}
FileMode := 0;
Reset(file_1, 1);
{$I+}
if (IOResult = 0) then b_open := true
else b_good := false;
end;
if b_good then
begin
{ get the length of the file }
{$I-}
i_file_length := FileSize(file_1);
{$I+}
if (IOResult <> 0) then b_good := false;
end;
if b_good then
begin
if (i_file_length > fi_max_length) then
begin
b_good := false;
sub_program_error('file too big');
end;
end;
if b_good then
begin
s_data := StringOfChar(' ', i_file_length);
{ read the entire file into string sdata }
i_file_byte := 0;
b_loop := true;
while b_loop do
begin
{ finp }
Application.ProcessMessages;
{$I-}
Seek(file_1, i_file_byte);
BlockRead(file_1, chara_4096, 4096, i_bytes_read);
{$I+}
if (IOResult <> 0) then
begin
b_loop := false;
b_good := false;
end;
for iz := 1 to i_bytes_read do
s_data[i_file_byte + iz] := chara_4096[iz];
Inc(i_file_byte, i_bytes_read);
if (Succ(i_file_byte) >= i_file_length) then b_loop := false;
end;
end;
{ close the file if needed }
if b_open then CloseFile(file_1);
if not b_good then s_data := '';
sub_store_string(6, s_data);
end; { sub_comm_finp }
procedure TForm1.sub_comm_fout;
{ updated 2003/09/15 }
{ entire file output }
var
file_1 : file;
chara_4096 : array[1..4096] of char;
i_bytes_written : integer;
i_tbytes_written : integer;
i_string_byte : integer;
s_string : string;
s_record : string;
i_long : integer;
s_filename : string;
iz : integer;
b_loop : boolean;
b_open : boolean;
b_good : boolean;
begin
{ 1234567890123456789012345 }
{ FOUT 00401p,00101n,00102n }
s_filename := fns_string_eval(13);
s_string := fns_string_eval(20);
s_filename := LowerCase(s_filename);
i_long := Length(s_string);
i_tbytes_written := 0;
b_good := true;
b_open := false;
if b_good then
begin
AssignFile(file_1, s_filename);
{ open the file for write only }
{$I-}
FileMode := 1;
Rewrite(file_1, 1);
{$I+}
if (IOResult = 0) then b_open := true
else b_good := false;
end;
if b_good then
begin
i_string_byte := 1;
b_loop := true;
while b_loop do
begin
s_record := Copy(s_string, i_string_byte, 4096);
for iz := 1 to Length(s_record) do
chara_4096[iz] := s_record[iz];
{$I-}
Seek(file_1, Pred(i_string_byte));
BlockWrite(file_1, chara_4096, Length(s_record), i_bytes_written);
{$I+}
if (IOResult <> 0) then
begin
b_loop := false;
b_good := false;
end;
{ fout }
Application.ProcessMessages;
Inc(i_tbytes_written, i_bytes_written);
Inc(i_string_byte, i_bytes_written);
if (i_string_byte > i_long) then b_loop := false;
end;
end;
if b_open then CloseFile(file_1);
{ save the length written }
sub_store_decimal(6, i_tbytes_written);
end; { sub_comm_fout }
procedure TForm1.sub_comm_fsip;
{ updated 2005/04/16, 2003/09/15 }
{ read line from file fs_filename_1 }
var
file_1 : file;
chara_4096 : array[1..4096] of char;
s_char10 : string;
s_char13 : string;
i_bytes_read : integer;
i_oldbyte : integer;
i_newbyte : integer;
i_long : integer;
i_error : integer;
s_filename : string;
i_filelength : integer;
s_record : string;
b_good : boolean;
sz : string;
iz : integer;
begin
{ 1234567890123456789012345 }
{ FSIP 00901p,00101n,00902p }
{ FSIP s_reco,s_filename,d_byte }
s_filename := fns_string_eval(13);
i_oldbyte := fni_decimal_eval(20);
{ initialize }
s_char10 := Chr(10);
s_char13 := Chr(13);
i_newbyte := 0;
s_record := '';
i_bytes_read := 0;
if FileExists(s_filename) then b_good := true
else b_good := false;
if (i_oldbyte < 1) then b_good := false;
{ in Teapro the first byte 1 in Delphi it is 0 }
{ set FileMode to zero to make sure the file is read only }
if b_good then
begin
AssignFile(file_1, s_filename);
{$I-}
FileMode := 0;
Reset(file_1, 1);
i_filelength := FileSize(file_1);
if (i_oldbyte > i_filelength) then b_good := false;
if b_good then
begin
{ file begin at 0 in Delphi and at 1 in Teapro }
Seek(file_1, Pred(i_oldbyte));
BlockRead(file_1, chara_4096, 4096, i_bytes_read);
end;
CloseFile(file_1);
{$I+}
i_error := IOResult;
if (i_error > 0) then b_good := false;
if b_good then
begin
s_record := chara_4096;
s_record := Copy(s_record, 1, i_bytes_read);
i_newbyte := i_oldbyte + i_bytes_read;
{ look for a s_char10 = line feed }
i_long := Pos(s_char10, s_record);
if (i_long > 0) then
begin
{ s_char10 in i_long is s_char13 in i_long - 1 }
iz := i_long - 1;
sz := Copy(s_record, iz, 1);
if (sz = s_char13) then Dec(iz);
s_record := Copy(s_record, 1, iz);
i_newbyte := i_oldbyte + i_long;
end;
end;
end;
{ if no record was read }
if not b_good then i_newbyte := 0;
{ put the new position into the third parameter variable }
iz := StrToIntDef(Copy(fs_tpline, 20, 5), -1);
if (iz = -1) then
begin
sub_program_error('bad variable link');
end
else
begin
sub_store_decimal(20, i_newbyte);
{ put the string into the first parameter variable }
sub_store_string(6, s_record);
end;
end; { sub_comm_fsip }
procedure TForm1.sub_comm_fapp(const pbyte_1 : byte);
{ updated 2005/09/07, 2005/06/20, 2005/04/18, 2003/09/16 }
{ append line to file with lf or crlf added to end }
{ pbyte_1=1 means FAPP crlf }
{ pbyte_1=2 means FADD lf }
var
file_1 : file;
chara_4096 : array[1..4098] of char;
i_file_length : integer;
i_bytes_written : integer;
i_byte : integer;
s_record : string;
s_filename : string;
i_count : integer;
iz : integer;
b_loop : boolean;
b_error : boolean;
b_exists : boolean;
begin
{ 1234567890123456789012345 }
{ FAPP 00401p,00101n,00101n }
{ FADD 00401p,00101n,00101n }
s_filename := fns_string_eval(13);
s_record := fns_string_eval(20);
{ in Teapro the first file byte is 1 in Delphi it is 0 }
i_bytes_written := 0;
b_error := false;
if (Length(s_record) > 4096) then b_error := true;
if (pbyte_1 = 1) then
begin
s_record := s_record + Chr(13) + Chr(10);
end
else
begin
s_record := s_record + Chr(10);
end;
i_count := 0;
b_loop := true;
if b_error then b_loop := false;
while b_loop do
begin
{ chara_4096 is actually 4098 long }
for iz := 1 to Length(s_record) do
chara_4096[iz] := s_record[iz];
s_filename := LowerCase(s_filename);
b_exists := FileExists(s_filename);
{ set FileMode to 1 for write only }
AssignFile(file_1, s_filename);
{$I-}
FileMode := 1;
if b_exists then Reset(file_1, 1)
else Rewrite(file_1, 1);
i_file_length := FileSize(file_1);
i_byte := Succ(i_file_length);
Seek(file_1, Pred(i_byte));
BlockWrite(file_1, chara_4096, Length(s_record), i_bytes_written);
CloseFile(file_1);
{$I+}
if (IOResult > 0) then
begin
{ the record was not appended }
i_bytes_written := 0;
Inc(i_count);
if (i_count >= 10) then b_loop := false
{ FAPP or FADD }
else for iz := 0 to 1000 do Application.ProcessMessages;
end
{ the record was appended so we are done }
else b_loop := false;
end;
{ save the length written }
if not b_error then sub_store_decimal(6, i_bytes_written)
else sub_program_error('string > 4096');
end; { sub_comm_fapp }
function TForm1.fnd_decimal_eval(const pbyte_1 : byte) : double;
{ updated 2002/04/19 }
{ evaluate a number to a decimal }
var
i_value : integer;
c_z : char;
begin
{ C = single character }
{ D = local decimal }
{ G = global decimal }
{ N = literal number }
{ R = global string }
{ S = local string }
i_value := StrToIntDef(Copy(fs_tpline, pbyte_1, 5), -1);
if (i_value = -1) then
begin
sub_program_error('bad integer');
Result := 0;
end
else
begin
c_z := fs_tpline[pbyte_1 + 5];
Case c_z of
{ local variable }
'D' : Result := fea_var[i_value + fi_delta_d];
{ global variable }
'G' : Result := fea_var[i_value];
else
{ literal value }
Result := i_value;
end;
end;
end; { fnd_decimal_eval }
function TForm1.fni_decimal_eval(const pbyte_1 : byte) : integer;
{ updated 2004/03/03 }
{ evaluate a number to a decimal }
var
dz : double;
i_value : integer;
c_z : char;
i_result : integer;
begin
{ C = single character }
{ D = local decimal }
{ G = global decimal }
{ N = literal number }
{ R = global string }
{ S = local string }
i_value := StrToIntDef(Copy(fs_tpline, pbyte_1, 5), -1);
i_result := 0;
if (i_value = -1) then
begin
sub_program_error('bad integer');
end
else
begin
c_z := fs_tpline[pbyte_1 + 5];
Case c_z of
{ local variable }
'D' : dz := fea_var[i_value + fi_delta_d];
{ global variable }
'G' : dz := fea_var[i_value];
else
{ literal value }
dz := i_value;
end;
if (dz > MaxInt) then dz := MaxInt
else if (dz < -MaxInt) then dz := -MaxInt;
i_result := Round(dz);
end;
Result := i_result;
end; { fni_decimal_eval }
function TForm1.fnd_modulus(
const dp_number : double;
const dp_divisor : double) : double;
{ updated 2007/01/20, 2007/01/19 }
var
c_1 : comp;
c_2 : comp;
d_result : double;
begin
{ the sign of e_answer prevails }
c_1 := dp_number;
c_2 := Abs(dp_divisor);
d_result := 1;
if (c_2 > 0) then
begin
{ find mod }
d_result := c_1 - Int(c_1 / c_2) * c_2;
end
else sub_program_error('zero modulus');
Result := d_result;
end; { fnd_modulus }
function TForm1.fns_from_double(
const pd_num : double;
const pbyte_commas : byte) : string;
{ updated 2004/03/03 }
var
s_number : string;
iz : integer;
begin
{ pi2 is 1 to put in commas }
if (pbyte_commas = 1) then
s_number := FloatToStrF(pd_num, ffNumber, 16, 16)
else s_number := FloatToStrF(pd_num, ffFixed, 16, 16);
s_number := Trim(s_number);
{ not exponential and with decimal }
if (Pos('E', s_number) = 0) and (Pos('.', s_number) > 0) then
begin
iz := Length(s_number);
while (s_number[iz] = '0') do Dec(iz);
s_number := Copy(s_number, 1, iz);
{ take off a trailing decimal }
iz := Length(s_number);
if (s_number[iz] = '.') then s_number := Copy(s_number, 1, Pred(iz));
end;
Result := s_number;
end; { fns_from_double }
procedure TForm1.sub_double_from_string(
const ps1 : string;
var pe2 : double;
var pb3 : boolean);
{ updated 2004/09/25 }
{ convert a string to a double number }
var
s_digits : string;
s_number : string;
e_number : double;
s_test : string;
i_dot : integer;
b_loop : boolean;
b_negative : boolean;
b_enumber : boolean;
sz : string;
iy, iz : integer;
b_error : boolean;
begin
e_number := 0;
b_error := false;
b_negative := false;
s_digits := '0123456789';
s_number := UpperCase(Trim(ps1));
if (Length(s_number) = 0) then b_error := true;
if not b_error then
begin
if (s_number[1] = '+') then s_number := Copy(s_number, 2, 999)
else if (s_number[1] = '-') then
begin
s_number := Copy(s_number, 2, 999);
b_negative := true;
end;
end;
if (Length(s_number) = 0) then b_error := true;
if not b_error then
begin
if (Pos(s_number[1], '+-') > 0) then b_error := true;
end;
if not b_error then
begin
{ take out any commas ie. ,000}
b_loop := true;
while b_loop do
begin
iz := Pos(',', s_number);
if (iz = 0) then b_loop := false
else
begin
if (iz = 1) then b_error := true;
sz := Copy(s_number, Succ(iz), 3);
iy := StrToIntDef(sz, -1);
if (iy >= 0) then Delete(s_number, iz, 1)
else
begin
b_error := true;
b_loop := false;
end;
end;
end;
if (Length(s_number) = 0) then b_error := true;
end;
if not b_error then
begin
s_test := s_number;
{ validate the E part if any }
iz := Pos('E', s_test);
if (iz > 0) then
begin
if (iz < 4) or (Length(s_test) - iz < 1) then b_error := true;
if not b_error then
begin
{ sz is part following the E }
sz := Copy(s_test, Succ(iz), 99);
{ s_test is part preceding the E }
s_test := Copy(s_test, 1, Pred(iz));
{ sz is part following the E }
if (sz[1] = '-') then sz := Copy(sz, 2, 99);
iz := StrToIntDef(sz, -1);
if (iz = -1) then b_error := true;
if (iz > 4392) then b_error := true;
{ s_test is part preceding the E }
if (s_test[2] <> '.') then b_error := true;
if (Pos(s_test[1], s_digits) = 0) then b_error := true;
if (Pos(s_test[3], s_digits) = 0) then b_error := true;
{ s_test will be further validated below }
end;
end;
end;
if not b_error then
begin
{ take off unneccessary leading zeros }
b_loop := true;
while b_loop do
begin
if (Length(s_test) > 15) and (s_test[1] = '0')
then s_test := Copy(s_test, 2, 99)
else b_loop := false;
end;
{ take off unneccessary trailing zeros }
i_dot := Pos('.', s_test);
if (i_dot > 0) then b_loop := true
else b_loop := false;
while b_loop do
begin
iz := Length(s_test);
if (iz > 15) and (s_test[iz] = '0')
then s_test := Copy(s_test, 1, Pred(iz))
else b_loop := false;
end;
{ take out the dot }
i_dot := Pos('.', s_test);
if (i_dot > 0) then Delete(s_test, i_dot, 1);
{ do we have all numbers }
for iz := 1 to Length(s_test) do
begin
if (Pos(s_test[iz], s_digits) = 0)
then b_error := true;
end;
if (Length(s_test) > 16) then b_error := true;
end;
if not b_error then e_number := StrToFloat(s_number);
if b_negative then e_number := - e_number;
pe2 := e_number;
pb3 := b_error;
end; { sub_double_from_string }
procedure TForm1.sub_store_decimal(const pbyte_1 : byte; const pd_1 : double);
{ updated 2002/09/04 }
var
i_store : integer;
sz : string;
begin
{ 12345S }
i_store := StrToIntDef(Copy(fs_tpline, pbyte_1, 5), -1);
if (i_store < 0) then
begin
sub_program_error('bad integer=' + Copy(fs_tpline, pbyte_1, 5));
end
else
begin
{ store the decimal }
if (fs_tpline[pbyte_1 + 5] = 'D') then Inc(i_store, fi_delta_d);
fea_var[i_store] := pd_1;
end;
end; { sub_store_decimal }
procedure TForm1.sub_store_string(const pbyte_1 : byte; const ps_1 : string);
{ updated 2002/09/03 }
var
i_store : integer;
sz : string;
begin
{ 12345S }
i_store := StrToIntDef(Copy(fs_tpline, pbyte_1, 5), -1);
if (i_store < 0) then
begin
sub_program_error('bad integer=' + Copy(fs_tpline, pbyte_1, 5));
end
else
begin
{ store the string }
if (fs_tpline[pbyte_1 + 5] = 'S') then Inc(i_store, fi_delta_s);
fsa_var[i_store] := ps_1;
end;
end; { sub_store_string }
function TForm1.fns_string_eval(const pbyte_1 : byte) : string;
{ updated 2002/04/19 }
var
i_value : integer;
c_z : char;
begin
{ C = single character }
{ D = local decimal }
{ G = global decimal }
{ N = literal number }
{ R = global string }
{ S = local string }
{ 123456 }
{ 00101S }
i_value := StrToIntDef(Copy(fs_tpline, pbyte_1, 5), -1);
if (i_value = -1) then
begin
sub_program_error('bad integer');
Result := '';
end
else
begin
c_z := fs_tpline[pbyte_1 + 5];
Case c_z of
{ single character }
'C' : Result := Chr(i_value);
{ local decimal variable }
'D' : Result := fns_from_double(fea_var[i_value + fi_delta_d], 0);
{ global decimal variable }
'G' : Result := fns_from_double(fea_var[i_value], 0);
{ global or constant string }
'R' : Result := fsa_var[i_value];
{ local string variable }
'S' : Result := fsa_var[i_value + fi_delta_s];
else
{ number = N }
Result := fns_from_double(i_value, 0);
end;
end;
end; { fns_string_eval }
function TForm1.fns_string_parse(const ps1 : string) : string;
{ updated 2003/04/25 }
var
i_long1, i_long2 : integer;
s_result : string;
i_value : integer;
s_term : string;
s_line : string;
b_loop : boolean;
b_error : boolean;
begin
{ C = single character }
{ D = local decimal }
{ G = global decimal }
{ N = literal number }
{ R = global string }
{ S = local string }
{ 123456 }
{ 00101n }
{ hundred million }
b_error := false;
s_line := ps1;
s_result := '';
b_loop := false;
if (Length(s_line) > 5) then b_loop := true;
while b_loop do
begin
i_value := StrToIntDef(Copy(s_line, 1, 5), -1);
if (i_value = -1) then
begin
sub_program_error('bad variable link');
b_loop := false;
s_result := '';
end
else
begin
{ local string variable }
if (s_line[6] = 'S') then s_term := fsa_var[i_value + fi_delta_s]
{ global string variable }
else if (s_line[6] = 'R') then s_term := fsa_var[i_value]
{ single character }
else if (s_line[6] = 'C') then s_term := Chr(i_value)
{ local decimal variable }
else if (s_line[6] = 'D') then s_term :=
fns_from_double(fea_var[i_value + fi_delta_d], 0)
{ global decimal variable }
else if (s_line[6] = 'G') then s_term :=
fns_from_double(fea_var[i_value], 0)
{ number }
else s_term := fns_from_double(i_value, 0);
i_long1 := Length(s_result);
i_long2 := Length(s_term);
if (i_long1 + i_long2 > fi_max_length) then b_error := true;
if b_error then
begin
b_loop := false;
sub_program_error('string too long');
end
else
begin
s_result := s_result + s_term;
s_line := Copy(s_line, 8, 200);
if (Length(s_line) < 6) then b_loop := false;
end;
end;
end;
Result := s_result;
end; { fns_string_parse }
procedure TForm1.sub_memo_show(
const ps1 : string;
const pbyte_2 : byte);
{ updated 2005/02/07, 2004/03/04 }
var
s_line : string;
i_top : integer;
iy, iz : integer;
sz : string;
begin
s_line := TrimRight(Copy(ps1, 1, 77));
{ blank escape characters }
s_line := fns_blank_escapes(s_line);
if not fb_show then
begin
{ $out rather than $sho }
{ fsa_show is 1..35 }
for iz := 1 to 34 do fsa_show[iz] := fsa_show[Succ(iz)];
end;
{ store new output line on the show stack }
fsa_show[35] := s_line;
{ prep string to show fi_show_lines }
i_top := 35 - fi_show_lines + 1;
sz := fsa_show[i_top];
for iz := 1 to Pred(fi_show_lines) do
sz := sz + nl + fsa_show[i_top + iz];
{ show on form }
label_show.caption := sz;
{ pbyte_2=1 comes from $out, pbyte_2=2 from $sho }
if (pbyte_2 = 1) then fb_show := false
else fb_show := true;
end; { sub_memo_show }
function TForm1.fns_blank_escapes(const ps1 : string) : string;
{ updated 2004/01/18 }
{ replace escape characters with blanks/nothing }
var
s_result : string;
iz : integer;
begin
s_result := ps1;
for iz := 1 to Length(s_result) do
begin
if (s_result[iz] < ' ') then s_result[iz] := ' ';
end;
Result := s_result;
end; { fns_blank_escapes }
procedure TForm1.sub_commands_to_int;
{ updated 2007/04/14 }
{ 2007/01/19, 2006/06/02, 2006/05/12, 2005/03/22, 2004/10/19 }
var
i_command : integer;
i_line : integer;
s_commands : string;
s_comm : string;
i_index : integer;
sz : string;
begin
{ this is the command list for real }
s_commands := ''
+ 'DABS,DARC,DCH$,DDEC,DED$,DFAC,DIF1,'
+ 'DIFT,DINC,DLOG,DPK$,DPOW,DRAN,DROU,'
+ 'DSEC,DSET,DSIN,DTO$,DTOF,DTOI,DTRU,DWHI,'
+ 'ELSE,ENDI,ENDP,ENDS,ENDW,ESUB,XXXX,EVAR,'
+ 'ITO$,ITOD,'
+ '$APP,$BAK,$BES,$CH$,$CHD,$CLO,$CNT,$COD,$CUP,'
+ '$CUT,$DAT,$DEL,$DOT,$IF1,$IFT,$INP,$INS,$ISC,'
+ '$ISD,$ISP,$IST,$LEN,$LOK,$OFF,$OUT,$PAR,$PKD,'
+ '$REP,$SET,$SHO,$SOR,$SWP,$SYS,$TLO,$TOD,$TOI,'
+ '$TRB,$TRL,$TRR,$TUP,$WHI,'
+ 'FDAT,FDEL,FLEN,FREN,'
+ 'FINP,FOUT,'
+ 'FSIP,FAPP,FADD,'
+ 'FREA,FWRI,'
+ 'QAPP,QINP,QOUT,QSET,QTOI,'
+ 'XXXX,XXXX,XXXX,XXXX,XXXX,'
+ 'ARRZ,ARRB,ADDI,DSYS,DBAD,'
+ '$TOE,$HSH,DBUG,DFAK,GOTO,'
+ 'GTAG,SUBR,VARI';
fi_tpline := 0;
i_line := 1;
while (i_line <= fi_tpline_last) and not fb_terminate do
begin
fs_tpline := fsa_tpline[i_line];
s_comm := Copy(fs_tpline, 1, 4);
{ set the beginning line of the program }
if (fi_tpline = 0) and (s_comm <> 'VARI') then
fi_tpline := i_line;
i_command := Pos(s_comm, s_commands);
if (i_command > 0) then
i_index := ((i_command - 1) div 5) + 1
else
begin
sz := 'Bad command line' + nl
+ IntToStr(i_line) + ' ' + fs_tpline;
ShowMessage(sz);
fb_terminate := true;
end;
if (i_index < 1) or (i_index > 255) then i_index := 0;
fbytea_command[i_line] := byte(i_index);
Inc(i_line);
end;
end; { sub_commands_to_int }
procedure TForm1.sub_validate_commands;
{ updated 2007/04/14, 2007/01/19, 2006/05/02 }
{ 2006/05/12, 2006/04/30, 2006/04/29, 2005/03/22, 2004/10/19 }
var
s_op1 : string;
s_commands : string;
begin
fb_error := false;
fs_tpline := fsa_tpline[fi_tpline];
s_op1 := Copy(fs_tpline, 1, 4);
{ validate the command }
s_commands := ''
+ 'DABS,DARC,DCH$,DDEC,DED$,DFAC,DIF1,'
+ 'DIFT,DINC,DLOG,DPK$,DPOW,DRAN,DROU,'
+ 'DSEC,DSET,DSIN,DTO$,DTOF,DTOI,DTRU,DWHI,'
+ 'ELSE,ENDI,ENDP,ENDS,ENDW,ESUB,XXXX,EVAR,'
+ 'ITO$,ITOD,'
+ '$APP,$BAK,$BES,$CH$,$CHD,$CLO,$CNT,$COD,$CUP,'
+ '$CUT,$DAT,$DEL,$DOT,$IF1,$IFT,$INP,$INS,$ISC,'
+ '$ISD,$ISP,$IST,$LEN,$LOK,$OFF,$OUT,$PAR,$PKD,'
+ '$REP,$SET,$SHO,$SOR,$SWP,$SYS,$TLO,$TOD,$TOI,'
+ '$TRB,$TRL,$TRR,$TUP,$WHI,'
+ 'FDAT,FDEL,FLEN,FREN,'
+ 'FINP,FOUT,'
+ 'FSIP,FAPP,FADD,'
+ 'FREA,FWRI,'
+ 'QAPP,QINP,QOUT,QSET,QTOI,'
+ 'XXXX,XXXX,XXXX,XXXX,XXXX,'
+ 'ARRZ,ARRB,ADDI,DSYS,DBAD,'
+ '$TOE,$HSH,DBUG,DFAK,GOTO,'
+ 'GTAG,SUBR,VARI';
if (Pos(s_op1, s_commands) = 0) or (Pos(',', s_op1) > 0)
then fb_error := true;
if (fs_tpline[5] <> ',') then fb_error := true;
if fb_error then sub_error_in_prog_line('Bad command', fi_tpline);
end; { sub_validate_commands }
procedure TForm1.sub_validate_variables;
{ updated 2007/07/08, 2007/05/06, 2007/04/15, 2007/01/19 }
{ 2006/06/11, 2006/06/09, 2006/05/23, 2006/05/12, 2006/04/30 }
{ 2006/04/29, 2006/04/14, 2006/01/17, 2005/06/20, 2004/10/19 }
var
iy, iz : integer;
s_op1 : string;
sy, sz : string;
b_loop : boolean;
begin
fb_error := false;
fs_tpline := fsa_tpline[fi_tpline];
s_op1 := Copy(fs_tpline, 1, 4);
{ COMM 00001S,00002S,00003S,00004S; }
{ 123456789012345678901234567890123 }
{ N means decimal literal or variable }
{ D means decimal variable }
{ $ means string literal or variable }
{ S means string variable }
{ a variable can give and receive values }
{ validate variables }
if (s_op1 = 'DINC')
or (s_op1 = 'DDEC')
or (s_op1 = 'DSEC')
or (s_op1 = 'DRAN') then
begin
sub_validate_variable(6, 'D');
sub_validate_semicolon(12);
end
else if (s_op1 = '$DAT') then
begin
sub_validate_variable(6, 'S');
sub_validate_semicolon(12);
end
else if (s_op1 = 'QTOI') then
begin
sub_validate_variable(6, 'N');
end
else if (s_op1 = 'QAPP')
or (s_op1 = 'QINP')
or (s_op1 = 'QSET') then
begin
sub_validate_variable(6, 'S');
end
else if (s_op1 = '$OUT')
or (s_op1 = '$SHO') then
begin
sub_validate_append(6);
end
else if (s_op1 = '$SET')
or (s_op1 = '$APP')
or (s_op1 = '$INP') then
begin
sub_validate_variable(6, 'S');
sub_validate_append(13);
end
else if (s_op1 = '$IFT')
or (s_op1 = '$IF1')
or (s_op1 = '$WHI') then
begin
sub_validate_variable(6, '$');
sub_validate_variable(14, '$');
sub_validate_semicolon(22);
end
else if (s_op1 = '$CLO')
or (s_op1 = '$CUP')
or (s_op1 = '$COD')
or (s_op1 = '$BES')
or (s_op1 = '$TLO')
or (s_op1 = '$TRB')
or (s_op1 = '$TRL')
or (s_op1 = '$TRR')
or (s_op1 = '$TUP')
or (s_op1 = 'FINP') then
begin
sub_validate_variable(6, 'S');
sub_validate_variable(13, '$');
sub_validate_semicolon(19);
end
else if (s_op1 = '$TOD')
or (s_op1 = '$CHD')
or (s_op1 = '$HSH')
or (s_op1 = '$LEN')
or (s_op1 = 'FDEL')
or (s_op1 = '$ISD')
or (s_op1 = 'FLEN') then
begin
sub_validate_variable(6, 'D');
sub_validate_variable(13, '$');
sub_validate_semicolon(19);
end
else if (s_op1 = '$TOI') then
begin
sub_validate_variable(6, 'N');
sub_validate_variable(13, '$');
sub_validate_semicolon(19);
end
else if (s_op1 = 'ITO$')
or (s_op1 = '$SYS') then
begin
sub_validate_variable(6, 'S');
sub_validate_variable(13, 'N');
sub_validate_semicolon(19);
end
else if (s_op1 = 'DIFT')
or (s_op1 = 'DBAD')
or (s_op1 = 'DIF1')
or (s_op1 = 'DWHI') then
begin
sub_validate_variable(6, 'N');
sub_validate_variable(14, 'N');
sub_validate_semicolon(22);
end
else if (s_op1 = 'DLOG')
or (s_op1 = 'DROU')
or (s_op1 = 'DTRU')
or (s_op1 = 'DABS')
or (s_op1 = 'DSIN')
or (s_op1 = 'DFAC')
or (s_op1 = 'DSYS')
or (s_op1 = 'DARC') then
begin
sub_validate_variable(6, 'D');
sub_validate_variable(13, 'N');
sub_validate_semicolon(19);
end
else if (s_op1 = 'DTOI')
or (s_op1 = 'ADDI')
or (s_op1 = 'ITOD') then
begin
sub_validate_variable(6, 'N');
sub_validate_variable(13, 'N');
sub_validate_semicolon(19);
end
else if (s_op1 = '$CH$')
or (s_op1 = '$OFF')
or (s_op1 = '$SOR') then
begin
sub_validate_variable(6, 'S');
sub_validate_variable(13, '$');
sub_validate_variable(20, 'N');
sub_validate_semicolon(26);
end
else if (s_op1 = '$INS')
or (s_op1 = '$REP') then
begin
sub_validate_variable(6, 'S');
sub_validate_variable(13, 'N');
sub_validate_variable(20, '$');
sub_validate_semicolon(26);
end
else if (s_op1 = '$DEL')
or (s_op1 = 'DTOF')
or (s_op1 = 'DPK$')
or (s_op1 = 'DCH$') then
begin
sub_validate_variable(6, 'S');
sub_validate_variable(13, 'N');
sub_validate_variable(20, 'N');
sub_validate_semicolon(26);
end
else if (s_op1 = 'DPOW')
or (s_op1 = 'DFAK') then
begin
sub_validate_variable(6, 'D');
sub_validate_variable(13, 'N');
sub_validate_variable(20, 'N');
sub_validate_semicolon(26);
end
else if (s_op1 = 'FDAT') then
begin
sub_validate_variable(6, 'D');
sub_validate_variable(13, 'S');
sub_validate_variable(20, '$');
sub_validate_semicolon(26);
end
else if (s_op1 = 'FSIP') then
begin
sub_validate_variable(6, 'S');
sub_validate_variable(13, '$');
sub_validate_variable(20, 'D');
sub_validate_semicolon(26);
end
else if (s_op1 = '$SWP') then
begin
sub_validate_variable(6, 'S');
sub_validate_variable(13, '$');
sub_validate_variable(20, '$');
sub_validate_semicolon(26);
end
else if (s_op1 = 'FAPP')
or (s_op1 = 'FADD')
or (s_op1 = '$ISP')
or (s_op1 = '$ISC')
or (s_op1 = '$IST')
or (s_op1 = '$CNT')
or (s_op1 = 'FREN')
or (s_op1 = 'FOUT') then
begin
sub_validate_variable(6, 'D');
sub_validate_variable(13, '$');
sub_validate_variable(20, '$');
sub_validate_semicolon(26);
end
else if (s_op1 = '$CUT')
or (s_op1 = 'FREA') then
begin
sub_validate_variable(6, 'S');
sub_validate_variable(13, '$');
sub_validate_variable(20, 'N');
sub_validate_variable(27, 'N');
sub_validate_semicolon(33);
end
else if (s_op1 = '$LOK')
or (s_op1 = 'FWRI')
or (s_op1 = '$BAK') then
begin
sub_validate_variable(6, 'D');
sub_validate_variable(13, '$');
sub_validate_variable(20, 'N');
sub_validate_variable(27, '$');
sub_validate_semicolon(33);
end
else if (s_op1 = '$DOT') then
begin
sub_validate_variable(6, 'D');
sub_validate_variable(13, '$');
sub_validate_variable(20, '$');
sub_validate_variable(27, 'N');
sub_validate_semicolon(33);
end
else if (s_op1 = 'DTO$')
or (s_op1 = 'DED$') then
begin
sub_validate_variable(6, 'S');
sub_validate_variable(13, 'N');
sub_validate_variable(20, 'N');
sub_validate_variable(27, 'N');
sub_validate_semicolon(33);
end
else if (s_op1 = '$PAR')
or (s_op1 = '$TOE') then
begin
sub_validate_variable(6, 'S');
sub_validate_variable(13, '$');
sub_validate_variable(20, '$');
sub_validate_variable(27, 'N');
sub_validate_semicolon(33);
end
else if (s_op1 = 'DSET') then
begin
{ 123456789012345678901234567890 }
{ DSET 00401p=+00402p-00403p*00404p/00405p; }
if (fs_tpline[12] <> '=') then fb_error := true;
if (Pos(fs_tpline[13], '+-') = 0) then fb_error := true;
sub_validate_variable(6, 'D');
iz := 13;
b_loop := true;
while not fb_error and b_loop do
begin
if (Length(fs_tpline) >= (iz + 7)) then
begin
{ validate the operator }
if (Pos(fs_tpline[iz], '+-*/%\^@?') = 0) then fb_error := true;
{ validate the variable }
sub_validate_variable(Succ(iz), 'N');
Inc(iz, 7);
if (fs_tpline[iz] = ';') then b_loop := false;
end
else fb_error := true;
end;
end; { DSET }
{ validate if and while compare operator }
if (s_op1 = 'DIF1')
or (s_op1 = 'DIFT')
or (s_op1 = 'DWHI')
or (s_op1 = 'DBAD')
or (s_op1 = '$IF1')
or (s_op1 = '$IFT')
or (s_op1 = '$WHI') then
begin
{ 1234567890123456789012 }
{ DIFT 00401p==00001n,1, }
sz := Copy(fs_tpline, 12, 2);
if (Pos(sz, '== <> << >> <= >=') = 0) then fb_error := true;
end;
{ save last sub name to help in case of error }
if (s_op1 = 'SUBR') then fs_subr_name := fs_tpline;
if fb_error then sub_error_in_prog_line('Bad variable', fi_tpline);
end; { sub_validate_variables }
procedure TForm1.sub_validate_semicolon(const pbyte_1 : byte);
{ updated 2002/04/20 }
var
s_rec : string;
begin
s_rec := fsa_tpline[fi_tpline];
if (s_rec[pbyte_1] <> ';') then fb_error := true;
end; { sub_validate_semicolon }
procedure TForm1.sub_error_in_prog_line(
const ps1 : string;
const pi2 : integer);
{ updated 2006/04/30, 2003/04/21 }
var
sz : string;
i_beg, i_end : integer;
iy, iz : integer;
begin
{ ps1 has an error message in it }
sz := ps1 + ' in ' + fs_subr_name
+ ' Error in prog line=' + nl
+ IntToStr(pi2) + ': '
+ fsa_tpline[pi2] + nl;
{ show a few lines before and after }
i_beg := pi2 - 8;
i_end := i_beg + 8;
sz := sz + nl + fns_tplines_to_show(i_beg, i_end);
sub_more_or_halt(sz);
end; { sub_error_in_prog_line }
procedure TForm1.sub_validate_variable(
const pi1 : integer;
const ps2 : string);
{ updated 2002/04/20 }
{ validate variable at pi1 in fs_tpline of type ps3=S,N,D }
var
iy, iz : integer;
s_var : string;
sz : string;
begin
{ 123456 }
{ 00101N }
s_var := Copy(fs_tpline, pi1, 6) + StringOfChar(' ', 6);
{ C = single character }
{ D = local decimal }
{ G = global decimal }
{ N = literal number }
{ R = global string }
{ S = local string }
{ $ means a real string }
if (ps2 = '$') then
begin
if (Pos(s_var[6], 'CRS') = 0) then fb_error := true;
end
{ S means only a variable string will do }
else if (ps2 = 'S') then
begin
if (Pos(s_var[6], 'RS') = 0) then fb_error := true;
end
{ N means a number of any kind }
else if (ps2 = 'N') then
begin
if (Pos(s_var[6], 'DGN') = 0) then fb_error := true;
end
{ D means only a variable number will do }
else if (ps2 = 'D') then
begin
if (Pos(s_var[6], 'DG') = 0) then fb_error := true;
end;
{ is s_var actually numeric }
iz := StrToIntDef(Copy(s_var, 1, 5), -1);
if (iz = -1) then fb_error := true;
end; { sub_validate_variable }
procedure TForm1.sub_validate_append(const pi1 : integer);
{ updated 2002/12/01 }
{ validate a string append expression }
var
s_line : string;
b_loop : boolean;
iz : integer;
begin
s_line := Copy(fs_tpline, pi1, 200);
b_loop := true;
{ C = single character }
{ D = local decimal }
{ G = global decimal }
{ N = literal number }
{ R = global string }
{ S = local string }
while b_loop do
begin
{ do we have a valid string variable }
if (Length(s_line) < 7) then fb_error := true
else
begin
{ validate the string link as a number }
iz := StrToIntDef(Copy(s_line, 1, 5), -1);
if (iz = -1) then fb_error := true;
if (Pos(s_line[6], 'CDGNRS') = 0) then fb_error := true;
if (Length(s_line) > 7) then
begin
if (s_line[7] <> '+') then fb_error := true;
s_line := Copy(s_line, 8, 200);
end
else
begin
if (s_line[7] <> ';') then fb_error := true;
b_loop := false;
end;
end;
if fb_error then b_loop := false;
end;
end; { sub_validate_append }
procedure TForm1.sub_more_or_halt(const ps1 : string);
{ updated 2000/01/01 }
begin
if not fnb_more(ps1) then sub_terminate;
end; { sub_more_or_halt }
function TForm1.fnb_more(const ps1 : string) : boolean;
{ updated 2000/01/01 }
var
iz : integer;
begin
iz := MessageDlgPos(ps1, mtCustom, mbOkCancel, 0, 100, 0);
if (iz = mrCancel) then Result := false
else Result := true;
end; { fnb_more }
function TForm1.fni_yesnocancel(const ps1 : string) : integer;
{ updated 2003/07/26 }
var
i_result : integer;
iz : integer;
begin
{ 1=yes, 2=no, 0=cancel }
iz := MessageDlgPos(ps1, mtCustom, mbYesNoCancel, 0, 100, 0);
i_result := 0;
if (iz = mrYes) then i_result := 1;
if (iz = mrNo) then i_result := 2;
Result := i_result;
end; { fni_yesnocancel }
function TForm1.fns_tplines_to_show(const pi1, pi2 : integer) : string;
{ updated 2006/04/30, 2003/07/26 }
var
i_beg, i_end : integer;
s_result : string;
sy, sz : string;
iz : integer;
begin
i_beg := pi1;
i_end := pi2;
s_result := '';
if (i_beg < 1) then i_beg := 1;
if (i_end > fi_tpline_last) then i_end := fi_tpline_last;
if (i_end < i_beg) then i_end := i_beg;
for iz := i_beg to i_end do
begin
{ put extra nl before SUBR }
sz := Copy(fsa_tpline[iz], 1, 4);
if (sz = 'SUBR') then s_result := s_result + nl;
sz := IntToStr(iz) + ': ' + fsa_tpline[iz];
s_result := s_result + sz + nl;
end;
Result := s_result;
end; { fns_tplines_to_show }
procedure TForm1.sub_link_first_parameter;
{ updated 2007/04/16, 2000/01/01 }
var
s_notcommands : string;
s_command : string;
begin
s_notcommands := 'DIFT,DWHI,$IFT,$WHI,ENDI,ENDW,ELSE,ESUB,GOTO';
fi_tpline := 1;
while (fi_tpline < fi_tpline_last) do
begin
{ get a record }
fs_tpline := fsa_tpline[fi_tpline];
s_command := Copy(fs_tpline, 1, 4);
{ do we want to link the first parameter of this command }
if (Pos(s_command, s_notcommands) = 0) then
{ 12345678901 }
{ NINC 12345p }
fia_link[fi_tpline] := StrToIntDef(Copy(fs_tpline, 6, 5), 0);
Inc(fi_tpline);
end;
end; { sub_link_first_parameter }
procedure TForm1.sub_link_dift_sift;
{ updated 2003/03/16 }
{ link the if and while type commands }
var
s_rec : string;
i_rec : integer;
i_above : integer;
sa_stack : array[1..1000] of string;
ia_stack : array[1..1000] of integer;
i_stack : integer;
s_comm : string;
i_last_endi : integer;
iz : integer;
sz : string;
b_loop : boolean;
b_error : boolean;
begin
{ initialize the stack }
for iz := 1 to 1000 do
begin
sa_stack[iz] := '';
ia_stack[iz] := 0;
end;
{ initialize the link array }
for iz := 1 to fi_tpline_last do
fia_link[iz] := fi_tpline_last;
{ read through the program and build the stack }
i_stack := 0;
fs_subr_name := 'Not in a subr;';
i_rec := 1;
b_loop := true;
while b_loop and not fb_terminate do
begin
b_error := false;
{ get a record }
s_rec := fsa_tpline[i_rec];
s_comm := Copy(s_rec, 1, 4);
if (s_comm = 'DWHI') or (s_comm = '$WHI') then
begin
Inc(i_stack);
sa_stack[i_stack] := 'DWHI';
ia_stack[i_stack] := i_rec;
end
else if (s_comm = 'ENDW') then
begin
if (sa_stack[i_stack] = 'DWHI') then
begin
i_above := ia_stack[i_stack];
fia_link[i_rec] := Pred(i_above);
fia_link[i_above] := i_rec;
end
else b_error := true;
Dec(i_stack);
end
else if (s_comm = '$IFT') or (s_comm = 'DIFT') then
begin
Inc(i_stack);
sa_stack[i_stack] := 'DIFT';
ia_stack[i_stack] := i_rec;
end
else if (s_comm = 'ELSE') then
begin
if (sa_stack[i_stack] = 'DIFT') then
begin
i_above := ia_stack[i_stack];
fia_link[i_above] := i_rec;
ia_stack[i_stack] := i_rec;
sa_stack[i_stack] := 'ELSE';
end
else b_error := true;
end
else if (s_comm = 'ENDI') then
begin
{ the last endi is when we have more than 1 }
i_last_endi := fni_link_last_endi(i_rec);
fia_link[i_rec] := i_last_endi;
if (sa_stack[i_stack] = 'DIFT')
or (sa_stack[i_stack] = 'ELSE') then
begin
i_above := ia_stack[i_stack];
fia_link[i_above] := i_last_endi;
end
else b_error := true;
Dec(i_stack);
end
else if (s_comm = 'SUBR') then
begin
if (i_stack <> 0) then b_error := true;
fs_subr_name := Copy(s_rec, 6, 50);
end
else if (s_comm = 'ENDS') and (i_stack <> 0) then
b_error := true;
if (i_stack < 0) then b_error := true;
if b_error then sub_error_in_prog_line('ENDS,ENDI,ENDW', i_rec);
Inc(i_rec);
if (i_rec > fi_tpline_last) then b_loop := false;
end;
end; { sub_link_dift_sift }
function TForm1.fni_link_last_endi(const pi_rec : integer) : integer;
{ updated 2003/03/16 }
var
{ find record number of last of series of endi }
i_last : integer;
i_rec : integer;
b_loop : boolean;
s_comm : string;
begin
i_rec := pi_rec;
i_last := pi_rec;
b_loop := true;
while b_loop do
begin
s_comm := Copy(fsa_tpline[i_rec], 1, 4);
if (s_comm = 'ENDI') then i_last := i_rec
else b_loop := false;
Inc(i_rec);
if (i_rec > fi_tpline_last) then b_loop := false;
end;
Result := i_last;
end; { fni_link_last_endi }
procedure TForm1.sub_link_subroutines;
{ updated 2007/04/15, 2007/04/14, 2004/10/27 }
var
sa_subnames : array[1..1000] of string;
ia_sublinelinks : array[1..1000] of integer;
i_subindex : integer;
s_goto : string;
s_gtag : string;
s_command : string;
s_restofline : string;
s_subname : string;
i_lastevar : integer;
i_nextends : integer;
iy, iz : integer;
sy, sz : string;
b_insub : boolean;
b_loop1 : boolean;
b_loop2 : boolean;
begin
{ initialize the stack }
for iz := 1 to 1000 do
begin
sa_subnames[iz] := '';
ia_sublinelinks[iz] := 0;
end;
{ read through the program and build the subroutine stack }
fi_subroutine_ct := 0;
s_subname := 'SUB_NOT';
i_subindex := 1;
fi_tpline := 1;
b_insub := false;
i_lastevar := 0;
b_loop1 := true;
while b_loop1 and not fb_terminate do
begin
{ get program line }
fs_tpline := fsa_tpline[fi_tpline];
s_command := Copy(fs_tpline, 1, 4);
s_restofline := Trim(Copy(fs_tpline, 6, 80));
if (s_command = 'EVAR') and (i_lastevar = 0)
then i_lastevar := fi_tpline;
if (s_command = 'ENDS') then
begin
if not b_insub then
begin
ShowMessage('ENDS but not in sub');
fb_terminate := true;
end;
b_insub := false;
s_subname := '';
end;
if (s_command = 'SUBR') then
begin
if b_insub then
begin
ShowMessage('no ENDS for=' + s_subname);
fb_terminate := true;
end;
b_insub := true;
Inc(fi_subroutine_ct);
{ sa_subnames has the names of the subs }
{ ia_sublinelinks has the last VARI line number in it }
{ i_subindex is the index for sa_subnames,ia_sublinelinks }
{ subroutine names can be upto 64 long }
s_subname := s_restofline;
if (Length(s_subname) > 64) then
begin
ShowMessage('long SUBR name=' + s_subname);
fb_terminate := true;
end;
{ do we already have this sub }
for iz := 1 to Pred(i_subindex) do
begin
if (sa_subnames[iz] = s_subname) then
begin
ShowMessage('dup SUBR=' + s_subname);
fb_terminate := true;
end;
end;
sa_subnames[i_subindex] := s_subname;
{ find the last VARI line number for this sub }
iz := Succ(fi_tpline);
i_lastevar := iz;
i_nextends := 0;
b_loop2 := true;
while b_loop2 do
begin
sz := Copy(fsa_tpline[iz], 1, 4);
if (sz = 'EVAR') then i_lastevar := iz;
if (sz = 'ENDS') then
begin
i_nextends := iz;
b_loop2 := false;
end;
Inc(iz);
if (iz >= fi_tpline_last) then b_loop2 := false;
end;
{ ia_sublinelinks is for the last VARI line number }
ia_sublinelinks[i_subindex] := Pred(i_lastevar);
{ sa_subnames has the names of the subs }
{ ia_sublinelinks has the last VARI line number in it }
{ i_subindex is the index for sa_subnames,ia_sublinelinks }
Inc(i_subindex);
if (i_subindex > 1000) then
begin
ShowMessage('> 1000 of SUBR');
fb_terminate := true;
end;
end;
if (s_command = 'GOTO') then
begin
s_goto := s_restofline;
if (Length(s_subname) = 0) then
begin
ShowMessage('GOTO but not in sub');
fb_terminate := true;
end;
if (Copy(s_goto, 1, 4) <> 'TAG_') then
begin
ShowMessage('GOTO not to TAG_');
fb_terminate := true;
end;
{ find the GTAG for this GOTO }
iz := i_lastevar;
b_loop2 := true;
while b_loop2 do
begin
sz := Copy(fsa_tpline[iz], 1, 4);
sy := Trim(Copy(fsa_tpline[iz], 6, 80));
if (sz = 'GTAG') and (sy = s_goto) then
begin
if (fia_link[fi_tpline] <> fi_tpline_last) then
begin
ShowMessage('dup GTAG=' + sy);
fb_terminate := true;
end;
fia_link[fi_tpline] := iz;
end;
if (sz = 'ENDS') or (sz = 'SUBR') then b_loop2 := false;
Inc(iz);
if (iz >= i_nextends) then b_loop2 := false;
end;
if (fia_link[fi_tpline] = fi_tpline_last) then
begin
ShowMessage('not GTAG=' + sy);
fb_terminate := true;
end;
end;
if (s_command = 'GTAG') then
begin
s_gtag := s_restofline;
if (Length(s_subname) = 0) then
begin
ShowMessage('GTAG but not in sub');
fb_terminate := true;
end;
if (Copy(s_gtag, 1, 4) <> 'TAG_') then
begin
ShowMessage('GTAG name not TAG_');
fb_terminate := true;
end;
end;
Inc(fi_tpline);
if (fi_tpline >= fi_tpline_last) then b_loop1 := false;
end;
{ read through the program and link the ESUB,GTAG lines }
fi_tpline := 1;
b_loop1 := true;
while b_loop1 and not fb_terminate do
begin
{ get program line }
fs_tpline := fsa_tpline[fi_tpline];
s_command := Copy(fs_tpline, 1, 4);
s_restofline := Trim(Copy(fs_tpline, 6, 80));
if (s_command = 'ESUB') then
begin
{ sa_subnames has the names of the subs }
{ ia_sublinelinks has the last VARI line number in it }
{ i_subindex is the index for sa_subnames,ia_sublinelinks }
{ subroutine names can be upto 64 long }
s_subname := s_restofline;
{ find this s_subname to get the linkline }
i_subindex := 1;
b_loop2 := true;
while b_loop2 and not fb_terminate do
begin
if (s_subname = sa_subnames[i_subindex]) then
begin
{ link this sub }
fia_link[fi_tpline] := ia_sublinelinks[i_subindex];
b_loop2 := false;
end;
if b_loop2 then Inc(i_subindex);
if (i_subindex > 1000) then
begin
ShowMessage('no SUBR for=' + s_subname);
fb_terminate := true;
end;
end;
end;
Inc(fi_tpline);
if (fi_tpline >= fi_tpline_last) then b_loop1 := false;
end;
end; { sub_link_subroutines }
procedure TForm1.sub_link_variable_names;
{ updated 2004/01/24 }
{ replace variable names with location links }
var
i_global : integer;
sa_name : array[1..2000] of string;
sa_link : array[1..2000] of string;
s_line : string;
s_comm : string;
i_record : integer;
i_name : integer;
s_name, s_link : string;
s_char : string;
i_long : integer;
i_var_d, i_var_s : integer;
iy, iz : integer;
sy, sz : string;
b_loop1, b_loop2 : boolean;
b_update : boolean;
b_in_sub : boolean;
b_error1, b_error_all : boolean;
s_error : string;
begin
{ initialize the local variable counters for EVAR }
i_var_d := fi_literal_decimals;
i_var_s := fi_literal_strings;
fs_subr_name := 'Not in sub';
{ initialize }
for iz := 1 to 2000 do
begin
sa_name[iz] := '';
sa_link[iz] := '';
end;
{ make the character set }
s_char := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_';
{ 1234567890123456789012345678 }
{ VARI s_rec,s_name,ncnt1,dnum1 }
{ get the variable names }
i_global := 0;
b_in_sub := false;
i_record := 1;
i_name := 0;
b_loop1 := true;
while b_loop1 and not fb_terminate do
begin
s_line := fsa_tpline[i_record];
s_comm := Copy(s_line, 1, 4);
{ do we need to put the count of the local variables in EVAR }
if (s_comm = 'EVAR') then
begin
sz := IntToStr(i_var_d);
sz := StringOfChar('0', 5 - Length(sz)) + sz;
sy := 'EVAR,' + sz + 'N,';
sz := IntToStr(i_var_s);
sz := StringOfChar('0', 5 - Length(sz)) + sz;
sy := sy + sz + 'N;';
fsa_tpline[i_record] := sy;
{ initialize the local variable counters for EVAR }
i_var_d := 0;
i_var_s := 0;
end;
if (s_comm = 'VARI') then
begin
s_line := Copy(s_line, 6, 500);
{ take off the semi-colon }
iz := Pos(';', s_line);
s_line := Copy(s_line, 1, Pred(iz));
b_loop2 := true;
while b_loop2 do
begin
b_error_all := false;
iz := Pos(',', s_line);
if (iz = 0) then
begin
s_name := s_line;
s_line := '';
end
else
begin
{ we should already have UpperCase }
s_name := Trim(Copy(s_line, 1, Pred(iz)));
{ prepare for next time }
s_line := Trim(Copy(s_line, Succ(iz), 500));
end;
{ validate the length }
i_long := Length(s_name);
if (i_long < 5) or (i_long > 64) then
begin
b_error_all := true;
sz := 'Length of name bad=' + s_name;
sub_error_in_prog_line(sz, i_record);
end;
{ is this a valid name }
b_error1 := false;
if (Pos(s_name[1], 'DS') = 0) then b_error1 := true;
{ test for all valid characters }
for iy := 1 to i_long do
if (Pos(s_name[iy], s_char) = 0) then b_error1 := true;
if b_in_sub then
begin
if (s_name[2] <> '_') then b_error1 := true;
end
else
begin
if (s_name[2] <> 'G') or (s_name[3] <> '_') then
b_error1 := true;
end;
if b_error1 then
begin
b_error_all := true;
sz := 'Bad name=' + s_name;
sub_error_in_prog_line(sz, i_record);
end;
{ do we have an overlapping name, i_global is the last global }
b_error1 := false;
for iy := 1 to i_name do
begin
if (Pos(s_name, sa_name[iy]) > 0)
or (Pos(sa_name[iy], s_name) > 0) then
begin
s_error := s_name + ' / ' + sa_name[iy];
b_error1 := true;
end;
end;
if b_error1 then
begin
b_error_all := true;
sz := 'Overlapping name=' + s_error;
sub_error_in_prog_line(sz, i_record);
end;
if not b_error_all and (i_name < 2000) then
begin
Inc(i_name);
if not b_in_sub then Inc(i_global);
sa_name[i_name] := s_name;
{ build the link }
if (s_name[1] = 'S') then
begin
if b_in_sub then
begin
{ local variables }
Inc(i_var_s);
s_link := IntToStr(i_var_s) + 'S'
end
else
begin
{ global variables }
Inc(i_var_s);
Inc(fi_svar);
s_link := IntToStr(i_var_s) + 'R';
Inc(fi_global_strings);
end;
end
else
begin
if b_in_sub then
begin
{ local variables decimal }
Inc(i_var_d);
s_link := IntToStr(i_var_d) + 'D'
end
else
begin
{ global variables decimal }
Inc(i_var_d);
Inc(fi_dvar);
s_link := IntToStr(i_var_d) + 'G';
Inc(fi_global_decimals);
end;
end;
s_link := StringOfChar('0', 6 - Length(s_link)) + s_link;
sa_link[i_name] := s_link;
end;
if (Length(s_line) = 0) then b_loop2 := false;
end; { b_loop2 }
end
else if (s_comm = 'SUBR') then
begin
b_in_sub := true;
fs_subr_name := Copy(s_line, 6, 50);
{ wipe out the local variables from the previous sub }
for iy := Succ(i_global) to 2000 do
begin
sa_name[iy] := '';
sa_link[iy] := '';
i_name := i_global;
end;
{ reset the link variables for local variables }
i_var_d := 0;
i_var_s := 0;
end
else if (s_comm <> 'ESUB') then
begin
{ replace names with links }
{ go backwards so local variables will have precedence }
b_error1 := false;
for iz := i_name DownTo 1 do
begin
s_name := sa_name[iz];
s_link := sa_link[iz];
i_long := Length(s_name);
b_update := false;
b_loop2 := true;
while b_loop2 do
begin
iy := Pos(s_name, s_line);
if (iy > 0) then
begin
{ is name in s_line too long }
{ is next char a legal name char }
if (Pos(s_line[iy + i_long], s_char) > 0) then
begin
b_error_all := true;
sz := 'Bad name=' + s_name;
sub_error_in_prog_line(sz, i_record);
end;
{ put s_link in place of s_name }
s_line := Copy(s_line, 1, Pred(iy)) + s_link
+ Copy(s_line, iy + i_long, 200);
b_update := true;
end
else b_loop2 := false;
end; { b_loop2 }
if b_update then fsa_tpline[i_record] := s_line;
end;
end;
Inc(i_record);
if (i_record > fi_tpline_last) then b_loop1 := false;
end; { b_loop1 }
end; { sub_link_variable_names }
procedure TForm1.sub_old_to_new;
{ updated 2004/12/03 }
{ translate old commands to new }
var
s_record : string;
s_comm : string;
i_line : integer;
begin
i_line := 1;
while (i_line <= fi_tpline_last) do
begin
s_record := fsa_tpline[i_line];
s_comm := UpperCase(Copy(s_record, 1, 4));
if (s_comm = 'DPRI') then s_comm := 'DFAC';
if (s_comm = 'CSWP') then s_comm := '$SWP';
if (s_comm = '$PTT') then s_comm := '$ISP';
if (s_comm = 'FGET') then s_comm := 'FREA';
if (s_comm = 'FPUT') then s_comm := 'FWRI';
s_record := s_comm + Copy(s_record, 5, 99999);
fsa_tpline[i_line] := s_record;
Inc(i_line);
end;
end; { sub_old_to_new }
procedure TForm1.sub_initialize;
{ updated 2007/10/16 }
{ 2007/09/17, 2007/06/16, 2006/04/30, 2006/04/29, 2004/01/24 }
var
iz : integer;
begin
{ initialize program info variables }
fi_prog_lines := 0;
fd_total_lines := 0;
fi_max_length := 100000000;
fi_max_dvar := 2000;
fi_max_svar := 4000;
fi_max_darray := 8000;
fi_max_sarray := 2000;
{ string variable counts }
fi_svar := 0;
fi_literal_strings := 0;
fi_global_strings := 0;
{ decimal variable counts }
fi_dvar := 0;
fi_literal_decimals := 0;
fi_global_decimals := 0;
{ initialize the program array }
for iz := 1 to 15000 do
begin
fsa_tpline[iz] := '';
fbytea_command[iz] := 0;
fia_link[iz] := 0;
end;
{ initialize }
for iz := 1 to fi_max_svar do
begin
fsa_var[iz] := '';
end;
for iz := 1 to fi_max_dvar do
begin
fea_var[iz] := 0;
end;
for iz := 1 to fi_max_darray do
begin
fea_array[iz] := 0;
end;
for iz := 1 to fi_max_sarray do
begin
fsa_array[iz] := '';
end;
{ initialize the array arrays }
for iz := 1 to 1000 do
begin
{ some stacks }
fia_delta_s[iz] := 0;
fia_delta_d[iz] := 0;
fia_sub[iz] := 0;
end;
{ dynamic memory }
fii_delta_s := 1;
fii_delta_d := 1;
fi_delta_s := 0;
fi_delta_d := 0;
fii_sub := 0;
fi_max_delta_s := 0;
fi_max_delta_d := 0;
fi_max_sub := 0;
for iz := 1 to 30 do fsa_show[iz] := '';
end; { sub_initialize }
procedure TForm1.sub_tpprog_build_array;
{ updated 2007/06/16, 2006/06/11, 2004/10/11 }
var
file_text : TextFile;
i_record : integer;
s_record : string;
s_rec1, s_rec2 : string;
s_actualcode : string;
s_comm1, s_comm2 : string;
i_long : integer;
iz : integer;
sy, sz : string;
b_two : boolean;
b_good : boolean;
b_loop : boolean;
begin
fi_comment_ct := 0;
AssignFile(file_text, fs_tpprog_name);
{ set for read only access }
FileMode := 0;
{$I-}
Reset(file_text);
{$I+}
if (IOResult = 0) then
begin
{ put in system variables }
s_comm1 := '';
fi_tpline_last := 1;
i_record := 1;
fi_line := 0;
while not Eof(file_text) and not fb_terminate do
begin
{ read a line of the program }
Readln(file_text, s_record);
Inc(fi_line);
if fb_debug then
begin
application.processmessages;
label_show.caption := inttostr(fi_line) + ' '
+ IntToStr(i_record) + ' '
+ trim(s_record);
application.processmessages;
end;
{ blank char < 32 }
s_record := Trim(fns_blank_escapes(s_record));
b_good := true;
b_two := false;
if (Length(s_record) < 1) then b_good := false;
{ skip over comment lines which begin with an apostrophe }
if b_good and (s_record[1] = '''') then
begin
Inc(fi_comment_ct);
b_good := false;
end;
if b_good and (s_record[1] = '<') then
begin
Inc(fi_comment_ct);
b_good := false;
end;
{ eliminate extra blanks and put commas after commands }
{ also make upper case except for literal strings }
s_actualcode := '';
if b_good then s_actualcode := fns_eliminate_blanks(s_record);
s_record := s_actualcode;
i_long := Length(s_record);
if b_good then
begin
{ link the literal strings into fsa_var }
s_record := fns_link_literal_strings(s_record);
{ split into two records if needed }
s_rec1 := s_record;
s_rec2 := '';
sub_tpline_split(s_rec1, s_rec2);
if (Length(s_rec2) > 0) then b_two := true
else b_two := false;
{ put in DSET,$SET,ESUB and semi-colon at end }
s_rec1 := fns_tpline_format(s_rec1);
if b_two then s_rec2 := fns_tpline_format(s_rec2);
{ link the literal numbers into fda_var }
s_rec1 := fns_link_literal_numbers(s_rec1);
if b_two then s_rec2 := fns_link_literal_numbers(s_rec2);
s_comm2 := s_comm1;
s_comm1 := Copy(s_rec1, 1, 4);
{ do we need a EVAR for no global variables }
if (i_record = 1) and (s_comm1 <> 'VARI') then
begin
fsa_tpline[i_record] := 'EVAR,00000N,00000N;';
Inc(i_record);
end;
{ do we need a EVAR line to setup local variables }
if (s_comm2 = 'VARI') or (s_comm2 = 'SUBR') then
begin
if (s_comm1 <> 'VARI') then
begin
fsa_tpline[i_record] := 'EVAR,00000N,00000N;';
Inc(i_record);
end;
end;
{ store lines in fsa_tpline }
fsa_tpline[i_record] := s_rec1;
if b_two then
begin
Inc(i_record);
fsa_tpline[i_record] := s_rec2;
end;
Inc(i_record);
if (i_record > 15000) then
begin
sz := 'Program over 15000 lines';
sub_error_in_prog_line(sz, 15000 - 10);
end;
end;
end;
fi_tpline_last := i_record;
fi_prog_lines := i_record;
fsa_tpline[i_record] := 'ENDP,';
CloseFile(file_text);
end
else
begin
sz := 'Cannot open file=' + fs_tpprog_name;
ShowMessage(sz);
sub_terminate;
end;
end; { sub_tpprog_build_array }
function TForm1.fns_link_literal_strings(const ps_rec : string)
: string;
{ updated 2007/06/16, 2006/06/11, 2004/10/11 }
{ link literal strings to indexes in fsa_var }
var
s_link : string;
s_string : string;
s_line : string;
i_record : integer;
b_loop : boolean;
i_beg, i_long : integer;
s_rest : string;
c_beg : char;
i1, i2 : integer;
begin
s_line := ps_rec;
b_loop := true;
{ literal strings can be delimited by " and by # }
while b_loop do
begin
{ look for double quotes and for # }
i1 := Pos('"', s_line);
i2 := Pos('#', s_line);
if (i1 = 0) then i1 := 99999;
if (i2 = 0) then i2 := 99999;
i_beg := 99999;
if (i1 < i_beg) then
begin
i_beg := i1;
c_beg := '"';
end;
if (i2 < i_beg) then
begin
i_beg := i2;
c_beg := '#';
end;
if (i_beg = 99999) then
begin
i_beg := 0;
b_loop := false;
end;
if b_loop then
begin
{ get the literal string }
s_rest := Copy(s_line, Succ(i_beg), 200);
{ find i_long which is actually length + 1 }
i_long := Pos(c_beg, s_rest);
{ did we find the other c_beg = " or # }
if (i_long < 1) then b_loop := false
else
begin
{ we have the string }
s_string := Copy(s_rest, 1, Pred(i_long));
{ do we have a single character }
if (Length(s_string) = 1) then
begin
s_link := '00000' + IntToStr(Ord(s_string[1])) + 'C';
s_link := Copy(s_link, Length(s_link) - 5, 6);
{ delete the string from s_line }
Delete(s_line, i_beg, Succ(i_long));
{ insert the link into the string }
Insert(s_link, s_line, i_beg);
end
else if (fi_svar < fi_max_svar) then
begin
{ get the string literal link }
Inc(fi_svar);
Inc(fi_literal_strings);
{ save the literal string }
fsa_var[fi_svar] := s_string;
{ prepare the link as a global variable }
s_link := '00000' + IntToStr(fi_svar) + 'R';
s_link := Copy(s_link, Length(s_link) - 5, 6);
{ delete the string from s_line }
Delete(s_line, i_beg, Succ(i_long));
{ insert the link into the string }
Insert(s_link, s_line, i_beg);
end
else
begin
sub_program_error('too many literal strings');
end;
end;
end;
end; { b_loop }
{ send the result back }
Result := s_line;
end; { fns_link_literal_strings }
procedure TForm1.sub_tpline_split(var s_rec1, s_rec2 : string);
{ updated 2004/10/11 }
{ split a line into two if needed }
var
s_line : string;
iz : integer;
sz : string;
begin
{ string literals have been removed }
s_rec2 := '';
s_line := s_rec1;
sz := Copy(s_line, 1, 4);
if (sz = 'DIFT') or (sz = '$IFT') then
begin
iz := Pos(':', s_line);
if (iz > 0) then
begin
{ we need to split the line }
s_rec1 := Trim(Copy(s_line, 1, Pred(iz)));
{ change DIFT,$IFT to DIF1,$IF1 }
s_rec1[4] := '1';
s_rec2 := Trim(Copy(s_line, Succ(iz), 9999));
end;
end;
{ s_rec1,s_rec2 are variable parameters }
end; { sub_tpline_split }
function TForm1.fns_tpline_format(const ps1 : string) : string;
{ updated 2004/10/11 }
{ put in DSET,$SET,ESUB and semi-colon at end }
var
s_line : string;
sy, sz : string;
iz : integer;
begin
s_line := ps1 + ' ';
{ prefix DSET, if needed }
sz := Copy(s_line, 1, 2);
sy := Copy(s_line, 1, 3);
if (sz = 'D_') or (sy = 'DG_') then s_line := 'DSET,' + s_line;
{ prefix $SET, if needed }
if (sz = 'S_') or (sy = 'SG_') then s_line := '$SET,' + s_line;
{ prefix ESUB if needed }
sz := Copy(s_line, 1, 4);
if (sz = 'SUB_') then s_line := 'ESUB,' + s_line;
{ omit comment at end of ENDS, }
if (sz = 'ENDS') then s_line := 'ENDS,';
{ put semi-colon at end of line }
s_line := Trim(s_line) + ';';
Result := s_line;
end; { fns_tpline_format }
function TForm1.fns_link_literal_numbers(const ps_rec : string) : string;
{ updated 2006/06/11, 2004/10/11 }
{ link literal numbers into fda_var }
var
s_record : string;
s_alpha, s_digit : string;
i_byte : integer;
i_count : integer;
i_dot : integer;
i_long : integer;
b_error : boolean;
b_inquotes : boolean;
c_quotechar : char;
i_end : integer;
iz : integer;
sz : string;
b_loop1, b_loop2 : boolean;
b_dsetcommand : boolean;
b_negsign : boolean;
begin
{ string literals and spaces have }
{ been removed by now }
s_record := ps_rec + ' ';
{ do we have a DSET command }
b_dsetcommand := false;
if (Copy(s_record, 1, 4) = 'DSET') then b_dsetcommand := true;
{ we have all uppercase }
s_alpha := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ_';
s_digit := '0123456789';
{ 123456789012345678901234567890123 }
{ DIF1 00401p<<00101n:00005n+00001n }
c_quotechar := '"';
b_inquotes := false;
i_byte := 5;
b_loop1 := true;
while b_loop1 do
begin
if (s_record[i_byte] = '"') or (s_record[i_byte] = '#') then
begin
if b_inquotes then
begin
if (s_record[i_byte] = c_quotechar)
then b_inquotes := false
end
else
begin
c_quotechar := s_record[i_byte];
b_inquotes := true;
end;
end;
if not b_inquotes then
begin
{ do we have the beginning of a literal number to expand }
if (Pos(s_record[i_byte], s_digit) > 0)
and (Pos(s_record[Pred(i_byte)], s_digit) = 0)
and (Pos(s_record[Pred(i_byte)], s_alpha) = 0) then
begin
{ is the literal number preceded by a negative sign }
b_negsign := false;
if (s_record[Pred(i_byte)] = '-') then
begin
if b_dsetcommand then
begin
{ if DSET command we must have an operator }
if (Pos(s_record[i_byte - 2], '+-/*\%') > 0)
then b_negsign := true;
end
else b_negsign := true;
if b_negsign then
begin
{ we have negative sign so delete }
Dec(i_byte);
Delete(s_record, i_byte, 1);
end;
end;
{ is the literal number preceded by a positive sign }
if (s_record[Pred(i_byte)] = '+') then
begin
if (Pos(s_record[i_byte - 2], '+-/*\%') > 0) then
begin
{ we have an uneeded positive sign so delete }
Dec(i_byte);
Delete(s_record, i_byte, 1);
end;
end;
{ how many digits are in the number }
i_count := 1;
i_dot := 0;
i_end := i_byte;
b_loop2 := true;
while b_loop2 do
begin
Inc(i_end);
if (Pos(s_record[i_end], s_digit) > 0) then Inc(i_count)
else if (s_record[i_end] = '.') then Inc(i_dot)
else b_loop2 := false;
end;
{ get the length i_end is 1 too many }
i_long := i_end - i_byte;
{ can the number be just a number literal }
{ only if whole and + and < 100000 }
if (i_long < 6) and (i_dot = 0) and not b_negsign then
begin
{ insert a N if not ending with a letter }
if (Pos(s_record[i_end], s_alpha) = 0) then
begin
Insert('N', s_record, i_end);
{ how many zeros do we need to insert }
i_count := 5 - i_count;
if (i_count > 0) then
Insert(StringOfChar('0', i_count), s_record, i_byte);
end;
end
else if (i_dot < 2) then
begin
{ we must store the number in the decimal array }
{ get the string for the number }
sz := Copy(s_record, i_byte, i_long);
{ increment the literal decimal array index }
Inc(fi_literal_decimals);
Inc(fi_dvar);
{ change to a literal decimal and store }
fea_var[fi_dvar] := StrToFloat(sz);
{ change the sign if needed }
if b_negsign then fea_var[fi_dvar] := -fea_var[fi_dvar];
{ delete the number in the line }
Delete(s_record, i_byte, i_long);
{ change the index to the global decimal }
{ array index for the number }
sz := IntToStr(fi_dvar);
sz := StringOfChar('0', 5 - Length(sz)) + sz + 'G';
{ insert back into the record }
Insert(sz, s_record, i_byte);
end;
end;
end;
Inc(i_byte);
if (i_byte > Length(s_record)) then b_loop1 := false;
end; { b_loop1 }
Result := Trim(s_record);
end; { fns_link_literal_numbers }
function TForm1.fns_eliminate_blanks(const ps_rec : string) : string;
{ updated 2004/10/11 }
{ eliminate extra blanks and put comma after commands }
{ also make upper case except for literal strings }
var
s_record : string;
c_limit : char;
i_colon : integer;
b_instring : boolean;
ix : integer;
begin
s_record := Trim(ps_rec) + StringOfChar(' ', 5);
if (s_record[5] = ' ') then s_record[5] := ',';
{ shrink and remove various blanks }
i_colon := 0;
ix := 1;
c_limit := ' ';
b_instring := false;
{ delete spaces }
while (ix <= Length(s_record)) do
begin
if not b_instring and (s_record[ix] = ':') then i_colon := ix;
if not b_instring then
begin
s_record[ix] := UpCase(s_record[ix]);
if (s_record[ix] = '"') or (s_record[ix] = '#') then
begin
b_instring := true;
c_limit := s_record[ix];
end;
end
else
begin
if (s_record[ix] = c_limit) then b_instring := false;
end;
if not b_instring and (s_record[ix] = ' ') then
begin
{ remove blank unless after second command in dift }
{ dift d_any=d_dot:$out 'hello' }
if (i_colon <> (ix - 5)) then
begin
Delete(s_record, ix, 1);
Dec(ix);
end
else s_record[ix] := ',';
end;
Inc(ix);
end;
Result := s_record;
end; { fns_eliminate_blanks }
procedure TForm1.sub_format_lines;
{ updated 2004/10/19 }
var
i_record : integer;
s_record : string;
s_op : string;
sy, sz : string;
b_loop : boolean;
begin
i_record := 1;
b_loop := true;
while b_loop and not fb_terminate do
begin
s_record := fsa_tpline[i_record];
{ expand the compares }
s_op := Copy(s_record, 1, 4);
if (s_op = 'DIF1')
or (s_op = 'DIFT')
or (s_op = 'DWHI')
or (s_op = 'DBAD')
or (s_op = '$WHI')
or (s_op = '$IF1')
or (s_op = '$IFT') then
begin
{ ==,<>,<<,>>,>=,<= }
{ 1234567890123456789 }
{ DIFT 00401n=00001n }
{ DIFT 00401n==00001n }
if (Pos(s_record[13], '=<>') = 0) then
Insert(s_record[12], s_record, 13);
sy := ',0';
sz := Copy(s_record, 12, 2);
if (sz = '==') then sy := ',1'
else if (sz = '<>') then sy := ',2'
else if (sz = '<<') then sy := ',3'
else if (sz = '>>') then sy := ',4'
else if (sz = '>=') then sy := ',5'
else if (sz = '<=') then sy := ',6';
Insert(sy, s_record, 20);
end;
{ expand the = to =+ in DSET }
s_op := Copy(s_record, 1, 4);
if (s_op = 'DSET') and (s_record[12] = '=') and (s_record[13] <> '+')
and (s_record[13] <> '-') then Insert('+', s_record, 13);
{ replace the changed line }
fsa_tpline[i_record] := s_record;
Inc(i_record);
if (i_record > fi_prog_lines) then b_loop := false;
end;
end; { sub_format_lines }
procedure TForm1.sub_prog_process;
{ updated 2003/01/02 }
{ process the program }
begin
fb_terminate := false;
btn_start.visible := false;
{ initialize }
sub_initialize;
{ build the fs_tpprog array }
sub_tpprog_build_array;
{ link the names }
if not fb_terminate then sub_link_variable_names;
{ format some lines }
if not fb_terminate then sub_format_lines;
{ link DWHI and DIFT }
if not fb_terminate then sub_link_dift_sift;
{ link the subroutines }
if not fb_terminate then sub_link_subroutines;
{ link the first parameter }
if not fb_terminate then sub_link_first_parameter;
{ replace old commands with new }
sub_old_to_new;
{ validate the lines }
fs_subr_name := 'Not in a subr';
fi_tpline := 1;
while not fb_terminate and (fi_tpline <= fi_tpline_last) do
begin
sub_validate_commands;
sub_validate_variables;
Inc(fi_tpline);
end;
{ sets fi_tpline and builds integer array of line commands }
if not fb_terminate then sub_commands_to_int;
{ begin processing the gtprog }
if not fb_terminate then sub_tpline_process;
if fb_terminate then Application.Terminate;
end; { sub_prog_process }
procedure TForm1.sub_view_code;
{ updated 2003/12/15 }
{ view subroutines program and code }
var
i_line : integer;
s_line : string;
s_somelines : string;
i_count : integer;
i_yesno : integer;
iz : integer;
sz : string;
b_loop : boolean;
begin
{ subroutines }
i_yesno := 999;
i_count := 0;
s_somelines := '';
i_line := 1;
b_loop := true;
while b_loop do
begin
{ view subroutines }
s_line := LowerCase(fsa_tpline[i_line]);
if (Copy(s_line, 1, 4) = 'subr') then
begin
s_somelines := s_somelines
+ IntToStr(i_line) + ' ' + s_line + nl;
Inc(i_count);
if (i_count >= 19) then
begin
i_yesno := fni_yesnocancel(s_somelines + 'More?');
if (i_yesno <> 1) then b_loop := false;
i_count := 0;
s_somelines := '';
end;
end;
Inc(i_line);
if (i_line > fi_tpline_last) then b_loop := false;
end;
if (Length(s_somelines) > 0)
then fni_yesnocancel(s_somelines + 'More?');
sz := 'Total lines=' + IntToStr(fi_tpline_last) + nl
+ 'Enter line number?';
sz := InputBox('Current=' + IntToStr(fi_tpline - 1), sz, '1');
i_line := StrToIntDef(Trim(sz), 1);
if (i_line < 1) or (i_line > fi_tpline_last) then i_line := 1;
i_yesno := 999;
b_loop := true;
while b_loop do
begin
s_somelines := 'subroutine=' + fns_subroutine(i_line) + nl
+ fns_tplines_to_show(i_line, i_line + 19);
i_yesno := fni_yesnocancel(s_somelines + 'More?');
if (i_yesno <> 1) then b_loop := false;
i_line := i_line + 20;
if (i_line > fi_tpline_last) then b_loop := false;
end;
end; { sub_view_code }
procedure TForm1.sub_variables;
{ updated 2007/06/16, 2004/03/04 }
{ show values of variable locations }
var
ez : double;
i_long : integer;
i_yesnocancel : integer;
sz : string;
i_index : integer;
i_count : integer;
b_more : boolean;
b_loop : boolean;
begin
i_index := 1;
b_more := true;
while b_more do
begin
sz := 'Non-Zero Decimal Variables';
b_loop := true;
i_count := 0;
while b_loop do
begin
ez := fea_var[i_index];
if (ez <> 0) then
begin
sz := sz + nl
+ IntToStr(i_index) + '='
+ fns_from_double(ez, 1);
Inc(i_count);
end;
Inc(i_index);
if (i_count >= 25) or (i_index > fi_max_dvar)
then b_loop := false;
end;
if (i_index > fi_max_dvar) then b_more := false;
{ 1=yes, 2=no, 0=cancel }
i_yesnocancel := fni_yesnocancel(sz);
if (i_yesnocancel <> 1) then b_more := false;
end;
i_index := 1;
if (i_yesnocancel > 0) then b_more := true;
while b_more do
begin
sz := 'Non-Zero Decimal Array Elements';
b_loop := true;
i_count := 0;
while b_loop do
begin
ez := fea_array[i_index];
if (ez <> 0) then
begin
sz := sz + nl
+ IntToStr(i_index) + '='
+ fns_from_double(ez, 1);
Inc(i_count);
end;
Inc(i_index);
if (i_count >= 25) or (i_index > fi_max_darray)
then b_loop := false;
end;
if (i_index > fi_max_darray) then b_more := false;
{ 1=yes, 2=no, 0=cancel }
i_yesnocancel := fni_yesnocancel(sz);
if (i_yesnocancel <> 1) then b_more := false;
end;
i_index := 1;
if (i_yesnocancel > 0) then b_more := true;
while b_more do
begin
i_count := 0;
b_loop := true;
sz := 'Non-Empty Variable Strings, First 80 Trimmed Bytes';
while b_loop do
begin
i_long := Length(fsa_var[i_index]);
if (i_long > 0) then
begin
sz := sz + nl
+ IntToStr(i_index)
+ '='
+ Copy(Trim(fsa_var[i_index]), 1, 80);
Inc(i_count);
end;
Inc(i_index);
if (i_count >= 25) or (i_index > fi_max_svar)
then b_loop := false;
end;
if (i_index > fi_max_svar) then b_more := false;
{ 1=yes, 2=no, 0=cancel }
i_yesnocancel := fni_yesnocancel(sz);
if (i_yesnocancel <> 1) then b_more := false;
end;
i_index := 1;
if (i_yesnocancel > 0) then b_more := true;
while b_more do
begin
i_count := 0;
b_loop := true;
sz := 'Non-Empty Array Strings, First 80 Trimmed Bytes';
while b_loop do
begin
i_long := Length(fsa_array[i_index]);
if (i_long > 0) then
begin
sz := sz + nl
+ IntToStr(i_index)
+ '='
+ Copy(Trim(fsa_array[i_index]), 1, 80);
Inc(i_count);
end;
Inc(i_index);
if (i_count >= 25) or (i_index > fi_max_sarray)
then b_loop := false;
end;
if (i_index > fi_max_sarray) then b_more := false;
{ 1=yes, 2=no, 0=cancel }
i_yesnocancel := fni_yesnocancel(sz);
if (i_yesnocancel <> 1) then b_more := false;
end;
end; { sub_variables }
procedure TForm1.sub_variables_info;
{ updated 2007/06/16, 2004/10/27 }
{ show values of variable locations }
var
sz : string;
iz : integer;
i_bytesvar : integer;
i_bytesarr : integer;
i_local_d : integer;
i_local_s : integer;
i_total_d : integer;
i_total_s : integer;
begin
{ add up lengths of string variables }
i_bytesvar := 0;
for iz := 1 to fi_max_svar do
begin
i_bytesvar := i_bytesvar + Length(fsa_var[iz]);
end;
i_bytesarr := 0;
for iz := 1 to fi_max_sarray do
begin
i_bytesarr := i_bytesarr + Length(fsa_array[iz]);
end;
{ get the total number of variables }
i_total_d := fia_delta_d[fii_delta_d];
i_total_s := fia_delta_s[fii_delta_s];
{ get total number of local variables }
i_local_d := i_total_d - fi_literal_decimals - fi_global_decimals;
i_local_s := i_total_s - fi_literal_strings - fi_global_strings;
sz := '';
sz := sz
+ 'Program Information' + nl
+ 'Lines=' + IntToStr(fi_prog_lines) + nl
+ 'Subroutines=' + IntToStr(fi_subroutine_ct) + nl
+ 'Comments=' + IntToStr(fi_comment_ct) + nl
+ 'max subs=' + IntToStr(fi_max_sub) + nl
+ 'max decimals=' + IntToStr(fi_max_delta_d) + nl
+ 'max strings=' + IntToStr(fi_max_delta_s) + nl + nl
+ 'Decimal Literals=' + IntToStr(fi_literal_decimals) + nl
+ 'Decimal Globals=' + IntToStr(fi_global_decimals) + nl
+ 'Decimal Locals=' + IntToStr(i_local_d) + nl
+ 'Decimal Variables=' + IntToStr(i_total_d) + nl + nl
+ 'String Literals=' + IntToStr(fi_literal_strings) + nl
+ 'String Globals=' + IntToStr(fi_global_strings) + nl
+ 'String Locals=' + IntToStr(i_local_s) + nl
+ 'String Variables=' + IntToStr(i_total_s) + nl + nl
+ 'Total String Var Length=' + IntToStr(i_bytesvar) + nl
+ 'Total String Arr Length=' + IntToStr(i_bytesarr) + nl
+ fns_subroutine(fi_tpline);
ShowMessage(sz);
end; { sub_variables_info }
procedure TForm1.sub_get_program_name;
{ updated 2003/09/15 }
var
s_filename : string;
b_exists : boolean;
sz : string;
begin
{ end if program already running }
fb_program_loop := false;
{ choose a file for fs_tpprog_name }
sz := 'Enter the path and filename';
s_filename := fs_tpprog_name;
s_filename := InputBox('Enter Teapro Program Name', sz, s_filename);
s_filename := Trim(LowerCase(s_filename));
label_show.Caption := '';
fs_tpprog_name := s_filename;
Form1.Caption := 'Teapro = ' + fs_tpprog_name;
btn_start.Caption := 'run ' + fs_tpprog_name;
Application.Title := fs_tpprog_name;
btn_start.Visible := true;
btn_start.SetFocus;
end; { sub_get_program_name }
procedure TForm1.sub_terminate;
{ updated 2006/04/28, 2000/01/01 }
{ terminate the program }
begin
fb_program_loop := false;
fb_terminate := true;
Application.Terminate;
end; { sub_terminate }
procedure TForm1.menu_exitClick(Sender: TObject);
{ updated 2000/01/01 }
begin
sub_terminate;
end; { Exit1Click }
procedure TForm1.FormActivate(Sender: TObject);
{ updated 2006/06/11, 2005/11/02, 2005/09/12, 2005/03/22, 2004/07/25 }
var
sz : string;
begin
Form1.Left := 0;
Form1.Top := 0;
label_show.caption := '';
Randomize;
Form1.Caption := 'Teapro9';
Application.Title := 'Teapro9';
fb_string_input := false;
fs_filename_1 := '';
fi_show_lines := 24;
fb_show := true;
fd_begin_time := Now;
fs_tpprog_name := Trim(ParamStr(1));
if (fs_tpprog_name = '') then fs_tpprog_name := 'tinytea.tea';
if not FileExists(fs_tpprog_name) then sub_get_program_name;
fs_tpprog_name := LowerCase(fs_tpprog_name);
Form1.Caption := 'Teapro9 = ' + fs_tpprog_name;
Application.Title := fs_tpprog_name;
btn_start.Caption := 'run ' + fs_tpprog_name;
btn_start.Visible := True;
btn_start.SetFocus;
Form1.Height := 478;
Form1.Width := 640;
end; { FormActivate }
procedure TForm1.btn_startClick(Sender: TObject);
{ updated 2000/01/01 }
begin
sub_prog_process;
end; { btn_startClick }
procedure TForm1.edit_inputKeyPress(Sender: TObject; var Key: Char);
{ updated 2000/01/01 }
begin
if (Key = Chr(13)) then
begin
if fb_string_input then
begin
Key := Chr(0);
fs_input := TrimRight(edit_input.text);
edit_input.text := '';
sub_tpline_process;
end;
end;
end;
procedure TForm1.About1Click(Sender: TObject);
{ updated 2000/01/01 }
begin
sub_about;
end;
procedure TForm1.menu_ProgramCodeClick(Sender: TObject);
{ updated 2000/01/01 }
begin
sub_view_code;
end;
procedure TForm1.menu_VariablesClick(Sender: TObject);
{ updated 2000/01/01 }
begin
sub_variables_info;
sub_variables;
end;
procedure TForm1.menu_debugClick(Sender: TObject);
{ updated 2002/04/30 }
{ turn debug mode on or off }
var
iz : integer;
begin
if fb_debug then fb_debug := false
else
begin
fb_debug := true;
for iz := 1 to 10 do fsa_debug[iz] := '';
sub_debug;
end;
end;
procedure TForm1.FormResize(Sender: TObject);
{ updated 2005/02/07, 2004/07/24 }
var
i_height : integer;
i_width : integer;
begin
i_height := Form1.Height;
i_width := Form1.Width;
{
Form1.label_show.height := i_height - 78;
Form1.label_show.width := i_width - 20;
Form1.edit_input.top := i_height - 70;
Form1.edit_input.width := i_width - 16;
}
Form1.label_show.height := i_height - 78;
Form1.label_show.width := i_width - 20;
Form1.edit_input.top := i_height - 70;
Form1.edit_input.width := i_width - 16;
fi_show_lines := Trunc((i_height - 78) / 16.0);
fi_show_lines := Round((i_height - 78) / 16.0);
if (fi_show_lines < 1) then fi_show_lines := 1
else if (fi_show_lines > 35) then fi_show_lines := 35;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
{ updated 2000/01/01 }
begin
sub_terminate;
end;
procedure TForm1.menu_openClick(Sender: TObject);
{ updated 2000/01/01 }
begin
sub_get_program_name;
end;
procedure TForm1.Pause1Click(Sender: TObject);
{ updated 2003/12/27 }
begin
ShowMessagePos('Ok to continue Teapro9',
Form1.Left + 200, Form1.Top);
end;
procedure TForm1.menu_generalhelpClick(Sender: TObject);
{ updated 2000/01/01 }
begin
sub_help_general;
end;
procedure TForm1.menu_help_commandsClick(Sender: TObject);
{ updated 2000/01/01 }
begin
sub_help_commands
end;
procedure TForm1.menu_help_runningClick(Sender: TObject);
{ updated 2000/01/01 }
begin
sub_help_running;
end;
end.
{ }