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


implementation
uses
    {$IFDEF UNIX}
     dl,
    {$ENDIF}
    {$IFDEF Windows}
     Windows,
    {$ENDIF}
     SysUtils, Forms,Controls,
     variabl,express,texthand,base,HelpCtex,supplied,SConsts,
     MainFrm,textfrm,paintfrm,tracefrm,inputdlg,charinp,locatefrm,locatech;

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



{*******}
{ŠO•”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;
       constructor create(prev,eld:TStatement);
     procedure exec;override;
     destructor destroy;override;
    end;

constructor TAssign.Create(prev,eld:TStatement);
var
  Routine:TRoutine;
begin
  inherited create(prev,eld);
  routine:=localroutine;
  if routine=nil then routine:=programunit;

{$IFDEF UNIX}
  Cdecl:=true;
  Handle:=dlopen (PChar(ExtractFilePath(Application.ExeName)+TokenString), RTLD_LAZY);
  if Handle=nil then
     Handle:=dlopen (PChar(TokenString), RTLD_LAZY);
  if (Handle=nil) then
     SetErr(tokenString + ' could not be loaded' ,IDH_DLL);
  if Handle<>nil then
     begin
        gettoken;
        check(',',IDH_DLL);
        Pointer(@ProcAddr):= dlsym(Handle, PChar(TokenString));
        gettoken;
     end ;
{$ELSE}
  Handle:=LoadLibrary(PChar(ExtractFilePath(Application.ExeName)+TokenString));
  if Handle=0 then
     Handle:=LoadLibrary(PChar(TokenString));
  if (Handle=0) then
     SetErr(tokenString + ' could not be loaded' ,IDH_DLL);
  if Handle<>0 then
     begin
        gettoken;
        check(',',IDH_DLL);
        @ProcAddr:=GetProcAddress(Handle,PChar(TokenString));
        gettoken;
     end ;
{$ENDIF}

  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;*)

   if  token=',' then
     begin
        if (Routine.Resultvar<>nil) and(nexttoken='FPU') 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');
              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;

{$IFDEF CPU86}
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
   if GUI then sleep(50);        //2019/09/02 Ver 8.0.1.7

   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;

     try
       j:=i;
       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;

    if cdecl then
      // restore stack  (assume Cdecl)
        begin
         j:=i;
         while j>0 do
           begin
             asm
               pop EAX
             end;
             dec(j);
         end;
       end;

     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;
{$ELSE}
Function RoundToInt64(x:extended):Int64;
begin
   result:=Round(x)
end;


 procedure TAssign.exec;
var
   i,j:integer;
   p:pointer;
   x:Int64;
begin
   if GUI then sleep(50);        //2019/09/02 Ver 8.0.1.7

   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
                Int64(params^[i]):=RoundToInt64(subs.evalX);
              end;
         inc(i);
       end;

     try
        j:=NumParam;
        while j>6 do
          begin
            dec(j);
            x:=int64(params^[j]);
            asm
            push x
            end;
          end;
        if NumParam>=6 then
           begin
             x:=int64(params^[5]);
             asm
                mov  r9,x
             end;
          end;
        if NumParam>=5 then
           begin
             x:=int64(params^[4]);
             asm
                mov  r8,x
             end;
          end;
         if NumParam>=4 then
             begin
               x:=int64(params^[3]);
               asm
                  mov  rcx,x
               end;
            end;
        if NumParam>=3 then
            begin
              x:=int64(params^[2]);
              asm
                 mov  rdx,x
              end;
           end;
        if NumParam>=2 then
            begin
              x:=int64(params^[1]);
              asm
                 mov  rsi,x
              end;
           end;
        if NumParam>=1 then
            begin
              x:=int64(params^[0]);
              asm
                 mov  rdi,x
              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;

       // restore stack  ()
        begin
        end;

     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
              Int64(params^[i]):=0;
       end;
   end;

end;
{$ENDIF}


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


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

type
    TWinHandle=class(TMiscInt)
       exp:TPrincipal;
      constructor create;
      function evalLongint:longint;override;
      destructor destroy;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.evalLongint:longint;
var
   s:string;
   w:TWinControl;
begin
   s:=uppercase(exp.evalS);
   if s='MAIN' then
      w:=FrameForm
   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') or (s='LOCATEVALUE') then
      w:=LocateForm
   else if s='LOCATECHOICE' then
      w:=LocateChoiceForm
   else if s='EDIT' then
      w:=TextForm.memo1
   else
      w:=nil;
   if w<>nil then
      result:=Integer(w.Handle)
   else
      result:=0
end;

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


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


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


begin
   tableInitProcs.accept(statementTableinit);
end.

