aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog171
-rw-r--r--gcc/ada/adaint.c63
-rw-r--r--gcc/ada/aspects.adb5
-rw-r--r--gcc/ada/atree.adb6
-rw-r--r--gcc/ada/debug.adb5
-rw-r--r--gcc/ada/doc/gnat_rm/obsolescent_features.rst2
-rw-r--r--gcc/ada/einfo-utils.adb8
-rw-r--r--gcc/ada/einfo.ads1
-rw-r--r--gcc/ada/exp_fixd.adb14
-rw-r--r--gcc/ada/exp_util.adb81
-rw-r--r--gcc/ada/fmap.adb4
-rw-r--r--gcc/ada/freeze.adb44
-rw-r--r--gcc/ada/gcc-interface/utils.cc3
-rw-r--r--gcc/ada/gnat_rm.texi4
-rw-r--r--gcc/ada/libgnarl/s-taprop__qnx.adb91
-rw-r--r--gcc/ada/par-ch4.adb3
-rw-r--r--gcc/ada/par_sco.adb3
-rw-r--r--gcc/ada/sem_ch12.adb186
-rw-r--r--gcc/ada/sem_ch13.adb18
-rw-r--r--gcc/ada/sem_ch3.adb8
-rw-r--r--gcc/ada/sem_ch7.adb27
-rw-r--r--gcc/ada/sem_ch8.adb115
-rw-r--r--gcc/ada/sem_elab.adb2
-rw-r--r--gcc/ada/sem_prag.adb71
-rw-r--r--gcc/ada/sem_type.adb11
-rw-r--r--gcc/ada/sem_util.adb20
-rw-r--r--gcc/ada/table.adb20
-rw-r--r--gcc/ada/table.ads7
28 files changed, 642 insertions, 351 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index a732e94..f91fc31 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,174 @@
+2025-10-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/15610
+ * sem_type.adb (Collect_Interps): Apply the same visibility
+ criterion to expanded names as Find_Expanded_Name.
+
+2025-10-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/54178
+ * sem_ch12.adb (Instantiate_Object): Strip qualification to detect
+ aggregates used as actuals.
+
+2025-10-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/16214
+ * sem_ch8.adb (Find_Expanded_Name): Consolidate and streamline the
+ processing required for references to instances within themselves.
+
+2025-10-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/48039
+ * sem_ch12.adb (Analyze_Subprogram_Instantiation): Call
+ Remove_Homonym to remove the enclosing package from visibility.
+
+2025-10-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_util.adb (Remove_Side_Effects): Use separately the Etype of
+ the expression to build new nodes and its Underlying_Type to drive
+ part of the processing.
+
+2025-10-28 Johannes Kliemann <kliemann@adacore.com>
+
+ * adaint.c: Remove __gnat_enable_signals, __gnat_disable_signals
+ and related code for QNX.
+ * libgnarl/s-taprop__qnx.adb: Disable and enable
+ signals in Ada.
+
+2025-10-28 Alexandre Oliva <oliva@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Export_Import): Skip
+ Set_Is_Imported on E_Exception.
+ * sem_prag.adb (Process_Import_Or_Interface): Explain
+ why not Set_Is_Imported.
+
+2025-10-28 Denis Mazzucato <mazzucato@adacore.com>
+
+ * sem_util.adb (Collect_Primitive_Operations): Avoid setting
+ Is_Primitive for noninherited and nonoverriding subprograms not
+ declared immediately within a package specification.
+ * sem_ch13.adb (Check_Nonoverridable_Aspect_Subprograms): Better
+ error posting to allow multiple errors on same type but different
+ aggregate subprogram.
+
+2025-10-28 Ronan Desplanques <desplanques@adacore.com>
+
+ * table.ads (Clear, Is_Empty): New subprograms.
+ * table.adb (Clear, Is_Empty): Likewise.
+ (Init): Use new subprogram.
+ * atree.adb (Traverse_Func_With_Parent): Use new subprograms.
+ * fmap.adb (Empty_Tables): Use new subprogram.
+ * par_sco.adb (Process_Pending_Decisions): Likewise.
+ * sem_elab.adb (Check_Elab_Call): Likewise.
+ * sem_ch12.adb (Build_Local_Package, Analyze_Package_Instantiation,
+ Analyze_Subprogram_Instantiation): Likewise.
+ (Save_And_Reset): Use Table.Table.First.
+
+2025-10-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/122063
+ * exp_fixd.adb (Build_Double_Divide_Code): Convert the result of the
+ multiply.
+ (Build_Multiply): Use base types of operands to size the operation.
+ (Build_Rem): Likewise.
+ (Build_Scaled_Divide_Code): Convert the result of the multiply.
+
+2025-10-28 Tonu Naks <naks@adacore.com>
+
+ * doc/gnat_rm/obsolescent_features.rst: typo
+ * gnat_rm.texi: Regenerate.
+
+2025-10-28 Javier Miranda <miranda@adacore.com>
+
+ * aspects.adb (Get_Aspect_Id): Enable aspect Unsigned_Base_Range
+ using -gnatd.u
+ * debug.adb (Debug_Flag_Dot_U): Document this switch.
+ * einfo-utils.adb (Is_Modular_Integer_Type): Return True if
+ the entity is a modular integer type and its base type does
+ not have the attribute has_unsigned_base_range_aspect.
+ (Is_Signed_Integer_Type): Return True if the entity is a signed
+ integer type, or it is a modular integer type and its base type
+ has the attribute has_unsigned_base_range_aspect.
+ * einfo.ads (E_Modular_Integer_Type): Add documentation of
+ Has_Unsigned_Base_Range_Aspect.
+ * par-ch4.adb (Scan_Apostrophe): Enable attribute Unsigned_Base_Range
+ using -gnatd.u
+ * sem_ch13.adb (Analyze_One_Aspect): Check general language
+ restrictions on aspect Unsigned_Base_Range. For Unsigned_Base_Range
+ aspect, do not delay the generation of the pragma becase we need
+ to process it before any type or subtype derivation is analyzed.
+ * sem_ch3.adb (Build_Scalar_Bound): Disable code analyzing the
+ bound with the base type of the parent type because, for unsigned
+ base range types, their base type is a modular type but their
+ type is a signed integer type.
+ * sem_prag.adb (Analyze_Pragma): Enable pragma Unsigned_Base_Range
+ using -gnatd.u. Check more errors on Unsigned_Base_Range pragma,
+ and create the new base type only when required.
+
+2025-10-28 Ronan Desplanques <desplanques@adacore.com>
+
+ * sem_ch12.adb (Build_Local_Package)
+ (Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation):
+ Fix Set_Last calls.
+ (Set_Instance_Of): Use Table.Table.Append.
+ (Save_And_Reset): Remove useless call. Remove defensive code.
+ (Restore): Remove incorrect Set_Last call and adapt to
+ Set_Instance_Of change.
+
+2025-10-28 Denis Mazzucato <mazzucato@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Add enclosing quotation when the
+ invalid switch ends with a space.
+
+2025-10-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/59234
+ * sem_ch12.adb (Analyze_Formal_Package_Declaration): Mark the
+ special name built for the formal in the parent of a child unit
+ as internal.
+
+2025-10-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/34511
+ * sem_ch12.adb (Analyze_Associations): Add Parent_Installed formal
+ parameter and pass it in call to Analyze_One_Association.
+ (Analyze_One_Association): Add Parent_Installed formal parameter
+ and pass it in call to Instantiate_Formal_Subprogram.
+ (Analyze_Formal_Package_Declaration): Pass Parent_Installed in call
+ to Analyze_Associations.
+ (Analyze_Package_Instantiation): Likewise.
+ (Analyze_Subprogram_Instantiation): Likewise.
+ (Instantiate_Formal_Subprogram): Add Parent_Installed formal
+ parameter and prune references to the parent unit(s) only if
+ it is true.
+
+2025-10-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/29958
+ * sem_ch7.adb (Declare_Inherited_Private_Subprograms): Deal with
+ formal types specially.
+
+2025-10-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/25988
+ * sem_ch12.adb (Save_Global_References.Reset_Entity): Also call
+ Save_Global_Defaults for instances with an expanded name.
+ (Save_Global_References.Save_References): Minor code cleanup.
+
+2025-10-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/15800
+ * freeze.adb (Freeze_Entity.Freeze_Record_Type): Small cleanup
+ in code and comments.
+ * gcc-interface/utils.cc (create_field_decl): Assert that the type
+ of the field is frozen at this point.
+
+2025-10-26 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/13370
+ * sem_prag.adb (Analyze_Pragma) <Pragma_Machine_Attribute>: Set the
+ Has_Delayed_Freeze flag if the argument is not a literal.
+
2025-10-24 Eric Botcazou <ebotcazou@adacore.com>
PR ada/80033
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index 7b78d91..adc3951 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -107,7 +107,6 @@
#ifdef __QNX__
#include <sys/syspage.h>
#include <sys/time.h>
-#include <signal.h>
#endif
#ifdef IN_RTS
@@ -3720,68 +3719,6 @@ void __gnat_killprocesstree (int pid, int sig_num)
*/
}
-#if defined (__QNX__)
-
-static __thread sigset_t set;
-static __thread sigset_t oset;
-static __thread int signals_disabled = 0;
-
-int __gnat_disable_signals(void)
-{
- sigemptyset(&set);
- sigaddset(&set, SIGHUP);
- sigaddset(&set, SIGINT);
- sigaddset(&set, SIGQUIT);
- sigaddset(&set, SIGILL);
- sigaddset(&set, SIGTRAP);
- sigaddset(&set, SIGIOT);
- sigaddset(&set, SIGABRT);
- sigaddset(&set, SIGEMT);
- sigaddset(&set, SIGDEADLK);
- sigaddset(&set, SIGFPE);
- sigaddset(&set, SIGKILL);
- sigaddset(&set, SIGBUS);
- sigaddset(&set, SIGSEGV);
- sigaddset(&set, SIGSYS);
- sigaddset(&set, SIGPIPE);
- sigaddset(&set, SIGALRM);
- sigaddset(&set, SIGTERM);
- sigaddset(&set, SIGUSR1);
- sigaddset(&set, SIGUSR2);
- sigaddset(&set, SIGCHLD);
- sigaddset(&set, SIGCLD);
- sigaddset(&set, SIGPWR);
- sigaddset(&set, SIGWINCH);
- sigaddset(&set, SIGURG);
- sigaddset(&set, SIGPOLL);
- sigaddset(&set, SIGIO);
- sigaddset(&set, SIGSTOP);
- sigaddset(&set, SIGTSTP);
- sigaddset(&set, SIGCONT);
- sigaddset(&set, SIGTTIN);
- sigaddset(&set, SIGTTOU);
- sigaddset(&set, SIGVTALRM);
- sigaddset(&set, SIGPROF);
- sigaddset(&set, SIGXCPU);
- sigaddset(&set, SIGXFSZ);
- sigaddset(&set, SIGDOOM);
-
- int ret = sigprocmask(SIG_BLOCK, &set, &oset);
- signals_disabled = !ret;
- return ret;
-}
-
-int __gnat_enable_signals(void)
-{
- if (!signals_disabled) {
- return 0;
- }
- signals_disabled = 0;
- return sigprocmask(SIG_SETMASK, &oset, 0);
-}
-
-#endif
-
#ifdef __cplusplus
}
#endif
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index c9eaea1..aecbbe2 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Atree; use Atree;
+with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
@@ -282,7 +283,9 @@ package body Aspects is
begin
-- Aspect Unsigned_Base_Range temporarily disabled
- if Name = Name_Unsigned_Base_Range then
+ if Name = Name_Unsigned_Base_Range
+ and then not Debug_Flag_Dot_U
+ then
return No_Aspect;
end if;
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 14d9ba4..327bc2d 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -2766,14 +2766,14 @@ package body Atree is
-- it is global and hence a tree traversal with parents must be finished
-- before the next tree traversal with parents starts.
- pragma Assert (Parents_Stack.Last = 0);
- Parents_Stack.Set_Last (0);
+ pragma Assert (Parents_Stack.Is_Empty);
+ Parents_Stack.Clear;
Parents_Stack.Append (Parent (Node));
Result := Traverse (Node);
Parents_Stack.Decrement_Last;
- pragma Assert (Parents_Stack.Last = 0);
+ pragma Assert (Parents_Stack.Is_Empty);
return Result;
end Traverse_Func_With_Parent;
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index b7c54a0..ffe4adc 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -105,7 +105,7 @@ package body Debug is
-- d.r Disable reordering of components in record types
-- d.s Strict secondary stack management
-- d.t Disable static allocation of library level dispatch tables
- -- d.u
+ -- d.u Enable Unsigned_Base_Range aspect language extension
-- d.v Enforce SPARK elaboration rules in SPARK code
-- d.w Do not check for infinite loops
-- d.x No exception handlers
@@ -800,7 +800,8 @@ package body Debug is
-- previous dynamic construction of tables. It is there as a possible
-- work around if we run into trouble with the new implementation.
- -- d.u
+ -- d.u Enable the support for Unsigned_Base_Range aspect, attribute, and
+ -- pragma.
-- d.v This flag enforces the elaboration rules defined in the SPARK
-- Reference Manual, chapter 7.7, to all SPARK code within a unit. As
diff --git a/gcc/ada/doc/gnat_rm/obsolescent_features.rst b/gcc/ada/doc/gnat_rm/obsolescent_features.rst
index d78d986f..f1e2061 100644
--- a/gcc/ada/doc/gnat_rm/obsolescent_features.rst
+++ b/gcc/ada/doc/gnat_rm/obsolescent_features.rst
@@ -14,7 +14,7 @@ historical compatibility purposes.
PolyORB
========
-AWS is a deprecated product. It will be baselined with the GNAT Pro
+PolyORB is a deprecated product. It will be baselined with the GNAT Pro
release 28. After this release, there will be no new versions of this
product. Contact your sales representative or send a message to
sales@adacore.com to get recommendations for replacements.
diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index 290ae33..b0acb25 100644
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -333,7 +333,8 @@ package body Einfo.Utils is
function Is_Modular_Integer_Type (Id : E) return B is
begin
- return Ekind (Id) in Modular_Integer_Kind;
+ return Ekind (Id) in Modular_Integer_Kind
+ and then not Has_Unsigned_Base_Range_Aspect (Base_Type (Id));
end Is_Modular_Integer_Type;
function Is_Named_Access_Type (Id : E) return B is
@@ -393,7 +394,10 @@ package body Einfo.Utils is
function Is_Signed_Integer_Type (Id : E) return B is
begin
- return Ekind (Id) in Signed_Integer_Kind;
+ return Ekind (Id) in Signed_Integer_Kind
+ or else
+ (Ekind (Id) in Modular_Integer_Kind
+ and then Has_Unsigned_Base_Range_Aspect (Base_Type (Id)));
end Is_Signed_Integer_Type;
function Is_Subprogram (Id : E) return B is
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index b5d9c1c..b9548a7 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -5757,6 +5757,7 @@ package Einfo is
-- Non_Binary_Modulus (base type only)
-- Has_Biased_Representation
-- Has_Shift_Operator (base type only)
+ -- Has_Unsigned_Base_Range_Aspect (base type only)
-- No_Predicate_On_Actual
-- No_Dynamic_Predicate_On_Actual
-- Type_Low_Bound (synth)
diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb
index 8759099..1107af3 100644
--- a/gcc/ada/exp_fixd.adb
+++ b/gcc/ada/exp_fixd.adb
@@ -595,7 +595,8 @@ package body Exp_Fixd is
Defining_Identifier => Dnn,
Object_Definition => New_Occurrence_Of (QR_Typ, Loc),
Constant_Present => True,
- Expression => Build_Multiply (N, Y, Z)));
+ Expression =>
+ Build_Conversion (N, QR_Typ, Build_Multiply (N, Y, Z))));
Quo :=
Build_Divide (N,
@@ -656,8 +657,8 @@ package body Exp_Fixd is
function Build_Multiply (N : Node_Id; L, R : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
- Left_Type : constant Entity_Id := Etype (L);
- Right_Type : constant Entity_Id := Etype (R);
+ Left_Type : constant Entity_Id := Base_Type (Etype (L));
+ Right_Type : constant Entity_Id := Base_Type (Etype (R));
Left_Size : Int;
Right_Size : Int;
Result_Type : Entity_Id;
@@ -746,8 +747,8 @@ package body Exp_Fixd is
function Build_Rem (N : Node_Id; L, R : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
- Left_Type : constant Entity_Id := Etype (L);
- Right_Type : constant Entity_Id := Etype (R);
+ Left_Type : constant Entity_Id := Base_Type (Etype (L));
+ Right_Type : constant Entity_Id := Base_Type (Etype (R));
Result_Type : Entity_Id;
Rnode : Node_Id;
@@ -959,7 +960,8 @@ package body Exp_Fixd is
Defining_Identifier => Nnn,
Object_Definition => New_Occurrence_Of (QR_Typ, Loc),
Constant_Present => True,
- Expression => Build_Multiply (N, X, Y)),
+ Expression =>
+ Build_Conversion (N, QR_Typ, Build_Multiply (N, X, Y))),
Make_Object_Declaration (Loc,
Defining_Identifier => Dnn,
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 30b2461..4d88626 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -12613,8 +12613,12 @@ package body Exp_Util is
-- Local variables
Loc : constant Source_Ptr := Sloc (Exp);
- Exp_Type : constant Entity_Id := Etype (Exp);
Svg_Suppress : constant Suppress_Record := Scope_Suppress;
+ Typ : constant Entity_Id := Etype (Exp);
+ Und_Typ : constant Entity_Id :=
+ (if Present (Typ) then Underlying_Type (Typ) else Typ);
+ -- The underlying type that drives part of the processing
+
Def_Id : Entity_Id;
E : Node_Id;
New_Exp : Node_Id;
@@ -12640,8 +12644,9 @@ package body Exp_Util is
-- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
-- Remove_Side_Effects).
- elsif No (Exp_Type)
- or else Ekind (Exp_Type) = E_Access_Attribute_Type
+ elsif No (Typ)
+ or else No (Und_Typ)
+ or else Ekind (Und_Typ) = E_Access_Attribute_Type
then
return;
@@ -12690,12 +12695,12 @@ package body Exp_Util is
-- anyway, see below). Also do it if we have a volatile reference and
-- Name_Req is not set (see comments for Side_Effect_Free).
- elsif (Is_Elementary_Type (Exp_Type)
- or else (Is_Record_Type (Exp_Type)
- and then Known_Static_RM_Size (Exp_Type)
- and then RM_Size (Exp_Type) <= System_Max_Integer_Size
- and then not Has_Discriminants (Exp_Type)
- and then not Is_By_Reference_Type (Exp_Type)))
+ elsif (Is_Elementary_Type (Und_Typ)
+ or else (Is_Record_Type (Und_Typ)
+ and then Known_Static_RM_Size (Und_Typ)
+ and then RM_Size (Und_Typ) <= System_Max_Integer_Size
+ and then not Has_Discriminants (Und_Typ)
+ and then not Is_By_Reference_Type (Und_Typ)))
and then (Variable_Ref
or else (not Is_Name_Reference (Exp)
and then Nkind (Exp) /= N_Type_Conversion)
@@ -12703,7 +12708,7 @@ package body Exp_Util is
and then Is_Volatile_Reference (Exp)))
then
Def_Id := Build_Temporary (Loc, 'R', Exp);
- Set_Etype (Def_Id, Exp_Type);
+ Set_Etype (Def_Id, Typ);
Res := New_Occurrence_Of (Def_Id, Loc);
-- If the expression is a packed reference, it must be reanalyzed and
@@ -12719,7 +12724,7 @@ package body Exp_Util is
end if;
-- Generate:
- -- Rnn : Exp_Type renames Expr;
+ -- Rnn : Typ renames Expr;
-- In GNATprove mode, we prefer to use renamings for intermediate
-- variables to definition of constants, due to the implicit move
@@ -12730,22 +12735,22 @@ package body Exp_Util is
if Renaming_Req
or else (GNATprove_Mode
and then Is_Object_Reference (Exp)
- and then not Is_Scalar_Type (Exp_Type))
+ and then not Is_Scalar_Type (Und_Typ))
then
E :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Def_Id,
- Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name => Relocate_Node (Exp));
-- Generate:
- -- Rnn : constant Exp_Type := Expr;
+ -- Rnn : constant Typ := Expr;
else
E :=
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
- Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
Constant_Present => True,
Expression => Relocate_Node (Exp));
@@ -12801,7 +12806,7 @@ package body Exp_Util is
elsif Nkind (Exp) = N_Unchecked_Type_Conversion
and then not Safe_Unchecked_Type_Conversion (Exp)
then
- if CW_Or_Needs_Finalization (Exp_Type) then
+ if CW_Or_Needs_Finalization (Und_Typ) then
-- Use a renaming to capture the expression, rather than create
-- a controlled temporary.
@@ -12812,18 +12817,18 @@ package body Exp_Util is
Insert_Action (Exp,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Def_Id,
- Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name => Relocate_Node (Exp)));
else
Def_Id := Build_Temporary (Loc, 'R', Exp);
- Set_Etype (Def_Id, Exp_Type);
+ Set_Etype (Def_Id, Typ);
Res := New_Occurrence_Of (Def_Id, Loc);
E :=
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
- Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
Constant_Present => not Is_Variable (Exp),
Expression => Relocate_Node (Exp));
@@ -12853,7 +12858,7 @@ package body Exp_Util is
-- type and we do not have Name_Req set true (see comments for
-- Side_Effect_Free).
- and then (Name_Req or else not Treat_As_Volatile (Exp_Type)))
+ and then (Name_Req or else not Treat_As_Volatile (Und_Typ)))
then
Def_Id := Build_Temporary (Loc, 'R', Exp);
Res := New_Occurrence_Of (Def_Id, Loc);
@@ -12861,7 +12866,7 @@ package body Exp_Util is
Insert_Action (Exp,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Def_Id,
- Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name => Relocate_Node (Exp)));
-- Avoid generating a variable-sized temporary, by generating the
@@ -12871,7 +12876,7 @@ package body Exp_Util is
elsif Nkind (Exp) = N_Selected_Component
and then Nkind (Prefix (Exp)) = N_Function_Call
- and then Is_Array_Type (Exp_Type)
+ and then Is_Array_Type (Und_Typ)
then
Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
goto Leave;
@@ -12890,9 +12895,9 @@ package body Exp_Util is
-- to the object in the latter case.
if Nkind (Exp) = N_Function_Call
- and then (Is_Build_In_Place_Result_Type (Exp_Type)
+ and then (Is_Build_In_Place_Result_Type (Und_Typ)
or else
- Is_Constr_Array_Subt_Of_Unc_With_Controlled (Exp_Type))
+ Is_Constr_Array_Subt_Of_Unc_With_Controlled (Und_Typ))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
and then not Is_Expression_Of_Func_Return (Exp)
then
@@ -12904,11 +12909,11 @@ package body Exp_Util is
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Obj,
- Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (Exp));
Insert_Action (Exp, Decl);
- Set_Etype (Obj, Exp_Type);
+ Set_Etype (Obj, Typ);
Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
goto Leave;
end;
@@ -12924,7 +12929,7 @@ package body Exp_Util is
if GNATprove_Mode then
Res := New_Occurrence_Of (Def_Id, Loc);
- Ref_Type := Exp_Type;
+ Ref_Type := Typ;
-- Regular expansion utilizing an access type and 'reference
@@ -12934,7 +12939,7 @@ package body Exp_Util is
Prefix => New_Occurrence_Of (Def_Id, Loc));
-- Generate:
- -- type Ann is access all <Exp_Type>;
+ -- type Ann is access all Typ;
Ref_Type := Make_Temporary (Loc, 'A');
@@ -12944,8 +12949,7 @@ package body Exp_Util is
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
- Subtype_Indication =>
- New_Occurrence_Of (Exp_Type, Loc)));
+ Subtype_Indication => New_Occurrence_Of (Typ, Loc)));
Insert_Action (Exp, Ptr_Typ_Decl);
end if;
@@ -12974,16 +12978,16 @@ package body Exp_Util is
if not Analyzed (Exp)
and then Nkind (Exp) = N_Aggregate
- and then (Is_Array_Type (Exp_Type)
- or else Has_Discriminants (Exp_Type))
- and then Is_Constrained (Exp_Type)
+ and then (Is_Array_Type (Und_Typ)
+ or else Has_Discriminants (Und_Typ))
+ and then Is_Constrained (Und_Typ)
then
-- Do not suppress checks associated with the qualified
-- expression we are about to introduce (unless those
-- checks were already suppressed when Remove_Side_Effects
-- was called).
- if Is_Array_Type (Exp_Type) then
+ if Is_Array_Type (Und_Typ) then
Scope_Suppress.Suppress (Length_Check) :=
Svg_Suppress.Suppress (Length_Check);
else
@@ -12991,9 +12995,10 @@ package body Exp_Util is
Svg_Suppress.Suppress (Discriminant_Check);
end if;
- E := Make_Qualified_Expression (Loc,
- Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
- Expression => E);
+ E :=
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Expression => E);
end if;
New_Exp := Make_Reference (Loc, E);
@@ -13041,7 +13046,7 @@ package body Exp_Util is
-- Finally rewrite the original expression and we are done
Rewrite (Exp, Res);
- Analyze_And_Resolve (Exp, Exp_Type);
+ Analyze_And_Resolve (Exp, Typ);
<<Leave>>
Scope_Suppress := Svg_Suppress;
diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb
index 4f20231..0ad24b3 100644
--- a/gcc/ada/fmap.adb
+++ b/gcc/ada/fmap.adb
@@ -191,8 +191,8 @@ package body Fmap is
begin
Unit_Hash_Table.Reset;
File_Hash_Table.Reset;
- Path_Mapping.Set_Last (0);
- File_Mapping.Set_Last (0);
+ Path_Mapping.Clear;
+ File_Mapping.Clear;
Last_In_Table := 0;
end Empty_Tables;
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 346789f..d8fdc30 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -5646,14 +5646,9 @@ package body Freeze is
-- If the component is an access type with an allocator as default
-- value, the designated type will be frozen by the corresponding
- -- expression in init_proc. In order to place the freeze node for
- -- the designated type before that for the current record type,
- -- freeze it now.
-
- -- Same process if the component is an array of access types,
- -- initialized with an aggregate. If the designated type is
- -- private, it cannot contain allocators, and it is premature
- -- to freeze the type, so we check for this as well.
+ -- expression in the initialization procedure. In order to place
+ -- the freeze node for the designated type ahead of that for the
+ -- current record type, freeze the designated type right now.
elsif Is_Access_Type (Etype (Comp))
and then Present (Parent (Comp))
@@ -5665,17 +5660,16 @@ package body Freeze is
declare
Alloc : constant Node_Id :=
Unqualify (Expression (Parent (Comp)));
-
+ Desig_Typ : constant Entity_Id :=
+ Designated_Type (Etype (Comp));
begin
if Nkind (Alloc) = N_Allocator then
-
-- If component is pointer to a class-wide type, freeze
-- the specific type in the expression being allocated.
-- The expression may be a subtype indication, in which
-- case freeze the subtype mark.
- if Is_Class_Wide_Type (Designated_Type (Etype (Comp)))
- then
+ if Is_Class_Wide_Type (Desig_Typ) then
if Is_Entity_Name (Expression (Alloc)) then
Freeze_And_Append
(Entity (Expression (Alloc)), N, Result);
@@ -5686,21 +5680,24 @@ package body Freeze is
(Entity (Subtype_Mark (Expression (Alloc))),
N, Result);
end if;
- elsif Is_Itype (Designated_Type (Etype (Comp))) then
+ elsif Is_Itype (Desig_Typ) then
Check_Itype (Etype (Comp));
else
- Freeze_And_Append
- (Designated_Type (Etype (Comp)), N, Result);
+ Freeze_And_Append (Desig_Typ, N, Result);
end if;
end if;
end;
+
elsif Is_Access_Type (Etype (Comp))
and then Is_Itype (Designated_Type (Etype (Comp)))
then
Check_Itype (Etype (Comp));
- -- Freeze the designated type when initializing a component with
- -- an aggregate in case the aggregate contains allocators.
+ -- Likewise if the component is an array of access types that is
+ -- initialized with an aggregate, in case the aggregate contains
+ -- allocators. But if the designated type is private, it cannot
+ -- contain allocators, and it is premature to freeze the type,
+ -- so we check for this as well.
-- type T is ...;
-- type T_Ptr is access all T;
@@ -5712,13 +5709,15 @@ package body Freeze is
elsif Is_Array_Type (Etype (Comp))
and then Is_Access_Type (Component_Type (Etype (Comp)))
+ and then Present (Parent (Comp))
+ and then Nkind (Parent (Comp)) = N_Component_Declaration
+ and then Present (Expression (Parent (Comp)))
+ and then Nkind (Expression (Parent (Comp))) = N_Aggregate
then
declare
- Comp_Par : constant Node_Id := Parent (Comp);
Desig_Typ : constant Entity_Id :=
Designated_Type
(Component_Type (Etype (Comp)));
-
begin
-- The only case when this sort of freezing is not done is
-- when the designated type is class-wide and the root type
@@ -5740,12 +5739,7 @@ package body Freeze is
then
null;
- elsif Is_Fully_Defined (Desig_Typ)
- and then Present (Comp_Par)
- and then Nkind (Comp_Par) = N_Component_Declaration
- and then Present (Expression (Comp_Par))
- and then Nkind (Expression (Comp_Par)) = N_Aggregate
- then
+ elsif Is_Fully_Defined (Desig_Typ) then
Freeze_And_Append (Desig_Typ, N, Result);
end if;
end;
diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc
index f176ca9..83b9e82 100644
--- a/gcc/ada/gcc-interface/utils.cc
+++ b/gcc/ada/gcc-interface/utils.cc
@@ -3226,6 +3226,9 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
{
tree field_decl = build_decl (input_location, FIELD_DECL, name, type);
+ /* The type must be frozen at this point. */
+ gcc_assert (COMPLETE_TYPE_P (type));
+
DECL_CONTEXT (field_decl) = record_type;
TREE_READONLY (field_decl) = TYPE_READONLY (type);
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 7351515..68a3c14 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -19,7 +19,7 @@
@copying
@quotation
-GNAT Reference Manual , Sep 29, 2025
+GNAT Reference Manual , Oct 17, 2025
AdaCore
@@ -33627,7 +33627,7 @@ historical compatibility purposes.
@section PolyORB
-AWS is a deprecated product. It will be baselined with the GNAT Pro
+PolyORB is a deprecated product. It will be baselined with the GNAT Pro
release 28. After this release, there will be no new versions of this
product. Contact your sales representative or send a message to
@email{sales@@adacore.com} to get recommendations for replacements.
diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb
index b51f2b5..c9a98e9 100644
--- a/gcc/ada/libgnarl/s-taprop__qnx.adb
+++ b/gcc/ada/libgnarl/s-taprop__qnx.adb
@@ -96,6 +96,22 @@ package body System.Task_Primitives.Operations is
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
+ Default_Signal_Mask : aliased sigset_t;
+ -- Default signal mask, used to restore signal mask after thread creation
+
+ Default_Signal_Mask_Initialized : Boolean := False;
+ -- Allow to not enable default signals if the default signal mask failed to
+ -- initialize.
+
+ procedure Disable_Signals;
+ -- Disable signals before calling pthread_create to avoid a potential
+ -- memory leak on QNX.
+
+ procedure Enable_Signals;
+ -- Enable signals after pthread_create and in the created task. Since the
+ -- created task inherits the disabled signals from the parent they have to
+ -- be enabled for each task separately.
+
-- The followings are internal configuration constants needed
Next_Serial_Number : Task_Serial_Number := 100;
@@ -654,6 +670,7 @@ package body System.Task_Primitives.Operations is
procedure Enter_Task (Self_ID : Task_Id) is
begin
+ Enable_Signals;
Self_ID.Common.LL.LWP := lwp_self;
Specific.Set (Self_ID);
@@ -765,17 +782,6 @@ package body System.Task_Primitives.Operations is
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- function Disable_Signals return Interfaces.C.int with
- Import,
- Convention => C,
- External_Name => "__gnat_disable_signals";
-
- function Enable_Signals return Interfaces.C.int with
- Import,
- Convention => C,
- External_Name => "__gnat_enable_signals";
-
begin
Adjusted_Stack_Size :=
Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
@@ -862,20 +868,17 @@ package body System.Task_Primitives.Operations is
-- Restricted.Stages is used). One can verify that by inspecting the
-- Task_Wrapper procedures.
- Result := Disable_Signals;
- pragma Assert (Result = 0);
+ Disable_Signals;
Result := pthread_create
(T.Common.LL.Thread'Access,
Attributes'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
pragma Assert (Result = 0 or else Result = EAGAIN);
+ Enable_Signals;
Succeeded := Result = 0;
- Result := Enable_Signals;
- pragma Assert (Result = 0);
-
Result := pthread_attr_destroy (Attributes'Access);
pragma Assert (Result = 0);
end Create_Task;
@@ -1292,6 +1295,10 @@ package body System.Task_Primitives.Operations is
end if;
end loop;
+ Result := pthread_sigmask
+ (SIG_SETMASK, null, Default_Signal_Mask'Access);
+ Default_Signal_Mask_Initialized := Result = 0;
+
-- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
@@ -1378,4 +1385,56 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
end Set_Task_Affinity;
+ ---------------------
+ -- Disable_Signals --
+ ---------------------
+
+ procedure Disable_Signals
+ is
+ Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+ begin
+ -- If the default signal mask is not initialized there is no point in
+ -- disabling signals since we can't enable them again. Not enabling them
+ -- might impact the runtimes functionality so we rather accept the
+ -- possible memory leak.
+ if not Default_Signal_Mask_Initialized then
+ return;
+ end if;
+
+ -- If any of the operations of setting up the signal mask fails we abort
+ -- disabling the signals. The function to enable the signals doesn't
+ -- need to care about this. It will simply restore the default signal
+ -- mask if it was successfully initialized. If the signals are not
+ -- disabled this is a no-op.
+ Result := sigemptyset (Set'Access);
+ if Result /= 0 then
+ return;
+ end if;
+ for S in SIGHUP .. SIGXFSZ loop
+ Result := sigaddset (Set'Access, Signal (S));
+ if Result /= 0 then
+ return;
+ end if;
+ end loop;
+ Result := pthread_sigmask (SIG_BLOCK, Set'Access, null);
+ pragma Assert (Result = 0);
+ end Disable_Signals;
+
+ --------------------
+ -- Enable_Signals --
+ --------------------
+
+ procedure Enable_Signals
+ is
+ Result : Interfaces.C.int;
+ begin
+ if not Default_Signal_Mask_Initialized then
+ return;
+ end if;
+ Result := pthread_sigmask
+ (SIG_SETMASK, Default_Signal_Mask'Access, null);
+ pragma Assert (Result = 0);
+ end Enable_Signals;
+
end System.Task_Primitives.Operations;
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index f8ae997..338be46 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -485,7 +485,8 @@ package body Ch4 is
-- Attribute Unsigned_Base_Range temporarily disabled
if not Is_Attribute_Name (Attr_Name)
- or else Attr_Name = Name_Unsigned_Base_Range
+ or else (Attr_Name = Name_Unsigned_Base_Range
+ and then not Debug_Flag_Dot_U)
then
if Apostrophe_Should_Be_Semicolon then
Expr_Form := EF_Name;
diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb
index 032bcf0..3575ad5 100644
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -2888,8 +2888,7 @@ package body Par_SCO is
end;
end loop;
- -- Clear the pending decisions list
- Pending_Decisions.Set_Last (0);
+ Pending_Decisions.Clear;
end Process_Pending_Decisions;
-----------------------------
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 3575b04..deb19ee 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -480,14 +480,16 @@ package body Sem_Ch12 is
-- Create a new access type with the given designated type
function Analyze_Associations
- (N : Node_Id;
- Formals : List_Id;
- F_Copy : List_Id) return List_Id;
+ (N : Node_Id;
+ Formals : List_Id;
+ F_Copy : List_Id;
+ Parent_Installed : Boolean) return List_Id;
-- At instantiation time, build the list of associations between formals
-- and actuals. Each association becomes a renaming declaration for the
-- formal entity. N is the instantiation node. Formals is the list of
- -- unanalyzed formals. F_Copy is the analyzed list of formals in the
- -- generic copy.
+ -- unanalyzed formals. F_Copy is the list of analyzed formals in the
+ -- generic copy. Parent_Installed is True if the parent has been installed
+ -- during the instantiation.
procedure Analyze_Subprogram_Instantiation
(N : Node_Id;
@@ -838,9 +840,12 @@ package body Sem_Ch12 is
-- the same list it is passing to Actual_Decls.
function Instantiate_Formal_Subprogram
- (Formal : Node_Id;
- Actual : Node_Id;
- Analyzed_Formal : Node_Id) return Node_Id;
+ (Formal : Node_Id;
+ Actual : Node_Id;
+ Analyzed_Formal : Node_Id;
+ Parent_Installed : Boolean) return Node_Id;
+ -- Parent_Installed is True if the parent has been installed during the
+ -- instantiation.
function Instantiate_Formal_Package
(Formal : Node_Id;
@@ -1283,12 +1288,14 @@ package body Sem_Ch12 is
procedure Analyze_One_Association
(N : Node_Id;
Assoc : Associations.Assoc_Rec;
+ Parent_Installed : Boolean;
Result_Renamings : List_Id;
Default_Actuals : List_Id;
Actuals_To_Freeze : Elist_Id);
- -- Called by Analyze_Associations for each association. The renamings
- -- are appended onto Result_Renamings. Defaulted actuals are appended
- -- onto Default_Actuals, and actuals that require freezing are
+ -- Called by Analyze_Associations for each association. Parent_Installed
+ -- is True if the parent has been installed during the instantiation. The
+ -- renamings are appended onto Result_Renamings. The defaulted actuals are
+ -- appended onto Default_Actuals, and actuals that require freezing are
-- appended onto Actuals_To_Freeze.
procedure Analyze_Structural_Associations
@@ -2362,9 +2369,10 @@ package body Sem_Ch12 is
--------------------------
function Analyze_Associations
- (N : Node_Id;
- Formals : List_Id;
- F_Copy : List_Id) return List_Id
+ (N : Node_Id;
+ Formals : List_Id;
+ F_Copy : List_Id;
+ Parent_Installed : Boolean) return List_Id
is
use Associations;
@@ -2412,6 +2420,7 @@ package body Sem_Ch12 is
Analyze_One_Association
(N,
Assoc,
+ Parent_Installed,
Result_Renamings,
Default_Actuals,
Actuals_To_Freeze);
@@ -2470,6 +2479,7 @@ package body Sem_Ch12 is
procedure Analyze_One_Association
(N : Node_Id;
Assoc : Associations.Assoc_Rec;
+ Parent_Installed : Boolean;
Result_Renamings : List_Id;
Default_Actuals : List_Id;
Actuals_To_Freeze : Elist_Id)
@@ -2736,7 +2746,10 @@ package body Sem_Ch12 is
else
Append_To (Result_Renamings,
Instantiate_Formal_Subprogram
- (Assoc.Un_Formal, Match, Assoc.An_Formal));
+ (Assoc.Un_Formal,
+ Match,
+ Assoc.An_Formal,
+ Parent_Installed));
-- If formal subprogram has contracts, create wrappers
-- for it. This is an expansion activity that cannot
@@ -3557,7 +3570,7 @@ package body Sem_Ch12 is
-- List of primitives made temporarily visible in the instantiation
-- to match the visibility of the formal type.
- function Build_Local_Package return Node_Id;
+ function Build_Local_Package (Parent_Installed : Boolean) return Node_Id;
-- The formal package is rewritten so that its parameters are replaced
-- with corresponding declarations. For parameters with bona fide
-- associations these declarations are created by Analyze_Associations
@@ -3569,7 +3582,8 @@ package body Sem_Ch12 is
-- Build_Local_Package --
-------------------------
- function Build_Local_Package return Node_Id is
+ function Build_Local_Package (Parent_Installed : Boolean) return Node_Id
+ is
Decls : List_Id;
Pack_Decl : Node_Id;
@@ -3639,15 +3653,16 @@ package body Sem_Ch12 is
Instantiating => True);
begin
- Generic_Renamings.Set_Last (0);
+ Generic_Renamings.Clear;
Generic_Renamings_HTable.Reset;
Instantiation_Node := N;
Decls :=
Analyze_Associations
- (N => Original_Node (N),
- Formals => Generic_Formal_Declarations (Act_Tree),
- F_Copy => Generic_Formal_Declarations (Gen_Decl));
+ (N => Original_Node (N),
+ Formals => Generic_Formal_Declarations (Act_Tree),
+ F_Copy => Generic_Formal_Declarations (Gen_Decl),
+ Parent_Installed => Parent_Installed);
Vis_Prims_List := Check_Hidden_Primitives (Decls);
end;
@@ -3782,7 +3797,7 @@ package body Sem_Ch12 is
-- internal declarations.
begin
- New_N := Build_Local_Package;
+ New_N := Build_Local_Package (Parent_Installed);
-- If there are errors in the parameter list, Analyze_Associations
-- raises Instantiation_Error. Patch the declaration to prevent further
@@ -3868,6 +3883,7 @@ package body Sem_Ch12 is
Renaming_In_Par :=
Make_Defining_Identifier (Loc, Chars (Gen_Unit));
Mutate_Ekind (Renaming_In_Par, E_Package);
+ Set_Is_Internal (Renaming_In_Par);
Set_Is_Not_Self_Hidden (Renaming_In_Par);
Set_Etype (Renaming_In_Par, Standard_Void_Type);
Set_Scope (Renaming_In_Par, Parent_Instance);
@@ -4998,7 +5014,7 @@ package body Sem_Ch12 is
-- inherited from formal packages of parent units, and these are
-- constructed when the parents are installed.
- Generic_Renamings.Set_Last (0);
+ Generic_Renamings.Clear;
Generic_Renamings_HTable.Reset;
-- Except for an abbreviated instance created to check a formal package,
@@ -5159,9 +5175,10 @@ package body Sem_Ch12 is
Renamings :=
Analyze_Associations
- (N => N,
- Formals => Generic_Formal_Declarations (Act_Tree),
- F_Copy => Generic_Formal_Declarations (Gen_Decl));
+ (N => N,
+ Formals => Generic_Formal_Declarations (Act_Tree),
+ F_Copy => Generic_Formal_Declarations (Gen_Decl),
+ Parent_Installed => Parent_Installed);
-- Bail out if the instantiation has been turned into something else
@@ -6718,7 +6735,7 @@ package body Sem_Ch12 is
-- Remove package itself from visibility, so it does not
-- conflict with subprogram.
- Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id));
+ Remove_Homonym (Pack_Id);
-- Set name and scope of internal subprogram so that the proper
-- external name will be generated. The proper scope is the scope
@@ -6962,7 +6979,7 @@ package body Sem_Ch12 is
-- Initialize renamings map, for error checking
- Generic_Renamings.Set_Last (0);
+ Generic_Renamings.Clear;
Generic_Renamings_HTable.Reset;
Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
@@ -6981,9 +6998,10 @@ package body Sem_Ch12 is
Renamings :=
Analyze_Associations
- (N => N,
- Formals => Generic_Formal_Declarations (Act_Tree),
- F_Copy => Generic_Formal_Declarations (Gen_Decl));
+ (N => N,
+ Formals => Generic_Formal_Declarations (Act_Tree),
+ F_Copy => Generic_Formal_Declarations (Gen_Decl),
+ Parent_Installed => Parent_Installed);
-- Bail out if the instantiation has been turned into something else
@@ -7236,7 +7254,7 @@ package body Sem_Ch12 is
Restore_Hidden_Primitives (Vis_Prims_List);
Restore_Env;
Env_Installed := False;
- Generic_Renamings.Set_Last (0);
+ Generic_Renamings.Clear;
Generic_Renamings_HTable.Reset;
end if;
@@ -12538,9 +12556,10 @@ package body Sem_Ch12 is
-----------------------------------
function Instantiate_Formal_Subprogram
- (Formal : Node_Id;
- Actual : Node_Id;
- Analyzed_Formal : Node_Id) return Node_Id
+ (Formal : Node_Id;
+ Actual : Node_Id;
+ Analyzed_Formal : Node_Id;
+ Parent_Installed : Boolean) return Node_Id
is
Analyzed_S : constant Entity_Id :=
Defining_Unit_Name (Specification (Analyzed_Formal));
@@ -12548,13 +12567,7 @@ package body Sem_Ch12 is
Defining_Unit_Name (Specification (Formal));
function From_Parent_Scope (Subp : Entity_Id) return Boolean;
- -- If the generic is a child unit, the parent has been installed on the
- -- scope stack, but a default subprogram cannot resolve to something
- -- on the parent because that parent is not really part of the visible
- -- context (it is there to resolve explicit local entities). If the
- -- default has resolved in this way, we remove the entity from immediate
- -- visibility and analyze the node again to emit an error message or
- -- find another visible candidate.
+ -- Return true if Subp is declared in a parent scope of Analyzed_S
procedure Valid_Actual_Subprogram (Act : Node_Id);
-- Perform legality check and raise exception on failure
@@ -12812,21 +12825,31 @@ package body Sem_Ch12 is
end if;
-- Gather possible interpretations for the actual before analyzing the
- -- instance. If overloaded, it will be resolved when analyzing the
- -- renaming declaration.
+ -- instance. If the actual is overloaded, then it will be resolved when
+ -- the renaming declaration is analyzed.
if Box_Present (Formal) and then No (Actual) then
Analyze (Nam);
- if Is_Child_Unit (Scope (Analyzed_S))
- and then Present (Entity (Nam))
+ -- If the generic is a child unit and the parent has been installed
+ -- during this instantiation (as opposed to having been installed in
+ -- the context of the instantiation at some earlier point), a default
+ -- subprogram cannot resolve to something in the parent because the
+ -- parent is not really part of the visible context (it is there to
+ -- resolve explicit local entities). If the default subprogram has
+ -- been resolved in this way, we remove the entity from immediate
+ -- visibility and analyze the node again to emit an error message
+ -- or find another visible candidate.
+
+ if Present (Entity (Nam))
+ and then Is_Child_Unit (Scope (Analyzed_S))
+ and then Parent_Installed
then
if not Is_Overloaded (Nam) then
if From_Parent_Scope (Entity (Nam)) then
Set_Is_Immediately_Visible (Entity (Nam), False);
Set_Entity (Nam, Empty);
Set_Etype (Nam, Empty);
-
Analyze (Nam);
Set_Is_Immediately_Visible (Entity (Nam));
end if;
@@ -13200,7 +13223,7 @@ package body Sem_Ch12 is
-- to capture local names that may be hidden if the generic is
-- a child unit.
- if Nkind (Actual) = N_Aggregate then
+ if Nkind (Unqualify (Actual)) = N_Aggregate then
Preanalyze_And_Resolve (Actual, Typ);
end if;
@@ -17639,6 +17662,8 @@ package body Sem_Ch12 is
Set_Etype (N2, E);
end if;
+ -- If the entity is global, save its type in the generic node
+
if Is_Global (E) then
Set_Global_Type (N, N2);
@@ -17659,12 +17684,24 @@ package body Sem_Ch12 is
Set_Etype (N, Empty);
end if;
+ -- If default actuals have been added to a generic instantiation
+ -- and they are global, save them in the generic node.
+
if Nkind (Parent (N)) in N_Generic_Instantiation
and then N = Name (Parent (N))
then
Save_Global_Defaults (Parent (N), Parent (N2));
end if;
+ if Nkind (Parent (N)) = N_Selected_Component
+ and then N = Selector_Name (Parent (N))
+ and then Nkind (Parent (Parent (N))) in N_Generic_Instantiation
+ and then Parent (N) = Name (Parent (Parent (N)))
+ then
+ Save_Global_Defaults
+ (Parent (Parent (N)), Parent (Parent (N2)));
+ end if;
+
elsif Nkind (Parent (N)) = N_Selected_Component
and then Nkind (Parent (N2)) = N_Expanded_Name
then
@@ -18488,12 +18525,13 @@ package body Sem_Ch12 is
elsif Nkind (N) = N_Pragma then
Save_References_In_Pragma (N);
+ -- Aspects
+
elsif Nkind (N) = N_Aspect_Specification then
declare
P : constant Node_Id := Parent (N);
- Expr : Node_Id;
- begin
+ begin
if Permits_Aspect_Specifications (P) then
-- The capture of global references within aspects
@@ -18505,15 +18543,11 @@ package body Sem_Ch12 is
if Requires_Delayed_Save (Original_Node (P)) then
null;
- -- Otherwise save all global references within the
- -- aspects
-
- else
- Expr := Expression (N);
+ -- Otherwise save all global references within the
+ -- expression of the aspect.
- if Present (Expr) then
- Save_Global_References (Expr);
- end if;
+ elsif Present (Expression (N)) then
+ Save_Global_References (Expression (N));
end if;
end if;
end;
@@ -18523,10 +18557,11 @@ package body Sem_Ch12 is
elsif Nkind (N) = N_Implicit_Label_Declaration then
null;
+ -- Other nodes
+
else
Save_References_In_Descendants (N);
end if;
-
end Save_References;
---------------------
@@ -18686,9 +18721,8 @@ package body Sem_Ch12 is
procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is
begin
- Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null);
+ Generic_Renamings.Append ((A, B, Assoc_Null));
Generic_Renamings_HTable.Set (Generic_Renamings.Last);
- Generic_Renamings.Increment_Last;
end Set_Instance_Of;
--------------------
@@ -19321,39 +19355,22 @@ package body Sem_Ch12 is
--------------------
function Save_And_Reset return Context is
+ First : constant Integer := Integer (Generic_Renamings.First);
+ Last : constant Integer := Integer (Generic_Renamings.Last);
begin
- return Result : Context (0 .. Integer (Generic_Renamings.Last)) do
+ return Result : Context (First .. Last) do
for Index in Result'Range loop
declare
Indexed_Assoc : Assoc renames Generic_Renamings.Table
(Assoc_Ptr (Index));
Result_Pair : Binding_Pair renames Result (Index);
begin
- -- If we have called Increment_Last but have not yet
- -- initialized the new last element of the table, then
- -- that last element might be invalid. Saving and
- -- restoring (especially restoring, it turns out) invalid
- -- values can result in exceptions if predicate checking
- -- is enabled, so replace invalid values with Empty.
-
- if Indexed_Assoc.Gen_Id'Valid then
- Result_Pair.Formal_Id := Indexed_Assoc.Gen_Id;
- else
- pragma Assert (Index = Result'Last);
- Result_Pair.Formal_Id := Empty;
- end if;
-
- if Indexed_Assoc.Act_Id'Valid then
- Result_Pair.Actual_Id := Indexed_Assoc.Act_Id;
- else
- pragma Assert (Index = Result'Last);
- Result_Pair.Actual_Id := Empty;
- end if;
+ Result_Pair.Formal_Id := Indexed_Assoc.Gen_Id;
+ Result_Pair.Actual_Id := Indexed_Assoc.Act_Id;
end;
end loop;
Generic_Renamings.Init;
- Generic_Renamings.Set_Last (-1);
Generic_Renamings_HTable.Reset;
end return;
end Save_And_Reset;
@@ -19365,13 +19382,10 @@ package body Sem_Ch12 is
procedure Restore (Saved : Context) is
begin
Generic_Renamings.Init;
- Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
- Generic_Renamings.Increment_Last;
for Pair of Saved loop
Set_Instance_Of (Pair.Formal_Id, Pair.Actual_Id);
end loop;
- Generic_Renamings.Decrement_Last;
end Restore;
end Instance_Context;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 22fea0d..f7be890 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1406,7 +1406,7 @@ package body Sem_Ch13 is
Error_Msg_N ("nonoverridable aspect % of type % requires % "
& Operation_Kind
& "# to be a primitive operation",
- Original);
+ Expr);
end;
end if;
end Check_Nonoverridable_Aspect_Subprograms;
@@ -2372,7 +2372,13 @@ package body Sem_Ch13 is
then
if A_Id = Aspect_Import then
Set_Has_Completion (E);
- Set_Is_Imported (E);
+
+ -- Do not set Is_Imported on Exceptions, similarly
+ -- to Sem_Prag.Process_Import_Or_Interface.
+
+ if Ekind (E) /= E_Exception then
+ Set_Is_Imported (E);
+ end if;
-- An imported object cannot be explicitly initialized
@@ -3590,6 +3596,7 @@ package body Sem_Ch13 is
| Aspect_Effective_Reads
| Aspect_Effective_Writes
| Aspect_Preelaborable_Initialization
+ | Aspect_Unsigned_Base_Range
then
Error_Msg_Name_1 := Nam;
@@ -3703,6 +3710,13 @@ package body Sem_Ch13 is
then
Delay_Required := False;
+ -- For Unsigned_Base_Range aspect, do not delay becase we
+ -- need to process it before any type or subtype derivation
+ -- is analyzed.
+
+ elsif A_Id in Aspect_Unsigned_Base_Range then
+ Delay_Required := False;
+
-- All other cases are delayed
else
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 9ca7708..aa15166 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -11287,7 +11287,13 @@ package body Sem_Ch3 is
-- not. It is OK for the new bound we are creating, but not for
-- the old one??? Still if it never happens, no problem.
- Analyze_And_Resolve (Bound, Base_Type (Par_T));
+ -- This must be disabled on unsigned base range types because their
+ -- base type is a modular type, and their type is a signed integer
+ -- type.
+
+ if not Has_Unsigned_Base_Range_Aspect (Base_Type (Par_T)) then
+ Analyze_And_Resolve (Bound, Base_Type (Par_T));
+ end if;
if Nkind (Bound) in N_Integer_Literal | N_Real_Literal then
New_Bound := New_Copy (Bound);
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 2002cc7..989e6bf 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -2266,7 +2266,32 @@ package body Sem_Ch7 is
Next_Elmt (Op_Elmt_2);
end loop;
- -- Case 2: We have not found any explicit overriding and
+ -- Case 2: For a formal type, we need to explicitly check
+ -- whether a local subprogram hides from all visibility
+ -- the implicitly declared primitive, because subprograms
+ -- declared in a generic package specification are never
+ -- primitive for a formal type, even if they happen to
+ -- override an operation of the type (RM 3.2.3(7.d/2)).
+
+ if Is_Generic_Type (E) then
+ declare
+ S : Entity_Id;
+
+ begin
+ S := E;
+ while Present (S) loop
+ if Chars (S) = Chars (Parent_Subp)
+ and then Type_Conformant (Prim_Op, S)
+ then
+ goto Next_Primitive;
+ end if;
+
+ Next_Entity (S);
+ end loop;
+ end;
+ end if;
+
+ -- Case 3: We have not found any explicit overriding and
-- hence we need to declare the operation (i.e., make it
-- visible).
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 86344b5..e9d00d0 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -7225,6 +7225,8 @@ package body Sem_Ch8 is
begin
while Present (Id) loop
+ -- The immediate case is when Id is an entity of the prefix
+
if Scope (Id) = P_Name then
Candidate := Id;
Is_New_Candidate := True;
@@ -7250,6 +7252,53 @@ package body Sem_Ch8 is
end if;
end if;
+ -- If the name of a generic child unit appears within an instance
+ -- of itself, then it is resolved to the renaming of the name of
+ -- the instance built in Sem_Ch12, so we get to the generic parent
+ -- through the renaming.
+
+ elsif Ekind (Id) in E_Function | E_Package | E_Procedure
+ and then Present (Renamed_Entity (Id))
+ and then Is_Generic_Instance (Renamed_Entity (Id))
+ and then In_Open_Scopes (Renamed_Entity (Id))
+ then
+ declare
+ Gen_Inst : constant Entity_Id := Renamed_Entity (Id);
+ Gen_Par : constant Entity_Id :=
+ Generic_Parent
+ (Specification (Unit_Declaration_Node (Gen_Inst)));
+
+ begin
+ -- The easy case is when Gen_Par is an entity of the prefix
+
+ if Scope (Gen_Par) = P_Name then
+ Is_New_Candidate := True;
+
+ -- Now the prefix may also be within an instance of itself,
+ -- but we do not need to go through the renaming for it, as
+ -- this was done on entry to the procedure.
+
+ elsif Is_Generic_Instance (P_Name)
+ and then In_Open_Scopes (P_Name)
+ then
+ declare
+ Gen_Par_P : constant Entity_Id :=
+ Generic_Parent
+ (Specification (Unit_Declaration_Node (P_Name)));
+
+ begin
+ if Scope (Gen_Par) = Gen_Par_P then
+ Is_New_Candidate := True;
+ else
+ Is_New_Candidate := False;
+ end if;
+ end;
+
+ else
+ Is_New_Candidate := False;
+ end if;
+ end;
+
-- Ada 2005 (AI-217): Handle shadow entities associated with
-- types declared in limited-withed nested packages. We don't need
-- to handle E_Incomplete_Subtype entities because the entities
@@ -7284,22 +7333,6 @@ package body Sem_Ch8 is
Candidate := Get_Full_View (Id);
Is_New_Candidate := True;
- -- An unusual case arises with a fully qualified name for an
- -- entity local to a generic child unit package, within an
- -- instantiation of that package. The name of the unit now
- -- denotes the renaming created within the instance. This is
- -- only relevant in an instance body, see below.
-
- elsif Is_Generic_Instance (Scope (Id))
- and then In_Open_Scopes (Scope (Id))
- and then In_Instance_Body
- and then Ekind (Scope (Id)) = E_Package
- and then Ekind (Id) = E_Package
- and then Renamed_Entity (Id) = Scope (Id)
- and then Is_Immediately_Visible (P_Name)
- then
- Is_New_Candidate := True;
-
else
Is_New_Candidate := False;
end if;
@@ -7434,55 +7467,6 @@ package body Sem_Ch8 is
end if;
else
- -- Within the instantiation of a child unit, the prefix may
- -- denote the parent instance, but the selector has the name
- -- of the original child. That is to say, when A.B appears
- -- within an instantiation of generic child unit B, the scope
- -- stack includes an instance of A (P_Name) and an instance
- -- of B under some other name. We scan the scope to find this
- -- child instance, which is the desired entity.
- -- Note that the parent may itself be a child instance, if
- -- the reference is of the form A.B.C, in which case A.B has
- -- already been rewritten with the proper entity.
-
- if In_Open_Scopes (P_Name)
- and then Is_Generic_Instance (P_Name)
- then
- declare
- Gen_Par : constant Entity_Id :=
- Generic_Parent (Specification
- (Unit_Declaration_Node (P_Name)));
- S : Entity_Id := Current_Scope;
- P : Entity_Id;
-
- begin
- for J in reverse 0 .. Scope_Stack.Last loop
- S := Scope_Stack.Table (J).Entity;
-
- exit when S = Standard_Standard;
-
- if Ekind (S) in E_Function | E_Package | E_Procedure
- then
- P :=
- Generic_Parent (Specification
- (Unit_Declaration_Node (S)));
-
- -- Check that P is a generic child of the generic
- -- parent of the prefix.
-
- if Present (P)
- and then Chars (P) = Chars (Selector)
- and then Scope (P) = Gen_Par
- then
- Id := S;
- goto Found;
- end if;
- end if;
-
- end loop;
- end;
- end if;
-
-- If this is a selection from Ada, System or Interfaces, then
-- we assume a missing with for the corresponding package.
@@ -7589,7 +7573,6 @@ package body Sem_Ch8 is
end if;
end if;
- <<Found>>
if Comes_From_Source (N)
and then Is_Remote_Access_To_Subprogram_Type (Id)
and then Ekind (Id) = E_Access_Subprogram_Type
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index 0ce2b35..4d57a86 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -17469,7 +17469,7 @@ package body Sem_Elab is
-- Stuff that happens only at the outer level
if No (Outer_Scope) then
- Elab_Visited.Set_Last (0);
+ Elab_Visited.Clear;
-- Nothing to do if current scope is Standard (this is a bit odd, but
-- it happens in the case of generic instantiations).
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 28c5f17..0dc2e4f 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -10699,6 +10699,9 @@ package body Sem_Prag is
-- the External_Name). For exceptions, the External_Name is the
-- name of the RTTI structure.
+ -- Do not call Set_Is_Imported as that would disable the output
+ -- of the needed exception data structures.
+
-- ??? Emit an error if pragma Import/Export_Exception is present
elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
@@ -12690,7 +12693,8 @@ package body Sem_Prag is
-- Pragma Unsigned_Base_Range temporarily disabled
if not Is_Pragma_Name (Pname)
- or else Pname = Name_Unsigned_Base_Range
+ or else (Pname = Name_Unsigned_Base_Range
+ and then not Debug_Flag_Dot_U)
then
declare
Msg_Issued : Boolean := False;
@@ -21867,8 +21871,17 @@ package body Sem_Prag is
if Rep_Item_Too_Late (Def_Id, N) then
return;
- else
- Set_Has_Gigi_Rep_Item (Def_Id);
+ end if;
+
+ Set_Has_Gigi_Rep_Item (Def_Id);
+
+ -- The pragma is processed directly by the back end when Def_Id is
+ -- translated. If the argument is not a string literal, it may be
+ -- declared after Def_Id and before the pragma, which requires the
+ -- processing of Def_Id to be delayed for the back end.
+
+ if Nkind (Get_Pragma_Arg (Arg2)) /= N_String_Literal then
+ Set_Has_Delayed_Freeze (Def_Id);
end if;
end Machine_Attribute;
@@ -28145,12 +28158,23 @@ package body Sem_Prag is
then
Error_Pragma_Arg
("cannot apply pragma %",
- "\& is not a signed integer type",
- Arg1);
+ "\& is not a signed integer type", Arg1);
elsif Is_Derived_Type (E) then
Error_Pragma_Arg
("pragma % cannot apply to derived type", Arg1);
+
+ elsif Is_Generic_Type (E) then
+ Error_Pragma_Arg
+ ("pragma % cannot apply to formal type", Arg1);
+
+ elsif Present (Expr)
+ and then Is_False (Expr_Value (Expr))
+ and then Ekind (Base_Type (E)) = E_Modular_Integer_Type
+ and then Has_Unsigned_Base_Range_Aspect (Base_Type (E))
+ then
+ Error_Pragma_Arg
+ ("pragma % can only confirm previous True value", Arg1);
end if;
Check_First_Subtype (Arg1);
@@ -28158,17 +28182,19 @@ package body Sem_Prag is
-- Create the new unsigned integer base type entity, and apply
-- the constraint to create the first subtype of E.
- Unsigned_Base_Range_Type_Declaration (E,
- Def => Type_Definition (Parent (E)));
+ if No (Expr) or else Is_True (Expr_Value (Expr)) then
+ Unsigned_Base_Range_Type_Declaration (E,
+ Def => Type_Definition (Parent (E)));
- Set_Direct_Primitive_Operations (Base_Type (E), New_Elmt_List);
- Set_Direct_Primitive_Operations (E,
- Direct_Primitive_Operations (Base_Type (E)));
- Ensure_Freeze_Node (Base_Type (E));
- Set_First_Subtype_Link (Freeze_Node (Base_Type (E)), E);
- Set_Has_Delayed_Freeze (E);
+ Set_Direct_Primitive_Operations (Base_Type (E), New_Elmt_List);
+ Set_Direct_Primitive_Operations (E,
+ Direct_Primitive_Operations (Base_Type (E)));
+ Ensure_Freeze_Node (Base_Type (E));
+ Set_First_Subtype_Link (Freeze_Node (Base_Type (E)), E);
+ Set_Has_Delayed_Freeze (E);
- Set_Has_Unsigned_Base_Range_Aspect (Base_Type (E));
+ Set_Has_Unsigned_Base_Range_Aspect (Base_Type (E));
+ end if;
end Unsigned_Base_Range;
----------------
@@ -28761,6 +28787,17 @@ package body Sem_Prag is
OK : Boolean;
Chr : Character;
+ function Enclose_Ending_Space
+ (Raw_Str : String) return String
+ is (if Raw_Str (Raw_Str'Last) = ' '
+ then '"' & Raw_Str & '"'
+ else Raw_Str);
+ function Enclose_Ending_Space
+ (Raw_Chr : Character) return String
+ is (Enclose_Ending_Space ((1 => Raw_Chr)));
+ -- This function ensures that no error message ends
+ -- with a space, in case we enclose it within quotes.
+
begin
J := 1;
while J <= Len loop
@@ -28792,7 +28829,8 @@ package body Sem_Prag is
if not Set_Warning_Switch ('.', Chr) then
Error_Pragma_Arg
("invalid warning switch character "
- & '.' & Chr, Arg1);
+ & Enclose_Ending_Space ('.' & Chr),
+ Arg1);
end if;
-- Non-Dot case
@@ -28803,7 +28841,8 @@ package body Sem_Prag is
if not OK then
Error_Pragma_Arg
- ("invalid warning switch character " & Chr,
+ ("invalid warning switch character "
+ & Enclose_Ending_Space (Chr),
Arg1);
end if;
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 32d0833..31a2acd 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -610,14 +610,17 @@ package body Sem_Type is
First_Interp := All_Interp.Last;
Add_One_Interp (N, Ent, Etype (N));
- -- For expanded name, pick up all additional entities from the
- -- same scope, since these are obviously also visible. Note that
- -- these are not necessarily contiguous on the homonym chain.
+ -- For an expanded name, pick up additional visible entities from
+ -- the same scope. Note that these are not necessarily contiguous
+ -- on the homonym chain.
if Nkind (N) = N_Expanded_Name then
H := Homonym (Ent);
while Present (H) loop
- if Scope (H) = Scope (Entity (N)) then
+ if Scope (H) = Scope (Entity (N))
+ and then (not Is_Hidden (H)
+ or else Is_Immediately_Visible (H))
+ then
Add_One_Interp (N, H, Etype (H));
end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 7f864d6..a8984c8 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -5881,18 +5881,20 @@ package body Sem_Util is
-- Test whether the result type or any of the parameter types of
-- each subprogram following the type match that type when the
- -- type is declared in a package spec, is a derived type, or the
- -- subprogram is marked as primitive. (The Is_Primitive test is
- -- needed to find primitives of nonderived types in declarative
- -- parts that happen to override the predefined "=" operator.)
-
- -- Note that generic formal subprograms are not considered to be
- -- primitive operations and thus are never inherited.
+ -- type is declared in a package spec, the subprogram is marked as
+ -- primitive, or the subprogram is inherited. Note that the
+ -- Is_Primitive test is needed to find primitives of nonderived
+ -- types in declarative parts that happen to override the
+ -- predefined "=" operator.
if Is_Overloadable (Id)
and then (Is_Type_In_Pkg
- or else Is_Derived_Type (B_Type)
- or else Is_Primitive (Id))
+ or else Is_Primitive (Id)
+ or else not Comes_From_Source (Id))
+
+ -- Generic formal subprograms are not considered to be primitive
+ -- operations and thus are never inherited.
+
and then Parent_Kind (Parent (Id))
not in N_Formal_Subprogram_Declaration
and then not Is_Child_Unit (Id)
diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb
index 31891de..f803fc8 100644
--- a/gcc/ada/table.adb
+++ b/gcc/ada/table.adb
@@ -130,7 +130,7 @@ package body Table is
begin
Locked := False;
- Last_Val := Min - 1;
+ Clear;
Max := Min + (Table_Initial * Table_Factor) - 1;
Length := Max - Min + 1;
@@ -372,6 +372,24 @@ package body Table is
end if;
end Set_Item;
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear is
+ begin
+ Last_Val := Min - 1;
+ end Clear;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty return Boolean is
+ begin
+ return Last_Val = Min - 1;
+ end Is_Empty;
+
--------------
-- Set_Last --
--------------
diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads
index 623ce14..94bb828 100644
--- a/gcc/ada/table.ads
+++ b/gcc/ada/table.ads
@@ -204,6 +204,13 @@ package Table is
-- to Index. Item will replace any value already present in the table
-- at this position.
+ procedure Clear;
+ -- Resets Last to its initial value, making the table have no elements.
+ -- No memory deallocation is performed.
+
+ function Is_Empty return Boolean;
+ -- Returns whether the table is empty
+
type Saved_Table is private;
-- Type used for Save/Restore subprograms
generated by cgit v1.1 at 2025-10-31 02:14:09 +0000