{
@abstract(Compiletime Interface support)
@author(Carlo Kok <ck@carlo-kok.com>)
}
unit ifpiinterface;

interface
uses
  ifpscomp, ifps3utl, SysUtils;

type
  TIFPSInterfaces = class;
  TIFPSInterface = class(TObject)
  private
    FOwner: TIFPSInterfaces;
    FInheritedFrom: TIFPSInterface;
    FGuid: string;
    FProcStart: Cardinal;
    FItems: TIfList;
    FName: string;
    FNameHash: Longint;
  public
    constructor Create(Owner: TIFPSInterfaces; InheritedFrom: TIFPSInterface; const GUID, Name: string);
    destructor Destroy; override;
    {This interface inherits from ...}
    property InheritedFrom: TIFPSInterface read FInheritedFrom;
    {The GUID for this interface}
    property Guid: string read FGuid;
    {The name of this interface}
    property Name: string read FName;
    {Hash of the name of this interface}
    property NameHash: Longint read FNameHash;

    {Register a method}
    function RegisterMethod(const Declaration: string; const cc: TIFPSCallingConvention): Boolean;
    {Register a method that cannot be called, but will hold an empty space
     This can be used for methods that cannot be registered (for example for functions that use pointer parameters).}
    procedure RegisterDummyMethod;
  end;

  TIFPSInterfaces = class(TObject)
  private
    FItems: TIfList;
    FSE: TIFPSPascalCompiler;
  public
    {Add a new interface}
    function Add(InheritedFrom: TIFPSInterface; const GUID, Name: string): TIFPSInterface;
    {Find an interface}
    function Find(const Name: string): TIFPSInterface;
  
    constructor Create(SE: TIFPSPascalCompiler; AutoFree: Boolean);
    destructor Destroy; override;
  end;




implementation

const
  IFPSInterfaceType = '!IFPSIntf';

type
  TIFPSInterfaceMethod = class(TObject)
  private
    FName, FDStr: string;
    FNameHash: Longint;
    FCC: TIFPSCallingConvention;
    FAbsoluteProcOffset: Cardinal;
    FScriptProcNo: Cardinal;
  public
    property AbsoluteProcOffset: Cardinal read FAbsoluteProcOffset;
    property ScriptProcNo: Cardinal read FScriptProcNo;
    property Name: string read FName;
    property NameHash: Longint read FNameHash;
    property DStr: string read FDStr;
    property CC: TIFPSCallingConvention read FCC;
  end;
  TIFPSInterfaceClass = class(TIFPSExternalClass)
  private
    FIntf: TIFPSInterface;
    FCompareProcNo,
    FNilProcNo: Cardinal;
  public
    constructor Create(Intf: TIFPSInterface; Se: TIFPSPascalCompiler; TypeNo: Cardinal);
    function SelfType: Cardinal; override;
    function Func_Find(const Name: string; var Index: Cardinal): Boolean; override;
    function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; override;
    function IsCompatibleWith(Cl: TIFPSExternalClass): Boolean; override;
    function SetNil(var ProcNo: Cardinal): Boolean; override;
    function CastToType(IntoType: Cardinal; var ProcNo: Cardinal): Boolean; override;
    function CompareClass(OtherTypeNo: Cardinal; var ProcNo: Cardinal): Boolean; override;
  end;


{ TIFPSInterface }

constructor TIFPSInterface.Create(Owner: TIFPSInterfaces; InheritedFrom: TIFPSInterface;
  const GUID, Name: string);
begin
  inherited Create;
  FOWner := Owner;
  FGuid := GUID;
  FInheritedFrom := InheritedFrom;
  if FInheritedFrom = nil then
    FProcStart := 0
  else
    FProcStart := FInheritedFrom.FProcStart + FInheritedFrom.FItems.Count;
  FItems := TIfList.Create;
  FName := Name;
  FNameHash := MakeHash(Name);
end;

destructor TIFPSInterface.Destroy;
var
  i: Longint;
begin
  for i := FItems.Count -1 downto 0 do
  begin
    TIFPSInterfaceMethod(FItems[i]).Free;
  end;
  FItems.Free;
  inherited Destroy;
end;

procedure TIFPSInterface.RegisterDummyMethod;
begin
  FItems.Add(TIFPSInterfaceMethod.Create);
end;

function TIFPSInterface.RegisterMethod(const Declaration: string;
  const cc: TIFPSCallingConvention): Boolean;
var
  M: TIFPSInterfaceMethod;
  DName,
  DStr: string;
  Func: TPMFuncType;
begin
  if not ParseMethod(FOwner.FSE, '', Declaration, DName, DStr, Func) then
  begin
    FItems.Add(TIFPSInterfaceMethod.Create); // in any case, add a dummy item
    Result := False;
    exit;
  end;
  M := TIFPSInterfaceMethod.Create;
  m.FName := DName;
  m.FNameHash := MakeHash(m.FName);
  m.FDStr := DStr;
  m.FCC := CC;
  m.FScriptProcNo := InvalidVal;
  m.FAbsoluteProcOffset := FProcStart + Cardinal(FItems.Add(m));
  Result := True;
end;

{ TIFPSInterfaces }
type
  TMySE = class(TIFPSPascalCompiler)
  end;

function TIFPSInterfaces.Add(InheritedFrom: TIFPSInterface; const GUID, Name: string): TIFPSInterface;
var
  f: TIFPSClassType;
begin
  Result := TIFPSInterface.Create(Self, InheritedFrom, GUID, FastUppercase(Name));
  FItems.Add(Result);
  f := TIFPSClassType(FSE.AddType(Result.Name, btClass));
  TIFPSClassType(f).ClassHelper := TIFPSInterfaceClass.Create(Result, FSE, TMySE(FSE).FAvailableTypes.Count -1);
end;

constructor TIFPSInterfaces.Create(SE: TIFPSPascalCompiler;
  AutoFree: Boolean);
begin
  inherited Create;
  FSE := SE;
  if AutoFree then
    FSE.AddToFreeList(Self);
  FItems := TIfList.Create;
  with Add(nil, '{00000000-0000-0000-C000-000000000046}', 'IUnknown') do
  begin
    RegisterDummyMethod; // Query Interface
    RegisterDummyMethod; // _AddRef
    RegisterDummyMethod; // _Release
  end;
end;

destructor TIFPSInterfaces.Destroy;
var
  i: Longint;
begin
  for i := FItems.Count -1 downto 0 do
  begin
    TIFPSInterface(FItems[i]).Free;
  end;
  FItems.Free;
  inherited Destroy;
end;

function TIFPSInterfaces.Find(const Name: string): TIFPSInterface;
var
  n: string;
  i, nh: Longint;
begin
  n := FastUpperCase(Name);
  nh := MakeHash(n);
  for i := FItems.Count -1 downto 0 do
  begin
    Result := FItems[i];
    if (Result.NameHash = nh) and (Result.Name = N) then
      exit;
  end;
  Result := nil;
end;

{ TIFPSInterfaceClass }

const
  ProcHDR = 'procedure a;';

function TIFPSInterfaceClass.CastToType(IntoType: Cardinal;
  var ProcNo: Cardinal): Boolean;
var
  P: TIFPSExternalProcedure;
  Pt: TIFPSType;
  sname: string;
begin
  pt := TMySE(Se).FUsedTypes[IntoType];
  if (pt <> nil) and (pt.BaseType <> btClass) or (not (TIFPSClassType(pt).ClassHelper is TIFPSInterfaceClass)) then
  begin
    Result := False;
    exit;
  end;

  sname := '!IFPSIntfCast.'+inttostr(IntoType);
  ProcNo := TMySE(Se).FindProc(sname);

  if ProcNo <> InvalidVal then
  begin
    Result := True;
    exit;
  end;
  ProcNo := TMySE(Se).AddUsedFunction2(P);
  P.RegProc := SE.AddFunction(ProcHDR);
  P.RegProc.Name := SName;
  P.RegProc.Decl := '-1 !VARTO '+IntToStr(TMySE(Se).at2ut(FTypeNo))+' !TYPENO '+IntToStr(TMySE(SE).GetType(True, btu32));

  P.RegProc.ImportDecl := 'class:+' + TIFPSInterfaceClass(TIFPSClassType(pt).ClassHelper).FIntf.Guid;
  Result := True;
end;

function TIFPSInterfaceClass.CompareClass(OtherTypeNo: Cardinal;
  var ProcNo: Cardinal): Boolean;
var
  P: TIFPSExternalProcedure;
  Pt: TIFPSType;
begin
  if OtherTypeNo <> InvalidVal then
  begin
    pt := TMySE(Se).FUsedTypes[OtherTypeNo];
    if (pt <> nil) and (pt.BaseType <> btClass) or (not (TIFPSClassType(pt).ClassHelper is TIFPSInterfaceClass)) then
    begin
      Result := False;
      exit;
    end;
  end;
  if FCompareProcNo <> InvalidVal then
  begin
    Procno := FCompareProcNo;
    Result := True;
    exit;
  end;
  ProcNo := TMySE(Se).AddUsedFunction2(P);
  P.RegProc := SE.AddFunction(ProcHDR);
  P.RegProc.Name := '';
  P.RegProc.Decl := IntToStr(TMySE(SE).at2ut(TMySE(SE).FBooleanType))+' !K '+IntToStr(TMySE(SE).at2ut(SE.FindType('IUnknown')))+' !J '+IntToStr(TMySE(SE).at2ut(SE.FindType('IUnknown')));
  P.RegProc.ImportDecl := 'class:+';
  FCompareProcNo := ProcNo;
  Result := True;
end;

constructor TIFPSInterfaceClass.Create(Intf: TIFPSInterface;
  Se: TIFPSPascalCompiler; TypeNo: Cardinal);
begin
  inherited Create(SE, TypeNo);
  FIntf := Intf;
  FCompareProcNo := InvalidVal;
  FNilProcNo := Invalidval;
end;

function TIFPSInterfaceClass.Func_Call(Index: Cardinal;
  var ProcNo: Cardinal): Boolean;
var
  c: TIFPSInterfaceMethod;
  P: TIFPSExternalProcedure;
  s, w, n: string;
begin
  c := TIFPSInterfaceMethod(Index);
  if c.FScriptProcNo <> InvalidVal then
  begin
    Procno := c.FScriptProcNo;
    Result := True;
    exit;
  end;
  ProcNo := TMySE(Se).AddUsedFunction2(P);
  P.RegProc := SE.AddFunction(ProcHDR);
  P.RegProc.Name := '';
  TMySE(Se).ReplaceTypes(C.FDStr);
  P.RegProc.Decl := C.FDStr;
  s := 'intf:.' + IFPS3_mi2s(c.AbsoluteProcOffset) + chr(ord(c.CC));
  w := C.FDStr;
  if GRFW(w) = '-1' then
    s := s + #0
  else
    s := s + #1;
  while W <> '' do
  begin
    n := grfw(w);
    grfw(w);
    if (n <> '') and (n[1] = '!') then
      s := s + #1
    else
      s := s + #0;
  end;
  P.RegProc.ImportDecl := s;
  C.FScriptProcNo := ProcNo;
  Result := True;
end;

function TIFPSInterfaceClass.Func_Find(const Name: string;
  var Index: Cardinal): Boolean;
var
  H: Longint;
  I: Longint;
  CurrClass: TIFPSInterface;
  C: TIFPSInterfaceMethod;
begin
  H := MakeHash(Name);
  CurrClass := FIntf;
  while CurrClass <> nil do
  begin
    for i := CurrClass.FItems.Count -1 downto 0 do
    begin
      C := CurrClass.FItems[I];
      if (C.NameHash = H) and (C.Name = Name) then
      begin
        Index := Cardinal(c);
        Result := True;
        exit;
      end;
    end;
    CurrClass := CurrClass.FInheritedFrom;
  end;
  Result := False;
end;

function TIFPSInterfaceClass.IsCompatibleWith(
  Cl: TIFPSExternalClass): Boolean;
var
  Temp: TIFPSInterface;
begin
  if not (cl is TIFPSInterfaceClass) then
  begin
    Result := False;
    exit;
  end;
  temp := TIFPSInterfaceClass(cl).FIntf;
  while Temp <> nil do
  begin
    if Temp = FIntf then
    begin
      Result := True;
      exit;
    end;
    Temp := Temp.FInheritedFrom;
  end;
  Result := False;
end;

function TIFPSInterfaceClass.SelfType: Cardinal;
begin
  Result := SE.FindType(IFPSInterfaceType);
  if Result = InvalidVal then
  begin
    TIFPSResourcePtrType(SE.AddType(IFPSInterfaceType, btResourcePointer)).ResourceType := 'Interface';
    Result := SE.FindType(IFPSInterfaceType);
  end;
end;

function TIFPSInterfaceClass.SetNil(var ProcNo: Cardinal): Boolean;
var
  P: TIFPSExternalProcedure;

begin
  if FNilProcNo <> InvalidVal then
  begin
    Procno := FNilProcNo;
    Result := True;
    exit;
  end;
  ProcNo := TMySE(Se).AddUsedFunction2(P);
  P.RegProc := SE.AddFunction(ProcHDR);
  P.RegProc.Name := '';
  P.RegProc.Decl := '-1 !VARNO '+IntToStr(TMySe(se).at2ut(FTypeNo));
  P.RegProc.ImportDecl := 'intf:-';
  FNilProcNo := Procno;
  Result := True;
end;


end.
