Browse Source

Adding TNullPtr to types

Additional changes:
* Now using TNullPtr instead of custom type in TNullable
* Adding assignment of variants with TNulPtr to avoid name conflicts
* Adding comparison to TNullPtr (Pointers, TObjects, TNullable)
Frederic Kehrein 10 months ago
parent
commit
23dd7a5173

+ 32 - 9
packages/rtl-objpas/src/inc/nullable.pp

@@ -22,14 +22,12 @@ unit nullable;
 interface
 interface
 
 
 {$IFDEF FPC_DOTTEDUNITS}
 {$IFDEF FPC_DOTTEDUNITS}
-uses System.SysUtils;
+uses System.SysUtils, System.Types;
 {$ELSE FPC_DOTTEDUNITS}
 {$ELSE FPC_DOTTEDUNITS}
-uses sysutils;
+uses sysutils, types;
 {$ENDIF FPC_DOTTEDUNITS}
 {$ENDIF FPC_DOTTEDUNITS}
 
 
 Type
 Type
-  TNull = record
-  end;
 
 
   { TNullable }
   { TNullable }
 
 
@@ -73,14 +71,19 @@ Type
     class operator Explicit(aValue: T): TMyType;
     class operator Explicit(aValue: T): TMyType;
     class operator Explicit(aValue: TMyType): T;
     class operator Explicit(aValue: TMyType): T;
     class operator := (aValue: T): TMyType;
     class operator := (aValue: T): TMyType;
-    class operator := (aValue: TNull): TMyType;
+    class operator := (aValue: TNullPtr): TMyType;
     class operator := (aValue: TMyType): T;
     class operator := (aValue: TMyType): T;
-    class operator Not (aValue: TMyType): Boolean;
+    class operator Not (const aValue: TMyType): Boolean; inline;
+    class operator =(const lhs: TMyType; rhs: TNullPtr): Boolean; inline;
+    class operator =(lhs: TNullPtr; const rhs: TMyType): Boolean; inline;
+    class operator <>(const lhs: TMyType; rhs: TNullPtr): Boolean; inline;
+    class operator <>(lhs: TNullPtr; const rhs: TMyType): Boolean; inline;
    end;
    end;
 
 
 {$Push}
 {$Push}
 {$WriteableConst Off}
 {$WriteableConst Off}
-const null: TNull = ();
+const
+  null: TNullPtr = ();
 {$Pop}
 {$Pop}
 
 
 implementation
 implementation
@@ -183,7 +186,7 @@ begin
   Result.Value:=aValue;
   Result.Value:=aValue;
 end;
 end;
 
 
-class operator TNullable.:=(aValue: TNull): TMyType;
+class operator TNullable.:=(aValue: TNullPtr): TMyType;
 begin
 begin
   Result := Default(TMyType);
   Result := Default(TMyType);
   Result.Clear;
   Result.Clear;
@@ -196,9 +199,29 @@ begin
   Result:=aValue.Value;
   Result:=aValue.Value;
 end;
 end;
 
 
-class operator TNullable.Not(aValue: TMyType): Boolean;
+class operator TNullable.not(const aValue: TMyType): Boolean;
 begin
 begin
   Result := Not aValue.HasValue;
   Result := Not aValue.HasValue;
 end;
 end;
 
 
+class operator TNullable.=(const lhs: TMyType; rhs: TNullPtr): Boolean;
+begin
+  Result := not lhs.HasValue;
+end;
+
+class operator TNullable.=(lhs: TNullPtr; const rhs: TMyType): Boolean;
+begin
+  Result := not rhs.HasValue;
+end;
+
+class operator TNullable.<>(const lhs: TMyType; rhs: TNullPtr): Boolean;
+begin
+  Result := lhs.HasValue;
+end;
+
+class operator TNullable.<>(lhs: TNullPtr; const rhs: TMyType): Boolean;
+begin
+  Result := rhs.HasValue;
+end;
+
 end.
 end.

+ 9 - 2
packages/rtl-objpas/src/inc/variants.pp

@@ -31,10 +31,10 @@ interface
 
 
 {$IFDEF FPC_DOTTEDUNITS}
 {$IFDEF FPC_DOTTEDUNITS}
   uses
   uses
-    System.SysUtils,System.SysConst,System.RtlConsts,System.TypInfo;
+    System.SysUtils,System.SysConst,System.RtlConsts,System.TypInfo,System.Types;
 {$ELSE FPC_DOTTEDUNITS}
 {$ELSE FPC_DOTTEDUNITS}
   uses
   uses
-    sysutils,sysconst,rtlconsts,typinfo;
+    sysutils,sysconst,rtlconsts,typinfo,types;
 {$ENDIF FPC_DOTTEDUNITS}
 {$ENDIF FPC_DOTTEDUNITS}
 
 
 type
 type
@@ -357,6 +357,8 @@ Procedure SetVariantProp(Instance: TObject; const PropName: AnsiString; const Va
 Procedure SetVariantProp(Instance: TObject; PropInfo : PPropInfo; const Value: Variant);
 Procedure SetVariantProp(Instance: TObject; PropInfo : PPropInfo; const Value: Variant);
 
 
 
 
+operator :=(ANullPtr: TNullPtr): Variant; inline;
+
 {$IFDEF DEBUG_VARIANTS}
 {$IFDEF DEBUG_VARIANTS}
 var
 var
   __DEBUG_VARIANTS: Boolean = False;
   __DEBUG_VARIANTS: Boolean = False;
@@ -4744,6 +4746,11 @@ begin
    end;
    end;
 end;
 end;
 
 
+operator :=(ANullPtr: TNullPtr): Variant;
+begin
+  Result := Null;
+end;
+
 var
 var
   i : LongInt;
   i : LongInt;
 
 

+ 76 - 0
rtl/objpas/types.pp

@@ -68,6 +68,30 @@ type
   LARGE_UINT= LargeUInt;
   LARGE_UINT= LargeUInt;
   PLargeuInt = ^LargeuInt;
   PLargeuInt = ^LargeuInt;
 
 
+  { Null dummy type, for compile time null passing }
+  TNullPtr = record
+    { Some operators to make it (more or less) nil compatible }
+    class operator :=(None: TNullPtr): Pointer; inline;
+    class operator :=(None: TNullPtr): TObject; inline;
+
+    class operator =(LHS: TNullPtr; RHS: Pointer): Boolean; inline;
+    class operator =(LHS: TNullPtr; RHS: TObject): Boolean; inline;
+    class operator =(LHS: Pointer; RHS: TNullPtr): Boolean; inline;
+    class operator =(LHS: TObject; RHS: TNullPtr): Boolean; inline;
+
+    class operator <>(LHS: TNullPtr; RHS: Pointer): Boolean; inline;
+    class operator <>(LHS: TNullPtr; RHS: TObject): Boolean; inline;
+    class operator <>(LHS: Pointer; RHS: TNullPtr): Boolean; inline;
+    class operator <>(LHS: TObject; RHS: TNullPtr): Boolean; inline;
+  end;
+
+  {$Push}
+  {$WriteableConst Off}
+const
+  NullPtr: TNullPtr = ();
+  {$Pop}
+
+type
   TBooleanDynArray = array of Boolean;
   TBooleanDynArray = array of Boolean;
   TByteDynArray = array of Byte;
   TByteDynArray = array of Byte;
   TClassicByteDynArray = TByteDynArray;
   TClassicByteDynArray = TByteDynArray;
@@ -1041,6 +1065,58 @@ begin
   Result:=S;
   Result:=S;
 end;
 end;
 
 
+{ TNullPtr }
+
+class operator TNullPtr.:=(None: TNullPtr): Pointer;
+begin
+  Result := nil;
+end;
+
+class operator TNullPtr.:=(None: TNullPtr): TObject;
+begin
+  Result := nil;
+end;
+
+class operator TNullPtr.=(LHS: TNullPtr; RHS: Pointer): Boolean;
+begin
+  Result := not Assigned(RHS);
+end;
+
+class operator TNullPtr.=(LHS: TNullPtr; RHS: TObject): Boolean;
+begin
+  Result := not Assigned(RHS);
+end;
+
+class operator TNullPtr.=(LHS: Pointer; RHS: TNullPtr): Boolean;
+begin
+  Result := not Assigned(LHS);
+end;
+
+class operator TNullPtr.=(LHS: TObject; RHS: TNullPtr): Boolean;
+begin
+  Result := not Assigned(LHS);
+end;
+
+class operator TNullPtr.<>(LHS: TNullPtr; RHS: Pointer): Boolean;
+begin
+  Result := Assigned(RHS);
+end;
+
+class operator TNullPtr.<>(LHS: TNullPtr; RHS: TObject): Boolean;
+begin
+  Result := Assigned(RHS);
+end;
+
+class operator TNullPtr.<>(LHS: Pointer; RHS: TNullPtr): Boolean;
+begin
+  Result := Assigned(LHS);
+end;
+
+class operator TNullPtr.<>(LHS: TObject; RHS: TNullPtr): Boolean;
+begin
+  Result := Assigned(LHS);
+end;
+
 { TPointF}
 { TPointF}
 
 
 function TPointF.ToString : RTLString;
 function TPointF.ToString : RTLString;

+ 28 - 0
tests/test/units/nullable/tnull.pp

@@ -208,6 +208,33 @@ begin
     Exit('Null assignement not correct');
     Exit('Null assignement not correct');
 end;
 end;
 
 
+Function TestCompareNull : string;
+
+Var
+  A : specialize TNullable<String>;
+begin
+  Result:='';
+  A.Value:=Val1;
+  If A = null then
+    Exit('Compare to null not correct');
+  If null = A then
+    Exit('Compare to null not correct');
+  If not (A <> null) then
+    Exit('Compare to null not correct');
+  If not (A <> null) then
+    Exit('Compare to null not correct');
+
+  A.Clear;
+  If not (A = null) then
+    Exit('Compare to null not correct');
+  If not (null = A) then
+    Exit('Compare to null not correct');
+  If A <> null then
+    Exit('Compare to null not correct');
+  If A <> null then
+    Exit('Compare to null not correct');
+end;
+
 Function TestBoolCheck : string;
 Function TestBoolCheck : string;
 
 
 Var
 Var
@@ -297,6 +324,7 @@ begin
   DoTest('TestGetEmptyValue',TestGetEmptyValue);
   DoTest('TestGetEmptyValue',TestGetEmptyValue);
   DoTest('TestGetEmptyValueOrDefault',TestGetEmptyValueOrDefault);
   DoTest('TestGetEmptyValueOrDefault',TestGetEmptyValueOrDefault);
   DoTest('TestAssignNull',TestAssignNull);
   DoTest('TestAssignNull',TestAssignNull);
+  DoTest('TestCompareNull',TestCompareNull);
   DoTest('TestBoolCheck',TestBoolCheck);
   DoTest('TestBoolCheck',TestBoolCheck);
   DoTest('TestUnpack',TestUnpack);
   DoTest('TestUnpack',TestUnpack);
   DoTest('TestValueOr',TestValueOr);
   DoTest('TestValueOr',TestValueOr);

+ 66 - 0
tests/test/units/types/tnullptr.pp

@@ -0,0 +1,66 @@
+program testnullptr;
+
+{$mode objfpc}
+{$h+}
+
+uses types;
+
+Function TestAssign : String;
+
+Var
+  A: TObject;
+  B: Pointer;
+
+begin
+  Result:='';
+  A:=TObject(1);
+  A:=nullptr;
+  If Assigned(A) then
+    Exit('Assignment should set to nil');
+  B:=Pointer(1);
+  B:=nullptr;
+  If Assigned(B) then
+    Exit('Assignment should set to nil');
+end;
+
+Function TestCompare : String;
+
+begin
+  Result:='';
+  If not (nullptr = nil) then
+    Exit('nullptr should compare to nil');
+  If not (nullptr = TObject(nil)) then
+    Exit('nullptr should compare to nil');
+  If not (nil = nullptr) then
+    Exit('nullptr should compare to nil');
+  If not (TObject(nil) = nullptr) then
+    Exit('nullptr should compare to nil');
+
+  If nullptr <> nil then
+    Exit('nullptr should compare to nil');
+  If nullptr <> TObject(nil) then
+    Exit('nullptr should compare to nil');
+  If nil <> nullptr then
+    Exit('nullptr should compare to nil');
+  If TObject(nil) <> nullptr then
+    Exit('nullptr should compare to nil');
+end;
+
+Procedure DoTest(aTest,aResult : String);
+
+begin
+  if aResult<>'' then
+    begin
+    writeln(aTest,' failed : ',aResult);
+    Halt(1);
+    end
+  else
+    Writeln(aTest,' OK.');
+end;
+
+
+begin
+  DoTest('TestAssign',TestAssign);
+  DoTest('TestCompare',TestCompare);
+end.
+

+ 15 - 0
tests/test/units/variants/tvariants.pp

@@ -0,0 +1,15 @@
+program tvariants;
+
+{$mode objfpc}
+
+uses
+  Variants, types;
+
+var
+  v: Variant;
+begin
+  v:=nullptr;
+  if not VarIsNull(v) then
+    ExitCode:=1;
+end.
+