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

type
    TExternalDLLs=class(TStringList)
        function Code:string;
    end;
var
  ExternalDLLs:TExternalDLLs;
var
  ProcPtr: array[0..9]of TRoutine;
  procedure CallbackPtrInit;

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

function  TExternalDLLs.code:string;
var
  i:integer;
begin
  result:='';
  for i:=0 to count-1 do
    result:=result + Strings[i]+EOL;
end;

{*******}
{外部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);
     destructor destroy;override;
     function Code:ansistring;override;
    private
     function Arguments:string;
     function ExternalDeclCode:string;
     function CodeExternal:string;
     function CodeGUI:string;
    end;

constructor TAssign.Create(prev,eld:TStatement);

begin
  inherited create(prev,eld);
   {for gen.code} name1:=Tokenstring;
 {$IFDEF UNIX}
 {$IFDEF CPUx86}
  cdecl:=true;
 {$ENDIF}
  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:=Proc.paramcount;
  params:=AllocMem(sizeof(pointer)*NumParam);

  if  token=',' then
     begin
        if (Proc.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(',') then
     begin
       if (token='CDECL') then
          CDECL:=not TargetCPU64
       {$IFDEF Windows}else if (token='STDCALL') then
          CDECL:=false{$ENDIF};
       gettoken;
     end;

  if pass=2 then ExternalDLLs.add(ExternalDeclCode);
end;

function TAssign.ExternalDeclCode:string;
var
  i:integer;
begin
  result:='';
  case Proc.kind of
   'F': Result:=Result+'function ';
   'S': Result:=result+'procedure ';
   else seterr('ASSIGN '+ s_CantBelongHere,IDH_DLL);
  end;
  result:=result+name2;
  if Numparam>0 then
    begin
      result:=result+'(';
      for i:=0 to NumParam-1 do
          begin
            if i>0 then result:=result+'; ';
            result:=result+ TIdRec(Proc.VarTable.items[i]).Literal;
            case  TIdRec(Proc.VarTable.items[i]).kindchar of
               'n':  Result:=result+':NativeInt ' ;
               's':  result:=result+':PChar'       ;
            end;
          end;
      result:=result+')';
    end;
  with proc do
    if kind = 'F' then
      case resultVar.kindchar of
       'n': if @ProcAddrX=nil then
                 result:=result+':NativeInt;'
             else
                 result:=result+':Extended;';    //FPU
       's': Result:=result+':PChar;' ;
      end;
  if CDECL then
    result:=result+'cdecl; '
  {$IFDEF Windows}else if not TargetCPU64  then
    result:=result+' stdcall; '{$ENDIF};
  result:=result+ ' external '''+name1+''' name '''+name2+''';';
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 TAssign.Code:ansistring;
begin
  if GUI then
    result:=CodeGUI
  else
    result:=CodeExternal
end;


function TAssign.CodeGUI:ansistring;
var
   i:integer;
   item:ansistring;
begin
   if @ProcAddrX=nil then
         if CDECL then
           result:='SyncASSIGNCdecl('
         else
            result:='SyncASSIGN(' ;

   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 TAssign.Arguments:string;
var
   i:integer;
   item:string;
begin
   result:='';
   if NumParam>0 then
     begin
        result:=Result+'(';
        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
              begin
                  if PUnit.Arithmetic=precisionComplex then
                     item := 'testreal('+item+')'
                  else if PUnit.Arithmetic=precisionNormal then
                     item := 'ExtendedVal('+item+')' ;
                  item:='trunc('+item+')';
              end
            else
                  item:='PChar('+item+')';
              result:=result+ item;
          end;
        result:=result+')';
     end;
end;

function TAssign.CodeExternal:string;
var
   i:integer;
   item:string;
begin
   if Proc.kind='F' then
      result:='result:='
   else
      result:='';
   result:=result + name2 + Arguments +';';
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;

{*************}
{ CallBack    }
{*************}
procedure CallbackPtrInit;
var
   i:integer;
begin
for i:=0 to 9 do
    ProcPtr[i]:=nil;
end;



type
TCallBackAdr=class(TMiscInt)
     Number:Char;
     PUnit:TProgramUnit;
    constructor create;
    function code:string;override;
  end;

constructor TCallBackAdr.create;
begin
  inherited create;
  check('(',IDH_CALLBACK);
  Number:=token[1];
  if Number in ['0' .. '9'] then
     GetToken
  else
     seterrIllegal(token,IDH_DLL);
  check(')',IDH_CALLBACK);
  PUnit:=ProgramUnit;
end;

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

function TCallBackAdr.code:string;
begin
 result:='NativeInt(@CallBack'+Number +')'
end;


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

procedure statementTableinit;
begin
   StatementTableInitDeclative ('ASSIGN',ASSIGNst);
   {$IFDEF Windows}
   SuppliedFunctionTable.accept('WINHANDLE',WinHandlefnc);
   {$ENDIF}
  SuppliedFunctionTable.accept('CALLBACKADR',CallBackAdrfnc);
end;


initialization
   tableInitProcs.accept(statementTableinit);
   ExternalDLLs:=TExternalDLLs.create;

finalization
   ExternalDLLs.free;

end.

