svn/view/baslib.pas

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


interface
uses
  Classes, SysUtils,
  base,base2,textfile,arrays, mathc;

 function FloatVal( const s:ansistring):double;

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);
     //function pchannel(chn:integer):PtTextDevice;          overload;
     //function pchannel(chn:double) :PtTextDevice;          overload;
     //function pchannel(chn:Complex):PtTextDevice;          overload;
  end;
// プログラム単位はTChannelList形の変数ChannelListを持つ。
// （経路番号式を参照する文を持つときに限る。）
// プログラム単位はtry～finallyでchannelListを解放する。


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


type
  TStdIO = class(TTextDevice)

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

PROCEDURE PRINT(args:array of const);


{*****************}
{Numeric functions}
{*****************}
const
  DefaultExcode=$03EA0BBD;   // 1002 3005
var
  excode:LongWord=DefaultExcode;

 function SGN(const x:double):double;inline;       overload;
 function TAN(const x:extended):extended;inline;   overload;
 function COT(const x:extended):extended;inline;   overload;
 function SEC(const x:extended):extended;inline;   overload;
 function CSC(const x:extended):extended;inline;   overload;
 function ATN(const x:extended):extended;inline;   overload;
 function ACOS(const x:extended):extended;inline;  overload;
 function ASIN(const x:extended):extended;inline;  overload;
 function TANDEG(const x:extended):extended;       overload;
 function COTDEG(const x:extended):extended;       overload;
 function SECDEG(const x:extended):extended;inline;overload;
 function CSCDEG(const x:extended):extended;inline;overload;
 function ATNDEG(const x:extended):extended;inline;overload;
 function ACOSDEG(const x:extended):extended;inline;overload;
 function ASINDEG(const x:extended):extended;inline;overload;
 function ANGLE(const x,y:extended):extended;inline;overload;
 function ANGLEDEG(const x,y:extended):extended;inline;overload;
 function COSH(const x:extended):extended;inline;  overload;
 function SINH(const x:extended):extended;inline;  overload;
 function SQRT(const x:extended):extended;inline;  overload;
 function EXP(const x:extended):extended; inline;  overload;
 function LOG(const x:extended):extended;inline;   overload;
 function LOG2(const x:extended):extended;inline;  overload;
 function LOG10(const x:extended):extended;inline; overload;
 function Power(const x,y:extended):extended;inline; overload;
 function EPS(x:double):double;inline;             overload;
 function BINT( x:double):double;inline;           overload;
 function BCEIL(x:double):double;inline;           overload;
 function BMOD( x,y:double):double;inline;         overload;
 function REMAINDER( x,y:double):double;inline;    overload;
 function ROUND( x:double):double; overload;inline;overload;
 function ROUND( x,y:double):double; overload;     overload;
 function TRUNCATE(  x,y:double):double;inline;    overload;
 function BMIN(const x,y:double):double;inline;    overload;
 function BMAX(const x,y:double):double;inline;    overload;


 function PERM( n,r:double):double;                overload;
 function COMB( n,r:double):double;                overload;
 function FACT(const 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 BreakPr(s:Ansistring);
procedure Wait(n:extended); overload;
procedure ShowMess(const s:string);
procedure FileDelete(const s:string);
procedure  FileGetName(const s:string; svar:TStrVar; aux:integer);
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;

{Initialize}

procedure init(TextMode,GraphMode,UseCharInput:boolean; BMPSize1:TypBMPsize; VirtualStackSize:Cardinal);
procedure finish;

implementation
uses Forms,Dialogs,Controls,math,Process,FileUtil,LCLProc, lclintf,
     vstack,arithmet,float,math2sub,format,charinp,basinit,sconsts,
     paintfrm,graphsys,textfrm;

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)
     {and DecideRecSize(rsize.evalS)}  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);
  ttext:=channel(chn);
  if ttext<>nil then
     begin
       ttext.close;
       ttext.free;
     end
  else
     setexception(7004);
  if chn<count then
     if (objects[chn] is TDeviceRef) then
        with TDeviceRef(objects[chn]) do owner.objects[index]:=nil
     else
        objects[chn]:=nil;
  ttext:=nil;
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);
begin
   inherited create;
   owner:=CL1;
   index:=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;

{
function TChannelList.pchannel(chn:integer):PtTextDevice;
begin
   // ???
end;

function TChannelList.pchannel(chn:double):PtTextDevice;
begin
  result:=pchannel(LongintRound(chn))
end;


function TChannelList.pchannel(chn:Complex):PtTextDevice;          overload;
begin
  result:=pchannel(testreal(chn));
end;
}

{*****************}
{Numeric functions}
{*****************}
function SGN(const x:double):double; inline;
begin
    result:=sign(x)
end;

function TAN(const x:extended):extended;inline;
begin
    excode:=$03EB03EB;   // 1003  1003
    result:=math.tan(x);
    excode:=DefaultExcode
end;

function COT(const x:extended):extended; inline;
var
    s,c:extended;
begin
    excode:=$03EB03EB;   // 1003  1003
    //{$IFDEF Windows}
    result:=math.cot(x);
    //{$ELSE}
    //{$MAXFPUREGISTERS 0}
    //s:=system.sin(x);
    //c:=system.cos(x);
    //result:=c / s ;
    //{$ENDIF}
    excode:=DefaultExcode
end;

function SEC(const x:extended):extended;inline;
begin
    excode:=$03EB03EB;   // 1003  1003
    result:=math.sec(x);
    excode:=DefaultExcode
end;

function CSC(const x:extended):extended;inline;
begin
    excode:=$03EB03EB;   // 1003  1003
    result:=math.csc(x);
    excode:=DefaultExcode
end;

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

 function ACOS(const x:extended):extended;inline;
 begin
      excode:=$03EB0BBF;   // 1003 3007
      result:=math2sub.acos(x);
      excode:=DefaultExcode
 end;

 function ASIN(const x:extended):extended;inline;
 begin
      excode:=$03EB0BBF;   // 1003 3007
      result:=math2sub.asin(x);
      excode:=DefaultExcode
 end;

function TANDEG(const x:extended):extended;
var
  y:extended;
begin
    excode:=$03EB03EB;   // 1003  1003
    y:=math2sub.cosdeg(x);
    if y=0 then
       setexception(1003)
    else
       result:=math2sub.sindeg(x)/y;
    excode:=DefaultExcode
end;

function COTDEG(const x:extended):extended;
var
  y:extended;
begin
    excode:=$03EB03EB;   // 1003  1003
    y:=math2sub.sindeg(x);
    if y=0 then
       setexception(1003)
    else
       result:=math2sub.cosdeg(x)/y;
    excode:=DefaultExcode
end;

 function SECDEG(const x:extended):extended;inline;
begin
    excode:=$03EB03EB;   // 1003  1003
    result:=math2sub.secdeg(x);
    excode:=DefaultExcode
end;

function CSCDEG(const x:extended):extended;inline;
begin
    excode:=$03EB03EB;   // 1003  1003
    result:=math2sub.cscdeg(x);
    excode:=DefaultExcode
end;


function ACOSDEG(const x:extended):extended;inline;
begin
    result:= acos(x)*degree
end;

function ASINDEG(const x:extended):extended;inline;
begin
    result:= asin(x)*degree
end;

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

function ANGLE(const x,y:extended):extended;inline;
begin
   if (x=0) and (y=0) then
      setexception(3008)
   else
      result:=ArcTan2(y,x)
end;

function ANGLEdeg(const x,y:extended):extended;inline;
begin
   result:=ANGLE(x,y)*degree
end;

function COSH(const x:extended):extended;inline;
begin
    excode:=$03EB0000;   // 1003     0
    result:=math2sub.cosh(x);
    excode:=DefaultExcode
end;

function SINH(const x:extended):extended;inline;
begin
    excode:=$03EB0000;   // 1003     0
    result:=math2sub.sinh(x);
    excode:=DefaultExcode
end;


function SQRT(const x:extended):extended;inline;
begin
 if x<0 then setexception(3005);
 result:=system.SQRT(x)
end;

var LogMaxExtended:extended;
function EXP(const x:extended):extended; inline;
begin
    if x>=LogMaxExtended then setexception(1003);
    //excode:=$03EB03EB;   // 1003    1003
    result:=system.exp(x);
    //excode:=DefaultExcode;
 end;


function LOG(const x:extended):extended;inline;
begin
    if x<=0 then setexception(3004);
    //excode:=$03EB0BBC;   // 1003 3004
    result:=ln(x);
    //excode:=DefaultExcode
end;

function LOG2(const x:extended):extended;inline;
begin
    if x<=0 then setexception(3004);
    //excode:=$03EB0BBC;   // 1003 3004
    result:=Math.log2(x);
    //excode:=DefaultExcode
end;

function LOG10(const x:extended):extended;inline;
begin
    if x<=0 then setexception(3004);
    //excode:=$03EB0BBC;   // 1003 3004
    result:=Math.log10(x);
    //excode:=DefaultExcode
end;


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


function BINT(x:double):double; inline;
begin
   float.FFloor(x);
   result:=x;
end;

function BCEIL(x:double):double;inline;
begin
   float.FCEIL(x);
   result:=x;
end;


function BMOD(x,y:double):double;inline;
begin
   excode:=$03EB0BBE;   // 1003 3006
   float.BasicMod(x,y);
   result:=x;
   excode:=DefaultExcode
end;

function REMAINDER(x,y:double):double;inline;
begin
   excode:=$03EB0BBE;   // 1003 3006
   result:=x-y*system.int(x/y);
   excode:=DefaultExcode
end;

function Power(const x,y:extended):extended;inline;
begin
   if x>0 then
      begin
      {$IFNDEF Windows}
      excode:=$03EA03EA;   // 1002    1002
      {$ENDIF}
      result:=math.power(x,y);
      {$IFNDEF Windows}
      excode:=DefaultExcode;
      {$ENDIF}
      end
   else if x=0 then
     if y=0 then
        result:=1
     else if y<0 then
        setexception(3003)
     else
        result:=0
   else { x<0 }
      if system.int(y)=y then
         result:=math.power(x,y)
      else
         setexception(3002)
end;


function power10(i:integer):extended;
var
   x,y:extended;
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;

procedure fround2(var x,n:double);
var
   e:extended;
begin
     e:=power10(LongIntRound(n));
     x:=x*e+0.5;
     FFLOOR(x);
     x:=x/e;
end;

procedure ftruncate(var x,n:double);
var
   e:extended;
begin
     e:=power10(LongIntRound(n));
     x:=x*e;
     x:=int(x);
     x:=x/e;
end;

function ROUND(x:double):double;overload; inline;
begin
   float.FROUND(x);
   result:=x
end;

function ROUND(x,y:double):double;overload; inline;
begin
   fround2(x,y);
   result:=x
end;

function TRUNCATE(x,y:double):double; inline;
begin
   ftruncate(x,y);
   result:=x
end;

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

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


function PERM( n,r:double):double;
var
   i,k:longint;
begin
   k:=LongIntRound(r);
   if k<0 then
      begin
         result:=0;
         invalidoperation
      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:longint;
   m:double;
   x:extended;
begin
   FROUND(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(const x:double):double;
begin
   result:=PERM(LongIntRound(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 LongIntRound(a)
end;

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

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

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

function BitAND(a:double;b:int64):int64;   overload;
begin
result:=LongIntRound(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:=LongIntRound(a) or LongIntRound(b)
end;

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

function BitOR(a:double;b:int64):int64;   overload;
begin
result:=LongIntRound(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:=LongIntRound(a) xor LongIntRound(b)
end;

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

function BitXOR(a:double;b:int64):int64;   overload;
begin
result:=LongIntRound(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;
begin
   try
       Nval(s,n);
       checkrangedecimal(n,1004);
    except
       on E:EExtype do
       begin
          if E.extype>=3000 then
             base.extype:=4001;
          if (E.extype>=1000) and (E.extype <1004) then
             base.extype:=1004;
          if Base.extype>0 then
          raise EExtype.create(base.extype)
       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:longint;
   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;
{***************}
{EXTYPE function}
{***************}

function EXTYPE(const E:Exception; ExcodeRec:LongWord):Integer;
begin
   if E is EOverflow then
        result:= excodeRec div $10000
   else if ( E is EdivByZero) or (E is EZeroDivide) then
        if excodeRec=defaultexcode then
           result:=3001
        else
           result:=excodeRec mod $10000
   else if E is EMathError then          // 算術演算の誤り
        result:=excodeRec mod $10000      // 3004 LOG, 3005 SQR, 3006 MOD, 3007 ACOS ASIN
   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;
        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
     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;

procedure BreakPr(s:Ansistring);
begin
   if MessageDlg(s, mtCustom, [mbOk,MbAbort], 230)=MrAbort then
      raise EStop.create;
end;

procedure Wait(n:extended);
var
   svCtrlBreakHit:boolean;
   finish:extended;
begin
   svCtrlBreakHit:=CtrlBreakHit;
   CtrlBreakHit:=false;
   try
      finish:=Date+time+n/(24*3600);
   except
     setexception(12004);
   end;
   repeat
       sleep(10);IdleImmediately;
   until (Date+time-Finish>=0) or CtrlBreakHit;
   CtrlBreakHit:=CtrlBreakHit or SvCtrlBreakHit;
end;

procedure ShowMess(const s:string);
begin
   if MessageDlg(s, mtCustom, [mbOk], 800)<>mrOk then
    CtrlBreakHit:=true;
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
  Application.ProcessMessages;
  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;

procedure  FileGetName(const s:string; svar:TStrVar; aux:integer);
var
  dlg:TOpenDialog;
begin
  if aux=2 then
     dlg:=TSaveDialog.create(nil)
  else
     dlg:=TOpenDialog.create(nil);
  with svar do
    with dlg do
       begin
         if aux=1 then options:=[ofPathMustExist,ofFileMustExist];
         options:=options + [ofOldStyleDialog];  //Lazarus 0.9.28.2 では必須
         if s='' then
          begin
            DefaultExt:='txt' ;
            Filter:=s_TextFile+'|*.TXT;*.kw*;*.log;*'+BasExt+';*'+LibExt+'|'
                 +s_BitMap  +'|*.bmp'+ '|'
                 +s_AllFile +'|*.*';
           end
          else
           begin
            if pos('|',s)=0 then
             begin
               DefaultExt:=s ;
               Filter:=s + s_FILE + '|' + '*.' +s
             end
            else
             begin
               Filter:=s
             end;
           end;
          execute;
          str:=FileName;
          free;
       end;
   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(Utf8ToSys(s),0,Rec)=0 then
              begin
               if a.Size<=i then SetException(5001);
               with a do elements^[i]:=SysToUtf8(Rec.Name);
               inc(i);
               while FindNext(Rec)=0 do
                 begin
                   if a.size<=i then SetException(5001);
                   with a do elements^[i]:=SysToUtf8(Rec.Name);
                   inc(i);
                 end;
              end;
          finally
             FindClose(Rec);
          end;
          a.Resize(i);
       end;
end;

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

function Files(const s:string):integer;
var
   Rec:TSearchRec;
begin
    result:=0;
    try
      if FindFirst(Utf8ToSys(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(UTF8ToSys(s))
   except
     on E:EInOutError do
       begin
         if E.ErrorCode=21 then
            exty:=9002
         else
            exty:=9008;
         setexception(exty);
       end;
   end;
end;

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

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

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

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

function AskCharacterPending(ch:TTextDevice):integer;far;
begin
     IdleImmediately;
     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;
            if UseCharInput and (ch=console) then
                  charinput.show;
         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: TProcess;
begin
   result:=false;
   AProcess := TProcess.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(Utf8ToSys(s1),UTF8ToSys(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;

{**********}
{Initialize}
{**********}

procedure init(TextMode,GraphMode,UseCharInput:boolean; BMPSize1:TypBMPsize; VirtualStackSize:Cardinal);
begin
   InitSeed;                           //2010/07/18
   InitVirtualStack(VirtualStackSize);

   if GraphMode then
      CreateFormsG
    else
      CreateFormsT;

   base.extype:=0;
   base.BMPSize:=BMPSize1;
   //CurrentOperation:=nil;
   statusmes.clear;

  LocalPrinter:=TLocalPrinter.create;

  console:=TConsole.create ;
  //PConsole.ttext:=console;           //2008.11.3
  if textmode then
     textForm.Visible:=true;

  PaintForm.Caption:=ChangeFileExt(TextForm.Caption,'.bmp');
  PaintForm.initial;
  InitGraphics;
  if graphmode {and  (nextGraphmode=ScreenBitmapMode)} then
       begin
          PaintForm.Visible:=true;
          PaintForm.WindowState:=wsNormal;
          PaintForm.BringToFront;
       end
   else
       PaintForm.Visible:=false;


  if UseCharInput then
    begin
       charinput.init;
       //CharInput.Show
    end;

   Set8087CW(controlWORD);
   asm
      mov initialESP,esp
   end;
end;

procedure finish;
begin
  MyGraphSys.finish;
  console.free;
  LocalPrinter.free;
end;

initialization
  GosubStack:=TGosubStack.create(128);
  LogMaxExtended:=system.ln(MaxExtended);
finalization
  GosubStack.free;
end.
