The "replaced" file is because I first had to undo some hacked manual

merges and redo them directly from trunk (without hacking) afterwards.


Merged revisions 6747,6853,6856,7105,7235,7513,7643,7732,8117,8247,8249,8390-8391 via svnmerge from 
svn+ssh://[email protected]/FPC/svn/fpc/trunk

........
r6747 | florian | 2007-03-07 21:45:06 +0100 (Wed, 07 Mar 2007) | 2 lines

* big variant from Thorsten Engler, fixes and improves several variant stuff

........
r6853 | jonas | 2007-03-14 20:43:12 +0100 (Wed, 14 Mar 2007) | 4 lines

  * turn off range checking for routines involving vararraybounds
    because they're declared as an array[0..0] (while they can
    be of any size)

........
r6856 | jonas | 2007-03-14 20:47:32 +0100 (Wed, 14 Mar 2007) | 5 lines

  * do not turn on range/overflow checking, because several of the
    statements cause range errors which should be ignored for Delphi
    compatibility (e.g. assigning a variant which contains -10 to a
    cardinal)

........
r7105 | florian | 2007-04-15 20:43:02 +0200 (Sun, 15 Apr 2007) | 2 lines

* handle copying of empty vararrays properly

........
r7235 | florian | 2007-05-01 22:23:50 +0200 (Tue, 01 May 2007) | 2 lines

* replaced a wrong WideCompareString, should fix the new variant code on unix

........
r7513 | jonas | 2007-05-29 16:09:24 +0200 (Tue, 29 May 2007) | 4 lines

  * fixed several range check errors inside variant helpers in case the
    rtl is compiled with range checking on (Delphi doesn't give range
    errors there either)

........
r7643 | joost | 2007-06-13 14:24:16 +0200 (Wed, 13 Jun 2007) | 1 line

 * If a variant contains a datetime value and is converted to a string, it should return a string in a date/time format. (+test)
........
r7732 | yury | 2007-06-19 14:45:26 +0200 (Tue, 19 Jun 2007) | 1 line

* removed debug output.
........
r8117 | florian | 2007-07-21 20:49:10 +0200 (Sat, 21 Jul 2007) | 1 line

+ VarArrayPut and VarArrayGet from Igor, resolves #9161
........
r8247 | jonas | 2007-08-08 15:26:28 +0200 (Wed, 08 Aug 2007) | 3 lines

  * support 'true'/'false' for SetOrdProp on booleans (fixes #9347)
  + test for that bug, plus another test based on it which doesn't work yet

........
r8249 | jonas | 2007-08-08 16:38:59 +0200 (Wed, 08 Aug 2007) | 3 lines

  + another test which currently fails (Delphi 7 supports converting
    variant('true') to an integer, Delphi 6/Kylix doesn't)

........
r8390 | jonas | 2007-09-07 11:44:13 +0200 (Fri, 07 Sep 2007) | 2 lines

  * added cwstring unit for unix

........
r8391 | jonas | 2007-09-07 12:40:26 +0200 (Fri, 07 Sep 2007) | 4 lines

  * disabled inlining when passing a refcounted parameter typecasted to
    a non-refcounted type to a procedure, as this is incompatible with
    the inlining process

........

git-svn-id: branches/fixes_2_2@8462 -

.gitattributes

@@ -6337,6 +6337,7 @@ tests/tbs/tb0532.pp svneol=native#text/x-pascal
 tests/tbs/tb0533.pp svneol=native#text/plain
 tests/tbs/tb0534.pp svneol=native#text/plain
 tests/tbs/tb0535.pp svneol=native#text/plain
+tests/tbs/tb0536.pp svneol=native#text/plain
 tests/tbs/tb0540.pp svneol=native#text/x-pascal
 tests/tbs/tb0541.pp svneol=native#text/plain
 tests/tbs/ub0060.pp svneol=native#text/plain
@@ -6859,6 +6860,7 @@ tests/test/tinline3.pp svneol=native#text/plain
 tests/test/tinline4.pp svneol=native#text/plain
 tests/test/tinline5.pp -text
 tests/test/tinline6.pp svneol=native#text/plain
+tests/test/tinline9.pp svneol=native#text/plain
 tests/test/tint2str1.pp svneol=native#text/plain
 tests/test/tint2str2.pp svneol=native#text/plain
 tests/test/tint641.pp svneol=native#text/plain
@@ -8284,6 +8286,7 @@ tests/webtbs/tw9107.pp svneol=native#text/plain
 tests/webtbs/tw9128.pp svneol=native#text/plain
 tests/webtbs/tw9139.pp svneol=native#text/plain
 tests/webtbs/tw9139a.pp svneol=native#text/plain
+tests/webtbs/tw9161.pp svneol=native#text/plain
 tests/webtbs/tw9174.pp svneol=native#text/plain
 tests/webtbs/tw9179.pp svneol=native#text/plain
 tests/webtbs/tw9187.pp svneol=native#text/plain
@@ -8291,6 +8294,9 @@ tests/webtbs/tw9190.pp svneol=native#text/plain
 tests/webtbs/tw9209.pp svneol=native#text/plain
 tests/webtbs/tw9221.pp svneol=native#text/plain
 tests/webtbs/tw9309.pp -text
+tests/webtbs/tw9347.pp svneol=native#text/plain
+tests/webtbs/tw9347a.pp svneol=native#text/plain
+tests/webtbs/tw9347b.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain
 tests/webtbs/uw0555.pp svneol=native#text/plain

compiler/ncal.pas

@@ -166,6 +166,9 @@ interface
           procedure secondcallparan;virtual;abstract;
           function docompare(p: tnode): boolean; override;
           procedure printnodetree(var t:text);override;
+          { returns whether a parameter contains a type conversion from }
+          { a refcounted into a non-refcounted type                     }
+          function contains_unsafe_typeconversion: boolean;
 
           property value : tnode read left write left;
           property nextpara : tnode read right write right;
@@ -1021,6 +1024,30 @@ implementation
       end;
 
 
+    function tcallparanode.contains_unsafe_typeconversion: boolean;
+      var
+        n: tnode;
+      begin
+        n:=left;
+        while assigned(n) and
+              (n.nodetype=typeconvn) do
+          begin
+            { look for type conversion nodes which convert a }
+            { refcounted type into a non-refcounted type     }
+            if (not n.resultdef.needs_inittable or
+                is_class(n.resultdef)) and
+               (ttypeconvnode(n).left.resultdef.needs_inittable and
+                not is_class(ttypeconvnode(n).left.resultdef)) then
+              begin
+                result:=true;
+                exit;
+              end;
+            n:=ttypeconvnode(n).left;
+          end;
+        result:=false;
+      end;
+
+
     procedure tcallparanode.firstcallparan;
       begin
         if not assigned(left.resultdef) then
@@ -2698,6 +2725,8 @@ implementation
     function tcallnode.pass_1 : tnode;
       var
         st : TSymtable;
+        n: tcallparanode;
+        do_inline: boolean;
       begin
          result:=nil;
 
@@ -2709,13 +2738,26 @@ implementation
              st:=procdefinition.owner;
              if (st.symtabletype=ObjectSymtable) then
                st:=st.defowner.owner;
+             do_inline:=true;
              if (pi_uses_static_symtable in tprocdef(procdefinition).inlininginfo^.flags) and
                 (st.symtabletype=globalsymtable) and
                 (not st.iscurrentunit) then
                begin
                  Comment(V_lineinfo+V_Debug,'Not inlining "'+tprocdef(procdefinition).procsym.realname+'", references static symtable');
-               end
-             else
+                 do_inline:=false;
+               end;
+             n:=tcallparanode(parameters);
+             while assigned(n) do
+               begin
+                 if n.contains_unsafe_typeconversion then
+                   begin
+                     Comment(V_lineinfo+V_Debug,'Not inlining "'+tprocdef(procdefinition).procsym.realname+'", invocation parameter contains unsafe type conversion');
+                     do_inline:=false;
+                     break;
+                   end;
+                 n:=tcallparanode(n.nextpara);
+               end;
+             if do_inline then
                begin
                  result:=pass1_inline;
                  exit;

rtl/inc/variant.inc

@@ -613,6 +613,24 @@ procedure VarArrayRedim(var A: Variant; HighBound: SizeInt);
     variantmanager.vararrayredim(a,highbound);
   end;
 
+procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of SizeInt);
+  begin
+    if Length(Indices)>0 then 
+      variantmanager.vararrayput(A, Value, Length(Indices), @Indices[0])
+    else
+      variantmanager.vararrayput(A, Value, 0, nil);
+  end;
+
+
+function VarArrayGet(const A: Variant; const Indices: array of SizeInt): Variant;
+  begin
+    if Length(Indices)>0 then 
+      Result:=variantmanager.vararrayget(A, Length(Indices), @Indices[0])
+    else 
+      Result:=variantmanager.vararrayget(A, 0, nil);
+  end;
+  
+ 
 procedure VarCast(var dest : variant;const source : variant;vartype : longint);
 
   begin

rtl/inc/varianth.inc

@@ -341,6 +341,8 @@ operator <=(const op1,op2 : variant) dest : boolean;{$ifdef SYSTEMINLINE}inline;
 
 { variant helpers }
 procedure VarArrayRedim(var A: Variant; HighBound: SizeInt);
+procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of SizeInt);
+function VarArrayGet(const A: Variant; const Indices: array of SizeInt): Variant;
 procedure VarCast(var dest : variant;const source : variant;vartype : longint);
 
 {**********************************************************************

rtl/objpas/fmtbcd.pp

@@ -1635,9 +1635,10 @@ IMPLEMENTATION
 {$else}
       BCD.Places := 4;
 {$endif}
-      CurrToBCD := False;
-      if Decimals <> 4
-        then NormalizeBCD ( BCD, BCD, Precision, Decimals );
+      if Decimals <> 4 then
+        Result := NormalizeBCD ( BCD, BCD, Precision, Decimals )
+      else
+        CurrToBCD := True;
      end;
 
 {$ifdef comproutines}

rtl/objpas/sysconst.pp

@@ -70,6 +70,8 @@ resourcestring
   SInvalidVarCast        = 'Invalid variant type cast';
   SInvalidVarNullOp      = 'Invalid NULL variant operation';
   SInvalidVarOp          = 'Invalid variant operation';
+  SInvalidBinaryVarOp    = 'Invalid variant operation %s %s %s';
+  SInvalidUnaryVarOp     = 'Invalid variant operation %s %s';
   SInvalidVarOpWithHResultWithPrefix = 'Invalid variant operation (%s%.8x)'+LineEnding+'%s';
   SNoError               = 'No error.';
   SNoThreadSupport       = 'Threads not supported. Recompile program with thread driver.';

rtl/objpas/varutilh.inc

@@ -55,25 +55,39 @@ function SafeArrayUnlock(psa: PVarArray): HRESULT; stdcall;
 
 { Conversion routines NOT in windows oleaut }
 
-Function VariantToSmallInt(Const VargSrc : TVarData) : SmallInt;
-Function VariantToLongint(Const VargSrc : TVarData) : Longint;
-Function VariantToShortint(Const VargSrc : TVarData) : ShortInt;
-Function VariantToCardinal(Const VargSrc : TVarData) : Cardinal;
-Function VariantToSingle(Const VargSrc : TVarData) : Single;
-Function VariantToDouble(Const VargSrc : TVarData) : Double;
-Function VariantToCurrency(Const VargSrc : TVarData) : Currency;
-Function VariantToDate(Const VargSrc : TVarData) : TDateTime;
-Function VariantToBoolean(Const VargSrc : TVarData) : Boolean;
-Function VariantToByte(Const VargSrc : TVarData) : Byte;
-Function VariantToInt64(Const VargSrc : TVarData ) : Int64;
-Function VariantToQWord(Const VargSrc : TVarData ) : Qword;
-Function VariantToWideString(Const VargSrc : TVarData) : WideString;
-Function VariantToAnsiString(Const VargSrc : TVarData) : AnsiString;
-Function VariantToShortString(Const VargSrc : TVarData) : ShortString;
+function VariantToSmallInt(const VargSrc : TVarData) : SmallInt;
+function VariantToLongint(const VargSrc : TVarData) : Longint;
+function VariantToShortint(const VargSrc : TVarData) : ShortInt;
+function VariantToCardinal(const VargSrc : TVarData) : Cardinal;
+function VariantToSingle(const VargSrc : TVarData) : Single;
+function VariantToDouble(const VargSrc : TVarData) : Double;
+function VariantToCurrency(const VargSrc : TVarData) : Currency;
+function VariantToDate(const VargSrc : TVarData) : TDateTime;
+function VariantToBoolean(const VargSrc : TVarData) : Boolean;
+function VariantToByte(const VargSrc : TVarData) : Byte;
+function VariantToInt64(const VargSrc : TVarData ) : Int64;
+function VariantToQWord(const VargSrc : TVarData ) : Qword;
+function VariantToWideString(const VargSrc : TVarData) : WideString;
+function VariantToAnsiString(const VargSrc : TVarData) : AnsiString;
+function VariantToShortString(const VargSrc : TVarData) : ShortString;
 
 {Debug routines }
-Procedure DumpVariant(Const VArgSrc : TVarData);
-Procedure DumpVariant(Var F : Text; Const VArgSrc : TVarData);
+procedure DumpVariant(const VSrc : Variant);
+procedure DumpVariant(const aName: string; const VSrc : Variant);
+procedure DumpVariant(var F : Text; const VSrc : Variant);
+procedure DumpVariant(var F : Text; const aName: string; const VSrc : Variant);
+
+procedure DumpVariant(const VArgSrc : TVarData);
+procedure DumpVariant(const aName: string; const VArgSrc : TVarData);
+procedure DumpVariant(var F : Text; const VArgSrc : TVarData);
+procedure DumpVariant(var F : Text; const aName: string; const VArgSrc : TVarData);
+
+
+
+{$IFDEF DEBUG_VARUTILS}
+var
+  __DEBUG_VARUTILS: Boolean;
+{$ENDIF}
 
 
 {$i varerror.inc}
@@ -86,6 +100,9 @@ const
   ARR_DISPATCH      = $0400;
   ARR_VARIANT       = $0800;
 
+  VAR_LOCALE_USER_DEFAULT = $400; // = Windows.LOCALE_USER_DEFAULT
+
+
 
   // only the byval types.
   CVarTypeToElementInfo : array[varempty..varqword] of TVarTypeToElementInfo = (

rtl/objpas/varutils.inc

@@ -17,7 +17,7 @@
     Some general stuff: Error handling and so on.
   ---------------------------------------------------------------------}
 
-{ we so ugly things with tvararray here }
+{ we do ugly things with tvararray here }
 {$RANGECHECKS OFF}
 
 Procedure SetUnlockResult (P : PVarArray; Res : HResult);
@@ -759,3 +759,5 @@ begin
     Result:=psa^.ElementSize;
 end;
 
+
+

tests/tbs/tb0536.pp

@@ -0,0 +1,15 @@
+program TestDateVariantConversion;
+
+uses variants;
+
+var dt : TDateTime;
+    v : variant;
+    s : String;
+
+begin
+  dt := 40000;
+  v := dt;
+  s := v;
+  // It should return the date, depending on the localisation settings
+  if s = '40000' then halt(1); 
+end.

tests/test/tinline9.pp

@@ -0,0 +1,27 @@
+{$ifdef fpc}
+{$mode objfpc}
+{$inline on}
+{$endif}
+
+function fa: ansistring;
+begin
+  fa:='b';
+  fa:=result+'a';
+end;
+
+function fb: ansistring;
+begin
+  fb:='c';
+  fb:=result+'d';
+end;
+
+procedure test(const a,b: pointer); inline;
+begin
+  if (ansistring(a)<>'ba') or
+     (ansistring(b)<>'cd') then
+    halt(1);
+end;
+
+begin
+  test(pointer(fa()),pointer(fb()));
+end.

tests/webtbs/tw9161.pp

@@ -0,0 +1,21 @@
+uses
+{$ifdef unix}
+  cwstring,
+{$endif}
+  variants,sysutils;
+var a:variant;
+begin
+  a:=VarArrayCreate([0,2,0,2],varVariant);
+  if VarArrayDimCount(a)<>2 then
+    halt(1);
+  VarArrayPut(a,'b',[1,1]);
+  if String(VarArrayGet(a,[1,1]))<>'b' then
+    halt(2);
+  a[2,1]:='asdf';
+  if VarArrayGet(a,[2,1])<>'asdf' then
+    halt(2);
+  a:='';
+  writeln('ok');
+end.
+
+

tests/webtbs/tw9347.pp

@@ -0,0 +1,21 @@
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+{$r-}
+uses
+  SysUtils, Classes, TypInfo, Variants;
+
+type
+  TBla = class(TPersistent)
+  private
+    fBool: Boolean;
+    fint: integer;
+  published
+    property Bool: Boolean read fBool write fBool;
+    property int: integer read fint write fint;
+  end;
+
+begin
+  SetPropValue(TBla.Create, 'Bool', 'true');
+end.

tests/webtbs/tw9347a.pp

@@ -0,0 +1,27 @@
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+{$r-}
+uses
+  SysUtils, Classes, TypInfo, Variants;
+
+type
+  TBla = class(TPersistent)
+  private
+    fBool: Boolean;
+    fint: integer;
+  published
+    property Bool: Boolean read fBool write fBool;
+    property int: integer read fint write fint;
+  end;
+
+begin
+  try
+    { delphi gives a range error here, also if range checking is off }
+    SetPropValue(TBla.Create, 'Bool', 2);
+  except on ERangeError do
+    halt(0);
+  end;
+  halt(1);
+end.

tests/webtbs/tw9347b.pp

@@ -0,0 +1,22 @@
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+{$r-}
+uses
+  SysUtils, Classes, TypInfo, Variants;
+
+type
+  TBla = class(TPersistent)
+  private
+    fBool: Boolean;
+    fint: integer;
+  published
+    property Bool: Boolean read fBool write fBool;
+    property int: integer read fint write fint;
+  end;
+
+begin
+  { fails in Delphi 6, succeeds in Delphi 7 }
+  SetPropValue(TBla.Create, 'int', 'true');
+end.