--- Merging r14435 into '.':

U    rtl/objpas/sysutils/sysstr.inc
U    rtl/objpas/sysutils/sysstrh.inc
--- Merging r14490 into '.':
G    rtl/objpas/sysutils/sysstr.inc
--- Merging r14513 into '.':
U    rtl/objpas/classes/streams.inc
U    rtl/objpas/classes/classesh.inc
--- Merging r14523 into '.':
G    rtl/objpas/classes/streams.inc
G    rtl/objpas/classes/classesh.inc
--- Merging r14936 into '.':
U    rtl/inc/objpash.inc
U    rtl/inc/objpas.inc
U    rtl/objpas/classes/compon.inc
G    rtl/objpas/classes/classesh.inc
--- Merging r14947 into '.':
G    rtl/objpas/classes/compon.inc
G    rtl/objpas/classes/classesh.inc
--- Merging r14948 into '.':
G    rtl/objpas/classes/compon.inc
G    rtl/objpas/classes/classesh.inc
A    tests/test/units/classes/tvclcomobject.pp
--- Merging r15032 into '.':
U    rtl/objpas/dateutil.inc
A    tests/webtbs/tw16040.pp
--- Merging r15033 into '.':
U    rtl/objpas/rtlconst.inc
U    rtl/objpas/sysconst.pp
--- Merging r15037 into '.':
G    rtl/objpas/dateutil.inc
U    tests/webtbs/tw16040.pp

# revisions: 14435,14490,14513,14523,14936,14947,14948,15032,15033,15037
------------------------------------------------------------------------
r14435 | florian | 2009-12-13 12:42:05 +0100 (Sun, 13 Dec 2009) | 2 lines
Changed paths:
   M /trunk/rtl/objpas/sysutils/sysstr.inc
   M /trunk/rtl/objpas/sysutils/sysstrh.inc

* change length parameter of CompareMem/CompareMemRange into PtrUInt, resolves #15190
* use CompareByte inside these routines instead of simple handmade code
------------------------------------------------------------------------
------------------------------------------------------------------------
r14490 | paul | 2009-12-28 16:53:35 +0100 (Mon, 28 Dec 2009) | 1 line
Changed paths:
   M /trunk/rtl/objpas/sysutils/sysstr.inc

rtl: fix FormatFloat to skip first spaces
------------------------------------------------------------------------
------------------------------------------------------------------------
r14513 | florian | 2010-01-01 22:05:18 +0100 (Fri, 01 Jan 2010) | 1 line
Changed paths:
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/streams.inc

* T*MemoryStream now uses PtrInt for sizes and positions so it can be bigger than 2 GB on 64 Bit systems, resolves #15313
------------------------------------------------------------------------
------------------------------------------------------------------------
r14523 | florian | 2010-01-02 17:05:57 +0100 (Sat, 02 Jan 2010) | 2 lines
Changed paths:
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/streams.inc

* fixed memory stream compilation on 64 bit targets

------------------------------------------------------------------------
------------------------------------------------------------------------
r14936 | paul | 2010-02-25 05:13:52 +0100 (Thu, 25 Feb 2010) | 1 line
Changed paths:
   M /trunk/rtl/inc/objpas.inc
   M /trunk/rtl/inc/objpash.inc
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/compon.inc

rtl: TObject.SafeCallException and TComponent.SafeCallException has HResult return value. Fix default return value to catastrophic failure error code.
------------------------------------------------------------------------
------------------------------------------------------------------------
r14947 | paul | 2010-02-27 09:05:51 +0100 (Sat, 27 Feb 2010) | 1 line
Changed paths:
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/compon.inc

rtl: initial TComponent.VCLComObject support - map interface related TComponent methods to the appropriate IVCLComObject interface methods
------------------------------------------------------------------------
------------------------------------------------------------------------
r14948 | paul | 2010-02-27 09:49:50 +0100 (Sat, 27 Feb 2010) | 1 line
Changed paths:
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/compon.inc
   A /trunk/tests/test/units/classes/tvclcomobject.pp

rtl: use CreateVCLComObject routing to create VCLComObject in case it is not assigned + test
------------------------------------------------------------------------
------------------------------------------------------------------------
r15032 | jonas | 2010-03-22 22:01:46 +0100 (Mon, 22 Mar 2010) | 4 lines
Changed paths:
   M /trunk/rtl/objpas/dateutil.inc
   A /trunk/tests/webtbs/tw16040.pp

  + fixed Julian date helpers (based on patch by Bernd Engelhardt, mantis
    #16040)
  * finished remaining unimplemented Julian date helpers

------------------------------------------------------------------------
------------------------------------------------------------------------
r15033 | jonas | 2010-03-22 23:28:59 +0100 (Mon, 22 Mar 2010) | 4 lines
Changed paths:
   M /trunk/rtl/objpas/rtlconst.inc
   M /trunk/rtl/objpas/sysconst.pp

  * moved SInvalidJulianDate from rtlconst to sysconst (part of r15032,
    necessary because dateutils only depends on sysconst and it contains
    the julian-datetime helper routines)

------------------------------------------------------------------------
------------------------------------------------------------------------
r15037 | jonas | 2010-03-23 11:34:43 +0100 (Tue, 23 Mar 2010) | 3 lines
Changed paths:
   M /trunk/rtl/objpas/dateutil.inc
   M /trunk/tests/webtbs/tw16040.pp

  * round(x) -> trunc(x+0.5) in Julian date conversion to prevent the current
    rounding mode from influencing the result

------------------------------------------------------------------------

git-svn-id: branches/fixes_2_4@16381 -

.gitattributes

@@ -8622,6 +8622,7 @@ tests/test/umacpas1.pp svneol=native#text/plain
 tests/test/umainnam.pp svneol=native#text/plain
 tests/test/units/classes/tmakeobjinst.pp svneol=native#text/plain
 tests/test/units/classes/tsetstream.pp svneol=native#text/plain
+tests/test/units/classes/tvclcomobject.pp svneol=native#text/plain
 tests/test/units/crt/tcrt.pp svneol=native#text/plain
 tests/test/units/crt/tctrlc.pp svneol=native#text/plain
 tests/test/units/dos/hello.pp svneol=native#text/plain
@@ -9523,6 +9524,7 @@ tests/webtbs/tw15843.pp svneol=native#text/plain
 tests/webtbs/tw15909.pp svneol=native#text/plain
 tests/webtbs/tw1592.pp svneol=native#text/plain
 tests/webtbs/tw16018.pp svneol=native#text/plain
+tests/webtbs/tw16040.pp svneol=native#text/plain
 tests/webtbs/tw16161.pp svneol=native#text/pascal
 tests/webtbs/tw16163.pp svneol=native#text/plain
 tests/webtbs/tw1617.pp svneol=native#text/plain

rtl/inc/objpas.inc

@@ -378,10 +378,10 @@
         end;
 
       function TObject.SafeCallException(exceptobject : tobject;
-        exceptaddr : pointer) : longint;
+        exceptaddr : pointer) : HResult;
 
         begin
-           safecallexception:=0;
+           safecallexception:=E_UNEXPECTED;
         end;
 
       class function TObject.ClassInfo : pointer;

rtl/inc/objpash.inc

@@ -188,7 +188,7 @@
           class function newinstance : tobject;virtual;
           procedure FreeInstance;virtual;
           function SafeCallException(exceptobject : tobject;
-            exceptaddr : pointer) : longint;virtual;
+            exceptaddr : pointer) : HResult;virtual;
           procedure DefaultHandler(var message);virtual;
 
           procedure Free;

rtl/objpas/classes/classesh.inc

@@ -867,13 +867,13 @@ type
   TCustomMemoryStream = class(TStream)
   private
     FMemory: Pointer;
-    FSize, FPosition: Longint;
+    FSize, FPosition: PtrInt;
   protected
-    procedure SetPointer(Ptr: Pointer; ASize: Longint);
+    procedure SetPointer(Ptr: Pointer; ASize: PtrInt);
   public
     Function GetSize : Int64; Override;
-    function Read(var Buffer; Count: Longint): Longint; override;
-    function Seek(Offset: Longint; Origin: Word): Longint; override;
+    function Read(var Buffer; Count: LongInt): LongInt; override;
+    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
     procedure SaveToStream(Stream: TStream);
     procedure SaveToFile(const FileName: string);
     property Memory: Pointer read FMemory;
@@ -883,18 +883,18 @@ type
 
   TMemoryStream = class(TCustomMemoryStream)
   private
-    FCapacity: Longint;
-    procedure SetCapacity(NewCapacity: Longint);
+    FCapacity: PtrInt;
+    procedure SetCapacity(NewCapacity: PtrInt);
   protected
-    function Realloc(var NewCapacity: Longint): Pointer; virtual;
-    property Capacity: Longint read FCapacity write SetCapacity;
+    function Realloc(var NewCapacity: PtrInt): Pointer; virtual;
+    property Capacity: PtrInt read FCapacity write SetCapacity;
   public
     destructor Destroy; override;
     procedure Clear;
     procedure LoadFromStream(Stream: TStream);
     procedure LoadFromFile(const FileName: string);
-    procedure SetSize(NewSize: Longint); override;
-    function Write(const Buffer; Count: Longint): Longint; override;
+    procedure SetSize({$ifdef CPU64}const{$endif CPU64} NewSize: PtrInt); override;
+    function Write(const Buffer; Count: LongInt): LongInt; override;
   end;
 
 { TStringStream }
@@ -1531,21 +1531,17 @@ type
     csTransient);
   TGetChildProc = procedure (Child: TComponent) of object;
 
-  {
-  TComponentName = type string;
-
   IVCLComObject = interface
-    function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
-    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
+    ['{E07892A0-F52F-11CF-BD2F-0020AF0E5B81}']
+    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
-      NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
+      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
-      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
-    function SafeCallException(ExceptObject: TObject;
-      ExceptAddr: Pointer): Integer;
+      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
+    function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult;
     procedure FreeOnRelease;
   end;
-  }
 
   IInterfaceComponentReference = interface 
     ['{3FEEC8E1-E400-4A24-BCAC-1F01476439B1}']
@@ -1583,7 +1579,7 @@ type
     FDesignInfo: Longint;
     FVCLComObject: Pointer;
     FComponentState: TComponentState;
-    // function GetComObject: IUnknown;
+    function GetComObject: IUnknown;
     function GetComponent(AIndex: Integer): TComponent;
     function GetComponentCount: Integer;
     function GetComponentIndex: Integer;
@@ -1630,12 +1626,12 @@ type
     function _Release: Integer; stdcall;
     function iicrGetComponent: TComponent;
     { IDispatch }
-    //!!!! function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
-    //!!!! function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
-    //!!!! function GetIDsOfNames(const IID: TGUID; Names: Pointer;
-    //!!!!   NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
-    //!!!! function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
-    //!!!!   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
+    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
+    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
+    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
   public
     //!! Moved temporary
     // fpdoc doesn't handle this yet :(
@@ -1660,10 +1656,10 @@ type
     procedure InsertComponent(AComponent: TComponent);
     procedure RemoveComponent(AComponent: TComponent);
     function SafeCallException(ExceptObject: TObject;
-      ExceptAddr: Pointer): Integer; override;
+      ExceptAddr: Pointer): HResult; override;
     procedure SetSubComponent(ASubComponent: Boolean);
     function UpdateAction(Action: TBasicAction): Boolean; dynamic;
-    // property ComObject: IUnknown read GetComObject;
+    property ComObject: IUnknown read GetComObject;
     function IsImplementorOf (const Intf:IInterface):boolean;
     procedure ReferenceInterface(const intf:IInterface;op:TOperation);
     property Components[Index: Integer]: TComponent read GetComponent;
@@ -1881,8 +1877,8 @@ var
   RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass);
 {!!!!  RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass;
     AxRegType: TActiveXRegType) = nil;
-  CurrentGroup: Integer = -1;
-  CreateVCLComObjectProc: procedure(Component: TComponent) = nil;}
+  CurrentGroup: Integer = -1;}
+  CreateVCLComObjectProc: procedure(Component: TComponent) = nil;
 
 { Point and rectangle constructors }
 

rtl/objpas/classes/compon.inc

@@ -38,6 +38,22 @@ end;
 {*                             TComponent                                   *}
 {****************************************************************************}
 
+function TComponent.GetComObject: IUnknown;
+begin
+  { Check if VCLComObject is not assigned - we need to create it by    }
+  { the call to CreateVCLComObject routine. If in the end we are still }
+  { have no valid VCLComObject pointer we need to raise an exception   }
+  if not Assigned(VCLComObject) then
+    begin
+      if Assigned(CreateVCLComObjectProc) then
+        CreateVCLComObjectProc(Self);
+      if not Assigned(VCLComObject) then
+        raise EComponentError.CreateFmt(SNoComSupport,[Name]);
+    end;
+  { VCLComObject is IVCComObject but we need to return IUnknown }
+  IVCLComObject(VCLComObject).QueryInterface(IUnknown, Result);
+end;
+
 Function  TComponent.GetComponent(AIndex: Integer): TComponent;
 
 begin
@@ -563,9 +579,9 @@ end;
 
 
 Procedure TComponent.FreeOnRelease;
-
 begin
-  // Delphi compatibility only at the moment.
+  if Assigned(VCLComObject) then
+    IVCLComObject(VCLComObject).FreeOnRelease;
 end;
 
 
@@ -608,10 +624,12 @@ end;
 
 
 Function  TComponent.SafeCallException(ExceptObject: TObject;
-  ExceptAddr: Pointer): Integer;
-
+  ExceptAddr: Pointer): HResult;
 begin
-  SafeCallException:=0;
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).SafeCallException(ExceptObject, ExceptAddr)
+  else
+    Result := inherited SafeCallException(ExceptObject, ExceptAddr);
 end;
 
 procedure TComponent.SetSubComponent(ASubComponent: Boolean);
@@ -636,20 +654,29 @@ end;
 
 function TComponent.QueryInterface(const IID: TGUID; out Obj): HResult;stdcall;
 begin
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).QueryInterface(IID, Obj)
+  else
   if GetInterface(IID, Obj) then
-    result:=S_OK
+    Result := S_OK
   else
-    result:=E_NOINTERFACE;
+    Result := E_NOINTERFACE;
 end;
 
 function TComponent._AddRef: Integer;stdcall;
 begin
-  result:=-1;
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject)._AddRef
+  else
+    Result := -1;
 end;
 
 function TComponent._Release: Integer;stdcall;
 begin
-  result:=-1;
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject)._Release
+  else
+    Result := -1;
 end;
 
 function TComponent.iicrGetComponent: TComponent;
@@ -657,3 +684,39 @@ function TComponent.iicrGetComponent: TComponent;
 begin
   result:=self;
 end;
+
+function TComponent.GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+begin
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).GetTypeInfoCount(Count)
+  else
+    Result := E_NOTIMPL;
+end;
+
+function TComponent.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
+begin
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).GetTypeInfo(Index, LocaleID, TypeInfo)
+  else
+    Result := E_NOTIMPL;
+end;
+
+function TComponent.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount,
+  LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
+begin
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs)
+  else
+    Result := E_NOTIMPL;
+end;
+
+function TComponent.Invoke(DispID: Integer; const IID: TGUID;
+  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
+  ArgErr: Pointer): HResult; stdcall;
+begin
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).Invoke(DispID, IID, LocaleID, Flags, Params,
+      VarResult, ExcepInfo, ArgErr)
+  else
+    Result := E_NOTIMPL;
+end;

rtl/objpas/classes/streams.inc

@@ -500,7 +500,7 @@ end;
 {*                             TCustomMemoryStream                          *}
 {****************************************************************************}
 
-procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; ASize: Longint);
+procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; ASize: PtrInt);
 
 begin
   FMemory:=Ptr;
@@ -515,7 +515,7 @@ begin
 end;
 
 
-function TCustomMemoryStream.Read(var Buffer; Count: Longint): Longint;
+function TCustomMemoryStream.Read(var Buffer; Count: LongInt): LongInt;
 
 begin
   Result:=0;
@@ -529,10 +529,10 @@ begin
 end;
 
 
-function TCustomMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
+function TCustomMemoryStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
 
 begin
-  Case Origin of
+  Case Word(Origin) of
     soFromBeginning : FPosition:=Offset;
     soFromEnd       : FPosition:=FSize+Offset;
     soFromCurrent   : FPosition:=FPosition+Offset;
@@ -573,7 +573,7 @@ end;
 
 Const TMSGrow = 4096; { Use 4k blocks. }
 
-procedure TMemoryStream.SetCapacity(NewCapacity: Longint);
+procedure TMemoryStream.SetCapacity(NewCapacity: PtrInt);
 
 begin
   SetPointer (Realloc(NewCapacity),Fsize);
@@ -581,10 +581,9 @@ begin
 end;
 
 
-function TMemoryStream.Realloc(var NewCapacity: Longint): Pointer;
+function TMemoryStream.Realloc(var NewCapacity: PtrInt): Pointer;
 
 begin
-
   If NewCapacity<0 Then
     NewCapacity:=0
   else  
@@ -647,7 +646,7 @@ begin
 end;
 
 
-procedure TMemoryStream.SetSize(NewSize: Longint);
+procedure TMemoryStream.SetSize({$ifdef CPU64}const{$endif CPU64} NewSize: PtrInt);
 
 begin
   SetCapacity (NewSize);
@@ -656,9 +655,9 @@ begin
     FPosition:=FSize;
 end;
 
-function TMemoryStream.Write(const Buffer; Count: Longint): Longint;
+function TMemoryStream.Write(const Buffer; Count: LongInt): LongInt;
 
-Var NewPos : Longint;
+Var NewPos : PtrInt;
 
 begin
   If (Count=0) or (FPosition<0) then

rtl/objpas/dateutil.inc

@@ -2022,43 +2022,58 @@ end;
 {$endif opt Q+}
 
 Function DateTimeToJulianDate(const AValue: TDateTime): Double;
+var
+  day,month,year: word;
+  a,y,m: integer;
 begin
-  DateTimeToJulianDate := AValue - JulianEpoch;
+  DecodeDate ( AValue, year, month, day );
+  a := (14-month) div 12;
+  y := year + 4800 - a;
+  m := month + (12*a) - 3;
+  result := day + ((153*m+2) div 5) + (365*y) + (y div 4) - (y div 100) + (y div 400) - 32045;
+  result := result - 0.5;
 end;
 
 
 Function JulianDateToDateTime(const AValue: Double): TDateTime;
 begin
-  JulianDateToDateTime := AValue + JulianEpoch;
-  if(AValue <= 0) or (AValue >= 10000)then
-    JulianDateToDateTime := NaN;
+  if not TryJulianDateToDateTime(AValue, Result) then
+    raise EConvertError.CreateFmt(SInvalidJulianDate, [AValue]);
 end;
 
 
 Function TryJulianDateToDateTime(const AValue: Double; out ADateTime: TDateTime): Boolean;
+var
+  a,b,c,d,e,m:integer;
+  day,month,year: word;
 begin
-  ADateTime := JulianDateToDateTime(AValue);
-  TryJulianDateToDateTime := ADateTime <> NaN;
+  a := trunc(AValue + 32044.5);
+  b := (4*a + 3) div 146097;
+  c := a - (146097*b div 4);
+  d := (4*c + 3) div 1461;
+  e := c - (1461*d div 4);
+  m := (5*e+2) div 153;
+  day := e - ((153*m + 2) div 5) + 1;
+  month := m + 3 - 12 *  ( m div 10 );
+  year := (100*b) + d - 4800 + ( m div 10 );
+  result := TryEncodeDate ( Year, Month, Day, ADateTime );
 end;
 
 Function DateTimeToModifiedJulianDate(const AValue: TDateTime): Double;
 begin
-  Result:=0;
-  NotYetImplemented('DateTimeToModifiedJulianDate');
+  result := DateTimeToJulianDate(AValue) - 2400000.5;
 end;
 
 
 Function ModifiedJulianDateToDateTime(const AValue: Double): TDateTime;
 begin
-  Result:=0;
-  NotYetImplemented('ModifiedJulianDateToDateTime');
+  result := JulianDateToDateTime(AValue + 2400000.5);
 end;
 
 
 Function TryModifiedJulianDateToDateTime(const AValue: Double; out ADateTime: TDateTime): Boolean;
 begin
-  Result:=False;
-  NotYetImplemented('TryModifiedJulianDateToDateTime');
+  Result:=TryJulianDateToDateTime(AValue + 2400000.5, ADateTime);
 end;
 
 {$ifdef RangeCheckWasOn}

rtl/objpas/rtlconst.inc

@@ -157,7 +157,6 @@ ResourceString
   SInvalidImage                 = 'Invalid stream format';
   SInvalidImageList             = 'Invalid ImageList';
   SInvalidImageSize             = 'Invalid image size';
-  SInvalidJulianDate            = '%f Julian cannot be represented as a DateTime';
   SInvalidMask                  = '"%s" is not a valid mask at (%d)';
   SInvalidMemoSize              = 'Text larger than memo capacity';
   SInvalidMetafile              = 'Invalid Metafile';

rtl/objpas/sysconst.pp

@@ -41,6 +41,7 @@ resourcestring
   SErrInvalidDayOfWeekInMonth = 'Year %d Month %d NDow %d DOW %d is not a valid date';
   SErrInvalidDayOfYear   = 'Year %d does not have a day number %d';
   SErrInvalidTimeStamp   = 'Invalid date/timestamp : "%s"';
+  SInvalidJulianDate            = '%f Julian cannot be represented as a DateTime';
   SErrIllegalDateFormatString   = '"%s" is not a valid date format string';
   SErrInvalidTimeFormat  = '"%s" is not a valid time';
   SExceptionErrorMessage = 'exception at %p';

rtl/objpas/sysutils/sysstr.inc

@@ -159,37 +159,14 @@ end;
     P1 > P2    > 0
     P1 = P2    = 0    }
 
-function CompareMemRange(P1, P2: Pointer; Length: cardinal): integer;
-
-var
-  i: cardinal;
-
+function CompareMemRange(P1, P2: Pointer; Length: PtrUInt): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
 begin
-  i := 0;
-  result := 0;
-  while (result=0) and (I<length) do
-    begin
-    result:=byte(P1^)-byte(P2^);
-    P1:=pchar(P1)+1;            // VP compat.
-    P2:=pchar(P2)+1;
-    i := i + 1;
-   end ;
-end ;
+  Result:=CompareByte(P1^,P2^,Length);
+end;
 
-function CompareMem(P1, P2: Pointer; Length: cardinal): Boolean;
-var
-  i: cardinal;
+function CompareMem(P1, P2: Pointer; Length: PtrUInt): Boolean;{$ifdef SYSUTILSINLINE}inline;{$endif}
 begin
-  Result:=True;
-  I:=0;
-  If (P1)<>(P2) then
-    While Result and (i<Length) do
-      begin
-      Result:=PByte(P1)^=PByte(P2)^;
-      Inc(I);
-      Inc(pchar(P1));
-      Inc(pchar(P2));
-      end;
+  Result:=CompareByte(P1^,P2^,Length)=0;
 end;
 
 
@@ -2226,8 +2203,11 @@ Var
                 { Everything unexpected is written before the first digit }
                 For N := 1 To UnexpectedDigits Do
                   Begin
-                  Buf[0] := Digits[N];
-                  Inc(Buf);
+                    if (Digits[N]<>' ') Then
+                    begin
+                      Buf[0] := Digits[N];
+                      Inc(Buf);
+                    end;
                   If thousand And (Digits[N]<>'-') Then
                     Begin
                     If (DigitExponent Mod 3 = 0) And (DigitExponent>0) Then

rtl/objpas/sysutils/sysstrh.inc

@@ -80,8 +80,8 @@ function LowerCase(const s: string): string; overload;
   version for a variant }
 function LowerCase(const V: variant): string; overload;{$ifdef SYSUTILSINLINE}inline;{$endif}
 function CompareStr(const S1, S2: string): Integer; overload;
-function CompareMemRange(P1, P2: Pointer; Length: cardinal): integer;
-function CompareMem(P1, P2: Pointer; Length: cardinal): Boolean;
+function CompareMemRange(P1, P2: Pointer; Length: PtrUInt): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
+function CompareMem(P1, P2: Pointer; Length: PtrUInt): Boolean;{$ifdef SYSUTILSINLINE}inline;{$endif}
 function CompareText(const S1, S2: string): integer;
 function SameText(const s1,s2:String):Boolean;
 

tests/test/units/classes/tvclcomobject.pp

@@ -0,0 +1,76 @@
+program vclcomobject;
+
+{$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
+{$APPTYPE CONSOLE}
+
+uses
+  SysUtils, Classes;
+
+type
+  TDummyVCLComObject = class(TInterfacedObject, IVCLComObject)
+  public
+    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
+    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
+    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
+    function SafeCallException(ExceptObject: TObject;
+      ExceptAddr: Pointer): HResult; override;
+    procedure FreeOnRelease;
+  end;
+var
+  c: TComponent;
+  v: IVCLComObject;
+
+procedure DoCreateVCLComObject(Component: TComponent);
+begin
+  Component.VCLComObject := Pointer(V);
+end;
+
+{ TDummyVCLComObject }
+
+procedure TDummyVCLComObject.FreeOnRelease;
+begin
+
+end;
+
+function TDummyVCLComObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
+  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
+begin
+  Result := E_NOTIMPL;
+end;
+
+function TDummyVCLComObject.GetTypeInfo(Index, LocaleID: Integer;
+  out TypeInfo): HResult;
+begin
+  Result := E_NOTIMPL;
+end;
+
+function TDummyVCLComObject.GetTypeInfoCount(out Count: Integer): HResult;
+begin
+  Result := E_NOTIMPL;
+end;
+
+function TDummyVCLComObject.Invoke(DispID: Integer; const IID: TGUID;
+  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
+  ArgErr: Pointer): HResult;
+begin
+  Result := E_NOTIMPL;
+end;
+
+function TDummyVCLComObject.SafeCallException(ExceptObject: TObject;
+  ExceptAddr: Pointer): HResult;
+begin
+  Result := E_UNEXPECTED;
+end;
+
+begin
+  v := TDummyVCLComObject.Create;
+  CreateVCLComObjectProc := @DoCreateVCLComObject;
+  c := TComponent.Create(nil);
+  if c.ComObject = nil then
+    halt(1);
+  c.Free;
+  v := nil;
+end.

tests/webtbs/tw16040.pp

@@ -0,0 +1,53 @@
+uses
+  dateutils;
+var
+  date1,
+  date2: tdatetime;
+  jdate: double;
+begin
+  date1:=EncodeDateTime(2010,03,22,0,0,0,0);
+  date2:=JulianDateToDateTime(2455277.50000);
+  if date1<>date2 then
+    begin
+      writeln(date1:0:12);
+      writeln(date2:0:12);
+      halt(1);
+    end;
+  if DateTimeToJulianDate(date2)<>2455277.50000 then
+    begin
+      writeln(DateTimeToJulianDate(date2):0:5);
+      writeln(2455277.50000:0:5);
+      halt(2);
+    end;
+  jdate:=DateTimeToModifiedJulianDate(date1);
+  if ModifiedJulianDateToDateTime(jdate)<>date1 then
+    begin
+      writeln(jdate:0:12);
+      writeln(date1:0:12);
+      halt(3);
+    end;
+
+
+  date1:=EncodeDateTime(2010,03,23,0,0,0,0);
+  date2:=JulianDateToDateTime(2455278.50000);
+  if date1<>date2 then
+    begin
+      writeln(date1:0:12);
+      writeln(date2:0:12);
+      halt(4);
+    end;
+  if DateTimeToJulianDate(date2)<>2455278.50000 then
+    begin
+      writeln(DateTimeToJulianDate(date2):0:5);
+      writeln(2455278.50000:0:5);
+      halt(5);
+    end;
+  jdate:=DateTimeToModifiedJulianDate(date1);
+  if ModifiedJulianDateToDateTime(jdate)<>date1 then
+    begin
+      writeln(jdate:0:12);
+      writeln(date1:0:12);
+      halt(6);
+    end;
+
+end.