{ }
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 }