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

uses
  Classes, SysUtils, math, Forms,
  base;


function SysIntRound(x:double):NativeInt;
function LongIntRound(x:double):LongInt;
//function floor(x:double):NativeInt;
procedure  FEPS  (var x:double);

 type
    EControlException=class(Exception)
        constructor create;
    end  ;

    ERetry=class(EControlException);
    EContinue=class(EControlException);
    //EExitHandler=class(EControlException);

    EStop=class(EControlException);
    EExitFunction=class(EControlException);
    EExitSub=class(EControlException);
    EExitPicture=class(EControlException);
    EExitDo=class(EControlException);
    EExitFor=class(EControlException);
    EExitSeize=class(EControlException);

type
    PAnsiString=^AnsiString;

    function NumericVariable(var x:double; a:double):PDouble;  overload;
    function StringVariable(var s:Ansistring; const t:ansistring):PAnsiString;

type
   StringArray=Array[0..1023] of AnsiString;
   PStringArray=^StringArray;

type
   IntArray=array [0..255] of Integer;
   PIntArray=^IntArray;
type
  PExtended=^extended;
  ExtendedArray=array[0..65535] of extended;
  PExtendedArray=^ExtendedArray;



type
   TNval=class(Tobject)
      value:double;
      constructor create(x:double);
   end;

   TSVal=class(TObject)
      value:Ansistring;
      constructor create(const s:ansistring);
      destructor destroy;override;
   end;

   TValList=class(TList)
      function itself:TValList;
      procedure addval(x:double);overload;
      procedure addval(s:ansistring);overload;
      destructor destroy;override;
   end;


 var
   AppName:Ansistring='';
   GraphMode:boolean=false;
   TextMode:boolean=false;
   KeepGraphic:boolean=false;
   KeepText:boolean=false;
   UseCharInput:boolean=false;
   //InitialPrecisionMode0:tpPrecision=PrecisionNative;
   //InitialPrecisionMode:tpPrecision=PrecisionNative;
   //PrecisionMode :tpPrecision=PrecisionNative;
   //initialOptionBase:byte=1;
   //initialAngleDegrees:boolean=false;
   //initialCharacterByte0:boolean=true;
   //initialCharacterByte:boolean=true;
   JISFormat:boolean=false;
   JISSetWindow:boolean=true;
   //JISDim:boolean=false;
   //JISDef:boolean=false;
   //ForNextBroadOwn:boolean=false;
   //UseTranscendentalFunction:boolean=false;
   //signiwidthMore:boolean=false;
   //MinimalBasic:boolean=false;
   PermitMicrosoft:boolean=false;
   SystemStackSize :sizeUINT=$1000000{16MB};
   FirstThreadPriority:TThreadPriority=tpNormal;
   //VirtualStackSize:sizeUINT= $200000{ 2MB};
   signiwidth0:integer=15;

   OldFileDialog:boolean=false;
 var
   ExecutingNow:boolean=false;
   StopRequest:boolean=false;


type  TMyStruct=object
      Valid:boolean;
      //ThID:DWORD;
    procedure waitforValid;
    procedure waitforReady;
    procedure waitforValidTimeOut(t:double);
    procedure waitforReadyTimeOut(t:double);
   private
    //procedure setValid(b:LongBool);
    //function  getValid:LongBool;
    //function  Locked:boolean;
    //procedure Lock;
    //procedure UnLock;
   public
    //property valid:LongBool read getValid write setValid;
end;

//type PMyStruct=^TMyStruct;
//Procedure Seize(A: Array of PMyStruct);
//Procedure EndSeize(A: Array of PMyStruct);

//function Copy(S: String;  Index: SizeInt; Count: SizeInt):string; //debug
//function Concat(const s1,s2:string):string;                       //debug

implementation

function Copy(S: String;  Index: SizeInt; Count: SizeInt):string; //debug
var
  t:string;
  i:sizeint;
  c:sizeint;
begin
  c:=length(s)-Index+1;
  if c>Count then c:=Count;
  SetLength(t,c);
  for i:=1 to c do
     t[i]:=s[Index+i-1];
  result:=t;
  t:='';
end;

function Concat(const s1,s2:string):string;                       //debug
var
  t:string;
  i,c1,c2:SizeInt;
begin
  c1:=length(s1); c2:=length(s2);
  setlength(t,c1+c2);
  for i:=1 to c1 do t[i]:=s1[i];
  for i:=1 to c2 do t[c1+i]:=s2[i];
  concat:=t;
  t:='';
end;

{$IFDEF CPU64}
{$DEFINE UseAltLongIntRound}
{$ENDIF}

{$IFDEF UseAltLongIntRound}
function LongIntRound(x:double):LongInt;
var
  v:LongInt;
begin
asm
    FLD x
    FISTP v
end;
  result:=v
end;
{$ELSE}
function LongIntRound(x:double):LongInt;assembler;
asm
    PUSH EAX
    FLD x
    FISTP DWORD PTR [ESP]
    WAIT
    POP EAX
end;
{$ENDIF}

{$IFDEF CPU32}
function SysIntRound(x:double):NativeInt;inline;
begin
   result:=LongIntRound(x)
end;
{$ELSE}
function SysIntRound(x:double):NativeInt;inline;
begin
 result:=System.Round(x);
end;
{$ENDIF}

var
   number2:array[0..3]of word=($ffff,$ffff,$ffff,$7fef);
var
   number0:double absolute number2;

procedure  FEPS(var x:double);
//const
//   number2:array[0..3]of word=($ffff,$ffff,$ffff,$7fef);
//var
//   number0:double absolute number2;
var
   e:word;
begin
    number0:=x;
    e:=(number2[3] and $7ff0) div $10;
    if e>0 then
       begin
         number2[3]:=e*$10 ;
         number2[2]:=0;
         number2[1]:=0;
         number2[0]:=0;
         x:=number0/4503599627370496.
       end
    else
       begin
         number2[3]:=0;
         number2[2]:=0;
         number2[1]:=0;
         number2[0]:=1;
         x:=number0
       end;
end;

constructor EControlException.create;
begin
   inherited create('')
end;



function NumericVariable(var x:double; a:double):PDouble; inline;  overload;
begin
   x:=a;
   result:=@x
end;

function StringVariable(var s:Ansistring; const t:ansistring):PAnsiString;inline;
begin
   s:=t;
   result:=@s
end;


{********}
{TValList}
{********}

constructor TNval.create(x:double);
begin
   inherited create;
   value:=x
end;

constructor TSVal.create(const s:ansistring);
begin
   inherited create;
   value:=s;
end;

destructor TSVal.destroy;
begin
   value:='';
   inherited destroy;
end;

function TValList.itself:TValList;
begin
   result:=self
end;


procedure TValList.addval(x:double);overload;
begin
    add(TNVal.create(x))
end;

procedure TValList.addval(s:ansistring);overload;
begin
   add(TSVal.create(s))
end;

destructor TValList.destroy;
var
  i:integer;
begin
  for i:=0 to count-1 do
     Tobject(items[i]).free ;
  inherited destroy;
end;

procedure TMyStruct.waitforValid;
begin
  while not valid do (TThread.CurrentThread).Yield;
end;
procedure TMyStruct.waitforReady;
begin
  while valid do (TThread.CurrentThread).Yield;
end;

procedure TMyStruct.waitforValidTimeOut(t:double);
var
  t0,tt:QWord;
begin
  t0:=gettickcount64;
  tt:=System.Round(t*1000);
  while not valid and(QWord(getTickCount64-t0)<tt) do
           (TThread.CurrentThread).Yield;
  if valid=false then setexception(12103);
end;

procedure TMyStruct.waitforReadyTimeOut(t:double);
var
  t0,tt:QWord;
begin
  t0:=gettickcount64;
  tt:=System.Round(t*1000);
  while  valid and (QWord(getTickCount64-t0)<tt) do
        (TThread.CurrentThread).Yield;
  if valid then setexception(12103);
end;

initialization

finalization

end.


