[fpc-pascal] Primitive Record Wrappers

[Mazola Winstrol]

I've implemented a new version. For this version i created a mock class to
use with FHasValue (the previous implementation uses a hack to the
interface internal layout).


unit NullableTypes;

{$mode delphi}{$H+}

interface

type

  { TMockInterfacedObject }

  TMockInterfacedObject = class(TObject, IUnknown)
  strict private
    class var FInstance: TMockInterfacedObject;
  public
    class constructor Create;
    class destructor Destroy;
    class property Instance: TMockInterfacedObject read FInstance;
    function QueryInterface({$IFDEF
FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) :
longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
    function _AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
    function _Release: longint; {$IFNDEF
WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  end;

  { TNullable }

  TNullable<T> = record
  strict private
    FValue: T;
    FHasValue: IInterface;
    function GetValue: T;
    function GetHasValue: Boolean;
    procedure SetValue(const AValue: T);
    procedure SetFlatInterface(var Intf: IInterface);
  public
    constructor Create(const AValue: T);
    procedure Clear;
    function GetValueOrDefault: T; overload;
    function GetValueOrDefault(Default: T): T; overload;
    property HasValue: Boolean read GetHasValue;
    property Value: T read GetValue;

    class operator Implicit(const AValue: Pointer): TNullable<T>;
    class operator Implicit(AValue: TNullable<T>): T;
    class operator Implicit(const AValue: T): TNullable<T>;
    class operator Explicit(AValue: TNullable<T>): T;
  end;


  TInteger = TNullable<Integer>;

implementation

uses
  SysUtils;

{ TNullable }

procedure TNullable<T>.SetFlatInterface(var Intf: IInterface);
begin
  Intf := TMockInterfacedObject.Instance;
end;

class operator TNullable<T>.Explicit(AValue: TNullable<T>): T;
begin
  Result := AValue.Value;
end;

function TNullable<T>.GetHasValue: Boolean;
begin
  Result := FHasValue <> nil;
end;

function TNullable<T>.GetValue: T;
begin
  if not HasValue then
    raise Exception.Create('Invalid operation, Nullable type has no value');
  Result := FValue;
end;

function TNullable<T>.GetValueOrDefault: T;
begin
  if HasValue then
    Result := FValue
  else
   Result := Default(T);
end;

function TNullable<T>.GetValueOrDefault(Default: T): T;
begin
  if not HasValue then
    Result := Default
  else
    Result := FValue;
end;

class operator TNullable<T>.Implicit(const AValue: Pointer): TNullable<T>;
begin
  if AValue = nil then
    Result.Clear
  else
    raise Exception.Create('Invalid operation, incompatible values.');
end;

class operator TNullable<T>.Implicit(AValue: TNullable<T>): T;
begin
  Result := AValue.Value;
end;

class operator TNullable<T>.Implicit(const AValue: T): TNullable<T>;
begin
  Result := TNullable<T>.Create(AValue);
end;

procedure TNullable<T>.SetValue(const AValue: T);
begin
  FValue := AValue;
  SetFlatInterface(FHasValue);
end;

constructor TNullable<T>.Create(const AValue: T);
begin
  FValue := AValue;
  SetFlatInterface(FHasValue);
end;

procedure TNullable<T>.Clear;
begin
  FHasValue := nil;
end;

{ TMockInterfacedObject }

class constructor TMockInterfacedObject.Create;
begin
  FInstance := TMockInterfacedObject.Create;
end;

class destructor TMockInterfacedObject.Destroy;
begin
  FInstance.Free;
end;

function TMockInterfacedObject.QueryInterface({$IFDEF
FPC_HAS_CONSTREF}constref
  {$ELSE}const{$ENDIF} iid : tguid;out obj): longint;
begin
  Result := E_NOINTERFACE;
end;

function TMockInterfacedObject._AddRef: longint;
begin
  Result := -1;
end;

function TMockInterfacedObject._Release: longint;
begin
  Result := -1;
end;

end.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.freepascal.org/pipermail/fpc-pascal/attachments/20160227/7d4c1870/attachment.html>