svn/view/extensio.pas

unit extensio;

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

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

interface

implementation
uses  Controls, Dialogs,  Forms, SysUtils,
  base,arithmet,base0,texthand,variabl,struct,express,compiler,control,
  helpctex,textfrm, 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);
end;

destructor TSWAP.destroy;
begin
   var1.free;
   var2.free;
   inherited destroy
end;
(*
procedure TSWAP.exec;
var
   p1,p2:TVar;
begin
   p1:=var1.substance0(false);
   p2:=var2.substance0(false);
   if (p1<>nil) and (p2<>nil) then p1.swap(p2) ;
   var1.disposesubstance0(p1,false);
   var2.disposesubstance0(p2,false);
end;
*)
function TSwap.Code:AnsiString;
begin
  result:='swap('+var1.code+','+var2.code+');'
end;

{******}
{PAUSE }
{******}

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 Wait(n:extended);
var
   svCtrlBreakHit:boolean;
   finish:longint;
begin
   svCtrlBreakHit:=CtrlBreakHit;
   CtrlBreakHit:=false;
   try
      finish:=GetTickCount+
            {$IFDEF ver100}system.round{$ELSE}LongIntRound{$ENDIF}(n*1000);
   except
     setexception(12004);
   end;
   repeat
       sleep(10);IdleImmediately;
   until (GetTickcount-Finish>=0) or CtrlBreakHit;
   CtrlBreakHit:=CtrlBreakHit or SvCtrlBreakHit;
end;
*)

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;

(*
procedure TPause.exec;
var
   x:extended;
begin
   if exp=nil then
      ShowMess('Pause')
   else if exp.kind='s' then
      ShowMess(exp.evalS)
   else
      begin
        x:=exp.evalX;
        wait(x)
      end;
end;
*)
function TPause.Code:ansistring;
begin
  if exp=nil then
     result:='ShowMess(''Pause'');'
  else if exp.kind='s' then
     result:='Showmess(' + 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;

{*******}
{INQUIRE}
{*******}
(*
type
   TCONFIRM=class(TStatement)
          svar:TStrVari;
          exp:TPrincipal;
      constructor create(prev,eld:TStatement);
      destructor destroy;override;
      //procedure exec;override;
      function code:ansistring;override;
   end;

function CONFIRMst(prev,eld:TStatement):TStatement;
begin
    CONFIRMst:=TCONFIRM.create(prev,eld)
end;

constructor TCONFIRM.create(prev,eld:TStatement);
begin
   inherited create(prev,eld);
      svar:=StrVari;
      checkToken('WITH',IDH_EXTENSION);
      exp:=NSExpression;
end;

destructor TCONFIRM.destroy;
begin
   svar.free;
   exp.free;
   inherited destroy
end;

function TCONFIRM.code:ansistring;
begin
  result:='with '+svar.code
             +' do begin str:=YesNoLiteral[MessageDlg('+exp.Code+',mtConfirmation,[mbYes,mbNo],0)=mrYes];'
             +' free end;';
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;   
(*
procedure TBEEP.exec;
var
   freq,duration:integer;
begin
   if exp1=nil then
      SysUtils.beep
   else
      begin
         freq:=exp1.evalInteger;
         duration:=exp2.evalInteger;
         SysUtils.beep;   //Windows.Beep(freq,duration);
      end;
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;
(*
procedure TDELETEFILE.exec;
var
   s:String;
begin
   s:=exp.evalS;
   if FileExists(s) then
     if  DeleteFile(s) then
     else
        setexception(9000)
   else
      setexception(9003)
end;
*)
function TDeleteFile.Code:ansistring;
begin
  result:='FileDelete('+exp.code+');'
end;

{***************}
{File Statements}
{***************}
type
  TSetCurDir=class(TDeleteFile)
      //procedure exec;override;
      function Code:AnsiString;override;
end;
(*
procedure TSetCurDir.exec;
begin
 {$I-}
  chDir(exp.evalS);
  if IOResult <> 0 then  // ���������������������������������������������������������
       setexception(9003);
  {$I+} { ������������������������������������������������������������������������ }
end;
*)
function TSetCurDir.Code:ansistring;
begin
  result:='if SetCurrentDir('+exp.code+') then else setexception(9003);';
end;


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

function TGetCurDir.Code:ansistring;
begin
  result:='with '+vari.Code+ 'do begin str:=GetCurrentDir; free end;';
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
   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;
(*
procedure TSplitName.exec;
var
   s,name,ext:string;
   i:integer;
begin
   s:=exp.evalS;
   vari1.substS(ExtractFilePath(s));
   name:=ExtractFileName(s);
   i:=lastDelimiter('.',name);
   ext:=copy(name,i,maxint);
   name:=copy(name,1,i-1);
   vari2.substS(name);
   vari3.substS(ext);
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;
(*
procedure TFileList.exec;
var
   s:string;
   Rec:TSearchRec;
   p:TSArray;
   sz:array3;
   i:integer;
begin
   s:=exp.evalS;

   TVar(p):=mat1.point;
     if p<>nil then
       begin
          i:=0;
          try
            if FindFirst(s,0,Rec)=0 then
              begin
               if p.MaxSize<=i then SetException(5001);
               with p do ItemSubstS(i*size[2] ,Rec.Name);
               inc(i);
               while FindNext(Rec)=0 do
                 begin
                   if p.ary.count<=i then SetException(5001);
                   p.pointij(i,0).SubstS(Rec.Name);
                   inc(i);
                 end;
              end;
          finally
             FindClose(Rec);
          end;

          sz[1]:=i;
          sz[2]:=1;
          sz[3]:=1;
          p.RedimNative(sz,false);
       end;
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;
(*
procedure TFileRename.exec;
var
  s1,s2:string;
begin
  s1:=exp1.evalS;
  s2:=exp2.evalS;
  if FileExists(s1) then
     begin
      if FileExists(s2) then
         setexception(9004)
      else if not RenameFile(s1,s2) then
         setexception(9000)
     end
  else
     setexception(9003);
end;
*)
function 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='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 SetCurDirst(prev,eld:TStatement):TStatement;
begin
   result:=TSetCurDir.create(prev,eld)
end;

function GetCurDirst(prev,eld:TStatement):TStatement;
begin
   result:=TGetCurDir.create(prev,eld)
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;
(*
function TNumFiles.evalLongint:longint;
var
   s:string;
   Rec:TSearchRec;
begin
    s:=exp.evalS;
    result:=0;
    try
      if FindFirst(s,0,Rec)=0 then
        begin
          inc(result);
          while FindNext(Rec)=0 do
             inc(result);
         end;
    finally
       FindClose(Rec);
    end;
end;
*)
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;
(*
function TPack.evalS:ansistring;
var
   d:double;
   s:string[8];
begin
   d:=exp.evalX;
   move(d,s[1],8);
   setlength(s,8);
   result:=s;
end;
*)
destructor TPack.destroy;
begin
   exp.free;
   inherited destroy;
end;

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

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

{
function TDWordStr.evalS:ansistring;
var
   d:DWord;
   s:string[4];
begin
   d:=Trunc(exp.evalX);
   move(d,s[1],4);
   setlength(s,4);
   result:=s;
end;
}

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

{
function TWordStr.evalS:ansistring;
var
   w:word;
   s:string[2];
begin
   w:=exp.evalInteger;
   move(w,s[1],2);
   setlength(s,2);
   result:=s;
end;
}

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

{
function TByteStr.evalS:ansistring;
var
   b:byte;
   s:string[1];
begin
   b:=exp.evalInteger;
   move(b,s[1],1);
   setlength(s,1);
   result:=s;
end;
}

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

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

function Bytefnc:TPrincipal;far;
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;
(*
function TUnPack.evalX:extended;
var
   s:string[8];
   d:double;
begin
   s:=exp.evalS;
   move(s[1],d,8);
   result:=d;
end;
*)
destructor TUnPack.destroy;
begin
   exp.free;
   inherited destroy;
end;

function UnPackfnc:TPrincipal;far;
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;
  end;
constructor TBitNOT.create;
begin
    inherited create;
    check('(',0);
    exp:=NExpression;
    check(')',0);
end;

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

type
  TBitOp=class(TMiscReal)
      exp1,exp2:Tprincipal;
      constructor create;
  end;

constructor TBitOp.create;
begin
    inherited create;
    check('(',0);
    exp1:=NExpression;
    check(',',0);
    exp2:=NExpression;
    check(')',0);
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;


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

procedure statementTableinit;
begin
       StatementTableInitImperative('SWAP',SWAPst);
       StatementTableInitImperative('PAUSE',PAUSEst);
       StatementTableInitImperative('WAIT',WAITst);
       //StatementTableInitImperative('CONFIRM',CONFIRMst);
       StatementTableInitImperative('BEEP',BEEPst);
       StatementTableInitImperative('UNSAVE',UNSAVEst);
       StatementTableInitImperative('KILL',UNSAVEst);
       StatementTableInitImperative('FILE',FILEst);
       StatementTableInitImperative('SETCURDIR',SetCurDirst);
       StatementTableInitImperative('GETCURDIR',GetCurDirst);


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;


begin
  tableInitProcs.accept(statementTableinit);
  tableInitProcs.accept(FunctionTableInit);
end.