From 0f4e7b65b2596af6cb37c785b4c7a5e7139f17dd Mon Sep 17 00:00:00 2001
From: marco <marco@freepascal.org>
Date: Tue, 5 Nov 2019 15:35:13 +0000
Subject: [PATCH] # revisions: 41843,41844,42700
git-svn-id: branches/fixes_3_2@43396 -
---
.gitattributes | 4 ++
compiler/defcmp.pas | 5 ++
compiler/ncnv.pas | 39 ++++++++---
tests/test/tarray18.pp | 149 ++++++++++++++++++++++++++++++++++++++++
tests/test/tarray19.pp | 22 ++++++
tests/test/tarray20.pp | 21 ++++++
tests/webtbs/tw35955.pp | 18 +++++
7 files changed, 248 insertions(+), 10 deletions(-)
create mode 100644 tests/test/tarray18.pp
create mode 100644 tests/test/tarray19.pp
create mode 100644 tests/test/tarray20.pp
create mode 100644 tests/webtbs/tw35955.pp
diff --git a/.gitattributes b/.gitattributes
index a6133088aa..f11cf64422 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -12694,7 +12694,10 @@ tests/test/tarray14.pp svneol=native#text/pascal
tests/test/tarray15.pp svneol=native#text/pascal
tests/test/tarray16.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/tarray20.pp svneol=native#text/pascal
tests/test/tarray3.pp svneol=native#text/plain
tests/test/tarray4.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/tw3594.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/tw3617.pp svneol=native#text/plain
tests/webtbs/tw3619.pp svneol=native#text/plain
diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas
index 9b159d8021..21dd36fd16 100644
--- a/compiler/defcmp.pas
+++ b/compiler/defcmp.pas
@@ -1009,6 +1009,11 @@ implementation
end
else if subeq>te_convert_l6 then
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
eq:=subeq;
doconv:=tc_arrayconstructor_2_dynarray;
diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas
index 3a0b1ca57f..9cdbe428ab 100644
--- a/compiler/ncnv.pas
+++ b/compiler/ncnv.pas
@@ -1657,7 +1657,25 @@ implementation
left:=nil;
{ create a set constructor tree }
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;
@@ -2387,15 +2405,6 @@ implementation
not(resultdef.typ in [procvardef,recorddef,setdef]) then
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
exit;
@@ -2484,6 +2493,16 @@ implementation
te_incompatible :
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
own resultdef. They will therefore always be incompatible with
a procvar. Because isconvertable cannot check for procedures we
diff --git a/tests/test/tarray18.pp b/tests/test/tarray18.pp
new file mode 100644
index 0000000000..a167c1984f
--- /dev/null
+++ b/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.
diff --git a/tests/test/tarray19.pp b/tests/test/tarray19.pp
new file mode 100644
index 0000000000..5e8431a7e4
--- /dev/null
+++ b/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.
diff --git a/tests/test/tarray20.pp b/tests/test/tarray20.pp
new file mode 100644
index 0000000000..4c013b061f
--- /dev/null
+++ b/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.
diff --git a/tests/webtbs/tw35955.pp b/tests/webtbs/tw35955.pp
new file mode 100644
index 0000000000..3b473bdcd9
--- /dev/null
+++ b/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.