* Use pointer get/set methods

git-svn-id: trunk@37496 -

rtl/objpas/typinfo.pp

@@ -1403,6 +1403,7 @@ end;
   ---------------------------------------------------------------------}
 
 Function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Int64;
+
 type
   TGetInt64ProcIndex=function(index:longint):Int64 of object;
   TGetInt64Proc=function():Int64 of object;
@@ -1425,6 +1426,7 @@ begin
   Signed := false;
   DataSize := 4;
   case TypeInfo^.Kind of
+// We keep this for backwards compatibility, but internally it is no longer used.
 {$ifdef cpu64}
     tkInterface,
     tkInterfaceRaw,
@@ -1506,13 +1508,14 @@ begin
           end;
         end;
       end;
+  else
+    raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
   end;
 end;
 
-Resourcestring
-  SErrCannotWriteToProperty = 'Cannot write to property %s.';
 
 Procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo;Value : Int64);
+
 type
   TSetInt64ProcIndex=procedure(index:longint;i:Int64) of object;
   TSetInt64Proc=procedure(i:Int64) of object;
@@ -1692,6 +1695,73 @@ begin
   SetOrdProp(Instance,PropInfo,StringToSet(PropInfo,Value));
 end;
 
+{ ---------------------------------------------------------------------
+  Pointer properties - internal only
+  ---------------------------------------------------------------------}
+
+Function GetPointerProp(Instance: TObject; PropInfo : PPropInfo): Pointer;
+
+Type
+  TGetPointerProcIndex = function (index:longint): Pointer of object;
+  TGetPointerProc = function (): Pointer of object;
+
+var
+  AMethod : TMethod;
+
+begin
+  case (PropInfo^.PropProcs) and 3 of
+  ptField:
+    Result := PPointer(Pointer(Instance) + LongWord(PropInfo^.GetProc))^;
+  ptStatic,
+  ptVirtual:
+    begin
+      if (PropInfo^.PropProcs and 3)=ptStatic then
+        AMethod.Code:=PropInfo^.GetProc
+      else
+        AMethod.Code:=PCodePointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^;
+      AMethod.Data:=Instance;
+      if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
+        Result:=TGetPointerProcIndex(AMethod)(PropInfo^.Index)
+      else
+        Result:=TGetPointerProc(AMethod)();
+    end;
+  else
+    raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
+  end;
+end;
+
+Procedure SetPointerProp(Instance: TObject; PropInfo : PPropInfo;  Value: Pointer);
+
+type
+  TSetPointerProcIndex = procedure(index: longint; p: pointer) of object;
+  TSetPointerProc = procedure(p: pointer) of object;
+
+var
+  AMethod : TMethod;
+
+begin
+  case (PropInfo^.PropProcs shr 2) and 3 of
+    ptField:
+      PPointer(Pointer(Instance) + LongWord(PropInfo^.SetProc))^:=Value;
+    ptStatic,
+    ptVirtual:
+      begin
+        if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
+          AMethod.Code:=PropInfo^.SetProc
+        else
+          AMethod.Code:=PCodePointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
+        AMethod.Data:=Instance;
+        if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
+          TSetPointerProcIndex(AMethod)(PropInfo^.Index,Value)
+        else
+          TSetPointerProc(AMethod)(Value);
+      end;
+  else
+    raise EPropertyError.CreateFmt(SErrCannotWriteToProperty, [PropInfo^.Name]);
+  end;
+end;
+
+
 { ---------------------------------------------------------------------
   Object properties
   ---------------------------------------------------------------------}
@@ -1716,11 +1786,7 @@ end;
 
 Function GetObjectProp(Instance: TObject; PropInfo : PPropInfo; MinClass: TClass): TObject;
 begin
-{$ifdef cpu64}
-  Result:=TObject(GetInt64Prop(Instance,PropInfo));
-{$else cpu64}
-  Result:=TObject(PtrInt(GetOrdProp(Instance,PropInfo)));
-{$endif cpu64}
+  Result:=TObject(GetPointerProp(Instance,PropInfo));
   If (MinClass<>Nil) and (Result<>Nil) Then
     If Not Result.InheritsFrom(MinClass) then
       Result:=Nil;
@@ -1734,12 +1800,9 @@ end;
 
 
 Procedure SetObjectProp(Instance: TObject; PropInfo : PPropInfo;  Value: TObject);
+
 begin
-{$ifdef cpu64}
-  SetInt64Prop(Instance,PropInfo,Int64(Value));
-{$else cpu64}
-  SetOrdProp(Instance,PropInfo,PtrInt(Value));
-{$endif cpu64}
+  SetPointerProp(Instance,PropInfo,Pointer(Value));
 end;
 
 
@@ -1748,6 +1811,7 @@ begin
   Result:=GetTypeData(FindPropInfo(Instance,PropName,[tkClass])^.PropType)^.ClassType;
 end;
 
+
 Function  GetObjectPropClass(AClass: TClass; const PropName: string): TClass;
 begin
   Result:=GetTypeData(FindPropInfo(AClass,PropName,[tkClass])^.PropType)^.ClassType;
@@ -1789,6 +1853,8 @@ begin
         else
           Result:=TGetInterfaceProc(AMethod)();
       end;
+  else
+    raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
   end;
 end;
 
@@ -1800,11 +1866,14 @@ begin
 end;
 
 procedure SetInterfaceProp(Instance: TObject; PropInfo: PPropInfo; const Value: IInterface);
+
 type
   TSetIntfStrProcIndex=procedure(index:longint;const i:IInterface) of object;
   TSetIntfStrProc=procedure(i:IInterface) of object;
+
 var
   AMethod : TMethod;
+
 begin
   case Propinfo^.PropType^.Kind of
     tkInterface:
@@ -1848,11 +1917,7 @@ end;
 function GetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo): Pointer;
 
 begin
-{$ifdef cpu64}
-  Result:=Pointer(GetInt64Prop(Instance,PropInfo));
-{$else cpu64}
-  Result:=Pointer(PtrInt(GetOrdProp(Instance,PropInfo)));
-{$endif cpu64}
+  Result:=GetPointerProp(Instance,PropInfo);
 end;
 
 procedure SetRawInterfaceProp(Instance: TObject; const PropName: string; const Value: Pointer);
@@ -1862,38 +1927,9 @@ begin
 end;
 
 procedure SetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
-type
-  TSetPointerProcIndex=procedure(index:longint;const i:Pointer) of object;
-  TSetPointerProc=procedure(i:Pointer) of object;
-var
-  AMethod : TMethod;
+
 begin
-  case Propinfo^.PropType^.Kind of
-    tkInterfaceRaw:
-      begin
-        case (PropInfo^.PropProcs shr 2) and 3 of
-          ptField:
-            PPointer(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
-          ptStatic,
-          ptVirtual:
-            begin
-              if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
-                AMethod.Code:=PropInfo^.SetProc
-              else
-                AMethod.Code:=PCodePointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
-              AMethod.Data:=Instance;
-              if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
-                TSetPointerProcIndex(AMethod)(PropInfo^.Index,Value)
-              else
-                TSetPointerProc(AMethod)(Value);
-            end;
-          else
-            raise EPropertyError.CreateFmt(SErrCannotWriteToProperty, [PropInfo^.Name]);
-        end;
-      end;
-    tkInterface:
-      Raise Exception.Create('Cannot set interface from RAW interface');
-  end;
+  SetPointerProp(Instance,PropInfo,Value);
 end;
 
 { ---------------------------------------------------------------------
@@ -1906,14 +1942,17 @@ begin
 end;
 
 function GetDynArrayProp(Instance: TObject; PropInfo: PPropInfo): Pointer;
+
 type
   { we need a dynamic array as that type is usually passed differently from
     a plain pointer }
   TDynArray=array of Byte;
   TGetDynArrayProc=function:TDynArray of object;
   TGetDynArrayProcIndex=function(index:longint):TDynArray of object;
+
 var
   AMethod : TMethod;
+
 begin
   Result:=nil;
   if PropInfo^.PropType^.Kind<>tkDynArray then
@@ -1934,6 +1973,8 @@ begin
         else
           Result:=Pointer(TGetDynArrayProc(AMethod)());
       end;
+  else
+    raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
   end;
 end;
 
@@ -1943,14 +1984,17 @@ begin
 end;
 
 procedure SetDynArrayProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
+
 type
   { we need a dynamic array as that type is usually passed differently from
     a plain pointer }
   TDynArray=array of Byte;
   TSetDynArrayProcIndex=procedure(index:longint;const i:TDynArray) of object;
   TSetDynArrayProc=procedure(i:TDynArray) of object;
+
 var
   AMethod: TMethod;
+
 begin
   if PropInfo^.PropType^.Kind<>tkDynArray then
     Exit;
@@ -1980,13 +2024,16 @@ end;
   ---------------------------------------------------------------------}
 
 Function GetStrProp(Instance: TObject; PropInfo: PPropInfo): AnsiString;
+
 type
   TGetShortStrProcIndex=function(index:longint):ShortString of object;
   TGetShortStrProc=function():ShortString of object;
   TGetAnsiStrProcIndex=function(index:longint):AnsiString of object;
   TGetAnsiStrProc=function():AnsiString of object;
+
 var
   AMethod : TMethod;
+
 begin
   Result:='';
   case Propinfo^.PropType^.Kind of
@@ -2012,6 +2059,8 @@ begin
               else
                 Result:=TGetShortStrProc(AMethod)();
             end;
+        else
+          raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
         end;
       end;
     tkAString:
@@ -2032,6 +2081,8 @@ begin
               else
                 Result:=TGetAnsiStrProc(AMethod)();
             end;
+        else
+          raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
         end;
       end;
   end;
@@ -2039,13 +2090,16 @@ end;
 
 
 Procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo; const Value : AnsiString);
+
 type
   TSetShortStrProcIndex=procedure(index:longint;const s:ShortString) of object;
   TSetShortStrProc=procedure(const s:ShortString) of object;
   TSetAnsiStrProcIndex=procedure(index:longint;s:AnsiString) of object;
   TSetAnsiStrProc=procedure(s:AnsiString) of object;
+
 var
   AMethod : TMethod;
+
 begin
   case Propinfo^.PropType^.Kind of
     tkWString:
@@ -2096,8 +2150,6 @@ begin
             raise EPropertyError.CreateFmt(SErrCannotWriteToProperty, [PropInfo^.Name]);
         end;
       end;
-  else
-    raise EPropertyError.CreateFmt(SErrCannotWriteToProperty, [PropInfo^.Name]);
   end;
 end;
 
@@ -2157,6 +2209,8 @@ begin
               else
                 Result:=TGetWideStrProc(AMethod)();
             end;
+        else
+          raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
         end;
       end;
   end;
@@ -2201,23 +2255,28 @@ begin
 end;
 
 Function GetUnicodeStrProp(Instance: TObject; const PropName: string): UnicodeString;
+
 begin
   Result:=GetUnicodeStrProp(Instance, FindPropInfo(Instance, PropName));
 end;
 
 
 procedure SetUnicodeStrProp(Instance: TObject; const PropName: string; const Value: UnicodeString);
+
 begin
   SetUnicodeStrProp(Instance,FindPropInfo(Instance,PropName),Value);
 end;
 
 
 Function GetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo): UnicodeString;
+
 type
   TGetUnicodeStrProcIndex=function(index:longint):UnicodeString of object;
   TGetUnicodeStrProc=function():UnicodeString of object;
+
 var
   AMethod : TMethod;
+
 begin
   Result:='';
   case Propinfo^.PropType^.Kind of
@@ -2243,6 +2302,8 @@ begin
               else
                 Result:=TGetUnicodeStrProc(AMethod)();
             end;
+        else
+          raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
         end;
       end;
   end;
@@ -2250,11 +2311,14 @@ end;
 
 
 Procedure SetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: UnicodeString);
+
 type
   TSetUnicodeStrProcIndex=procedure(index:longint;s:UnicodeString) of object;
   TSetUnicodeStrProc=procedure(s:UnicodeString) of object;
+
 var
   AMethod : TMethod;
+
 begin
   case Propinfo^.PropType^.Kind of
     tkSString,tkAString:
@@ -2291,8 +2355,10 @@ function GetRawbyteStrProp(Instance: TObject; PropInfo: PPropInfo): RawByteStrin
 type
   TGetRawByteStrProcIndex=function(index:longint): RawByteString of object;
   TGetRawByteStrProc=function():RawByteString of object;
+
 var
   AMethod : TMethod;
+
 begin
   Result:='';
   case Propinfo^.PropType^.Kind of
@@ -2320,6 +2386,8 @@ begin
               else
                 Result:=TGetRawByteStrProc(AMethod)();
             end;
+          else
+            raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
         end;
       end;
   end;
@@ -2335,8 +2403,10 @@ procedure SetRawByteStrProp(Instance: TObject; PropInfo: PPropInfo; const Value:
 type
   TSetRawByteStrProcIndex=procedure(index:longint;s:RawByteString) of object;
   TSetRawByteStrProc=procedure(s:RawByteString) of object;
+
 var
   AMethod : TMethod;
+
 begin
   case Propinfo^.PropType^.Kind of
     tkWString:
@@ -2369,11 +2439,11 @@ begin
       end;
   end;
 end;
+
 procedure SetRawByteStrProp(Instance: TObject; const PropName: string; const Value: RawByteString);
 
 begin
   SetRawByteStrProp(Instance,FindPropInfo(Instance,PropName),Value);
-
 end;
 
 
@@ -2385,6 +2455,7 @@ end;
   ---------------------------------------------------------------------}
 
 function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
+
 type
   TGetExtendedProc = function:Extended of object;
   TGetExtendedProcIndex = function(Index: integer): Extended of object;
@@ -2394,8 +2465,10 @@ type
   TGetSingleProcIndex = function(Index: integer):Single of object;
   TGetCurrencyProc = function : Currency of object;
   TGetCurrencyProcIndex = function(Index: integer) : Currency of object;
+
 var
   AMethod : TMethod;
+
 begin
   Result:=0.0;
   case PropInfo^.PropProcs and 3 of
@@ -2443,11 +2516,14 @@ begin
               Result:=TGetCurrencyProcIndex(AMethod)(PropInfo^.Index);
         end;
       end;
+  else
+    raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
   end;
 end;
 
 
 Procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo; Value : Extended);
+
 type
   TSetExtendedProc = procedure(const AValue: Extended) of object;
   TSetExtendedProcIndex = procedure(Index: integer; AValue: Extended) of object;
@@ -2457,8 +2533,10 @@ type
   TSetSingleProcIndex = procedure(Index: integer; AValue: Single) of object;
   TSetCurrencyProc = procedure(const AValue: Currency) of object;
   TSetCurrencyProcIndex = procedure(Index: integer;  AValue: Currency) of object;
+
 Var
   AMethod : TMethod;
+
 begin
   case (PropInfo^.PropProcs shr 2) and 3 of
     ptfield:
@@ -2535,12 +2613,15 @@ end;
 
 
 Function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
+
 type
   TGetMethodProcIndex=function(Index: Longint): TMethod of object;
   TGetMethodProc=function(): TMethod of object;
+
 var
   value: PMethod;
   AMethod : TMethod;
+
 begin
   Result.Code:=nil;
   Result.Data:=nil;
@@ -2564,16 +2645,21 @@ begin
         else
           Result:=TGetMethodProc(AMethod)();
       end;
+  else
+    raise EPropertyError.CreateFmt(SErrCannotReadProperty, [PropInfo^.Name]);
   end;
 end;
 
 
 Procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo; const Value : TMethod);
+
 type
   TSetMethodProcIndex=procedure(index:longint;p:TMethod) of object;
   TSetMethodProc=procedure(p:TMethod) of object;
+
 var
   AMethod : TMethod;
+
 begin
   case (PropInfo^.PropProcs shr 2) and 3 of
     ptField:
@@ -2629,8 +2715,8 @@ end;
 
 Procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo; const Value: Variant);
 begin
-   CheckVariantEvent(CodePointer(OnSetVariantProp));
-   OnSetVariantProp(Instance,PropInfo,Value);
+  CheckVariantEvent(CodePointer(OnSetVariantProp));
+  OnSetVariantProp(Instance,PropInfo,Value);
 end;