unit baslib;
{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}
{$INLINE ON}
(***************************************)
(* Copyright (C) 2014, SHIRAISHI Kazuo *)
(***************************************)


interface
uses
  Classes, SysUtils, Forms,Dialogs,Controls,math,Process,FileUtil,LCLProc,
  lclintf, Clipbrd, UTF8Process,
  base,base2,textfile,arrays, mathc;

 function FloatVal( const s:ansistring):double;overload;

type

  TDeviceRef=class;
  PtTextDevice = ^TTextDevice;

  TChannelList = class(TStringList)
     constructor Create;
     procedure SetRefference(chn:integer; ch:TDeviceRef); // 経路引数をセットする
     function channel(chn:integer):TTextDevice;                      overload;
     function channel(chn0:double):TTextDevice;                      overload;
     procedure open(chn0:double; const FName:FNameStr;
                                 const amode,rectp,orgtp:string;
                                 len:integer; insideofwhen:boolean); overload;
     procedure OpenPrinter(chn0:double; insideofwhen:boolean);       overload;
     procedure close(chn0:double);                                   overload;
     function channel(chn0:Complex):TTextDevice;                     overload;
     procedure open(chn0:complex; const FName:FNameStr;
                                 const amode,rectp,orgtp:string;
                                 len:integer; insideofwhen:boolean); overload;
     procedure OpenPrinter(chn:complex; insideofwhen:boolean);       overload;
     procedure close(chn0:complex);                                  overload;
   public
     destructor destroy; override;                                   overload;
   private
     procedure assign(chn:integer; dev:TTextDevice; insideofwhen:boolean);
  end;
// プログラム単位はTChannelList形の変数ChannelListを持つ。
// （経路番号式を参照する文を持つときに限る。）
// プログラム単位はtry～finallyでchannelListを解放する。


   TDeviceRef=class         //副プログラムの経路引数として用いる
      owner:TChannelList;
      index:integer;
     constructor create(CL1:TChannelList; ix1:integer);  overload;
     constructor create(CL1:TChannelList; ix1:double);  overload;
   end;



type
  TStdIO = class(TTextDevice)

  end;  //  0番の経路として使う予定。未実装。

PROCEDURE PRINT(args:array of const);




{*****************}
{Numeric functions}
{*****************}
var
  excode:LongWord=$03EA0BB9;   // 1002 3001  ;

 function SGN( x:double):double;inline;   overload;
 function ATN( x:double):double;inline;   overload;
 function ATNDEG( x:double):double;inline;overload;

 function EPS(x:double):double;inline;      overload;
 function BINT( x:double):double;           overload;
 function BCEIL(x:double):double;           overload;
 function BMOD( x,y:double):double;         overload;
 function ROUND( x:double):double;          overload;
 function ROUND( x,y:double):double;        overload;
 function TRUNCATE( x,y:double):double;     overload;
 function BMIN( x,y:double):double;         overload;
 function BMAX( x,y:double):double;         overload;

 function PERM( n,r:double):double;         overload;
 function COMB( n,r:double):double;         overload;
 function FACT( x:double):double;           overload;

 function BitNOT(a:Int64):Int64;    overload;
 function BitNOT(a:double):Int64;    overload;
 function BitAND(a,b:int64):int64;   overload;
 function BitAND(a,b:double):int64;   overload;
 function BitAND(a:int64;b:double):int64;   overload;
 function BitAND(a:double;b:int64):int64;   overload;
 function BitOR(a,b:int64):int64;   overload;
 function BitOR(a,b:double):int64;   overload;
 function BitOR(a:int64;b:double):int64;   overload;
 function BitOR(a:double;b:int64):int64;   overload;
 function BitXOR(a,b:int64):int64;   overload;
 function BitXOR(a,b:double):int64;   overload;
 function BitXOR(a:int64;b:double):int64;   overload;
 function BitXOR(a:double;b:int64):int64;   overload;


 function EXTYPE(const E:Exception; ExcodeRec:LongWord):Integer;
 function EXMess(const E:Exception; ExcodeRec:LongWord):string;
 function PropagatedExtype(t:integer):integer;

{****************}
{STRING Functions}
{****************}
 function SubString(s:string; i1,i2:integer):string;overload;
 function SubString(s:string; i1,i2:double):string;overload;
 function SubStringByte(s:string; i1,i2:integer):string;overload;
 function SubStringByte(s:string; i1,i2:double):string;overload;
 function basicORD(s:AnsiString; CharacterByte:boolean):integer;
 function pos2(const a,b:ansistring):integer;
 function pos3(const a,b:ansistring; m0:double):integer;    overload;
 function UTF8Pos2(const a,b:ansistring):integer;
 function UTF8Pos3(const a,b:ansistring; m0:double):integer;
 function BVAL2(const s:string):int64;
 function BVAL16(const s:string):int64;
 function VAL(const s:string):double;
 function STR_s(x:double):string;                           overload;
 function CHR_s(x:double):string;                           overload;
 function CHRbyte(x:double):string;                         overload;
 function USING_s(const s:string; x:double):string;         overload;
 function USING_ss(const s:string; x:double):string;        overload;
 function REPEAT_s(const s:string; x:double):string;        overload;
 function LTRIM_s(s:string):string;
 function RTRIM_s(s:string):string;
 function BSTR_s(x:double; n:integer):string;               overload;
 function DATE_s:ansistring;
 function TIME_s:ansistring;

 function Mid_s(s:string; i1,i2:integer):string;            overload;
 function Mid_s(s:string; i1,i2:double):string;             overload;
 function Mid_sByte(s:string; i1,i2:integer):string;        overload;
 function Mid_sByte(s:string; i1,i2:double):string;         overload;
 function Left_sByte(s:string;i:integer):string;            overload;
 function Left_s(s:string;i:integer):string;                overload;
 function Left_sByte(s:string; i:double):string;            overload;
 function Left_s(s:string;i:double):string;                 overload;
 function Right_sByte(s:string;i:integer):string;           overload;
 function Right_s(s:string;i:integer):string;               overload;
 function Right_sByte(s:string; i:double):string;           overload;
 function Right_s(s:string;i:double):string;                overload;

 function confirm_s(s:string):string;

{String Variable}
procedure SubstSubstringByte(var v:AnsiString; i,j:integer; const s:ansistring);overload;
procedure SubstSubstringByte(var v:AnsiString; i,j:double; const s:ansistring); overload;
procedure SubstSubstring(var v:AnsiString; i,j:integer; const s:ansistring);    overload;
procedure SubstSubstring(var v:AnsiString; i,j:double; const s:ansistring);     overload;
type
 TStrVar=class
    PVar:PString;
   constructor create (P:PString);
   procedure setstring(const s:string);virtual;
   function getstring:string;virtual;
   property str:string read getstring write setstring;
 end;

 TStrVar2=class(TStrVar)
    left,right:integer;
   constructor create (P:PString; l,r:integer); overload;
   constructor create (P:PString; l,r:double);  overload;
   constructor create (P:PString; l,r:complex);  overload;
   constructor create (P:PString; l:complex;r:double);  overload;
   constructor create (P:PString; l:double; r:complex);  overload;
   procedure setstring(const s:string);override;
   function  getstring:string;override;
end;

TStrVarByte=class(TStrVar2)
   procedure setstring(const s:string);override;
   function  getstring:string;override;
end;


{Let Statements}
procedure LET(const p:Array of PDouble;  x:double);
procedure LETS(const p:Array of TStrVar;  const s:string);

{ Ask Statement}
procedure AskFile(ch:TTextDEvice;
                  expAccess,expDatum,expErasable,expFileType,expName,
                  expOrganization,expPointer,expRecsize1,expRecType,
                  expSetter,expCharin,expTypeahead,expEchoControl,expEcho:TStrVar;
                  expMargin,expRecSize2,expZonewidth,expCharacterPending,expFilesize:Pdouble);

{GOSUB～RETURN}
type
  TGosubStack=class
   public
     constructor create(ssize:integer);
     destructor destroy;override;
     procedure push(i:integer);
     function pop:integer;
   private
       p:integer;
       a:PIntArray;
       size:integer;
  end;
var
  GosubStack:TGosubStack;


{Misc.}

procedure Wait(n:double); overload;
procedure WaitTime(n:double);overload;
procedure WaitTime(s:string);overload;
procedure Pause(const s:string);
procedure FileDelete(const s:string);
procedure FileGetName(const s:string; svar:TStrVar; aux:integer);
procedure GetDirectoryName(svar:TStrVar);
procedure FileSplitname(const s:string; svar1,svar2,svar3:TStrVar);
function Files(const s:string):integer;
procedure FileReName(const s1,s2:string);
procedure FileList(const s:string; a:TArray1S);
procedure SetDirectory(const s:string);
procedure AskDirectory(svar:TStrVar);
procedure swap(var x,y:double);overload;
procedure swap(var x,y:integer);overload;
procedure swap(var x,y:string);overload;
function GetKeyState(const x:double):integer;

{Chain,Execute}
function ShellExec(const s1:string; args:array of const; opWaitFor:boolean):boolean;

{PackDbl$, UnPackDbl}
function PackDbl_s(d:Double):AnsiString;
function UnPackDbl(const s:string):double;
function DWord_s(x:DWord):AnsiString; overload;
function Word_s(x:DWord):AnsiString;  overload;
function Byte_s(x:Dword):ansistring;  overload;
function DWord_s(x:double):AnsiString;overload;
function Word_s(x:double):AnsiString; overload;
function Byte_s(x:double):ansistring; overload;




procedure ErrMessage(E:Exception);

{************}
implementation
{************}
uses LazUTF8,
     arithmet,math2sub,format,charinp,BASini,sconsts,
     paintfrm,graphsys,textfrm,debugdg,mythread,GraphQue;

{$MAXFPUREGISTERS Default}
procedure SubstSubstring(var v:AnsiString; i,j:integer; const s:ansistring);
var
   k,p:integer;
begin
    if i<=0 then i:=1;
    k:=UTF8length(v);
    if j>k then j:=k;
    UTF8delete(v,i,j-i+1);
    UTF8insert(s,v,i);
end;

procedure SubstSubstring(var v:AnsiString; i,j:double; const s:ansistring);
begin
   SubstSubstring(v, LongIntRound(i),LongIntRound(j),s)
end;



procedure SubstSubstringByte(var v:AnsiString; i,j:integer; const s:ansistring);
var
   p:integer;
begin
    if i<=0 then i:=1;
    if j>length(v) then j:=length(v);
    if j-i+1 =length(s) then
       for p:=i to j do
           v[p]:=s[p-i+1]
    else
       begin
         delete(v,i,j-i+1);
         insert(s,v,i);
       end;
end;

procedure SubstSubstringByte(var v:AnsiString; i,j:double; const s:ansistring);
begin
   SubstSubstringByte(v, LongIntRound(i),LongIntRound(j),s)
end;

function FloatVal( const s:ansistring):double;
var
   c:integer;
begin
  try
   System.Val(s,result,c);         {!!!!!!!! 要修正?? !!!!!!!}
   if c<>0 then
     if s='' then
        result:=0
     else
        setexception(8101);
  except
   on EMathError do setexception(1006)
  end;
end;

{*************}
{ ChannelList }
{*************}

constructor TChannelList.create;
var
  i:integer;
begin
  inherited create;
  Capacity:=100;
  for i:=0 to Capacity-1 do
     add('');
  objects[0]:=console;
end;

procedure TChannelList.Setrefference(chn:integer; ch:TDeviceRef); // 経路引数をセットする
begin
   if (chn>0) and (chn<Capacity) and (objects[chn]=nil) then
      begin
         Objects[chn]:=ch;
      end
   else
      setexception(7001)
end;

function TChannelList.channel(chn:integer):TTextDevice;
begin
  if (chn>=0) and (chn<Capacity) and (objects[chn]<>nil) then
     if objects[chn] is TDeviceRef then
           with TDeviceRef(objects[chn]) do
              result:=owner.channel(index)
     else {if objects[chn] is TTextDevice then}
           result:=TTextDevice(objects[chn])
   else
      setexception(7004)
end;

function TChannelList.channel(chn0:double):TTextDevice;
begin
  result:=channel(LongIntRound(chn0))
end;

function DecideAccessMode(const s:ansistring; var am:AccessMode):boolean;
begin
   result:=true;
   if s=AccessModeLiteral[amOUTIN] then
      am:=amOutin
   else if s=AccessModeLiteral[amINPUT] then
      am:=amInput
   else if s=AccessModeLiteral[amOUTPUT] then
      am:=amOUTput
   else
      result:=false
end;

function DecideRecordType(const s:ansistring; var rc:RecordType):boolean;
begin
   result:=true;
   if s=RecordTypeLiteral[rcDisplay] then
      rc:=rcDisplay
   else if s=RecordTypeLiteral[rcInternal] then
      rc:=rcInternal
   else if s=RecordTypeLiteral[rcCSV] then
      rc:=rcCSV
   else
      result:=false
end;

function DecideOrgType(const s:ansistring; var og:OrganizationType):boolean;
begin
   result:=true;
   if s=OrganizationTypeLiteral[orgSEQ] then
      og:=orgSEQ
   else if s=OrganizationTypeLiteral[orgSTREAM] then
      og:=orgSTREAM
   else
      result:=false
end;


procedure TChannelList.open(chn0:double; const FName:FNameStr;const amode,rectp,orgtp:string;
                                               len:integer; insideofwhen:boolean);
var
  ttext:TTextDevice;
  chn:integer;
  am:AccessMode;
  rc:RecordType;
  og:OrganizationType;
begin
  chn:=LongIntRound(chn0);

   if chn=0 then
     if insideofwhen then setexception(7002) else exit;

   if (chn<0) or (chn>=Capacity) then
     setexception(7001);


   if    DecideAccessMode(amode,am)
     and DecideRecordType(rectp,rc)
     and DecideOrgType(orgtp,og)
                                     then
         begin
            if rc=rcDisplay then
              {$IFDEF Windows}
               if isCommPortName(FName) then
                ttext:=TCommFile.create
               else
              {$ENDIF}
                ttext:=TTextFile.create
            else if rc=rcInternal then
                ttext:=TInternalFile.create
            else
                ttext:=TCSVfile.create;

            ttext.open(Fname,am,og,len);
            if (chn<count) and (objects[chn] is TDeviceRef) then
               with TDeviceRef(objects[chn]) do owner.assign(index,ttext,insideofwhen)
            else
               assign(chn,ttext,insideofwhen);
         end
   else
           setexception(7001);
end;

procedure TChannelList.assign(chn:integer; dev:TTextDevice; insideofwhen:boolean);
begin
   if (chn=0) then
     begin
       dev.free;
       if insideofwhen then setexception(7002) else exit;
     end;

   if (chn<count) and (objects[chn]=nil) then
      Objects[chn]:=dev
   else
      setexception(7003)
end;


procedure TChannelList.OpenPrinter(chn0:double; insideofwhen:boolean);
var
  ttext:TTextDevice;
  chn:integer;
begin
  chn:=LongIntRound(chn0);
   if chn=0 then
     if insideofwhen then setexception(7002) else exit;

   if (chn<0) or (chn>=Capacity) then
     setexception(7001);

   ttext:=TLocalPrinter.create;
   ttext.open('',amOUTPUT,orgSeq,1024{dummy});
   if (chn<count) and (objects[chn] is TDeviceRef) then
       with TDeviceRef(objects[chn]) do owner.assign(index,ttext,insideofwhen)
   else
       assign(chn,ttext,insideofwhen);
end;

procedure TChannelList.close(chn0:double);
var
  ttext:TTextDevice;
  chn:integer;
begin
  chn:=LongIntRound(chn0);
  try
    ttext:=channel(chn);
    if ttext<>nil then
      begin
         if chn<count then
           if (objects[chn] is TDeviceRef) then
              with TDeviceRef(objects[chn]) do owner.objects[index]:=nil
           else
              objects[chn]:=nil;
         ttext.close;
         ttext.free;
         ttext:=nil;
       end
    //else
      // setexception(7004);
  except
    on E:EEXtype do
       if E.extype=7004 then
         else
            raise;
  end;
end;

destructor TChannelList.destroy;
var
   i:integer;
begin
 for i:=1 to Count-1 do     //0番(#0)を残す
     Objects[i].free;
 clear;
 inherited destroy;
end;

constructor TDeviceRef.create(CL1:TChannelList; ix1:integer); overload;
begin
   inherited create;
   owner:=CL1;
   index:=ix1
end;

constructor TDeviceRef.create(CL1:TChannelList; ix1:double); overload;
begin
   inherited create;
   owner:=CL1;
   index:=LongIntRound(ix1)
end;

function TChannelList.channel(chn0:Complex):TTextDevice; overload;
begin
   result:=channel(testreal(chn0))
end;

procedure TChannelList.open(chn0:complex; const FName:FNameStr;
                                 const amode,rectp,orgtp:string;
                                 len:integer; insideofwhen:boolean); overload;
begin
   open(testreal(chn0),FName,amode,rectp,orgtp,len,insideofwhen)
end;

procedure TChannelList.OpenPrinter(chn:complex; insideofwhen:boolean); overload;
begin
   OpenPrinter(testreal(chn),insideofwhen)
end;

procedure TChannelList.close(chn0:complex);                          overload;
begin
   close(testreal(chn0))
end;



{*****************}
{Numeric functions}
{*****************}


function SGN( x:double):double; inline;
begin
    result:=sign(x)
end;


function ATN( x:double):double; inline;
begin
   result:=arctan(x)
end;

function ATNDEG( x:double):double;inline;
begin
   result:=arctan(x)*degree
end;



function EPS(x:double):double;inline;
begin
   base2.FEPS(x);
   result:=x;
end;






function power10(i:integer):double;
var
   x,y:double;
begin
    x:=10.;
    y:=1.;
    if i<0 then begin x:=1./x ; i:=-i end;
    while i>0 do
        begin
           if i mod 2 =1 then
              y:=y*x;
           i:=i div 2;
           if i>0 then x:=x*x;
        end;
    power10:=y
end;

function ROUND(x,y:double):double;overload;
var
   e:double;
begin
     e:=power10(LongIntRound(y));
     result:=bint(x*e+0.5)/e;
end;


function TRUNCATE(x,y:double):double; overload;
var
   e:double;
begin
     e:=power10(LongIntRound(y));
     result:=int(x*e)/e;
end;

function BMIN( x,y:double):double;
begin
  if x<y then
     result:=x
  else
     result:=y
end;

function BMAX( x,y:double):double;
begin
  if x>y then
     result:=x
  else
     result:=y
end;


function PERM( n,r:double):double;
var
   i,k:integer;
begin
   if Frac(r)<>0 then  setexception(4000);
   k:=LongIntRound(r);
   if k<0 then
      begin
         result:=0;
         setexception(3000)
      end
   else
      begin
         result:=1;
         for i:=1 to k do
             begin
                result:=result*n;
                n:=n-1;
             end;
      end;
end;

function COMB( n,r:double):double;
var
   i,k:integer;
   m:double;
   x:extended;
begin
   if Frac(r)<>0 then  setexception(4000);
   //r:=ROUND(r);
   k:=LongIntRound(r);
   if k<0 then
     x:=0
   else if (k>n/2) and (n=int(n)) and (n>0) then
     x:=comb(n,n-r)
   else
     begin
        x:=1;
        m:=1;
        for i:=1 to k do
           begin
             x:=x*n/m;
             n:=n-1;
             m:=m+1;
          end;
     end;
   result:=x;
end;

function FACT( x:double):double;
begin
   result:=PERM(x,x)
end;


{**************}
{BIT Operations}
{**************}
function BitNOT(a:Int64):Int64;    overload;
begin
   result:=not a
end;

function BitNOT(a:double):Int64;    overload;
begin
 result:=not system.Round(a)
end;

function BitAND(a,b:int64):int64;   overload;
begin
 result:=a and b
end;

function BitAND(a,b:double):int64;   overload;
begin
result:=system.Round(a) and system.Round(b)
end;

function BitAND(a:int64;b:double):int64;   overload;
begin
result:=a and system.Round(b)
end;

function BitAND(a:double;b:int64):int64;   overload;
begin
result:=system.Round(a) and b
end;

function BitOR(a,b:int64):int64;   overload;
begin
 result:=a or b
end;

function BitOR(a,b:double):int64;   overload;
begin
result:=System.Round(a) or System.Round(b)
end;

function BitOR(a:int64;b:double):int64;   overload;
begin
result:=a or System.Round(b)
end;

function BitOR(a:double;b:int64):int64;   overload;
begin
result:=System.Round(a) or b
end;

function BitXOR(a,b:int64):int64;   overload;
begin
 result:=a xor b
end;

function BitXOR(a,b:double):int64;   overload;
begin
result:=System.Round(a) xor System.Round(b)
end;

function BitXOR(a:int64;b:double):int64;   overload;
begin
result:=a xor System.Round(b)
end;

function BitXOR(a:double;b:int64):int64;   overload;
begin
result:=System.Round(a) xor b
end;



{****************}
{String Functions}
{****************}
function SubStringByte(s:string; i1,i2:integer):string;overload;
begin
   result:=Copy(s,i1,i2-i1+1)
end;

function SubStringByte(s:string; i1,i2:double):string;overload;
begin
  result:=SubStringByte(s,LongIntRound(i1),LongIntRound(i2))
end;



function SubString(s:string; i1,i2:integer):string;overload;
begin
   result:=UTF8Copy(s,i1,i2-i1+1)
end;

function SubString(s:string; i1,i2:double):string;overload;
begin
  result:=SubString(s,LongIntRound(i1),LongIntRound(i2))
end;

function Mid_s(s:string; i1,i2:integer):string;overload;
begin
   result:=UTF8Copy(s,i1,i2)
end;

function Mid_s(s:string; i1,i2:double):string;overload;
begin
   result:=Mid_s(s,LongIntRound(i1),LongIntRound(i2))
end;

function Mid_sByte(s:string; i1,i2:integer):string;overload;
begin
  result:=Copy(s,i1,i2)
end;

function Mid_sByte(s:string; i1,i2:double):string;overload;
begin
   result:=Mid_sByte(s,LongIntRound(i1),LongIntRound(i2))
end;

function Left_sByte(s:string;i:integer):string;overload;
begin
   result:=Copy(s,1,i)
end;

function Left_sByte(s:string; i:double):string;overload;
begin
   result:=Left_sByte(s,LongIntRound(i))
end;

function Left_s(s:string;i:integer):string;overload;
begin
  result:=UTF8Copy(s,1,i)
end;

function Left_s(s:string;i:double):string;overload;
begin
   result:=Left_s(s,LongIntRound(i))
end;

function Right_sByte(s:string;i:integer):string;overload;
begin
   result:=copy(s,length(s)-i+1,i)
end;

function Right_s(s:string;i:integer):string;overload;
var
  len:integer;
begin
   len:=Utf8Length(s);
   result:=UTF8copy(s,len-i+1,i)
end;

function Right_sByte(s:string; i:double):string;overload;
begin
   result:=Right_sByte(s,LongIntRound(i))
end;

function Right_s(s:string;i:double):string;overload;
begin
   result:=Right_s(s,LongIntRound(i))
end;


function basicORD(s:AnsiString; CharacterByte:boolean):integer;
var
   i:integer;
   charlen:integer;
begin
   if Length(s)=1 then
      basicORD:=ord(s[1])
   else if (Length(s)=3) and (byte(s[1])<128) then
      begin
         s:=AnsiUpperCase(s);
         if (length(s)=3) and (copy(s,1,2)='LC') then
             basicORD:=ord(s[3])+32
         else
         begin
             for i:=0 to 39 do
                 if s=CharNameTBL1[i] then begin basicORD:=CharNameTBL2[i]; exit end;
             basicORD:=0;
             setexceptionwith('ORD',4003);
         end ;
      end
   else if characterbyte then
      begin
             basicORD:=0;
             setexceptionwith('ORD',4003);
      end
    else
      begin
         BASICOrd:=UTF8CharacterToUnicode(PChar(s),charlen);
         if charlen<length(s) then  setexceptionwith('ORD',4003);
      end;
end;

function pos2(const a,b:ansistring):integer; inline;
begin
   if b<>'' then
      pos2:=pos(b,a)
   else
      pos2:=1;
end;

function pos3(const a,b:ansistring; m0:double):integer;
var
   temp1,temp3:integer;
   temp2:ansistring;
   m:integer;
begin
   m:=LongIntRound(m0);
   if m<=length(a) then
     begin
       temp1:=base.max(1,base.min(m,length(a)+1));
       temp2:=copy(a,temp1,maxint);
       temp3:=pos2(temp2,b);
       if temp3=0 then
          pos3:=0
       else
          pos3:=temp3+temp1-1
     end
   else
     pos3:=0;
end;

function UTF8Pos2(const a,b:ansistring):integer;
begin
   if b<>'' then
      result:=UTF8Pos(b,a)
   else
      result:=1;
end;

function UTF8Pos3(const a,b:ansistring; m0:double):integer;
var
   temp1,temp3:integer;
   temp2:ansistring;
   m:integer;
begin
   m:=LongIntRound(m0);
   if m<=Utf8length(a) then
     begin
       temp1:=base.max(1,base.min(m,Utf8length(a)+1));
       temp2:=Utf8copy(a,temp1,maxint);
       temp3:=UTF8Pos2(temp2,b);
       if temp3=0 then
          Result:=0
       else
          Result:=temp3+temp1-1
     end
   else
     result:=0;
end;


function BVAL2(const s:string):int64;
var
   i:integer;
   t:int64;
begin
    result:=0;
    t:=1;
    i:=length(s);
    while i>0 do
      begin
         case s[i] of
            '0' : ;
            '1' : result:=result + t;
            else  setexceptionwith('BVAL',4201);
         end;
         t:=t*2;
         dec(i)
      end;
end;

function BVAL16(const s:string):int64;
var
   i:integer;
   t:int64;
   c:char;
begin
    result:=0;
    t:=1;
    i:=length(s);
    while i>0 do
      begin
         c:=s[i];
         case c of
            '0'..'9' : result:=result + t * (ord(c)-ord('0'));
            'A'..'F' : result:=result + t * (ord(c)-ord('A')+10);
            'a'..'f' : result:=result + t * (ord(c)-ord('a')+10);
            else  setexceptionwith('BVAL',4201);
         end;
         t:=t*16;
         dec(i)
      end;
end;


function VAL(const s:string):double;
var
   n:number;
   RenovExtype:integer;
begin
   try
       Nval(s,n);
       checkrangedecimal(n,1004);
    except
       on E:EExtype do
       begin
          if E.extype>=3000 then
             RenovExtype:=4001;
          if (E.extype>=1000) and (E.extype <1004) then
             RenovExtype:=1004;
          if RenovExtype>0 then
          raise EExtype.create(RenovExtype)
       end;
    end;
    result:=extendedVal(n);
end;


function STR_s(x:double):string;
var
  n:number;
begin
    convert(x,n);
    result:=Trim(Dstr(n));
end;

function CHRbyte(x:double):string;
var
  b:byte;
begin
  b:=LongIntRound(x);
  result:=chr(b)
end;

function CHR_s(x:double):string;
begin
  result:=UnicodeToUTF8(LongIntRound(x));
end;

function USING_ss(const s:string; x:double):string;
var
   i,c:integer;
begin
   i:=1;
   TestFormatItem(s);
   result:=formatDouble(x,s,i,c);
   if (c<>0)  then
       setexceptionwith('USING$',c)
end;

function USING_s(const s:string; x:double):string;
var
   i,c:integer;
begin
   i:=1;
   TestFormatItem(s);
   result:=formatDouble(x,s,i,c);
end;

function REPEAT_s(const s:string; x:double):string;
var
   m,len:int64;
   l:integer;
   i:integer;
begin
   result:='';
   m:=system.Round(x);
   l:=Length(s);
   if (m>=0) then
     begin
       len:=m*l;
       if (len<0) or (len>=MaxLongInt) then setexception(1051);
       try
          setlength(result,len);
          if len>0 then
             if l=1 then
                FillChar(result[1],len,s[1])
             else
                for i:=0 to m-1 do move(s[1],result[1+i*l],l) ;
       except
          setexception(OutOfMemory)
       end;
     end
      else
        setexception(4010);
end;

function LTRIM_s(s:string):string;
var
  i:integer;
begin
  i:=0;
  while (i<length(s)) and (s[i+1]=' ') do inc(i);
  delete(s,1,i);
  result:=s
end;

function RTRIM_s(s:string):string;
var
  i:integer;
begin
  i:=Length(s);
  while (i>0) and (s[i]=' ') do dec(i);
  delete(s,i+1,length(s)-i);
  result:=s
end;

function BSTR_s(x:double; n:integer):string;
var
   t:double;
   i:integer;
begin
   if (x<0.0) then setexceptionwith('BSTR$',4203);
   t:=system.int(x);
   if x-t<0.5 then x:=t else x:=t+1;
   if x=0 then
      result:='0'
   else
      if n=2 then
         begin
            result:='';
            while x>0 do
               begin
                  t:=x/2;
                  x:=system.int(t);
                  if x=t then
                      result:='0' + result
                  else
                      result:='1'+result;
               end;
         end
      else if n=16 then
         begin
            result:='';
            while x>0 do
               begin
                  t:=x/16;
                  x:=system.int(t);
                  i:=system.round(16*(t-x));
                  if i<10 then
                     result:=chr(ord('0')+ i) + result
                  else
                     result:=chr(ord('A')-10 + i) + result

               end;
         end
end;


function format2(i:integer):ansistring;
var
   s:ansistring;
begin
   system.str(i:2,s);
   if s[1]=' ' then s[1]:='0';
   format2:=s
end;

function DATE_s:ansistring;
var
   y,m,d,w:WORD;
begin
   decodedate(date,y,m,d);
   {getdate(y,m,d,w);}
   system.str(y:4,result);
   result:=result+format2(m)+format2(d);
end;

function TIME_s:ansistring;
var
   h,m,sec,msec:WORD;
begin
   DecodeTime(Time, h, m, Sec, MSec);
   {   gettime(h,m,sec,s100);}
   result:=format2(h)+':'+format2(m)+':'+format2(sec);
end;

function confirm_s(s:string):string;
begin
  result:=YesNoLiteral[MessageDlg(s,mtConfirmation,[mbYes,mbNo],0)=mrYes]
end;



{*******************}
{Assembler functions}
{*******************}

{$ASMMODE intel}
{$IFDEF CPU386}
function BINT(x:double):double;assembler;
asm
   fld x
   FLDCW RoundNins
   frndint
   FLDCW ControlWord
end;

function BCEIL(x:double):double;assembler;
asm
   fld x
   FLDCW RoundPlus
   frndint
   FLDCW ControlWord
end;

function ROUND(x:double):double;assembler;
asm
   fld x;
   frndint;
end;

function BMOD(x,y:double):double; assembler;
asm
       fld y
       fld x
       FLD ST(0)
       FDIV ST(0),ST(2)
       FLDCW RoundNins
       FRNDINT
       FLDCW ControlWord
       FMULP ST(2),ST(0)
       fSUBRP st(1),st(0)
end;
{$ELSE}
{$IFDEF AvailSSE41}
function ROUND(x:double):double; assembler; nostackframe;
asm
   roundsd xmm0, xmm0, 0
end;

function BINT(x:double):double; assembler;   nostackframe;
asm
   roundsd xmm0, xmm0, 1
end;

function BCEIL(x:double):double; assembler;  nostackframe;
asm
   roundsd xmm0, xmm0, 2
end;

function BMOD(x,y:double):double;
begin
  result:=x-y*BINT(x/y);
end;
{$ELSE}
{$IFDEF FPC_HAS_TYPE_EXTENDED}

function BINT(x:double):double;
var
   svCW:word;
begin
asm
   FNSTCW svCW
   FLDCW [RoundNins+rip]
   fld x
   frndint
   FLDCW svCW
   fstp result
end;
end;

function BCEIL(x:double):double;
var
   svCW:word;
begin
asm
   FNSTCW svCW
   FLDCW [RoundPlus+rip]
   fld x
   frndint
   FLDCW svCW
   fstp result
end;
end;

function ROUND(x:double):double;
begin
asm
   fld x;
   frndint;
   fstp result
end;
end;

function BMOD(x,y:double):double;
var
   svCW:word;
begin
asm
       FNSTCW svCW
       fld y
       fld x
       FLD ST(0)
       FDIV ST(0),ST(2)
       wait
       FLDCW [RoundNins+rip]
       FRNDINT
       FLDCW svCW
       FMULP ST(2),ST(0)
       fSUBRP st(1),st(0)
       fstp result
end;
end;

{$ELSE}
function BINT(x:double):double;
begin
   if x>=0 then
      result:=int(x)
   else if frac(x)=0 then
      result:=x
   else
      result:=int(x-1)
end;

function BCEIL(x:double):double;
begin
   if x<=0 then
      result:=-int(-x)
   else if frac(x)=0 then
      result:=x
   else
      result:=1-int(-x)
end;

function ROUND(x:double):double;
begin
   try
     result:=System.Round(x)
   except
     result:=x
   end
end;

function BMOD(x,y:double):double;
begin
     result:=x-y*BINT(x/y);
end;


{$ENDIF}
{$ENDIF}
{$ENDIF}

{***************}
{EXTYPE function}
{***************}

function EXTYPE(const E:Exception; ExcodeRec:LongWord):Integer;
var
   p:pointer;
begin
  if ( E is EdivByZero) or (E is EZeroDivide) then
      begin
            p:=ExceptAddr;
            if (p>@BMOD) and (p<@EXTYPE) then
               result:=3006
            else
               result:=excodeRec mod $10000
      end
  //else if E is EOverflow then
  //      result:= excodeRec div $10000
  else if E is EMathError then
        result:=excodeRec div $10000
   else if E is EExtype then
        result:=EExtype(E).Extype
   else
      result:=0;
end;

function Exmess(const E:Exception; ExcodeRec:LongWord):string;
var
  i:integer;
begin
  result:='';
  i:=EXTYPE(E, ExcodeRec);
  if i<>0 then
  begin
  case i mod 100000 of
           0      : result:='' ;
        1001      : result:=s_Extype1001;
        1002      : result:=s_Extype1002;
        1003      : result:=s_Extype1003;
        1006      : result:=s_Extype1006;
        1007      : result:=s_Extype1007;
        1008      : result:=s_Extype1008;
        1050..1106: result:=s_Extype1050;
        1004..1005,
        1009..1049,
        1107..1999: result:=s_Extype1000;

        2001      : result:=s_Extype2001;
        3000      : result:=s_Extype3000;
        3001      : result:=s_Extype3001;
        3002      : result:=s_Extype3002;
        3003      : result:=s_Extype3003;
        3004      : result:=s_Extype3004 + '(LOG)';
        3005      : result:=s_Extype3004 + '(SQR)'+ EOL + 'Otherwise' + EOL + 'Unknown Fault (wrong FPU usage)';
        3006      : result:=s_Extype3004 + '(MOD)';
        3007      : result:=s_Extype3004 + '(ASIN or ACOS)';
        3008      : result:=s_Extype3004 + '(ANGLE)';
        3009      : result:=s_Extype3009;
        4000..4299:
               begin
                    result:=s_Extype3004;
                    case i mod 100000 of
                         4004: result:=result + '(SIZE)';
                         4005: result:=result + '(TAB)';
                         4008: result:=result + '(LBOUND)';
                         4009: result:=result + '(UBOUND)';
                         4010: result:=result + '(REPEAT$)';
                       else
                    end;
               end;
        5001,5002 : result:=s_Extype5001;
        6001..6402: result:=s_Extype6001;
        7001      : result:=s_Extype7001;
        7003      : result:=s_Extype7003;
        7004      : result:=s_Extype7004;
        7101      : result:=s_Extype7101;
        7102      : result:=s_Extype7102;
        7103      : result:=s_Extype7103;
        7301      : result:=s_EXtype7301;
        7302      : result:=s_EXtype7302;
        7303      : result:=s_EXtype7303;
        7305      : result:=s_Extype7305;
        7308      : result:=s_Extype7308;
        7317      : result:=s_Extype7317;
        7318      : result:=s_Extype7318;

        7005..7100,7104..7300,7311..7316,7320..7402
                  : result:=s_Extype7000;
        8001      : result:=s_Extype8001;
        8011      : result:=s_Extype8011;
        8012      : result:=s_Extype8012;
        8013      : result:=s_Extype8013;
        8101      : result:=s_Extype8101;
        8002,8003,8102,8103: result:=s_Extype8002;
        8105      : result:=s_Extype8105;
        8120      : result:=s_Extype8120;
        8201      : result:=s_Extype8201;
        8202      : result:=s_Extype8202;
        8401      : result:=s_Extype8401;
        8402      : result:=s_Extype8402;
        9000      : result:=s_Extype9000;
        9002      : result:=s_Extype9002;
        9003      : result:=s_Extype9003;
        9004      : result:=s_Extype9004;
        9102      : result:=s_Extype9102;
        10002     : result:=s_Extype10002;
        10004     : result:=s_Extype10004;
        11004     : result:=s_Extype11004;
        11051     : result:=s_Extype11051;
        12004     : result:=s_Extype12004;
        outofmemory :         result:=s_OutoOfMemory;
        virtualStackOverflow: result:=s_VStackOverflow;
        stackoverflow:        result:=s_StackOverflow;
        ArraySizeOverflow:    result:=s_ArraySizeOverflow;
        TooLargeVirtualStack: result:=s_TooLargeVStack;
        TextOverFlow:         result:=s_OutputOverflow;
        systemErr   :         result:='system error';
        else                  result:=''   ;
     end;
     result:='extype '+inttostr(i mod 100000)+EOL + result;
    end;
  if not (E is EExtype) then
     begin
       if Result<>'' then
          Result:=Result +EOL+ 'or' + EOL;
       Result:= Result + E.Message + EOL + E.classname;
       if Pos('Run-Time', E.Message)>0 then
         if Pos('202',E.Message)>0 then
             result:=Result + EOL + 'Stack overflow'
         else if Pos('203',E.Message)>0 then
             result:=Result + EOL + 'Heap overflow'
         else;
       if i=0 then
         result:=result+EOL+EOL
         +'Reporting EXTYPE is disabled.'+EOL
         +'To enable reporting EXTYPE, switch '+EOL
         +'Option - Compatibility - Debug - Reporting EXTYPE'
     end;
end;

 function PropagatedExtype(t:integer):integer;
 begin
   result:=t;
   if (result>0) and (result<100000)  then
      result:=100000 + result
   else if (result<0) and (result>-100000) then
      result:=result-100000
 end;

{String Variable}

constructor TStrVar.create (p:PString);
begin
  inherited create;
  PVar:=p
end;

procedure TStrVar.setstring(const s:string);
begin
   PVar^:=s;
end;

function TStrVar.getstring:string;
begin
   result:=PVar^
end;


constructor TStrVar2.create (P:PString; l,r:integer); overload;
begin
   inherited create(p);
   left:=l;
   right:=r
end;

constructor TStrVar2.create (P:PString; l,r:double); overload;
begin
  create(P,LongIntRound(l),LongIntRound(r))
end;

constructor TStrVar2.create (P:PString; l,r:complex);  overload;
begin
  create(P,testreal(l),testreal(r))
end;
constructor TStrVar2.create (P:PString; l:complex;r:double);  overload;
begin
  create(P,testreal(l),testreal(r))
end;
constructor TStrVar2.create (P:PString; l:double; r:complex);  overload;
begin
  create(P,testreal(l),testreal(r))
end;

procedure TStrVar2.setstring(const s:string);
begin
  SubstSubstring(Pvar^,left,right,s)
end;

function TStrVar2.getstring:string;
begin
   result:=substring(PVar^, left, right)
end;

procedure TStrVarByte.setstring(const s:string);
begin
  SubstSubstringByte(Pvar^,left,right,s)
end;

function TStrVarByte.getstring:string;
begin
   result:=substringbyte(PVar^, left, right)
end;




{Let Statements}
procedure LET(const p:Array of PDouble;  x:double);
var
   i:integer;
begin
   for i:=0 to High(p) do
       p[i]^:=x;
end;


procedure LETS(const p:Array of TStrVar; const s:string);
var
   i:integer;
begin
   for i:=0 to High(p) do
       begin
          p[i].str:=s;
          p[i].free
       end;
end;

{$IFDEF Windows}
TYPE uint=CARDINAL;
     MMRESULT = UINT;
Function timeBeginPeriod(x1: UINT): MMRESULT;stdcall; external 'winmm.dll' name 'timeBeginPeriod';
Function timeEndPeriod(x1: UINT): MMRESULT;stdcall; external 'winmm.dll' name 'timeEndPeriod';
procedure MySleep(duration:int64);
begin
   timeBeginPeriod(1);
   sleep(duration);
   timeEndPeriod(1)
end;
{$ELSE}
procedure MySleep(duration:int64);inline;
begin
  sleep(duration);
end;
{$ENDIF}

procedure wait(n:double);
var
   duration:int64;
begin
  duration:=system.round(n*1000);
  if (duration>0) and (duration<$ffffffff) then
     MySleep(duration)
  else  if duration<>0 then
    setexception(12004);
end;

procedure Pause(const s:string);
begin
  debugdg.Pause(s);
end;

procedure WaitTime(n:double);overload;
var
   i:int64;
begin
  i:=system.Round((n-time*24*60*60)*1000) {milliseconds};
  if i<0 then
    i:=i+24*60*60*1000;
  if i>0 then
    sleep(Cardinal(i))
end;

procedure WaitTime(s:string);overload;
var
   n:double;
begin
  try
     n:=StrToTime(s)*24*60*60
  except
     setexception(12005)
  end;
  WaitTime(n);
end;
{PRINT Statements}


PROCEDURE PRINT(args:array of const);
begin
   console.PRINT([],rsNone,false,args)
end;

{swap}
procedure swap(var x,y:double);overload;
var
  t:double;
begin
  t:=x;
  x:=y;
  y:=t
end;

procedure swap(var x,y:integer);overload;
var
  t:integer;
begin
  t:=x;
  x:=y;
  y:=t
end;

procedure swap(var x,y:string);overload;
var
  t:string;
begin
  t:=x;
  x:=y;
  y:=t
end;

function GetKeyState(const x:double):integer;
begin
  //SetFPUMask(OriginalCW);    //2014.1.9
  //Application.ProcessMessages;
  //SetFPUMask(controlword);  //2014.1.9

  result:=lclintf.GetKeyState(LongIntRound(x));
end;



{ File st}

procedure FileDelete(const s:string);
begin
  if FileExists(s) then
     if  DeleteFile(s) then
     else
        setexception(9000)
   else
      setexception(9003)
end;



{************}
{FILE GETNAME}
{************}

{$IFDEF Darwin}
type TFileGetName=class(TResetBoolean)
    s:String;
    svar:TStrVar;
    aux:integer;
  constructor create(var b:boolean; const s0:string; svar0:TStrVar; aux0:integer);
  procedure execute;override;
end;

constructor TFileGetName.create(var b:boolean; const s0:string; svar0:TStrVar; aux0:integer);
begin
  inherited create(b);
  s:=s0;
  svar:=svar0;
  aux:=aux0;
end;

procedure TFileGetname.execute;
var
  dlg:TOpenDialog;
begin
  if aux=2 then
     dlg:=textform.SaveDialog2 //TSaveDialog.create(Application.MainForm)
  else
     dlg:=textform.OpenDialog2;//TOpenDialog.create(Application.MainForm);
  with svar do
    with dlg do
       begin
         Options:=[ofHideReadOnly,ofPathMustExist,ofEnableSizing];
         if aux=1 then options:=options+[ofFileMustExist];
         if aux=2 then options:=options+[ofOverWritePrompt, ofNoReadOnlyReturn];
         if OldFileDialog then options:=options + [ofOldStyleDialog];
         if s='' then
          begin
          {$IFDEF Linux}
          DefaultExt:='' ;
          Filter:=s_TextFile+'|*.TXT;*.txt;*.kw*;*.LOG;*.log;*.BAS;*.bas;*.LIB;*.lib|'
                 +s_ImageFile+'|*.BMP;*.bmp;*.PNG;*.png;*.JPEG;*.jpeg;*.JPG;*.jpg;*.JPE;*.jpe;*.GIF;*.gif;*.TIFF;*.tiff*.TIF;*.tif*;.XBM;*.xbm' + '|'
                 +s_AllFile +'|*.*';
          {$ELSE}
          DefaultExt:='txt' ;
          Filter:=s_TextFile+'|*.TXT;*.kw*;*.LOG;*'+BasExt+';*'+LibExt+'|'
                 +s_ImageFile+'|*.BMP;*.PNG;*.JPEG;*.JPG;*.JPE;*.GIF;*.TIFF;*.TIF;*.XBM' + '|'
                 +s_AllFile +'|*.*';
          {$ENDIF}
           end
          else
           begin
            if pos('|',s)=0 then
             begin
               DefaultExt:=s ;
               Filter:=s + s_FILE + '|' + '*.' +s
             end
            else
             begin
               Filter:=s
             end;
           end;
          dlg.execute;
          str:=FileName;
          //free;
       end;

   inherited execute;
end;

procedure FileGetName(const s:string; svar:TStrVar; aux:integer);
var
  b:boolean;
begin
   b:=true;
   addQueue(TFileGetName.create(b,s,svar,aux));
   while b do (TThread.CurrentThread).Yield  ;
   svar.free;
end;

{$ELSE}
procedure FileGetName(const s:string; svar:TStrVar; aux:integer);
var
  dlg:TOpenDialog;

begin

  if aux=2 then
     dlg:=textform.SaveDialog2 //TSaveDialog.create(Application.MainForm)
  else
     dlg:=textform.OpenDialog2;//TOpenDialog.create(Application.MainForm);
  with svar do
    with dlg do
       begin
         Options:=[ofHideReadOnly,ofPathMustExist,ofEnableSizing];
         if aux=1 then options:=options+[ofFileMustExist];
         if aux=2 then options:=options+[ofOverWritePrompt, ofNoReadOnlyReturn];
         if OldFileDialog then options:=options + [ofOldStyleDialog];
         if s='' then
          begin
          {$IFDEF Linux}
          DefaultExt:='' ;
          Filter:=s_TextFile+'|*.TXT;*.txt;*.CSV;*.csv;*.kw*;*.LOG;*.log;*.BAS;*.bas;*.LIB;*.lib|'
                 +s_ImageFile+'|*.BMP;*.bmp;*.PNG;*.png;*.JPEG;*.jpeg;*.JPG;*.jpg;*.JPE;*.jpe;*.GIF;*.gif;*.TIFF;*.tiff*.TIF;*.tif*;.XBM;*.xbm' + '|'
                 +s_AllFile +'|*.*';
          {$ELSE}
          DefaultExt:='txt' ;
          Filter:=s_TextFile+'|*.TXT;*.CSV;*.kw*;*.LOG;*'+BasExt+';*'+LibExt+'|'
                 +s_ImageFile+'|*.BMP;*.PNG;*.JPEG;*.JPG;*.JPE;*.GIF;*.TIFF;*.TIF;*.XBM' + '|'
                 +s_AllFile +'|*.*';
          {$ENDIF}
           end
          else
           begin
            if pos('|',s)=0 then
             begin
               DefaultExt:=s ;
               Filter:=s + s_FILE + '|' + '*.' +s
             end
            else
             begin
               Filter:=s
             end;
           end;
          TmyThread(TThread.CurrentThread).SyncExec(Tmethod(dlg.execute));
          str:=FileName;
          //free;
       end;
   svar.free;

 end;
{$ENDIF}



procedure GetDirectoryName(svar:TStrVar);
var
  dir:string;
begin
  if SelectDirectory(s_Select_Directory, '', dir) then
  svar.str:=dir;
  svar.free;
end;


procedure FileSplitname(const s:string; svar1,svar2,svar3:TStrVar);
var
   name,ext:string;
   i:integer;
begin
   svar1.str:=ExtractFilePath(s);
   name:=ExtractFileName(s);
   i:=lastDelimiter('.',name);
   ext:=copy(name,i,maxint);
   name:=copy(name,1,i-1);
   svar2.str:=name;
   svar3.str:=ext;
   svar3.free;
   svar2.free;
   svar1.free;
end;

procedure FileList(const s:string; a:TArray1S);
var
   Rec:TSearchRec;
   i:integer;
begin
  if a<>nil then
       begin
          i:=0;
          try
            if FindFirst(s,0,Rec)=0 then
              begin
               if a.Size<=i then SetException(5001);
               with a do elements^[i]:=Rec.Name;
               inc(i);
               while FindNext(Rec)=0 do
                 begin
                   if a.size<=i then SetException(5001);
                   with a do elements^[i]:=Rec.Name;
                   inc(i);
                 end;
              end;
          finally
             FindClose(Rec);
          end;
          a.Resize(i);
       end;
end;

procedure FileReName(const s1,s2:string);
begin
  if FileExists(s1) then
     begin
      if FileExists(s2) then
         setexception(9004)
      else if not RenameFile(s1,s2) then
         setexception(9000)
     end
  else
     setexception(9003);
end;

function Files(const s:string):integer;
var
   Rec:TSearchRec;
begin
    result:=0;
    try
      if FindFirst(s,0,Rec)=0 then
        begin
          inc(result);
          while FindNext(Rec)=0 do
             inc(result);
         end;
    finally
       FindClose(Rec);
    end;
end;

procedure SetDirectory(const s:string);
var
  exty:integer;
begin
   try
     chDir(s)
   except
     on E:EInOutError do
       begin
         if E.ErrorCode=21 then
            exty:=9002
         else
            exty:=9008;
         setexception(exty);
       end;
     on E:Exception do
        begin
           setexception(9000);
        end;
    end;
end;

procedure AskDirectory(svar:TStrVar);
begin
  svar.str:=GetCurrentDir;
  svar.free
end;

{***}
{ASK}
{***}

function AskMargin(ch:TTextDevice):integer;
begin
     if  (ch.rectype=rcDisplay) then
        AskMargin:=ch.Margin
     else
        AskMargin:=0;
end;

function AskZoneWidth(ch:TTextDevice):integer;
begin
     if (ch.rectype=rcDisplay)then
        AskZoneWidth:=ch.ZoneWidth
     else
        AskZoneWidth:=0;
end;

function AskCharacterPending(ch:TTextDevice):integer;
begin
     ;
     result:=ch.AskCharacterPending
end;


function AskFILETYPE(ch:TTextDevice):AnsiString;
begin
    if ch.TrueFile then
          result:='FILE'
    else
          result:='DEVICE'
end;

function AskEcho(ch:TTextDevice):AnsiString;
begin
    if ch.echoOn then
           result:='ON'
    else
           result:='OFF'
end;

procedure AskFile(ch:TTextDEvice;
                  expAccess,expDatum,expErasable,expFileType,expName,
                  expOrganization,expPointer,expRecsize1,expRecType,
                  expSetter,expCharin,expTypeahead,expEchoControl,expEcho:TStrVar;
                  expMargin,expRecSize2,expZonewidth,expCharacterPending,expFilesize:Pdouble);
begin
  if (ch<>nil) and ch.isopen then
     begin
      if expAccess<>nil then
        with expAccess do
         begin
           str:=AccessModeLiteral[ch.AMode];
           free;
         end;
      if expDatum<>nil then
         with expDatum do
           begin
             str:=ch.Datum;
             free;
           end;
      if expErasable<>nil then
        with expErasable do
          begin
           str:=YesNoLiteral[((ch.amode=amOUTIN) and ch.TrueFile) or (ch is TLocalPrinter)];
           free;
          end;
      if expFileType<>nil then
        with expFiletype do
          begin
           str:=askFileType(ch);
           free;
          end;
      if expName<>nil then
         with expName do
          begin
           str:=ch.Name;
           free;
          end;
      if expOrganization<>nil then
         with expOrganization do
          begin
           str:=OrganizationTypeLiteral[ch.OrgType];
           free;
          end;
      if expPointer<>nil then
         with expPointer do
          begin
            str:=ch.askPointer;
            free;
          end;
      if expRecType<>nil then
        with expRecType do
         begin
          str:=RecordTypeLiteral[ch.Rectype];
          free;
         end;
      if expSetter<>nil then
         with expSetter do
           begin
             str:=YesNoLiteral[ch.TrueFile];
             free;
           end;
      if expCharin<>nil then
         with expCharin do
           begin
             str:=YesNoLiteral[(ch.rectype=rcDisplay) and (ch.AMode in [amOutin,amInput])];
             free;
            end;
      if expTypeahead<>nil then
         begin
            with expTypeAhead do
              begin
                str:=YesNoLiteral[ch.AskTypeAhead];
                free;
              end;
         end;
      if expEchoControl<>nil then
         with expEchoControl do
           begin
             str:=YesNoLiteral[ch=console];
             free;
           end;
      if expEcho<>nil then
         with expEcho do
           begin
            str:=askEcho(ch);
            free;
           end;
      if expMargin<>nil then expMargin^:=askMargin(ch);
      if expZonewidth<>nil then expZonewidth^:=askZonewidth(ch);
      if expCharacterPending<>nil then expCharacterPending^:=askCharacterPending(ch);
      if expFileSize<>nil then expFilesize^:=(ch.askfilesize);

      if expRecsize1<>nil then
         with expRecSize1 do
           begin
            str:='VARIABLE';
            free;
           end;
      if expRecSize2<>nil then expRecSize2^:=ch.leng;
     end
   else
     begin
      if expAccess<>nil then
        with expAccess do
         begin
           str:='';
           free;
         end;
      if expDatum<>nil then
         with expDatum do
           begin
             str:='';
             free;
           end;
      if expErasable<>nil then
        with expErasable do
          begin
           str:='';
           free;
          end;
      if expFileType<>nil then
        with expFiletype do
          begin
           str:='';
           free;
          end;
      if expName<>nil then
         with expName do
          begin
           str:='';
           free;
          end;
      if expOrganization<>nil then
         with expOrganization do
          begin
           str:='';
           free;
          end;
      if expPointer<>nil then
         with expPointer do
          begin
            str:='';
            free;
          end;
      if expRecType<>nil then
        with expRecType do
         begin
          str:='';
          free;
         end;
      if expSetter<>nil then
         with expSetter do
           begin
             str:='';
             free;
           end;
      if expCharin<>nil then
         with expCharin do
           begin
             str:='';
             free;
            end;
      if expTypeahead<>nil then
            with expTypeAhead do
              begin
                str:='';
                free;
              end;
      if expEchoControl<>nil then
         with expEchoControl do
           begin
             str:='';
             free;
           end;
      if expEcho<>nil then
         with expEcho do
           begin
            str:='';
            free;
           end;
      if expMargin<>nil then expMargin^:=0;
      if expZonewidth<>nil then expZonewidth^:=0;
      if expCharacterPending<>nil then expCharacterPending^:=0;
      if expFileSize<>nil then expFilesize^:=0;

      if expRecsize1<>nil then
         with expRecSize1 do
           begin
            str:='';
            free;
           end;
      if expRecSize2<>nil then expRecSize2^:=0;
     end

end;


{Chain,Execute}
function ShellExecSub(s1,s2:string; opWaitFor:boolean):boolean;
var
   AProcess: TProcessUTF8;
begin
   result:=false;
   AProcess := TProcessUTF8.Create(nil);
   AProcess.CommandLine :=s1 + ' ' +s2;
   if opWaitFor then
     AProcess.Options := AProcess.Options + [poWaitOnExit];
   try
   try
      AProcess.Execute;
      result:=Aprocess.ExitStatus=0;
   finally
      AProcess.Free;
   end;
   except
   end;
end;

function ShellExec(const s1:string; args:array of const; opWaitFor:boolean):boolean;
var
  i:integer;
  s2:string;
begin
  s2:='';
  for i:=0 to high(args) do
    with args[i] do
      case VType of
        VTInteger:   s2:=s2+' '+IntToStr(VInteger);
        VtExtended:  s2:=s2+' '+FloatToStr(VExtended^);
        VtInt64:     s2:=s2+' '+IntToStr(Vint64^);
        VtChar:      s2:=s2+' '+VChar;
        VtString:    s2:=s2+' '+{QuotedStr}(VString^);
        VtAnsiString:s2:=s2+' '+{QuotedStr}(string(VAnsiString));
      end;
  result:=ShellExecSub(s1,s2,opWaitFor)
end;

{****************}
{Pack$ and Unpack}
{****************}
function PackDbl_s(d:Double):AnsiString;
var
   s:string[8];
begin
   move(d,s[1],8);
   setlength(s,8);
   result:=s;
end;

function DWord_s(x:Dword):AnsiString;
var
   s:string[4];
begin
   move(x,s[1],4);
   setlength(s,4);
   result:=s;
end;

function Word_s(x:DWord):AnsiString;
var
   s:string[2];
begin
   move(x,s[1],2);
   setlength(s,2);
   result:=s;
end;

function Byte_s(x:DWord):ansistring;
var
   s:string[1];
begin
   move(x,s[1],1);
   setlength(s,1);
   result:=s;
end;

function DWord_s(x:double):AnsiString;
var
   d:DWord;
   s:string[4];
begin
   d:=Trunc(x);
   move(d,s[1],4);
   setlength(s,4);
   result:=s;
end;

function Word_s(x:double):AnsiString;
var
   w:word;
   s:string[2];
begin
   w:=Trunc(x);
   move(w,s[1],2);
   setlength(s,2);
   result:=s;
end;

function Byte_s(x:double):ansistring;
var
   b:byte;
   s:string[1];
begin
   b:=Trunc(x);
   move(b,s[1],1);
   setlength(s,1);
   result:=s;
end;

function UnPackDbl(const s:string):double;
var
   d:double;
begin
   move(s[1],d,8);
   result:=d;
end;



{*************}
{GOSUB～RETURN}
{*************}

constructor TGosubStack.create(ssize:integer);
begin
  inherited create;
  size:=ssize;
  Getmem(a,size*SizeOf(integer));
end;

destructor TGosubStack.destroy;
begin
  freemem(a,Size*SizeOf(integer));
  inherited destroy;
end;

procedure TGosubStack.push(i:integer);
begin
  if p>=size then SetExceptionWith('GOSUB Stack overflow',GosubStackOverflow);
  a^[p]:=i;
  inc(p);
end;

function TGosubStack.pop:integer;
begin
  if p=0 then SetException(10002);
  dec(p);
  result:=a^[p];
end;

 procedure ErrMessage(E:Exception);
var
   s:Ansistring;
begin
  s:= EXMess(E,excode);
  MessageDlg(s, mtError, [mbOK], 0);
  // Clipboard.AsText:=s;
end;











initialization
  GosubStack:=TGosubStack.create(128);

finalization
  GosubStack.free;
end.

