svn/view/extdll.pas

unit ExtDll;
{$IFDEF FPC}
  {$MODE DELPHI} {$H+}
{$ENDIF}
interface
uses struct;

//procedure PrepareCallback(Proc:TRoutine);

implementation
uses Windows,SysUtils, Forms,Controls,
     variabl,express,texthand,base,base0,base2,HelpCtex,supplied,SConsts,
     TEXTFRM,PAINTFRM,TRACEFRM,INPUTDLG,CHARINP,LocateFrm;

const DLL_Error=-9900;
const MissingCALLBACK=-9901;


{*******}
{外部DLL}
{*******}
type
    PPointerArray=^TPointerArray;
    TPointerArray=array[0..7] of pointer;
    TLongIntFunction=function:LongInt;
    TFPUFunction=function:extended;
    TAssign=class(TStatement)
       Handle:THandle;
       ProcAddr:TLongIntFunction;
       ProcAddrX:TFPUFunction;
       NumParam:integer;
       params:PPointerArray;
       ResultType:char;
       {for gen. code}
       Name1,name2:ansistring;
     constructor create(prev,eld:TStatement);
     //procedure exec;override;
     destructor destroy;override;
     function Code:ansistring;override;
    end;

constructor TAssign.Create(prev,eld:TStatement);
var
  Routine:TRoutine;
begin
  inherited create(prev,eld);
   {for gen.code} name1:=Tokenstring;
  routine:=localroutine;
  if routine=nil then routine:=programunit;
  Handle:=LoadLibrary(PChar(ExtractFilePath(Application.ExeName)+TokenString));
  if Handle=0 then
     Handle:=LoadLibrary(PChar(TokenString));
  if (Handle=0) then
     SetErr(tokenString + s_cannotbeloaded ,IDH_DLL);
  if Handle<>0 then
     begin
        gettoken;
        check(',',IDH_DLL);
        {for gen.code} name2:=Tokenstring;
        @ProcAddr:=GetProcAddress(Handle,PChar(TokenString));
        gettoken;
     end ;
  if @ProcAddr=nil then
                 SetErr(tokenString+ s_isnotfound,IDH_DLL);
  NumParam:=Routine.paramcount;
  params:=AllocMem(sizeof(pointer)*NumParam);

  if (Routine.Resultvar<>nil) and test(',') then
     begin
        CheckToken('FPU',IDH_EXTENSION_MS);
         @ProcAddrX:=@ProcAddr;
        @ProcAddr:=nil;
     end;

end;

destructor TAssign.destroy;
begin
  FreeLibrary(Handle);
  if params<>nil then freemem(params,sizeof(pointer)*NumParam);
  inherited destroy
end;

Function GetString(p:PChar):string;
begin
  result:=p
end;

Function RoundToLongint(x:extended):longint;assembler;
asm
    PUSH EDX
    PUSH EAX
    FLD x
    FISTP QWORD PTR [ESP]
    WAIT
    POP EAX
    POP EDX
end;
(*
procedure TAssign.exec;
var
   i,j:integer;
   p:pointer;
   x:double;
begin
   i:=0;

   try
     while i<NumParam do
       begin
         with TIdRec(Proc.VarTable.items[i]) do
           if kindchar='s' then
              string(params^[i]):=subs.evalS
           else
              begin
                longint(params^[i]):=RoundToLongint(subs.evalX);
              end;
         inc(i);
       end;

     j:=i;
     try
       while j>0 do
         begin
           dec(j);
           p:=@params^[j];
           asm
             mov eax, p
             push dword ptr [eax]
           end;
         end;
       if Proc.resultVar<>nil then
           if @ProcAddr<>nil then
              if Proc.resultVar.kindchar='n' then
                 Proc.resultVar.subs.assignLongint(ProcAddr)
              else
                 Proc.resultVar.subs.substS(GetString(Pchar(ProcAddr)))
           else
              Proc.resultVar.subs.assignX(ProcAddrX)
       else
            ProcAddr;
     except
      on E:EExtype do
         raise;
      else
         SetException(DLL_Error)
     end;

   finally
     while i>0 do
       begin
         dec(i);
         with TIdRec(Proc.VarTable.items[i]) do
           if kindchar='s' then
              string(params^[i]):=''
           else
              longint(params^[i]):=0;
       end;
   end;

end;
*)
function TAssign.Code:ansistring;
var
   i:integer;
begin
   if @ProcAddrX=nil then
      result:='winlib.ASSIGN('
   else
      result:='ASSIGNFPU(';
   result:=result+''''+name1+''','''+name2+''','+'[';
   for i:=0 to NumParam-1 do
       begin
         if i>0 then result:=result+',';
         result:=result+ TIdRec(Proc.VarTable.items[i]).Literal;
       end;
   result:=result+'])'  ;

   if Proc.resultVar<>nil then
      if @ProcAddr<>nil then
          if Proc.resultVar.kindchar='n' then
                 result:='result:='+result +';'
              else
                 result:='result:=PChar(pointer('+result+'));'
           else
                 result:='result:='+result +';'
       else
            result:=result+';';

end;

function  ASSIGNst(prev,eld:TStatement):TStatement;
begin
   ASSIGNst:=TAssign.create(prev,eld);
end;

{*************}
{ CallBack    }
{*************}

type
    TIntArray=array[0..255] of integer;
    PIntArray=^TIntArray;

var
   ProcPtr: array[0..9]of TRoutine;
   NumParams:array[0..9]of integer;
(*
function ManageCallBack(n:integer; p:PIntArray):integer;
var
   i,j:integer;
   svCurrentStatement,svNextStatement:TStatement;
begin
  result:=0;

  with ProcPtr[n] do
    begin
      NumParams[n]:=Paramcount;

      VarTable.pushStack;
      for j:=0 to VarTable.count-1 do
        TIdrec(VarTable.items[j]).subs.getVar1;

      for i:=0 to ParamCount-1 do
        begin
          with TIdRec(VarTable.items[i]) do
             case kindchar of
               's':
                 subs.substS(PChar(p^[i]));
               'n':
                 subs.assignLongint(p^[i]);
             end;
        end;

      svCurrentStatement:=CurrentStatement;
      svNextStatement:=NextStatement;
      try
        try
          runBlock(block);
        except
          On E:EControlException do
           if    (kind='F') and (E is EExitFunction)
               or (kind='S') and (E is EExitSub)
               or (kind='P') and (E is EExitPicture)
           then
           else
             raise
        end;
        if resultvar<>nil then
          with ResultVar do
             case kindchar of
               's': result:=LongInt(Pchar(resultvar.subs.evalS));
               'n': result:=resultvar.subs.evalLongInt;
             end;
      finally
         CurrentStatement:=svCurrentStatement;
         NextStatement:=svNextStatement;

         for j:=VarTable.count -1 downto 0 do
            TIdrec(VarTable.items[j]).FreeVar;
         VarTable.popStack;

         propagateException;
      end;
  end;
end;

function CallBack0(p0:longint):longint; stdcall;
begin
  result:=ManageCallBack(0,@p0);
 asm
  mov ecx,Dword Ptr Numparams
  dec ecx
  shl ecx,2  //ecxを4倍する
  pop ebp
  pop edx   //return address
  add esp,ecx
  push edx
  push ebp
 end;
end;

function CallBack1(p0:longint):longint; stdcall;
begin
  result:=ManageCallBack(1,@p0);
 asm
  mov ecx,Dword Ptr Numparams + 4
  dec ecx
  shl ecx,2  //ecxを4倍する
  pop ebp
  pop edx   //return address
  add esp,ecx
  push edx
  push ebp
 end;
end;

function CallBack2(p0:longint):longint; stdcall;
begin
  result:=ManageCallBack(2,@p0);
 asm
  mov ecx,Dword Ptr Numparams + 8
  dec ecx
  shl ecx,2  //ecxを4倍する
  pop ebp
  pop edx   //return address
  add esp,ecx
  push edx
  push ebp
 end;
end;

function CallBack3(p0:longint):longint; stdcall;
begin
  result:=ManageCallBack(3,@p0);
 asm
  mov ecx,Dword Ptr Numparams + 12
  dec ecx
  shl ecx,2  //ecxを4倍する
  pop ebp
  pop edx   //return address
  add esp,ecx
  push edx
  push ebp
 end;
end;

function CallBack4(p0:longint):longint; stdcall;
begin
  result:=ManageCallBack(4,@p0);
 asm
  mov ecx,Dword Ptr Numparams + 16
  dec ecx
  shl ecx,2  //ecxを4倍する
  pop ebp
  pop edx   //return address
  add esp,ecx
  push edx
  push ebp
 end;
end;

function CallBack5(p0:longint):longint; stdcall;
begin
  result:=ManageCallBack(5,@p0);
 asm
  mov ecx,Dword Ptr Numparams + 20
  dec ecx
  shl ecx,2  //ecxを4倍する
  pop ebp
  pop edx   //return address
  add esp,ecx
  push edx
  push ebp
 end;
end;

function CallBack6(p0:longint):longint; stdcall;
begin
  result:=ManageCallBack(6,@p0);
 asm
  mov ecx,Dword Ptr Numparams + 24
  dec ecx
  shl ecx,2  //ecxを4倍する
  pop ebp
  pop edx   //return address
  add esp,ecx
  push edx
  push ebp
 end;
end;

function CallBack7(p0:longint):longint; stdcall;
begin
  result:=ManageCallBack(7,@p0);
 asm
  mov ecx,Dword Ptr Numparams + 28
  dec ecx
  shl ecx,2  //ecxを4倍する
  pop ebp
  pop edx   //return address
  add esp,ecx
  push edx
  push ebp
 end;
end;

function CallBack8(p0:longint):longint; stdcall;
begin
  result:=ManageCallBack(8,@p0);
 asm
  mov ecx,Dword Ptr Numparams + 32
  dec ecx
  shl ecx,2  //ecxを4倍する
  pop ebp
  pop edx   //return address
  add esp,ecx
  push edx
  push ebp
 end;
end;

function CallBack9(p0:longint):longint; stdcall;
begin
  result:=ManageCallBack(9,@p0);
 asm
  mov ecx,Dword Ptr Numparams + 36
  dec ecx
  shl ecx,2  //ecxを4倍する
  pop ebp
  pop edx   //return address
  add esp,ecx
  push edx
  push ebp
 end;
end;
*)
(*
type
  TCallBackAdr=class(TMiscInt)
       exp:TPrincipal;
       PUnit:TProgramUnit;
      constructor create;
      function evalLongint:longint;override;
      destructor destroy;override;
     private
      function getAddress(i:integer):integer;
    end;

function TCallBackAdr.getAddress(i:integer):integer;
begin
         case i of
             0:  result:=integer(@CallBack0);
             1:  result:=integer(@CallBack1);
             2:  result:=integer(@CallBack2);
             3:  result:=integer(@CallBack3);
             4:  result:=integer(@CallBack4);
             5:  result:=integer(@CallBack5);
             6:  result:=integer(@CallBack6);
             7:  result:=integer(@CallBack7);
             8:  result:=integer(@CallBack8);
             9:  result:=integer(@CallBack9);
           else  result:=0;
         end;
end;

constructor TCallBackAdr.create;
var
  i:integer;
begin
    inherited create;
    check('(',IDH_CALLBACK);
    exp:=NExpression ;
    check(')',IDH_CALLBACK);
    PUnit:=ProgramUnit;
end;

destructor TCallBackAdr.destroy;
begin
    inherited destroy;
end;

function TCallBackAdr.evalLongint:longint;
var
   i:integer;
begin
  i:=exp.evalLongint ;
  if (i>=0) and (i<=9)
            and (ProcPtr[i]<>nil)
            and ( not (ProcPtr[i] is TLocalProc)
                   or (TLocalProc(ProcPtr[i]).parent=Punit)) then
      result:=GetAddress(i)
  else
      setexception(MissingCallBack);

end;

function CallBackAdrfnc:TPrincipal;far;
begin
    CallBackAdrFnc:=NOperation(TCallBackAdr.create)
end;


procedure PrepareCallback(Proc:TRoutine);
var
   i:integer;
begin
  if (Proc.paramcount=0) then
          seterr('Unsuitable for CallBack',IDH_CALLBACK);

  if (length(token)=1) and (token[1]>='0') and (token[1]<='9') then
     begin
       i:=ord(token[1])-ord('0');
       if (Pass=1) and (ProcPtr[i]<>nil) then
          seterr('Duplicate index',IDH_CALLBACK);
       ProcPtr[i]:=proc;
       gettoken;
     end
end;

procedure InitCallBack;
var
  i:integer;
begin
   for i:=0 to 9 do
     ProcPtr[i]:=nil;
end;
*)

{**************}
{Windows Handle}
{**************}

type
    TWinHandle=class(TMiscInt)
       exp:TPrincipal;
      constructor create;
      //function evalLongint:longint;override;
      destructor destroy;override;
      function Code:Ansistring;override;
    end;

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

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

function TWinhandle.code:ansistring;
begin
  result:='WinHandle('+exp.code+')'
end;

(*
function TWinHandle.evalLongint:longint;
var
   s:string;
   w:TWinControl;
begin
   s:=uppercase(exp.evalS);

   if s='MAIN' then
      w:=Application.mainForm
   else if s='TEXT' then
      w:=TextForm
   else if s='GRAPHICS' then
      w:=PaintForm
   else {if s='TRACE' then
      w:=TraceForm
   else} if s='INPUT' then
      w:=InputDialog
   else if s='CHARACTER INPUT' then
      w:=CharInput
   else if s='LOCATE' then
      w:=LocateForm
   else{ if s='TEXTWINDOW1' then
      w:=TextWindow1
   else if s='TEXTWINDOW2' then
      w:=TextWindow2
   else if s='RICHEDIT' then
      w:=TextForm.memo1
   else if s='RICHEDIT1' then
      w:=TextWindow1.memo1
   else if s='RICHEDIT2' then
      w:=TextWindow2.memo1
   else}
      w:=nil;
   if w<>nil then
      result:=w.Handle
   else
      result:=0
end;
*)

function WinHandlefnc:TPrincipal;far;
begin
    WinHandlefnc:=NOperation(TWinHandle.create)
end;


{*************}
{Win32 API関数}
{*************}


{************}
{Registration}
{************}


procedure statementTableinit;far;
begin
   StatementTableInitDeclative ('ASSIGN',ASSIGNst);
   SuppliedFunctionTable.accept('WINHANDLE',WinHandlefnc);
   //SuppliedFunctionTable.accept('CALLBACKADR',CallBackAdrfnc);   //未実装
   //InitCallBack;
 end;


begin
   tableInitProcs.accept(statementTableinit);
end.
