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;

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;
     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}
  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;
  
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 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;

     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;

      {$IFNDEF Windows}
       // restore stack  (assume Cdecl)
       j:=i;
       while j>0 do
         begin
           asm
             pop EAX
           end;
           dec(j);
       end;
      {$ENDIF}

     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  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' then
      w:=LocateForm
   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);
   SuppliedFunctionTable.accept('WINHANDLE',WinHandlefnc);
 end;


begin
   tableInitProcs.accept(statementTableinit);
end.

