unit ExtDll;
{$IFDEF FPC}
  {$MODE DELPHI} {$H+}
{$ENDIF}
interface
uses SysUtils, Forms,Controls,
    {$IFDEF UNIX}      dl,  {$ENDIF}
    {$IFDEF Windows}Windows,{$ENDIF}
    struct;


implementation
uses
     variabl,express,texthand,base,base0,HelpCtex,supplied,SConsts;



{*******}
{外部DLL}
{*******}
type
    PPointerArray=^TPointerArray;
    TPointerArray=array[0..7] of pointer;
    TLongIntFunction=function:LongInt;
    TFPUFunction=function:extended;
    TAssign=class(TStatement)
      {$IFDEF UNIX}
       Handle:Pointer;
      {$ELSE}
       Handle:THandle;
      {$ENDIF}
       ProcAddr:TLongIntFunction;
       ProcAddrX:TFPUFunction;
       NumParam:integer;
       params:PPointerArray;
       ResultType:char;
       GUI:boolean;
       CDECL:boolean;
       {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;
 {$IFDEF UNIX}
  Cdecl:=not TargetCPU64;
  Handle:=dlopen (PChar(ExtractFilePath(Application.ExeName)+'output/'+name1), RTLD_LAZY);
  if Handle=nil then
     Handle:=dlopen (PChar(name1), RTLD_LAZY);
  gettoken;
  check(',',IDH_DLL);
  {for gen.code} name2:=Tokenstring;
  if Handle<>nil then
        Pointer(@ProcAddr):= dlsym(Handle, PChar(TokenString));
{$ELSE}//Windows
  Handle:=LoadLibrary(PChar(ExtractFilePath(Application.ExeName)+'output\'+name1));
  if Handle=0 then
    Handle:=LoadLibrary(PChar(name1));
  gettoken;
  check(',',IDH_DLL);
  {for gen.code} name2:=Tokenstring;
  if Handle<>0 then
     @ProcAddr:=GetProcAddress(Handle,PChar(TokenString));
 {$ENDIF}

  if {$IFDEF CPU64}TargetCPU64{$ELSE}not TargetCPU64 {$ENDIF} then
     if (Handle={$IFDEF UNIX}nil{$ELSE}0{$ENDIF}) then
         SetErr(name1 + s_cannotbeloaded ,IDH_DLL);

   if {$IFDEF CPU64}TargetCPU64{$ELSE}not TargetCPU64 {$ENDIF} then
     if @ProcAddr=nil then
                 SetErr(Name2+ s_isnotfound,IDH_DLL);

  gettoken;
  NumParam:=Routine.paramcount;
  params:=AllocMem(sizeof(pointer)*NumParam);

  if  token=',' then
     begin
        if (Routine.Resultvar<>nil) and(nexttoken='FPU') and not TargetCPU64 then
           begin
             gettoken;
             gettoken;
             @ProcAddrX:=@ProcAddr;
             @ProcAddr:=nil;
           end
        else if nexttoken='GUI' then
           begin
              gettoken;
              gettoken;
              GUI:=true;
           end
    end;

  if  test(',') and ((token='CDECL') or (token='STDCALL'))  then
         begin
            CDECL:=(token='CDECL')and not TargetCPU64;;
            gettoken;
         end;


end;

destructor TAssign.destroy;
begin
   {$IFDEF UNIX}
     if Handle<>nil then
         dlclose(Handle);
   {$ELSE}
     FreeLibrary(Handle);
   {$ENDIF}
   if params<>nil then freemem(params,sizeof(pointer)*NumParam);
  inherited destroy
end;

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

function TAssign.Code:ansistring;
var
   i:integer;
   item:ansistring;
begin
   if @ProcAddrX=nil then
      if GUI then
        if CDECL then
           result:='SyncASSIGNCdecl('
        else
           result:='SyncASSIGN('
      else
        if CDECL then
          result:='ASSIGNCdecl('
        else
          result:='ASSIGN('
   else
      if CDECL then
         result:='ASSIGNFPUCdecl('
      else
         result:='ASSIGNFPU(';

   result:=result+''''+name1+''','''+name2+''','+'[';
   for i:=0 to NumParam-1 do
       begin
         if i>0 then result:=result+',';
         item:=TIdRec(Proc.VarTable.items[i]).Literal;
         if TIdRec(Proc.VarTable.items[i]).kindchar='n' then
           if PUnit.Arithmetic=precisionComplex then
               item := 'testreal('+item+')'
            else if PUnit.Arithmetic=precisionNormal then
               item := 'ExtendedVal('+item+')' ;
          result:=result+ item;
       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;


{**************}
{Window 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 WinHandlefnc:TPrincipal;
begin
    WinHandlefnc:=NOperation(TWinHandle.create)
end;



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

procedure statementTableinit;
begin
   //If not TargetCPU64 then
      begin
         StatementTableInitDeclative ('ASSIGN',ASSIGNst);
         {$IFDEF Windows}
         SuppliedFunctionTable.accept('WINHANDLE',WinHandlefnc);
         {$ENDIF}
       end;
end;


begin
   tableInitProcs.accept(statementTableinit);
end.

