2
0
Эх сурвалжийг харах

# revisions: 41843,41844,42700

git-svn-id: branches/fixes_3_2@43396 -
marco 5 жил өмнө
parent
commit
0f4e7b65b2

+ 4 - 0
.gitattributes

@@ -12694,7 +12694,10 @@ tests/test/tarray14.pp svneol=native#text/pascal
 tests/test/tarray15.pp svneol=native#text/pascal
 tests/test/tarray15.pp svneol=native#text/pascal
 tests/test/tarray16.pp svneol=native#text/pascal
 tests/test/tarray16.pp svneol=native#text/pascal
 tests/test/tarray17.pp svneol=native#text/pascal
 tests/test/tarray17.pp svneol=native#text/pascal
+tests/test/tarray18.pp svneol=native#text/pascal
+tests/test/tarray19.pp svneol=native#text/pascal
 tests/test/tarray2.pp svneol=native#text/plain
 tests/test/tarray2.pp svneol=native#text/plain
+tests/test/tarray20.pp svneol=native#text/pascal
 tests/test/tarray3.pp svneol=native#text/plain
 tests/test/tarray3.pp svneol=native#text/plain
 tests/test/tarray4.pp svneol=native#text/plain
 tests/test/tarray4.pp svneol=native#text/plain
 tests/test/tarray5.pp svneol=native#text/plain
 tests/test/tarray5.pp svneol=native#text/plain
@@ -16435,6 +16438,7 @@ tests/webtbs/tw35862.pp svneol=native#text/pascal
 tests/webtbs/tw3589.pp svneol=native#text/plain
 tests/webtbs/tw3589.pp svneol=native#text/plain
 tests/webtbs/tw3594.pp svneol=native#text/plain
 tests/webtbs/tw3594.pp svneol=native#text/plain
 tests/webtbs/tw3595.pp svneol=native#text/plain
 tests/webtbs/tw3595.pp svneol=native#text/plain
+tests/webtbs/tw35955.pp svneol=native#text/pascal
 tests/webtbs/tw3612.pp svneol=native#text/plain
 tests/webtbs/tw3612.pp svneol=native#text/plain
 tests/webtbs/tw3617.pp svneol=native#text/plain
 tests/webtbs/tw3617.pp svneol=native#text/plain
 tests/webtbs/tw3619.pp svneol=native#text/plain
 tests/webtbs/tw3619.pp svneol=native#text/plain

+ 5 - 0
compiler/defcmp.pas

@@ -1009,6 +1009,11 @@ implementation
                                       end
                                       end
                                     else if subeq>te_convert_l6 then
                                     else if subeq>te_convert_l6 then
                                       eq:=pred(subeq)
                                       eq:=pred(subeq)
+                                    else if subeq=te_convert_operator then
+                                      { the operater needs to be applied by element, so we tell
+                                        the caller that it's some unpreffered conversion and let
+                                        it handle the per-element stuff }
+                                      eq:=te_convert_l6
                                     else
                                     else
                                       eq:=subeq;
                                       eq:=subeq;
                                    doconv:=tc_arrayconstructor_2_dynarray;
                                    doconv:=tc_arrayconstructor_2_dynarray;

+ 29 - 10
compiler/ncnv.pas

@@ -1657,7 +1657,25 @@ implementation
         left:=nil;
         left:=nil;
         { create a set constructor tree }
         { create a set constructor tree }
         arrayconstructor_to_set(hp);
         arrayconstructor_to_set(hp);
-        result:=hp;
+        if is_emptyset(hp) then
+          begin
+            { enforce the result type for an empty set }
+            hp.resultdef:=resultdef;
+            result:=hp;
+          end
+        else if hp.resultdef<>resultdef then
+          begin
+            { the set might contain a subrange element (e.g. through a variable),
+              thus we need to insert another type conversion }
+            if nf_explicit in flags then
+              result:=ctypeconvnode.create_explicit(hp,totypedef)
+            else if nf_internal in flags then
+              result:=ctypeconvnode.create_internal(hp,totypedef)
+            else
+              result:=ctypeconvnode.create(hp,totypedef);
+          end
+        else
+          result:=hp;
       end;
       end;
 
 
 
 
@@ -2387,15 +2405,6 @@ implementation
            not(resultdef.typ in [procvardef,recorddef,setdef]) then
            not(resultdef.typ in [procvardef,recorddef,setdef]) then
           maybe_call_procvar(left,true);
           maybe_call_procvar(left,true);
 
 
-        { convert array constructors to sets, because there is no conversion
-          possible for array constructors }
-        if (resultdef.typ<>arraydef) and
-           is_array_constructor(left.resultdef) then
-          begin
-            arrayconstructor_to_set(left);
-            typecheckpass(left);
-          end;
-
         if target_specific_general_typeconv then
         if target_specific_general_typeconv then
           exit;
           exit;
 
 
@@ -2484,6 +2493,16 @@ implementation
 
 
               te_incompatible :
               te_incompatible :
                 begin
                 begin
+                  { convert an array constructor to a set so that we still get
+                    the error "set of Y incompatible to Z" instead of "array of
+                    X incompatible to Z" }
+                  if (resultdef.typ<>arraydef) and
+                     is_array_constructor(left.resultdef) then
+                    begin
+                      arrayconstructor_to_set(left);
+                      typecheckpass(left);
+                    end;
+
                   { Procedures have a resultdef of voiddef and functions of their
                   { Procedures have a resultdef of voiddef and functions of their
                     own resultdef. They will therefore always be incompatible with
                     own resultdef. They will therefore always be incompatible with
                     a procvar. Because isconvertable cannot check for procedures we
                     a procvar. Because isconvertable cannot check for procedures we

+ 149 - 0
tests/test/tarray18.pp

@@ -0,0 +1,149 @@
+program tarray18;
+
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+function CheckArray(aArr, aExpected: array of LongInt): Boolean;
+var
+  i: LongInt;
+begin
+  if Length(aArr) <> Length(aExpected) then
+    Exit(False);
+  for i := Low(aArr) to High(aArr) do
+    if aArr[i] <> aExpected[i] then
+      Exit(False);
+  Result := True;
+end;
+
+type
+  TTest1 = record
+    f: array of LongInt;
+    class operator := (a: array of LongInt): TTest1;
+  end;
+
+  TTest2 = record
+    f: array of LongInt;
+    class operator Explicit(a: array of LongInt): TTest2;
+  end;
+
+  TTest3 = record
+    f: array of LongInt;
+  end;
+
+  TTest4 = record
+    f: array of LongInt;
+  end;
+
+function AssignArray(a: array of LongInt): specialize TArray<LongInt>;
+var
+  i: LongInt;
+begin
+  SetLength(Result, Length(a));
+  for i := 0 to High(a) do
+    Result[i] := a[i];
+end;
+
+class operator TTest1.:=(a: array of LongInt): TTest1;
+begin
+  Result.f := AssignArray(a);
+end;
+
+class operator TTest2.Explicit(a: array of LongInt): TTest2;
+begin
+  Result.f := AssignArray(a);
+end;
+
+operator :=(a: array of LongInt): TTest3;
+begin
+  Result.f := AssignArray(a);
+end;
+
+operator :=(a: array of LongInt): TTest4;
+begin
+  Result.f := AssignArray(a);
+end;
+
+procedure Test1(aRec: TTest1; a: array of LongInt; aCode: LongInt);
+begin
+  if not CheckArray(aRec.f, a) then
+    Halt(aCode);
+end;
+
+procedure Test2(aRec: TTest2; a: array of LongInt; aCode: LongInt);
+begin
+  if not CheckArray(aRec.f, a) then
+    Halt(aCode);
+end;
+
+procedure Test3(aRec: TTest3; a: array of LongInt; aCode: LongInt);
+begin
+  if not CheckArray(aRec.f, a) then
+    Halt(aCode);
+end;
+
+procedure Test4(aRec: TTest4; a: array of LongInt; aCode: LongInt);
+begin
+  if not CheckArray(aRec.f, a) then
+    Halt(aCode);
+end;
+
+var
+  t1: TTest1;
+  t2: TTest2;
+  t3: TTest3;
+  t4: TTest4;
+begin
+  t1 := [];
+  if not CheckArray(t1.f, []) then
+    Halt(1);
+  t1 := [2, 4];
+  if not CheckArray(t1.f, [2, 4]) then
+    Halt(2);
+  t1 := TTest1([]);
+  if not CheckArray(t1.f, []) then
+    Halt(3);
+  t1 := TTest1([2, 4]);
+  if not CheckArray(t1.f, [2, 4]) then
+    Halt(4);
+
+  t2 := TTest2([]);
+  if not CheckArray(t2.f, []) then
+    Halt(5);
+  t2 := TTest2([2, 4]);
+  if not CheckArray(t2.f, [2, 4]) then
+    Halt(6);
+
+  t3 := [];
+  if not CheckArray(t3.f, []) then
+    Halt(7);
+  t3 := [2, 4];
+  if not CheckArray(t3.f, [2, 4]) then
+    Halt(8);
+  t3 := TTest3([]);
+  if not CheckArray(t3.f, []) then
+    Halt(9);
+  t3 := TTest3([2, 4]);
+  if not CheckArray(t3.f, [2, 4]) then
+    Halt(10);
+
+  t4 := TTest4([]);
+  if not CheckArray(t4.f, []) then
+    Halt(11);
+  t4 := TTest4([2, 4]);
+  if not CheckArray(t4.f, [2, 4]) then
+    Halt(12);
+
+  Test1([], [], 13);
+  Test1([2, 4], [2, 4], 14);
+
+  Test2(TTest2([]), [], 15);
+  Test2(TTest2([2, 4]), [2, 4], 16);
+
+  Test3([], [], 17);
+  Test3([2, 4], [2, 4], 18);
+
+  Test4(TTest4([]), [], 19);
+  Test4(TTest4([2, 4]), [2, 4], 20);
+
+  Writeln('ok');
+end.

+ 22 - 0
tests/test/tarray19.pp

@@ -0,0 +1,22 @@
+{ %FAIL }
+
+program tarray19;
+
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+type
+  TTest = record
+    class operator Explicit(a: array of LongInt): TTest;
+  end;
+
+class operator TTest.Explicit(a: array of LongInt): TTest;
+begin
+
+end;
+
+var
+  t: TTest;
+begin
+  t := [21, 42];
+end.

+ 21 - 0
tests/test/tarray20.pp

@@ -0,0 +1,21 @@
+{ %FAIL }
+
+program tarray20;
+
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+type
+  TTest = record
+  end;
+
+operator Explicit(a: array of LongInt): TTest;
+begin
+
+end;
+
+var
+  t: TTest;
+begin
+  t := [21, 42];
+end.

+ 18 - 0
tests/webtbs/tw35955.pp

@@ -0,0 +1,18 @@
+{ %NORUN }
+
+program tw35955;
+
+{$mode delphi}
+
+type
+  TVariantArray = array of Variant;
+
+var
+  S: string;
+  A: TVariantArray;
+begin
+  S := 'xyz';
+  A := [S]; // << project1.lpr(13,8) Error: Compilation raised exception internally
+  Writeln(A[0]);
+  Readln;
+end.