From 1a5d8dc34eb1f837fe0ba056e8008bd5016eb7fd Mon Sep 17 00:00:00 2001 From: Fedor Rybin Date: Tue, 13 Feb 2024 14:08:49 +0300 Subject: [PATCH] Fix setters for private instantiation type parameters Ignore parameters whose types come from a generic package instantiated in the private part of package spec when creating setters and stub bodies. part of CS0038083 fixes eng/ide/libadalang-tools#145 --- src/test-stub.adb | 11 +++++ .../test/private_instantiation/generics.gpr | 2 + .../test/private_instantiation/importing.ads | 4 ++ .../private_instantiation/instantiations.adb | 8 +++ .../private_instantiation/instantiations.ads | 17 +++++++ .../sorting_algorithms.adb | 49 +++++++++++++++++++ .../sorting_algorithms.ads | 13 +++++ .../tests/test/private_instantiation/test.sh | 4 ++ .../test/private_instantiation/test.yaml | 7 +++ 9 files changed, 115 insertions(+) create mode 100644 testsuite/tests/test/private_instantiation/generics.gpr create mode 100644 testsuite/tests/test/private_instantiation/importing.ads create mode 100644 testsuite/tests/test/private_instantiation/instantiations.adb create mode 100644 testsuite/tests/test/private_instantiation/instantiations.ads create mode 100644 testsuite/tests/test/private_instantiation/sorting_algorithms.adb create mode 100644 testsuite/tests/test/private_instantiation/sorting_algorithms.ads create mode 100644 testsuite/tests/test/private_instantiation/test.sh create mode 100644 testsuite/tests/test/private_instantiation/test.yaml diff --git a/src/test-stub.adb b/src/test-stub.adb index 144fd920..9e2d3123 100755 --- a/src/test-stub.adb +++ b/src/test-stub.adb @@ -2535,6 +2535,17 @@ package body Test.Stub is Type_Decl := Type_Decl.P_Previous_Part; end loop; + declare + Insts : constant Generic_Instantiation_Array := + Type_Decl.P_Generic_Instantiations; + begin + for Inst of Insts loop + if Is_Private (Inst) then + return True; + end if; + end loop; + end; + return Is_Private (Type_Decl); end Is_Fully_Private; diff --git a/testsuite/tests/test/private_instantiation/generics.gpr b/testsuite/tests/test/private_instantiation/generics.gpr new file mode 100644 index 00000000..0313d365 --- /dev/null +++ b/testsuite/tests/test/private_instantiation/generics.gpr @@ -0,0 +1,2 @@ +project generics is +end generics; diff --git a/testsuite/tests/test/private_instantiation/importing.ads b/testsuite/tests/test/private_instantiation/importing.ads new file mode 100644 index 00000000..07431203 --- /dev/null +++ b/testsuite/tests/test/private_instantiation/importing.ads @@ -0,0 +1,4 @@ +with Instantiations; +package Importing is + function One return Integer is (1); +end Importing; diff --git a/testsuite/tests/test/private_instantiation/instantiations.adb b/testsuite/tests/test/private_instantiation/instantiations.adb new file mode 100644 index 00000000..4a7004a3 --- /dev/null +++ b/testsuite/tests/test/private_instantiation/instantiations.adb @@ -0,0 +1,8 @@ +package body Instantiations is + + procedure Do_Stuff (X : in out Sort_String_3.Array_To_Sort); + begin + null; + end Do_Stuff; + +end Instantiations; diff --git a/testsuite/tests/test/private_instantiation/instantiations.ads b/testsuite/tests/test/private_instantiation/instantiations.ads new file mode 100644 index 00000000..935ebf38 --- /dev/null +++ b/testsuite/tests/test/private_instantiation/instantiations.ads @@ -0,0 +1,17 @@ +with Sorting_Algorithms; +package Instantiations is + + package Sort_Integers is new Sorting_Algorithms (5, Integer); + + procedure Need_Body (X : in out Integer); + +private + + type String_3 is new String (1 .. 3); + + package Sort_String_3 is new Sorting_Algorithms (3, String_3); + use type Sort_String_3.Array_To_Sort; + + procedure Do_Stuff (X : in out Sort_String_3.Array_To_Sort); + +end Instantiations; diff --git a/testsuite/tests/test/private_instantiation/sorting_algorithms.adb b/testsuite/tests/test/private_instantiation/sorting_algorithms.adb new file mode 100644 index 00000000..3cd324bc --- /dev/null +++ b/testsuite/tests/test/private_instantiation/sorting_algorithms.adb @@ -0,0 +1,49 @@ +package body Sorting_Algorithms is + + procedure Swap (L, R : in out Element_Type); + + procedure Swap (L, R : in out Element_Type) is + X : Element_Type; + begin + X := L; + L := R; + R := X; + end Swap; + + procedure Selection_Sort (X : in out Array_To_Sort) is + Min_Index : Natural; + begin + for I in X'First .. X'Last - 1 loop + + Min_Index := I; + + for J in I + 1 .. X'Last loop +-- if X (J) < X (I) then + if X (J) < X (Min_Index) then + Min_Index := J; + end if; + end loop; + + if I /= Min_Index then + Swap (X (I), X (Min_Index)); + end if; + + end loop; + end Selection_Sort; + + procedure Bubble_Sort (X : in out Array_To_Sort) is + Swapped : Boolean; + begin + for I in X'First .. X'Last - 1 loop + Swapped := False; + for J in X'First .. X'Last - 1 loop + if X (J + 1) < X (j) then + Swap (X (J), X (J + 1)); + Swapped := True; + end if; + end loop; + exit when not Swapped; + end loop; + end Bubble_Sort; + +end Sorting_Algorithms; diff --git a/testsuite/tests/test/private_instantiation/sorting_algorithms.ads b/testsuite/tests/test/private_instantiation/sorting_algorithms.ads new file mode 100644 index 00000000..911e7fe8 --- /dev/null +++ b/testsuite/tests/test/private_instantiation/sorting_algorithms.ads @@ -0,0 +1,13 @@ +generic + Length : Positive; + type Element_Type is private; + with function "<" (L, R : Element_Type) return Boolean is <>; +package Sorting_Algorithms is + + type Array_To_Sort is array (1 .. Length) of Element_Type; + + procedure Selection_Sort (X : in out Array_To_Sort); + + procedure Bubble_Sort (X : in out Array_To_Sort); + +end Sorting_Algorithms; diff --git a/testsuite/tests/test/private_instantiation/test.sh b/testsuite/tests/test/private_instantiation/test.sh new file mode 100644 index 00000000..88f2ae06 --- /dev/null +++ b/testsuite/tests/test/private_instantiation/test.sh @@ -0,0 +1,4 @@ +#!/bin/bash + +gnattest -q -P generics.gpr --stub importing.ads +gprbuild -q -P gnattest_stub/harness/test_drivers.gpr diff --git a/testsuite/tests/test/private_instantiation/test.yaml b/testsuite/tests/test/private_instantiation/test.yaml new file mode 100644 index 00000000..de52b9ce --- /dev/null +++ b/testsuite/tests/test/private_instantiation/test.yaml @@ -0,0 +1,7 @@ +description: + Test checking that parameter type that comes from + a generic package instantiated in private part + are properly ignored and not put into setter. + +driver: shell_script +