unit extensio;

{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}

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

interface
uses Classes, Controls, Dialogs,  Forms, SysUtils;

type
   TSignalList=class(TStringList)
      function  VarCode:AnsiString;
      function  IniCode:AnsiString;
      function  DestroyCode:AnsiString;
   end;

Var
   SignalList:TSignalList;

implementation
uses
  base,arithmet,base0,texthand,variabl,struct,express,compiler,control,
  helpctex, MainFrm,{float,}sconsts,supplied ;

type
   TSWAP=class(TStatement)

      var1,var2:TVariable;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
      //procedure exec;override;
      function Code:AnsiString;override;
    end;

function SWAPst(prev,eld:TStatement):TStatement;
begin
    SWAPst:=TSWAP.create(prev,eld);
end;

constructor TSWAP.create(prev,eld:TStatement);
begin
   inherited create(prev,eld);
   var1:=variable;
   check(',',IDH_EXTENSION);
   var2:=variable;
   if (var1=nil) or (var2=nil) or (var1.kind<>var2.kind) then
                          seterr('',IDH_EXTENSION);

   if Var1 is TCVari then
              TCvari(Var1).addQueryDouble(nil);
   if Var2 is TCVari then
              TCvari(Var2).addQueryDouble(nil);
   if Var1 is TFVari then
              TFvari(Var1).addQueryInteger(nil);
   if Var2 is TFVari then
              TFvari(Var2).addQueryInteger(nil);

end;

destructor TSWAP.destroy;
begin
   var1.free;
   var2.free;
   inherited destroy
end;

function TSwap.Code:AnsiString;
begin
  result:='swap('+var1.code+','+var2.code+');'
end;


{**********}
{  SIGNAL  }
{**********}

type
   TSIGNAL=class(TStatement)
       name:string;
          //HSignal:THANDLE;
      constructor create(prev,eld:TStatement);
     // procedure exec;override;
      function code:AnsiString;override;
      destructor destroy;override;
   end;

function SIGNALst(prev,eld:TStatement):TStatement;far;
begin
    SIGNALst:=TSIGNAL.create(prev,eld)
end;

constructor TSIGNAL.create(prev,eld:TStatement);
var
   i:integer;
begin
   inherited create(prev,eld);
   if tokenspec=NIdf then
      begin
        name:=token ;
        gettoken;
      end
   else
      seterrexpected( s_Identifier,IDH_EXTENSION);
   if pass=1 then
      SignalList.Add(Name)
   else
      {with SignalList do
       begin
        i:=IndexOf(Name);
        if Objects[i]=nil then
           begin
               HSignal:=CreateEvent(Nil,false,false,PChar(name));
               Objects[i]:=TObject(HSignal);
           end;
       end};
end;

destructor TSignal.destroy;
begin
  // if pass<>1 then
  //    CloseHandle(HSignal);
    inherited Destroy;
end;

{
procedure TSIGNAL.exec;
begin
   SetEvent(HSignal);
end;
}
function TSIGNAL.code:AnsiString;
begin
   result:='RTLeventSetEvent(Signal_'+Name+');'
end;

{***********}
{WAIT SIGNAL}
{***********}

type
   TWaitEvent=class(TStatement)
          name:String;
          exp:Tprincipal;
      constructor create(prev,eld:TStatement);
      //procedure exec;override;
      function Code:AnsiString;override;
      destructor destroy;override;
   end;

constructor TWaitEvent.create(prev,eld:TStatement);
begin
   inherited create(prev,eld);
   if tokenspec=NIdf then
      begin
        name:=token ;
        gettoken;
        if pass=2 then
           if SignalList.IndexOf(name)<0 then
              seterr('SIGNAL '+name+#13#10+s_IsNotFound,IDH_OLE);
      end
   else
      seterrexpected( s_Identifier,IDH_OLE);
   if token='TIMEOUT' then
      begin
         gettoken;
         exp:=Nexpression;
      end;
end;

destructor TWaitEvent.destroy;
begin
  exp.free;
  inherited Destroy;
end;

function TWaitEvent.code:AnsiString;
begin
  if exp=nil then
    result:='RTLEventWaitFor(Signal_'+Name+');'
  else
    result:='RTLEventWaitFor(Signal_'+Name+','+exp.code+');';
  result:=result+'RTLEventResetEvent(Signal_'+Name+');';
end;


{*********}
{WAIT TIME}
{*********}

type
   TWaitTime=class(TStatement)
          Exp:Tprincipal;
      constructor create(prev,eld:TStatement);
      //procedure exec;override;
      function Code:AnsiString;override;
      destructor destroy;override;
   end;

constructor TWaitTime.create(prev,eld:TStatement);
begin
   inherited create(prev,eld);
       exp:=NSExpression;
end;

destructor TWaitTime.destroy;
begin
   exp.free;
   inherited Destroy;
end;

function TWaitTime.code:AnsiString;
begin
  result:='WaitTime('+Exp.Code+');';
end;

{******}
{PAUSE }
{******}
type
   TPAUSE=class(TStatement)
          exp:TPrincipal;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
      //procedure exec;override;
      function Code:ansistring;override;
   end;

function PAUSEst(prev,eld:TStatement):TStatement;
begin
    PAUSEst:=TPause.create(prev,eld)
end;

constructor TPause.create(prev,eld:TStatement);
begin
   inherited create(prev,eld);
   if not ((tokenspec=tail) or (token='ELSE'))   then
      exp:=NSExpression;
end;

destructor TPause.destroy;
begin
   exp.free;
   inherited destroy
end;

procedure ShowMess(const s:string);
begin
   if MessageDlg(s, mtCustom, [mbOk], 800)<>mrOk then
    CtrlBreakHit:=true;
end;


function TPause.Code:ansistring;
begin
  if exp=nil then
     result:='PAUSE(''Pause'');'
  else if exp.kind='s' then
     result:='PAUSE(' + exp.code +');'
  else
     result:='wait('+exp.code +');'
end;


{**********}
{WAIT DELAY}
{**********}
{
function WAITst(prev,eld:TStatement):TStatement;
begin
    checktoken('DELAY',IDH_EXTENSION);
    WAITst:=TPause.create(prev,eld);
end;
}
function WAITst(prev,eld:TStatement):TStatement;
begin
   if token='DELAY' then
     begin
       gettoken;
       WAITst:=TPause.create(prev,eld);
     end
   else if token='EVENT' then
     begin
        gettoken;
        WAITst:=TWaitEvent.create(prev,eld);
     end
    else if token='TIME' then
     begin
        gettoken;
        WAITst:=TWaitTime.create(prev,eld);
     end
    else
      seterr('',IDH_EXTENSION)  ;
end;


{********}
{beep ST }
{********}
type
  TBEEP=class(TStatement)
     exp1,exp2:TPrincipal;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
      //procedure exec;override;
      function Code:ansistring;override;
   end;

constructor TBeep.create;
begin
  inherited create(prev,eld);
  if (tokenspec<>tail) and (token<>'ELSE') then
  begin
    exp1:=Nexpression;
    check(',',IDH_FILE_ENLARGE);
    exp2:=NExpression;
  end;
end;

destructor TBeep.destroy;
begin
   exp1.free;
   exp2.free;
   inherited destroy
end;   

function TBEEP.Code:ansistring;
begin
   result:='sysUtils.beep;';
{$IFDEF Windows}
   if exp1<>nil then
      result:='Windows.Beep( System.Round('+exp1.code+'),System.Round('+exp2.code+'));'
{$ENDIF}
end;

function BEEPst(prev,eld:TStatement):TStatement;
begin
   BEEPst:=TBEEP.create(prev,eld)
end;

{**********}
{DELETEFILE}
{**********}

type
   TDELETEFILE=class(TStatement)
          exp:TPrincipal;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
      //procedure exec;override;
      function Code:ansistring;override;
   end;

function UNSAVEst(prev,eld:TStatement):TStatement;
begin
    result:=TDELETEFILE.create(prev,eld)
end;

constructor TDELETEFILE.create(prev,eld:TStatement);
begin
   inherited create(prev,eld);
      exp:=SExpression;
end;

destructor TDELETEFILE.destroy;
begin
   exp.free;
   inherited destroy
end;

function TDeleteFile.Code:ansistring;
begin
  result:='FileDelete('+exp.code+');'
end;

{***************}
{File Statements}
{***************}

type
   TGetCurDir=class(TStatement)
       vari:TStrVari;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
end;


type
  TMakeDir=class(TDeleteFile)
      function code:ansistring;override;
end;

function TMakeDir.code:ansistring;
begin
   result:='if CreateDir('+exp.code+') then else setexception(9000);'
end;

type
  TRemoveDir=class(TDeleteFile)
      function code:ansistring;override;
end;

function TRemoveDir.code:ansistring;
begin
   result:='if RemoveDir('+exp.code+') then else setexception(9000);'
end;



type
   TGetName=Class(TGetCurDir)
       exp:TPrincipal;
       aux:integer;
      constructor create(prev,eld:TStatement; aux0:integer);
      destructor destroy;override;
      function Code:Ansistring;override;
   end;


constructor TGetCurDir.create(prev,eld:TStatement);
begin
    inherited create(prev,eld);
    vari:=StrVari;
end;

constructor TGetName.create(prev,eld:TStatement;aux0:integer);
begin
    inherited create(prev,eld);
    aux:=aux0;
    if test(',') then
      exp:=SExpression;
end;

destructor TGetCurDir.destroy;
begin
   vari.free;
   inherited destroy
end;

destructor TGetName.destroy;
begin
   exp.free;
   inherited destroy
end;

function TGetName.Code:ansistring;
var
  s:string;
begin
  s:='''''';
  if exp<>nil then s:=exp.code;
  result:='FileGetName('+s+',' +vari.Code+','+inttostr(aux)+'); ';
end;

type
  TGetDirectoryName=class(TGetCurDir)
       // procedure exec;override;
      function Code:Ansistring;override;
end;

function TGetDirectoryName.Code:ansistring;
begin
  result:= 'GetDirectoryName('+vari.Code+'); ';
end;




type
   TSplitName=Class(TStatement)
       exp:TPrincipal;
       vari1,vari2,vari3:TStrVari;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
      //procedure exec;override;
      function Code:ansistring;override;
   end;

constructor TSplitName.create(prev,eld:TStatement);
begin
    inherited create(prev,eld);
    check('(',IDH_FILE_ENLARGE);
    exp:=SExpression;
    check(')',IDH_FILE_ENLARGE);
    vari1:=StrVari;
    check(',',IDH_FILE_ENLARGE);
    vari2:=StrVari;
    check(',',IDH_FILE_ENLARGE);
    vari3:=StrVari;
end;


destructor TSplitName.destroy;
begin
   exp.free;
   vari1.free;
   vari2.free;
   vari3.free;
   inherited destroy
end;

function TSplitName.code:ansistring;
begin
  result:='FileSplitName('+exp.code+','+vari1.code+','+vari2.code+','+vari3.code+');'
end;

type
   TFileList=Class(TStatement)
       exp:TPrincipal;
       mat1:TMatrix;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
      //procedure exec;override;
      function Code:AnsiString;override;
   end;

constructor TFileList.create(prev,eld:TStatement);
begin
    inherited create(prev,eld);
    exp:=SExpression;
    check(',',IDH_FILE_ENLARGE);
    mat1:=smatrix;
    if mat1.idr.dim<>1 then
               seterrDimension(IDH_FILE_ENLARGE);
end;


destructor TFileList.destroy;
begin
   exp.free;
   mat1.free;
   inherited destroy
end;

Function TFileList.Code:ansistring;
begin
  result:='FileList('+exp.code+','+mat1.code+');'
end;

type
   TFileRename=Class(TStatement)
       exp1,exp2:TPrincipal;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
      //procedure exec;override;
      function Code:ansistring;override;
   end;

constructor TFileRename.create(prev,eld:TStatement);
begin
    inherited create(prev,eld);
    exp1:=SExpression;
    check(',',IDH_FILE_ENLARGE);
    exp2:=SExpression;
end;

destructor TFileRename.destroy;
begin
   exp1.free;
   exp2.free;
   inherited destroy
end;

function TFileRename.code:ansistring;
begin
  result:='FileRename('+exp1.code+','+exp2.code+');'
end;



function FILEst(prev,eld:TStatement):TStatement;
begin
    if token='DELETE' then
       begin
          gettoken;
          result:=UNSAVEst(prev,eld);
       end
    else if token='GETNAME' then
       begin
          gettoken;
          result:=TGetName.create(prev,eld,0);
       end
    else if token='GETOPENNAME' then
       begin
          gettoken;
          result:=TGetName.create(prev,eld,1);
       end
    else if token='GETSAVENAME' then
       begin
          gettoken;
          result:=TGetName.create(prev,eld,2);
       end
    else if token='GETDIRECTORYNAME' then
       begin
          gettoken;
          result:=TGetDirectoryName.create(prev,eld);
       end
    else if token='SPLITNAME' then
       begin
          gettoken;
          result:=TSplitName.create(prev,eld);
       end
    else if token='RENAME' then
       begin
          gettoken;
          result:=TFileRename.create(prev,eld);
       end
    else if token='LIST' then
       begin
          gettoken;
          result:=TFileList.create(prev,eld);
       end
    else
           seterrIllegal(Token, IDH_FILE_ENLARGE)
end;

function DIRECTORYst(prev,eld:TStatement):TStatement;
begin
    if token='GETNAME' then
       begin
          gettoken;
          result:=TGetDirectoryName.create(prev,eld);
       end
    else if token='MAKE' then
       begin
          gettoken;
          result:=TMakeDir.create(prev,eld);
       end
    else if token='REMOVE' then
       begin
          gettoken;
          result:=TRemoveDir.create(prev,eld);
       end
    else
           seterrIllegal(Token, IDH_FILE_ENLARGE)
end;

function MAKEst(prev,eld:TStatement):TStatement;
begin
  if token='DIRECTORY' then
       begin
          gettoken;
          result:=TMakeDir.create(prev,eld);
       end
    else
           seterrIllegal(Token, IDH_FILE_ENLARGE)
end;

function REMOVEst(prev,eld:TStatement):TStatement;
begin
  if token='DIRECTORY' then
       begin
          gettoken;
          result:=TRemoveDir.create(prev,eld);
       end
    else
           seterrIllegal(Token, IDH_FILE_ENLARGE)
end;

{*******************************************}
{Number of Files that matches the expression}
{*******************************************}

type
    TNumFiles=class(TMiscInt)
       exp:TPrincipal;
      constructor create;
      //function  evalLongInt:LongInt;override;
      destructor destroy;override;
      function code:ansistring;override;
    end;


constructor TNumFiles.create;
begin
     inherited create;
     checkToken('(',IDH_EXTENSION) ;
     exp:=SExpression;
     checkToken(')',IDH_EXTENSION);
end;

destructor TNumFiles.destroy;
begin
    exp.free;
    inherited destroy
end;

function TNumFiles.code:ansistring;
begin
  result:='Files('+exp.code+')'
end;

function  Filesfnc:TPrincipal;
begin
      result:=NOperation(TNumFiles.create)
end;


{****************}
{Pack$ and Unpack}
{****************}

type
   TPack=class(TStrExpression)
             exp:TPrincipal;
          constructor create;
          //function evalS:ansistring;override;
          destructor destroy;override;
          function Code:AnsiString;override;
     end;

constructor TPack.create;
begin
   inherited create;
   exp:=argumentN1;
end;

destructor TPack.destroy;
begin
   exp.free;
   inherited destroy;
end;

function Packfnc:TPrincipal;
begin
   Packfnc:=TPack.create;
end;

type
   TDWordStr=class(Tpack)
          //function evalS:ansistring;override;
          function Code:AnsiString;override;
   end;



type
   TWordStr=class(Tpack)
          //function evalS:ansistring;override;
          function Code:AnsiString;override;
   end;



type
   TByteStr=class(Tpack)
          //function evalS:ansistring;override;
          function Code:AnsiString;override;
   end;



function DWordfnc:TPrincipal;
begin
   DWordfnc:=TDWordStr.create;
end;

function Wordfnc:TPrincipal;
begin
   Wordfnc:=TWordStr.create;
end;

function Bytefnc:TPrincipal;
begin
   Bytefnc:=TByteStr.create;
end;




type
   TUnpack=Class(TMiscReal)
             exp:TPrincipal;
          constructor create;
          //function evalX:extended;override;
          destructor destroy;override;
          function Code:AnsiString;override;

     end;

constructor TUnPack.create;
begin
    inherited create;
    check('(',IDH_DLL);
    exp:=SExpression;
    check(')',IDH_DLL);
end;

destructor TUnPack.destroy;
begin
   exp.free;
   inherited destroy;
end;

function UnPackfnc:TPrincipal;
begin
   UnPackfnc:=NOperation(TUnPack.create);
end;

function TPack.Code:ansistring;
begin
  result:='PackDbl_s('+exp.code+')'
end;

function TDwordStr.Code:ansistring;
begin
  result:='DWord_s('+exp.code+')'
end;

function TWordStr.Code:ansistring;
begin
  result:='Word_s('+exp.code+')'
end;

function TByteStr.Code:ansistring;
begin
  result:='Byte_s('+exp.code+')'
end;

function TUnPack.Code:ansistring;
begin
  result:='UnPackDbl('+exp.code+')'
end;


{**********}
{GetKeyStae}
{**********}
type
    TGetKeyState=class(TMiscInt)
       exp:TPrincipal;
      constructor create;
      function  evalLongInt:LongInt;override;
      destructor destroy;override;
      function Code:AnsiString;override;
    end;


constructor TGetKeyState.create;
begin
     inherited create;
     checkToken('(',IDH_EXTENSION) ;
     exp:=NExpression;
     checkToken(')',IDH_EXTENSION);
end;

function TGetKeyState. evalLongInt:LongInt;
begin
   //result:=GetKeyState(exp.evalinteger);
end;

function TGetKeyState.Code:ansistring;
begin
  result:='GetKeyState('+exp.code+')'
end;

destructor TGetKeyState.destroy;
begin
    exp.free;
    inherited destroy
end;

function  GetKeyStatefnc:TPrincipal;
begin
      GetKeyStatefnc:=NOperation(TGetKeyState.create)
end;


{**************}
{BIT operations}
{**************}
type
  TBitNOT=class(TMiscReal)
      exp:TPrincipal;
      constructor create;
      function Code:AnsiString;override;
      function QueryInteger:TSubstanceList;override;   // Integer型となるための条件。nilのとき不可。
  end;

constructor TBitNOT.create;
begin
    inherited create;
    check('(',0);
    exp:=NExpression;
    check(')',0);
end;

function TBitNOT.Code:AnsiString;
begin
   result:='BitNOT('+exp.Code+')'
end;

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

type
  TBitOp=class(TMiscReal)
      exp1,exp2:Tprincipal;
      constructor create;
      function QueryInteger:TSubstanceList;override;   // Integer型となるための条件。nilのとき不可。
  end;

constructor TBitOp.create;
begin
    inherited create;
    check('(',0);
    exp1:=NExpression;
    check(',',0);
    exp2:=NExpression;
    check(')',0);
end;

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



type
  TBitAND=class(TBitOp)
      function Code:AnsiString;override;
  end;
  TBitOR=class(TBitOp)
      function Code:AnsiString;override;
  end;
  TBitXOR=class(TBitOp)
      function Code:AnsiString;override;
  end;

function TBitAND.Code:AnsiString;
begin
   result:='BitAND('+exp1.code+','+exp2.code+')'
end;

function TBitOr.Code:AnsiString;
begin
   result:='BitOR('+exp1.code+','+exp2.code+')'
end;

function TBitXOR.Code:AnsiString;
begin
   result:='BitXOR('+exp1.code+','+exp2.code+')'
end;

function  BitNotfnc:TPrincipal;
begin
    Result:=NOperation(TBitNOT.create)
end;

function  BitAndfnc:TPrincipal;
begin
    Result:=NOperation(TBitAND.create)
end;

function  BitOrfnc:TPrincipal;
begin
    Result:=NOperation(TBitOR.create)
end;

function  BitXorfnc:TPrincipal;
begin
    Result:=NOperation(TBitXOR.create)
end;

{*******************}
{Confirmation Dialog}
{*******************}

type
   TConfirm=class(TStrExpression)
             exp:TPrincipal;
          constructor create;
          function code:ansistring;override;
          destructor destroy;override;
     end;

constructor TConfirm.create;
begin
   inherited create;
   exp:=SExpression;
end;


destructor TConfirm.destroy;
begin
   exp.free;
   inherited destroy;
end;

function TCONFIRM.code:AnsiString;
begin
   result:='confirm_s('+exp.code+')'
end;

function CONFIRMfnc:TPrincipal;
begin
    CONFIRMfnc:=TCONFIRM.create
end;

{***********}
{TSignalList}
{***********}
function  TSignalList.VarCode:AnsiString;
var
  i:integer;
begin
  result:='';
  for i:=0 to Count-1 do
      result:=result+'Var Signal_'+Strings[i]+':PRTLEvent;'+EOL;
end;

function  TSignalList.IniCode:AnsiString;
var
  i:integer;
begin
  result:='';
  for i:=0 to Count-1 do
      result:=result+'   Signal_'+Strings[i]+':=RTLEventCreate;'+EOL;
end;

function  TSignalList.DestroyCode:AnsiString;
 var
  i:integer;
begin
  result:='';
  for i:=0 to Count-1 do
      result:=result+'   RTLeventdestroy(Signal_'+Strings[i]+');'+EOL;
end;


{**********}
{initialize}
{**********}

procedure statementTableinit;
begin
       StatementTableInitImperative('SWAP',SWAPst);
       StatementTableInitImperative('PAUSE',PAUSEst);
       StatementTableInitImperative('WAIT',WAITst);
       StatementTableInitImperative('SIGNAL',SIGNALst);
       StatementTableInitImperative('BEEP',BEEPst);
       StatementTableInitImperative('UNSAVE',UNSAVEst);
       StatementTableInitImperative('KILL',UNSAVEst);
       StatementTableInitImperative('FILE',FILEst);
       StatementTableInitImperative('DIRECTORY',DIRECTORYst);
       StatementTableInitImperative('MAKE',MAKEst);
       StatementTableInitImperative('REMOVE',REMOVEst);
       SignalList.Clear;

end;


procedure  FunctionTableInit;
begin
      SuppliedFunctionTableInit('GETKEYSTATE' , GetKeyStatefnc);
      SuppliedFunctionTableInit('FILES' , Filesfnc);
      SuppliedFunctionTableInit('PACKDBL$' , Packfnc);
      SuppliedFunctionTableInit('DWORD$' , DWordfnc);
      SuppliedFunctionTableInit('WORD$' , Wordfnc);
      SuppliedFunctionTableInit('BYTE$' , Bytefnc);
      SuppliedFunctionTableInit('UNPACKDBL' , UnPackfnc);
      SuppliedFunctionTableInit('BITNOT' , BitNOTfnc);
      SuppliedFunctionTableInit('BITAND' , BitANDfnc);
      SuppliedFunctionTableInit('BITOR' , BitORfnc);
      SuppliedFunctionTableInit('BITXOR' , BitXORfnc);
      SuppliedFunctionTableInit('CONFIRM$',CONFIRMfnc);

end;


Initialization
  tableInitProcs.accept(statementTableinit);
  tableInitProcs.accept(FunctionTableInit);
  SignalList:=TSignalList.Create;
  with SignalList do
     begin
       Sorted:=true;
       CaseSensitive:=false;
       Duplicates:=dupIgnore;
     end;
finalization
   //SignalList.free;
end.
