+ Patch from Mattias Gaertner for single typeinfo

rtl/i386/typinfo.inc

@@ -58,7 +58,8 @@ Function CallIntegerProc(s : Pointer;Address : Pointer;Value : Integer; INdex,IV
      call %edi
   end;
 
-Function CallExtendedFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint) : Extended;assembler;
+Function CallSingleFunc(s : Pointer; Address : Pointer;
+  Index, IValue : Longint) : Single; assembler;
   asm
      movl S,%esi
      movl Address,%edi
@@ -74,24 +75,37 @@ Function CallExtendedFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint)
      //
   end;
 
-Function CallExtendedProc(s : Pointer;Address : Pointer;Value : Extended; INdex,IVAlue : Longint) : Integer;assembler;
+Function CallDoubleFunc(s : Pointer; Address : Pointer;
+  Index, IValue : Longint) : Double; assembler;
   asm
      movl S,%esi
      movl Address,%edi
-     // Push value to set
-     leal Value,%eax
-     pushl (%eax)
-     pushl 4(%eax)
-     pushl 8(%eax)
-     // ? Indexed Procedure
+     // ? Indexed Function
      movl Index,%eax
      testl %eax,%eax
-     je .LIPNoPush
+     je .LINoPush
      movl IValue,%eax
      pushl %eax
-  .LIPNoPush:
+  .LINoPush:
+     push %esi
+     call %edi
+     //
+  end;
+
+Function CallExtendedFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint) : Extended;assembler;
+  asm
+     movl S,%esi
+     movl Address,%edi
+     // ? Indexed Function
+     movl Index,%eax
+     testl %eax,%eax
+     je .LINoPush
+     movl IValue,%eax
+     pushl %eax
+  .LINoPush:
      push %esi
      call %edi
+     //
   end;
 
 Function CallBooleanFunc(s : Pointer;Address : Pointer; Index,IValue : Longint) : Boolean;assembler;
@@ -153,7 +167,10 @@ Procedure CallSStringProc(s : Pointer;Address : Pointer;Const Value : ShortStrin
 
 {
   $Log$
-  Revision 1.4  2002-09-07 16:01:19  peter
+  Revision 1.5  2003-03-29 16:55:56  michael
+  + Patch from Mattias Gaertner for single typeinfo
+
+  Revision 1.4  2002/09/07 16:01:19  peter
     * old logs removed and tabs fixed
 
 }

rtl/linux/i386/signal.inc

@@ -14,6 +14,7 @@
  **********************************************************************}
 
 {$packrecords C}
+
 const
   SI_PAD_SIZE   = ((128/sizeof(longint)) - 3);
 
@@ -130,6 +131,7 @@ Procedure SigAction(Signum:Integer;Act,OldAct:PSigActionRec );
   If Act is non-nil, it is used to specify the new action.
   If OldAct is non-nil the previous action is saved there.
 }
+
 Var
   sr : Syscallregs;
 begin
@@ -141,7 +143,10 @@ end;
 
 {
   $Log$
-  Revision 1.3  2002-09-07 16:01:20  peter
+  Revision 1.4  2003-03-29 16:55:56  michael
+  + Patch from Mattias Gaertner for single typeinfo
+
+  Revision 1.3  2002/09/07 16:01:20  peter
     * old logs removed and tabs fixed
 
 }

rtl/objpas/typinfo.pp

@@ -893,63 +893,125 @@ end;
 { ---------------------------------------------------------------------
   Float properties
   ---------------------------------------------------------------------}
-
 Function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
 
 var
-         Index,Ivalue : longint;
-         Value : Extended;
-
-begin
-         SetIndexValues(PropInfo,Index,Ivalue);
-         case (PropInfo^.PropProcs) and 3 of
-            ptfield:
-              Case GetTypeData(PropInfo^.PropType)^.FloatType of
-               ftSingle:
-                 Value:=PSingle(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
-               ftDouble:
-                 Value:=PDouble(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
-               ftExtended:
-                 Value:=PExtended(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
+  Index,Ivalue : longint;
+  Value : Extended;
+
+begin
+  SetIndexValues(PropInfo,Index,Ivalue);
+  case (PropInfo^.PropProcs) and 3 of
+    ptField:
+      Case GetTypeData(PropInfo^.PropType)^.FloatType of
+       ftSingle:
+         Value:=PSingle(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
+       ftDouble:
+         Value:=PDouble(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
+       ftExtended:
+         Value:=PExtended(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
 {$ifndef m68k}
-               ftcomp:
-                 Value:=PComp(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
+       ftcomp:
+         Value:=PComp(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
 {$endif m68k}
-               end;
-            ptstatic:
-              Value:=CallExtendedFunc(Instance,PropInfo^.GetProc,Index,IValue);
-            ptvirtual:
-              Value:=CallExtendedFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue);
-         end;
-         Result:=Value;
+       end;
+
+    ptStatic:
+      Case GetTypeData(PropInfo^.PropType)^.FloatType of
+       ftSingle:
+         Value:=CallSingleFunc(Instance,PropInfo^.GetProc,Index,IValue);
+       ftDouble:
+         Value:=CallDoubleFunc(Instance,PropInfo^.GetProc,Index,IValue);
+       ftExtended:
+         Value:=CallExtendedFunc(Instance,PropInfo^.GetProc,Index,IValue);
+      end;
+
+    ptVirtual:
+      Case GetTypeData(PropInfo^.PropType)^.FloatType of
+       ftSingle:
+         Value:=CallSingleFunc(Instance,
+              PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,
+              Index,IValue);
+       ftDouble:
+         Value:=CallDoubleFunc(Instance,
+              PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,
+              Index,IValue);
+       ftExtended:
+         Value:=CallExtendedFunc(Instance,
+              PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,
+              Index,IValue);
+      end;
+  end;
+  Result:=Value;
 end;
 
 Procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo;
-      Value : Extended);
-
-       Var IValue,Index : longint;
+  Value : Extended);
 
-begin
-         SetIndexValues(PropInfo,Index,Ivalue);
-         case (PropInfo^.PropProcs shr 2) and 3 of
-            ptfield:
-              Case GetTypeData(PropInfo^.PropType)^.FloatType of
-               ftSingle:
-                 PSingle(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
-               ftDouble:
-                 PDouble(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
-               ftExtended:
-                 PExtended(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
+type
+  TSetExtendedProc = procedure(const AValue: Extended) of object;
+  TSetExtendedProcIndex = procedure(Index: integer; const AValue: Extended) of object;
+  TSetDoubleProc = procedure(const AValue: Double) of object;
+  TSetDoubleProcIndex = procedure(Index: integer; const AValue: Double) of object;
+  TSetSingleProc = procedure(const AValue: Single) of object;
+  TSetSingleProcIndex = procedure(Index: integer; const AValue: Single) of object;
+
+Var IValue,Index : longint;
+  AMethod: TMethod;
+
+begin
+  SetIndexValues(PropInfo,Index,Ivalue);
+  case (PropInfo^.PropProcs shr 2) and 3 of
+
+    ptfield:
+      Case GetTypeData(PropInfo^.PropType)^.FloatType of
+        ftSingle:
+          PSingle(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
+        ftDouble:
+          PDouble(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
+        ftExtended:
+          PExtended(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
 {$ifndef m68k}
-               ftcomp:
-                 PComp(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Comp(Value);
+       ftcomp:
+          PComp(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Comp(Value);
 {$endif m68k}
-               end;
-            ptstatic:
-              CallExtendedProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
-            ptvirtual:
-              CallExtendedProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Value,Index,IValue);
-         end;
+        { Uncommenting this code results in a internal error!!
+       ftFixed16:
+         PFixed16(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
+       ftfixed32:
+         PFixed32(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
+       }
+       end;
+
+    ptStatic, ptVirtual:
+      begin
+        if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
+          AMethod.Code:=PropInfo^.SetProc
+        else
+          AMethod.Code:=
+            PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^;
+        AMethod.Data:=Instance;
+        Case GetTypeData(PropInfo^.PropType)^.FloatType of
+          ftSingle:
+            if Index=0 then
+              TSetSingleProc(AMethod)(Value)
+            else
+              TSetSingleProcIndex(AMethod)(IValue,Value);
+
+          ftDouble:
+            if Index=0 then
+              TSetDoubleProc(AMethod)(Value)
+            else
+              TSetDoubleProcIndex(AMethod)(IValue,Value);
+
+          ftExtended:
+            if Index=0 then
+              TSetExtendedProc(AMethod)(Value)
+            else
+              TSetExtendedProcIndex(AMethod)(IValue,Value);
+        end;
+      end;
+  end;
 end;
 
 Function GetFloatProp(Instance: TObject; const PropName: string): Extended;
@@ -1151,7 +1213,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.14  2002-09-07 16:01:22  peter
+  Revision 1.15  2003-03-29 16:55:56  michael
+  + Patch from Mattias Gaertner for single typeinfo
+
+  Revision 1.14  2002/09/07 16:01:22  peter
     * old logs removed and tabs fixed
 
   Revision 1.13  2002/04/04 18:32:59  peter