unit variabl;
{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}

(***************************************)
(* Copyright (C) 2013, SHIRAISHI Kazuo *)
(***************************************)

{$X+}

{********}
interface
{********}
uses classes, SysUtils,LCLProc,
     objlist,base,base0,arithmet,mathc;




type
    TMyObject=class(TObject)
         function OverflowErCode:integer;virtual;
         function InvalidErCode:integer;virtual;
         function OpName:string;virtual;
    end;

type
    TSubstanceList=class(TFPList)
         procedure merge(alist:TSubstanceList);
   end;
function MergedList(list1, list2:TSubstanceList):TSubstanceList;


type
    TArticle=class(TMyObject)
         function Code:AnsiString;virtual;abstract;
    end;

   TPrincipal=Class(TArticle)
         procedure evalN(var n:number);virtual;abstract;
         function evalX:extended;virtual;
         function evalF:double;virtual;abstract;            //abstractに変更2010.8.29
         procedure evalC(var c:complex);virtual;
         function  evalLongInt:LongInt;virtual;abstract;  //桁あふれはEInvalidOp
         function evalS:ansistring;virtual;abstract;
         function kind:char;virtual;abstract;
         function isConstant:boolean;virtual;
        //code gen
         function QueryInteger:TSubstanceList;virtual;   // double型となるための条件。nilのときdouble不可。
         function QueryDouble:TSubstanceList;virtual;   // double型となるための条件。nilのときdouble不可。
    end;


   TVariable=class(TPrincipal)
   end;

   TPointingVariable=class(TVariable)
   end;

   TidRec=class;
   TSubstance=class;

   ObjectProcedure = procedure of Object;




{******}
{TIdRec}
{******}

   TIdTag=(undeterm,intern,extern,IdShare,IdPublic);
   TIdRec = class(TObject)
                  subs     :TSubstance;
                  ModuleName:AnsiString;
                  name     :AnsiString;
                  prm      :boolean;   { parameter }
                  dim      :shortint;  { -1 for function, 0 for simple var}
                  kindchar :char ;     {'n' for numeric ,'s' for string, 'c' for channel}
                  tag      :TIdTag;
                  lbound,ubound:Array4;   {default dimension}
                  maxlen   :integer;
     constructor InitSimple(const nam:AnsiString; t:TIdTag; maxlen1:integer);
     constructor InitpSimple(const nam:AnsiString);
     constructor InitF(const mnam,nam:AnsiString; t:TIdTag);
     constructor InitpF(const nam:AnsiString; maxlen1:integer);
     constructor InitA(const nam:AnsiString; d:shortint; t:TIdTag);
     constructor InitpA(const nam:AnsiString; d:shortint);
     constructor InitArray(const nam:AnsiString; d:shortint;const  lb,ub:Array4; t:TIdTag; m:integer);
     constructor InitpArray(const nam:AnsiString; d:shortint;const  lb,ub:Array4);
     constructor InitCh(const mnam,nam:AnsiString; t:TIdTag);
     constructor InitpCh(const nam:AnsiString);
     constructor InitSimpleExt(const mnam,nam:AnsiString);
     constructor InitAExt(const mnam,nam:AnsiString; d:shortint);
     destructor destroy;override;

     procedure setdim(const lb,ub:Array4);
     procedure setdim1(d:shortint);
     procedure InitComplete(arith:tpPrecision);

     //For Code Generate
     function Literal:Ansistring;
     function LiteralWithType(ini:boolean):Ansistring;
   private
      iQueryDouble:TSubstanceList;
      iQueryInteger:TSubstanceList;
      procedure Init(const nam:AnsiString; p:boolean; d:shortint; t:TIdTag);
  end;



   TSubstance=class(TPointingVariable)
        idr:   TIdrec;
       constructor create(idr0:TIdRec; kindchar:char; dim:shortint; prm:boolean);
       function kind:char;override;
       function isConstant:boolean;override;
       procedure freeInstance;override;
       procedure FreeAnyway;
       function Code:AnsiString;override;
        procedure AddQueryInteger(list:TSubstancelist);
   end;

  TNVari=class(Tsubstance)
  end;

  TFVari=class(Tsubstance)
         //UsedAsASubscript:boolean;
       constructor create(idr0:TIdRec; kindchar:char; dim:shortint; prm:boolean);
       function QueryInteger:TSubstanceList;override;   //items[0]=selfであるTSubstanceList
     private
       function ApprovedInteger(n:integer):boolean;
   end;

   TorthoFVari=class(TFVari)
   end;

   TCVari=class(TFVari)
       constructor create(idr0:TIdRec; kindchar:char; dim:shortint; prm:boolean);
       function QueryDouble:TSubstanceList;override;   //items[0]=selfであるTSubstanceList
       procedure AddQueryDouble(list:TSubstancelist);
     private
       function ApprovedDouble(n:integer):boolean;
   end;

   TSVari=class(Tsubstance)
   end;

   TNAVari=class(TNVari)
   end;

   TFAVari=class(TFVari)
   end;

   TCAVari=class(TCVari)
   end;

   TSAVari=class(TSVari)
   end;

   TChVari=class(Tsubstance)
   end;




var OnIdTableFree:Boolean=false;




{============}
implementation
{============}
uses
     myutils,struct,express,sconsts,texthand,helpctex;

function compare(p1,p2:pointer):integer;
begin
 result:=NativeInt(p2)-NativeInt(p1)
end;

procedure TSubstanceList.merge(alist:TSubstanceList); // alistを併合し，alistを消去する。
var
    i:integer;
begin
  if self=nil then
     alist.free
  else
    begin
     addlist(alist);
     alist.free;
     sort(compare);
     for i:=0 to count-2 do
        if items[i]=items[i+1] then items[i]:=nil;
     pack;
    end;
end;

function MergedList(list1, list2:TSubstanceList):TSubstanceList;
begin
    if (list1<>nil) and (list2<>nil) then
    begin
       list1.merge(list2);
       result:=list1
    end
    else
    begin
       list1.free;
       list2.free;
       result:=nil;
    end;
end;

constructor TFVari.create(idr0:TIdRec; kindchar:char; dim:shortint; prm:boolean);
begin
    inherited create(idr0, kindchar, dim, prm);
    with idr do
      if prm then
         iQueryInteger:=nil                       // 引数はinteger不可
      else
         iQueryInteger:=TSubstanceList.create;    // 通常の変数はIntegerになり得る
end;

constructor TCVari.create(idr0:TIdRec; kindchar:char; dim:shortint; prm:boolean);
begin
    inherited create(idr0, kindchar, dim, prm);
    with idr do
      if prm then
         iQueryDouble:=nil                       // 引数はcomplexと仮定
      else
         iQueryDouble:=TSubstanceList.create;    // 通常の変数はDouble適格と仮定する
end;

function TFvari.QueryInteger:TSubstanceList;
begin
  result:=TSubstanceList.create;
  result.add(self)
end;

function TCvari.QueryDouble:TSubstanceList;
begin
  result:=TSubstanceList.create;
  result.add(self)
end;


procedure TSubstance.AddQueryInteger(list:TSubstancelist);
begin
   idr.iQueryInteger:=mergedList(idr.iQueryInteger,list)
end;

procedure TCVari.AddQueryDouble(list:TSubstancelist);
begin
   idr.iQueryDouble:=mergedList(idr.iQueryDouble,list)
end;


function TFVari.ApprovedInteger(n:integer):boolean;
var
    i:integer;
    subs:TFVari;
begin
    result:=false;
    //if OptimizeOnlyWhenSubscripts then
    //   if not UsedAsASubscript then exit;   //添字として用いられている場合に限定する

    if n=16 then//循環参照に落ちいったらIntegerと認定
       result:=true
    else if idr.iQueryInteger=nil then
       result:=false
    else
      begin
       result:=true;
       with idr.iQueryInteger do
         for i:=0 to count-1 do
             begin
                subs:=TObject(items[i]) as TFVari;
                if (subs<>self) and (subs<>nil) then
                  if subs.idr.iQueryInteger=nil then
                     begin
                       idr.iQueryInteger.free;
                       idr.iQueryInteger:=nil;
                       result:=false;
                       exit
                     end
                  else
                     begin
                        if subs.ApprovedInteger(n+1) then
                        else
                           begin
                               result:=false;
                               exit
                           end;
                     end;
             end;

      end;
end;


function TCVari.ApprovedDouble(n:integer):boolean;
var
    i:integer;
    subs:TCVari;
begin
    if n=16 then//循環参照に落ちいったらDoubleと認定
       result:=true
    else if idr.iQueryDouble=nil then
       result:=false
    else
      begin
       result:=true;
       with idr.iQueryDouble do
         for i:=0 to count-1 do
             begin
                subs:=TObject(items[i]) as TCVari;
                if (subs<>self) and (subs<>nil) then
                  if subs.idr.iQueryDouble=nil then
                     begin
                       idr.iQueryDouble.free;
                       idr.iQueryDouble:=nil;
                       result:=false;
                       exit
                     end
                  else
                     begin
                        if subs.ApprovedDouble(n+1) then
                        else
                           begin
                               result:=false;
                               exit
                           end;
                     end;
             end;

      end;
end;




{******}
{TIdRec}
{******}

procedure TIdRec.Init(const nam:AnsiString; p:boolean; d:shortint; t:TIdTag);
begin
     inherited create;
     ModuleName:='';
     maxlen:=maxint;
     name     :=nam;
     prm      :=p;
     dim      :=d;
     tag      :=t;

     if dim>4 then setErr(s_DimmensionError,IDH_Array); //配列次元最大値を4とする

    if (length(name)>0) and (name[1]='#') then
           kindchar:='c'
     else if (length(name)>0) and (name[length(name)]='$') then
          kindchar:='s'
     else
          kindchar:='n';

     case KindChar of
     'c': subs:=TchVari.create(self,KindChar,dim,prm);
     's': if dim<=0 then
            subs:=TSVari.create(self,KindChar,dim,prm)
          else
            subs:=TSAVari.create(self,KindChar,dim,prm);
     else
          begin
             subs:=TSubstance.create(self,kindchar,dim,prm);
             if pass=2 then initcomplete(programunit.arithmetic);
          end;
     end;
end;

constructor TSubstance.create(idr0:TIdRec;  kindchar:char; dim:shortint; prm:boolean);
begin
  inherited create;
  idr:=idr0;
  if (dim<0) xor (prm) then
     //GetVar:=GetNone
  else
     //GetVar:=getVar1;

end;

procedure TIdRec.InitComplete(arith:tpPrecision);
begin
    if kindchar<>'n' then exit;
    subs.freeAnyway;
    case arith of

      PrecisionNormal:
        if dim<=0 then
           subs:=TNVari.create(self,KindChar,dim,prm)
        else
           subs:=TNAVari.create(self,KindChar,dim,prm);
      PrecisionNative:
        if dim<=0 then
           subs:=TFVari.create(self,KindChar,dim,prm)
        else
           subs:=TFAVari.create(self,KindChar,dim,prm);
      PrecisionComplex:
        if dim<=0 then
           subs:=TCVari.create(self,KindChar,dim,prm)
        else
           subs:=TCAVari.create(self,KindChar,dim,prm);
     end;
end;

constructor TIdRec.InitF(const mnam,nam:AnsiString; t:TidTag);
begin
   init(nam,false,-1,t);
   moduleName:=mnam;

end;

constructor TIdRec.InitpF(const nam:AnsiString; maxlen1:integer);
begin
   init(nam,true,-1,intern);
   maxlen:=maxlen1;

end;

constructor TIdRec.InitSimple(const nam:AnsiString; t:TIdTag; maxlen1:integer);
begin
   init(nam,false,0,t);
   maxlen:=maxlen1;

   ModuleName:=CurModule.name;  // 2009.8.20 for Code gen
end;

constructor TIdRec.InitpSimple(const nam:AnsiString);
begin
   init(nam,true,0,intern);
end;

constructor TIdRec.InitA(const nam:AnsiString; d:shortint; t:TIdTag);
begin
   init(nam,false,d,t);

   ModuleName:=CurModule.name;  // 2009.8.20 for Code gen
end;

constructor TIdRec.InitpA(const nam:AnsiString; d:shortint);
begin
     Init(nam,true ,d,intern)
end;


constructor TIdRec.InitArray(const nam:AnsiString; d:shortint;const lb,ub:Array4; t:TIdTag; m:integer);
begin
     Init(nam,false ,d,t) ;
     setdim(lb,ub);
     maxlen:=m;
   ModuleName:=CurModule.name;  // 2009.8.20 for Code gen
end;
constructor TIdRec.InitpArray(const nam:AnsiString; d:shortint;const lb,ub:Array4);
begin
     Init(nam,true ,d,intern) ;
     setdim(lb,ub)
end;

constructor TIdRec.InitCh(const mnam,nam:AnsiString; t:TIdTag);
begin
   initSimple(nam,t,maxint);
   ModuleName:=mnam
end;

constructor TIdRec.InitpCh(const nam:AnsiString);
begin
   initpSimple(nam);
end;

destructor TIdrec.destroy;
begin
   subs.Freeanyway;
   iQueryInteger.free;
   iQueryDouble.free;
   inherited destroy;
end;



constructor TIdRec.InitSimpleExt(const mnam,nam:AnsiString);
begin
    initSimple(nam,extern,maxlen);
    ModuleName:=mnam
end;

constructor TIdRec.InitAExt(const mnam,nam:AnsiString; d:shortint);
begin
   InitA(nam,d,extern);
   ModuleName:=mnam
end;


procedure TIdRec.setdim(const lb,ub:Array4);
begin
   lbound:=lb;
   ubound:=ub;
end;

procedure TIdRec.setdim1(d:shortint);
var
  lb,ub:Array4;
  i:integer;
begin
  dim:=d;
  for i:=1 to 4 do lb[i]:=programUnit.ArrayBase;
  for i:=1 to dim do ub[i]:=10;
  setdim(lb,ub);
end;

procedure TSubstance.freeInstance;
begin
   if OnIdTableFree then
      inherited FreeInstance;
end;

procedure TSubstance.FreeAnyway;
var
  sv:boolean;
begin
  sv:=OnIdtableFree;
  OnIdTableFree:=true;
  free;
  OnIdTableFree:=sv;
end;

function TSubstance.kind:char;
begin
   result:=idr.kindchar
end;

function TSubstance.isConstant:boolean;
begin
   result:=false
end;



{******}
{TArray}
{******}

function TPrincipal.evalX:extended;
begin
   result:=evalF
end;

procedure TPrincipal.evalC(var c:complex);
begin
   c.x:=evalX; c.y:=0.0;
end;

function TMyObject.OverflowErCode:integer;
begin
   result:=1002
end;

function TMyObject.InvalidErCode:integer;
begin
   result:=3000
end;

function TMyObject.OpName:string;
begin
  result:=''
end;




function TPrincipal.isConstant:boolean;
begin
   isConstant:=false
end;

function TPrincipal.QueryInteger:TSubstanceList;   // Integer型となるための条件。nilのときInteger不可。
begin
   result:=nil;
end;

function TPrincipal.QueryDouble:TSubstanceList;   // double型となるための条件。nilのときdouble不可。
begin
   result:=nil;
end;



function quoted(s:ansistring):ansistring;
var
   i:integer;
begin
    {"を二重にして""で括る}
     i:=1;
     while i<=length(s) do
     begin
        if s[i]='"' then
           begin
              insert('"',s,i) ;
              inc(i);
           end;
        inc(i)
     end;
     result:='"'+s+'"'
end;

function MyCharToByteIndex(const s:Ansistring; i:integer):integer;
var
  k:integer;
begin
  //k:=CharToByteIndex(s,i);
  {todo 1}k:=i; //assume single byte
  if (k=0) and (i>0) then k:=length(s)+1;
  result:=k
end;




{*********}
{TSvarList}
{*********}
function substring(const s:ansistring; i,j:integer; CharacterByte:boolean):Ansistring;
begin
   if CharacterByte then
        if i<=j then
           result:=copy(s,i,j-i+1)
        else
           result:=''
   else
   if i<=j then
      result:=Copy(s,i,j-i+1)
   else
      result:=''

end;




{**************}
{ Generate Code}
{**************}

function TIdRec.Literal:Ansistring;
var
  n:ansistring;
begin
 if prm and (dim<0) then
    result:='result'
 else
 begin
    n:=name;
    if tag in [idshare, idpublic] then      //ver. 0.9.5.9
       n:='_'+n;
    case kindchar of
      'n': result := '_'+n;

      's': result := 's_'+copy(n, 1,length(n)-1);

      'c': result := 'ch_'+copy(n, 2,length(n)-1);
    end;
 end;

 if (moduleName<>'')
    and (ModuleName<>CurModule.name) and not (prm and (dim<0){Funtion return value}) then
    result:='_'+ModuleName+'.'+Result;
end;

function TIdrec.LiteralWithType(ini:boolean):Ansistring;
begin
  case kindchar of
   'n':
      if subs is TCVari then
        case dim of
          0: if OptimizeInteger and TCVari(subs).ApprovedInteger(0) then
                if ini then result := literal + ':INT64=0'
                    else result := literal + ':INT64'
             else if OptimizeDouble and TCVari(subs).ApprovedDouble(0) then
                if ini then result := literal + ':double=0'
                    else result := literal + ':double'
             else
                if ini then result := literal + ':Complex=(x: 0.0; y: 0.0)'
                    else result := literal + ':Complex';
          1: result := literal + ':TArray1C';
          2: result := literal + ':TArray2C';
          3: result := literal + ':TArray3C';
          4: result := literal + ':TArray4C';
          else ;
        end
      else if subs is TFVari then
        case dim of
          0:  if OptimizeInteger and TFVari(subs).ApprovedInteger(0) then
                if ini then result := literal + ':INT64=0'
                    else result := literal + ':INT64'
             else
                if ini then result := literal + ':double=0'
                    else result := literal + ':double';
          1: result := literal + ':TArray1N';
          2: result := literal + ':TArray2N';
          3: result := literal + ':TArray3N';
          4: result := literal + ':TArray4N';
          else ;
        end
      else if subs is TNVari then
        case dim of
          0: if ini then result := literal + ':Number=(sig:0; exp:1)'
                    else result := literal + ':Number';
          1: result := literal + ':TArray1D';
          2: result := literal + ':TArray2D';
          3: result := literal + ':TArray3D';
          4: result := literal + ':TArray4D';
          else ;
        end;
    's': case dim of
          0: result := literal + ':Ansistring';
          1: result := literal + ':TArray1S';
          2: result := literal + ':TArray2S';
          3: result := literal + ':TArray3S';
          4: result := literal + ':TArray4S';
          else ;
        end;
   'c': result := literal + ':TDeviceRef';
  end;
end;

function TSubstance.Code:AnsiString;
begin
   result:= idr.Literal
end;





initialization

finalization

end.



end.
