aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorIan Lance Taylor <ian@gcc.gnu.org>2019-10-25 23:18:41 +0000
committerIan Lance Taylor <ian@gcc.gnu.org>2019-10-25 23:18:41 +0000
commit0cec14923830569b8727d461bcf64adaf965de83 (patch)
tree39212625ea993fb193b64da0b13d64cd323dc23b /gcc/ada
parentf67dc76907675065f34ed0bd14915df8d0b63b2d (diff)
parent9bdc2a8f06cef54650798fcb4c343e4415fd5992 (diff)
downloadgcc-0cec14923830569b8727d461bcf64adaf965de83.zip
gcc-0cec14923830569b8727d461bcf64adaf965de83.tar.gz
gcc-0cec14923830569b8727d461bcf64adaf965de83.tar.bz2
Merge from trunk revision 277462.
From-SVN: r277464
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog285
-rw-r--r--gcc/ada/Makefile.rtl4
-rw-r--r--gcc/ada/atree.adb24
-rw-r--r--gcc/ada/atree.ads21
-rw-r--r--gcc/ada/bindgen.adb104
-rw-r--r--gcc/ada/doc/gnat_ugn/about_this_guide.rst6
-rw-r--r--gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst4
-rw-r--r--gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst6
-rw-r--r--gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst4
-rw-r--r--gcc/ada/einfo.adb15
-rw-r--r--gcc/ada/einfo.ads13
-rw-r--r--gcc/ada/errout.ads4
-rw-r--r--gcc/ada/exp_ch3.adb3
-rw-r--r--gcc/ada/exp_ch4.adb6
-rw-r--r--gcc/ada/exp_ch6.adb7
-rw-r--r--gcc/ada/exp_ch7.adb462
-rw-r--r--gcc/ada/exp_ch9.adb7
-rw-r--r--gcc/ada/exp_util.adb14
-rw-r--r--gcc/ada/freeze.adb1
-rw-r--r--gcc/ada/gcc-interface/decl.c73
-rw-r--r--gcc/ada/gcc-interface/trans.c33
-rw-r--r--gcc/ada/gcc-interface/utils.c15
-rw-r--r--gcc/ada/gnat1drv.adb18
-rw-r--r--gcc/ada/gnat_ugn.texi22
-rw-r--r--gcc/ada/gnatls.adb5
-rw-r--r--gcc/ada/impunit.adb4
-rw-r--r--gcc/ada/inline.adb126
-rw-r--r--gcc/ada/lib-writ.ads3
-rw-r--r--gcc/ada/libgnat/a-cbdlli.adb6
-rw-r--r--gcc/ada/libgnat/a-cbhama.adb10
-rw-r--r--gcc/ada/libgnat/a-cbhase.adb10
-rw-r--r--gcc/ada/libgnat/a-cbmutr.adb6
-rw-r--r--gcc/ada/libgnat/a-cborma.adb10
-rw-r--r--gcc/ada/libgnat/a-cborse.adb10
-rw-r--r--gcc/ada/libgnat/a-cdlili.adb6
-rw-r--r--gcc/ada/libgnat/a-cidlli.adb6
-rw-r--r--gcc/ada/libgnat/a-cihama.adb10
-rw-r--r--gcc/ada/libgnat/a-cihase.adb10
-rw-r--r--gcc/ada/libgnat/a-cimutr.adb6
-rw-r--r--gcc/ada/libgnat/a-ciorma.adb10
-rw-r--r--gcc/ada/libgnat/a-ciorse.adb10
-rw-r--r--gcc/ada/libgnat/a-cobove.adb10
-rw-r--r--gcc/ada/libgnat/a-cohama.adb10
-rw-r--r--gcc/ada/libgnat/a-cohase.adb10
-rw-r--r--gcc/ada/libgnat/a-coinve.adb10
-rw-r--r--gcc/ada/libgnat/a-comutr.adb6
-rw-r--r--gcc/ada/libgnat/a-conhel.adb4
-rw-r--r--gcc/ada/libgnat/a-convec.adb10
-rw-r--r--gcc/ada/libgnat/a-coorma.adb10
-rw-r--r--gcc/ada/libgnat/a-coorse.adb10
-rw-r--r--gcc/ada/libgnat/a-ststio.ads1
-rw-r--r--gcc/ada/libgnat/g-exptty.ads2
-rw-r--r--gcc/ada/opt.ads3
-rw-r--r--gcc/ada/rtsfind.adb62
-rw-r--r--gcc/ada/sem_aggr.adb57
-rw-r--r--gcc/ada/sem_cat.adb12
-rw-r--r--gcc/ada/sem_ch12.adb38
-rw-r--r--gcc/ada/sem_ch13.adb56
-rw-r--r--gcc/ada/sem_ch3.adb6
-rw-r--r--gcc/ada/sem_ch6.adb8
-rw-r--r--gcc/ada/sem_ch7.adb2
-rw-r--r--gcc/ada/sem_ch8.adb6
-rw-r--r--gcc/ada/sem_elab.adb16
-rw-r--r--gcc/ada/sem_prag.adb30
-rw-r--r--gcc/ada/sem_res.adb2
-rw-r--r--gcc/ada/sem_util.adb59
-rw-r--r--gcc/ada/sem_util.ads23
-rw-r--r--gcc/ada/sem_warn.adb14
-rw-r--r--gcc/ada/sinfo.adb38
-rw-r--r--gcc/ada/sinfo.ads21
-rw-r--r--gcc/ada/terminals.c2
-rw-r--r--gcc/ada/treepr.adb8
-rw-r--r--gcc/ada/treepr.ads4
73 files changed, 1409 insertions, 540 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 0463038..e0d4e65 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,288 @@
+2019-10-15 Arnaud Charlet <charlet@adacore.com>
+
+ * Makefile.rtl (a-except.o): Put -O1 earlier so that it can be
+ overriden if needed by other variables.
+
+2019-10-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/91995
+ * sem_ch8.adb (Chain_Use_Clause): Remove second argument in calls
+ to Defining_Entity.
+ * sem_elab.adb (Find_Unit_Entity): Likewise. Deal with N_Subunit
+ here in lieu of in Defining_Entity.
+ * sem_util.ads (Defining_Entity): Remove 2nd and 3th parameters.
+ * sem_util.adb (Defining_Entity): Remove 2nd and 3th parameters,
+ and adjust accordingly. Deal with N_Compilation_Unit.
+
+2019-10-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (elaborate_reference_1): Specifically deal with
+ pointer displacement.
+
+ * gcc-interface/decl.c (components_to_record): Use proper name.
+
+ * gcc-interface/trans.c (Sloc_to_locus): Use standard types.
+
+2019-10-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_field): Adjust again the packing
+ for a field without strict alignment and with an oversized clause.
+
+2019-10-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (annotate_value) <INTEGER_CST>: Really test the
+ sign of the value when deciding to build a NEGATE_EXPR.
+ <PLUS_EXPR>: Remove redundant line.
+ <BIT_AND_EXPR>: Do the negation here.
+
+2019-10-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (Gigi_Equivalent_Type) <E_Array_Subtype>: New
+ case. Return the base type if the subtype is not constrained.
+
+2019-10-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Named_{Integer|Real}>:
+ New case to deal with the definition of named numbers.
+ <E_Variable>: Minor tweaks. Set DECL_IGNORED_P on the CONST_DECL
+ if a corresponding variable is built.
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Integer_Literal>: Return
+ error_mark_node instead of aborting on overflow for named numbers.
+ <N_Number_Declaration>: Reuse the <N_Object_Declaration> case and
+ deal with error_mark_node specifically.
+ * gcc-interface/utils.c (create_var_decl): Do not set DECL_IGNORED_P
+ on CONST_DECLs.
+ (gnat_write_global_declarations): Output global constants.
+
+2019-10-10 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch7.adb (Check_Unnesting_In_Decls_Or_Stmts): When
+ encountering a loop at the top level of a package declaration
+ list (that is, within the declarations of a package spec or
+ body) that has nested subprograms, call Unnest_Loop to create a
+ new library-level procedure that will contain the loop, to allow
+ for proper handling of up-level references from within nested
+ subprograms, such as to loop parameters.
+ (Unnest_Loop): New procedure that takes a loop statement and
+ creates a new procedure body to enclose the loop statement,
+ along with generating a call to the procedure.
+
+2019-10-10 Arnaud Charlet <charlet@adacore.com>
+
+ * freeze.adb (Freeze_Subprogram): Ensure constructor is a C++
+ constructor.
+
+2019-10-10 Gary Dismukes <dismukes@adacore.com>
+
+ * libgnat/a-ststio.ads (File_Type): Apply pragma
+ Preelaborable_Initialization to the type.
+
+2019-10-10 Yannick Moy <moy@adacore.com>
+
+ * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Do not peek
+ under private types whose completion is SPARK_Mode Off.
+
+2019-10-10 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch4.adb, sem_cat.adb, sem_ch12.adb, sem_ch3.adb,
+ sem_ch6.adb, sem_prag.adb, sem_util.adb, sem_util.ads: Minor
+ typo fixes.
+
+2019-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_warn.adb (Warn_On_Useless_Assignment): Do not warn if the
+ second assignment is at the same source position as the first.
+
+2019-10-10 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_util.adb (Enclosing_Subprogram): Handle the case of
+ E_Entry_Family, returning the entry family's associated
+ Protected_Body_Subprogram (as was already done for E_Entry).
+ * exp_ch9.adb (Expand_N_Accept_Statement): Call Reset_Scopes_To
+ on the block created for an accept statement to reset the scopes
+ of any local entities to the block scope.
+
+2019-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Analyze_Formal_Package_Declaration): Propagate
+ an aspect specification for Abstract_State from generic package
+ to formal package, so that it is available when analyzing the
+ constructed formal.
+
+2019-10-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch6.adb (Set_Actual_Subtypes): Put the freeze node of the
+ actual subtype after its declaration when the type of the formal
+ has a predicate.
+
+2019-10-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Do not use
+ the Esize of the component to compute its layout, but only the
+ Component_Clause. Do not issue a warning for the _Tag
+ component. Also set the Esize of the component at the end of
+ the layout.
+ (Analyze_Record_Representation_Clause): Remove Hbit local
+ variable. Lay out the Original_Record_Component only if it's
+ distinct from the component.
+ (Check_Record_Representation_Clause): Fix off-by-one bug for the
+ Last_Bit of the artificial clause built for the _Tag component.
+
+2019-10-10 Bob Duff <duff@adacore.com>
+
+ * treepr.ads, treepr.adb (ppar): New procedure.
+
+2019-10-10 Bob Duff <duff@adacore.com>
+
+ * sem_aggr.adb (Resolve_Aggregate): Add missing cases in the
+ Others_Allowed => True case -- N_Case_Expression_Alternative and
+ N_If_Expression. Use Nkind_In.
+ * atree.adb, atree.ads, sinfo.adb, sinfo.ads (Nkind_In): New
+ 16-parameter version.
+
+2019-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): Set properly the
+ Predicated_Parent link of an itype created for an aggregate, so
+ that the predicate_function of the parent can support proofs on
+ the object that it initializes.
+
+2019-10-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch3.adb (Analyze_Number_Declaration): Set
+ Debug_Info_Needed in the case where the expression is an integer
+ literal.
+
+2019-10-10 Yannick Moy <moy@adacore.com>
+
+ * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Add subprograms
+ with deep parameter or result type as not candidates for
+ inlining.
+
+2019-10-10 Vadim Godunko <godunko@adacore.com>
+
+ * libgnat/g-exptty.ads (TTY_Process_Descriptor): Set default
+ value for Process.
+
+2019-10-10 Bob Duff <duff@adacore.com>
+
+ * sem_prag.adb (Defer_Compile_Time_Warning_Error_To_BE): In
+ addition to saving the pragma for further processing, copy the
+ pragma into the main unit if necessary.
+
+2019-10-10 Bob Duff <duff@adacore.com>
+
+ * einfo.ads, einfo.adb (Invariants_Ignored): New flag on types.
+ This leaves just one unused flag.
+ * sem_prag.adb (Invariant): Set the flag if appropriate.
+ * exp_util.adb (Make_Invariant_Call): Check the flag.
+
+2019-10-10 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat1drv.adb (Gnat1drv): Skip code generation when handling an
+ incomplete unit with -gnatceg.
+
+2019-10-10 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch7.adb (Check_Unnesting_Elaboration_Code): Various
+ cleanups.
+ (Set_Elab_Proc): New procedure to create the defining identifier
+ for a procedure created to encapsulate top-level blocks
+ occurring as a part of library package elaboration.
+ (First_Local_Scope): Function replaced by
+ Reset_Scopes_To_Elab_Proc.
+ (Reset_Scopes_To_Elab_Proc): New recursive procedure based on
+ First_Local_Scope, which it replaces, that is called to traverse
+ the statements of a library package body to locate top-level
+ blocks and determine whether they contain nested subprograms
+ that might address library-level objects of the package. Such
+ blocks (and loops) and certain top-level subprograms within the
+ statements will have their Scope reset here to match an
+ encapsulating procedure created by
+ Check_Unnesting_Elaboration_Code that will contain the
+ statements.
+ (Check_Unnesting_In_Decls_Or_Stmts): Code for handling blocks
+ factored out into Unnest_Block. Add handling for package
+ declarations and bodies, making recursive calls for
+ visible/private declarations, body declarations, statements, and
+ exception handlers. Also remove test for Is_Compilation_Unit:
+ caller tests for Is_Library_Level_Entity instead. Also, this
+ proc's name was changed from Check_Unnesting_In_Declarations.
+ (Check_Unnesting_In_Handlers): New procedure to traverse a
+ sequence of exception handlers, calling
+ Check_Unnesting_In_Decls_Or_Stmts on the statements of each
+ handler.
+ (Expand_N_Package_Body): Call Check_Unnesting_* routines only
+ when Unnest_Subprogram_Mode is set and the current scope is a
+ library-level entity (which includes packages and instantiations
+ nested directly within a library unit).
+ (Expand_N_Package_Declaration): Call Check_Unnesting_* routines
+ only when Unnest_Subprogram_Mode is set and the current scope is
+ a library-level entity (which includes packages and
+ instantiations nested directly within a library unit).
+ (Unnest_Block): New procedure factored out of
+ Check_Unnesting_In_Decls_Or_Stmts, for creating a new procedure
+ to replace a block statement and resetting the Scope fields of
+ the block's top-level entities.
+
+2019-10-10 Anthony Leonardo Gracio <leonardo@adacore.com>
+
+ * doc/gnat_ugn/about_this_guide.rst,
+ doc/gnat_ugn/building_executable_programs_with_gnat.rst,
+ doc/gnat_ugn/getting_started_with_gnat.rst,
+ doc/gnat_ugn/gnat_and_program_execution.rst, errout.ads,
+ exp_ch3.adb, gnatls.adb, impunit.adb, lib-writ.ads, opt.ads,
+ sem_ch7.adb, sem_prag.adb, sem_res.adb, sem_warn.adb,
+ terminals.c: Replace GPS by GNAT Studio.
+ * gnat_ugn.texi: Regenerate.
+
+2019-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch6.adb (Expand_Simple_Function_Return_Statement): If the
+ function to which the return statement applies is an
+ Ignored_Ghost_Function, do not indicate that it uses the
+ secondary stack when the return type is unconstrained.
+
+2019-10-10 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-cbdlli.adb, libgnat/a-cbhama.adb,
+ libgnat/a-cbhase.adb, libgnat/a-cbmutr.adb,
+ libgnat/a-cborma.adb, libgnat/a-cborse.adb,
+ libgnat/a-cdlili.adb, libgnat/a-cidlli.adb,
+ libgnat/a-cihama.adb, libgnat/a-cihase.adb,
+ libgnat/a-cimutr.adb, libgnat/a-ciorma.adb,
+ libgnat/a-ciorse.adb, libgnat/a-cobove.adb,
+ libgnat/a-cohama.adb, libgnat/a-cohase.adb,
+ libgnat/a-coinve.adb, libgnat/a-comutr.adb,
+ libgnat/a-conhel.adb, libgnat/a-convec.adb,
+ libgnat/a-coorma.adb, libgnat/a-coorse.adb (Reference,
+ Constant_Reference): Use Busy instead of Lock, so we forbid
+ tampering with cursors, rather than tampering with elements.
+
+2019-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_cat.adb (Set_Categorization_From_Pragma): Do not modify
+ any visibility settings if there are no compilation_unit pragmas
+ following the package declaration. Add comments for future
+ cleanup.
+
+2019-10-10 Patrick Bernardi <bernardi@adacore.com>
+
+ * bindgen.adb (System_Secondary_Stack_Package_In_Closure):
+ Renamed flag System_Secondary_Stack_Used to be clearer of what
+ it represents.
+ (Gen_Adainit): Refactor secondary stack related code to make it
+ clearer.
+ * rtsfind.adb (Load_RTU): Don't set Sec_Stack_Used flag here
+ (RTE): Set Sec_Stack_Used if the System.Secondary_Stack is
+ referenced, but not if we're ignoring ghost code.
+
+2019-10-10 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_prag.adb (Analyze_Global_In_Decl_Part): Simplify previous
+ test, just like in a recent commit we simplified a similar test
+ for Depends contract.
+
2019-10-04 Joseph Myers <joseph@codesourcery.com>
* gcc-interface/utils.c (flag_isoc2x): New variable.
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index e5aa6b8..c286701 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -2733,8 +2733,8 @@ s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads
# use -O1 otherwise gdb isn't able to get a full backtrace on mips targets.
a-except.o : a-except.adb a-except.ads
- $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \
- $(NO_INLINE_ADAFLAGS) $(NO_REORDER_ADAFLAGS) -O1 $(ADA_INCLUDES) \
+ $(ADAC) -c $(ALL_ADAFLAGS) -O1 $(FORCE_DEBUG_ADAFLAGS) \
+ $(NO_INLINE_ADAFLAGS) $(NO_REORDER_ADAFLAGS) $(ADA_INCLUDES) \
$< $(OUTPUT_OPTION)
# Compile s-excdeb.o without optimization and with debug info to let the
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 1521941..ef1d885 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -1924,6 +1924,30 @@ package body Atree is
V11);
end Nkind_In;
+ function Nkind_In
+ (N : Node_Id;
+ V1 : Node_Kind;
+ V2 : Node_Kind;
+ V3 : Node_Kind;
+ V4 : Node_Kind;
+ V5 : Node_Kind;
+ V6 : Node_Kind;
+ V7 : Node_Kind;
+ V8 : Node_Kind;
+ V9 : Node_Kind;
+ V10 : Node_Kind;
+ V11 : Node_Kind;
+ V12 : Node_Kind;
+ V13 : Node_Kind;
+ V14 : Node_Kind;
+ V15 : Node_Kind;
+ V16 : Node_Kind) return Boolean
+ is
+ begin
+ return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10,
+ V11, V12, V13, V14, V15, V16);
+ end Nkind_In;
+
--------
-- No --
--------
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 7de8a9e..e6617e9 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -780,6 +780,27 @@ package Atree is
V10 : Node_Kind;
V11 : Node_Kind) return Boolean;
+ -- 12..15-parameter versions are not yet needed
+
+ function Nkind_In
+ (N : Node_Id;
+ V1 : Node_Kind;
+ V2 : Node_Kind;
+ V3 : Node_Kind;
+ V4 : Node_Kind;
+ V5 : Node_Kind;
+ V6 : Node_Kind;
+ V7 : Node_Kind;
+ V8 : Node_Kind;
+ V9 : Node_Kind;
+ V10 : Node_Kind;
+ V11 : Node_Kind;
+ V12 : Node_Kind;
+ V13 : Node_Kind;
+ V14 : Node_Kind;
+ V15 : Node_Kind;
+ V16 : Node_Kind) return Boolean;
+
pragma Inline (Nkind_In);
-- Inline all above functions
diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index e60cb7a..9ac50fe 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -81,7 +81,7 @@ package body Bindgen is
-- domains just before calling the main procedure from the environment
-- task.
- System_Secondary_Stack_Used : Boolean := False;
+ System_Secondary_Stack_Package_In_Closure : Boolean := False;
-- Flag indicating whether the unit System.Secondary_Stack is in the
-- closure of the partition. This is set by Resolve_Binder_Options, and
-- is used to initialize the package in cases where the run-time brings
@@ -585,29 +585,33 @@ package body Bindgen is
WBI ("");
end if;
- -- A restricted run-time may attempt to initialize the main task's
- -- secondary stack even if the stack is not used. Consequently,
- -- the binder needs to initialize Binder_Sec_Stacks_Count anytime
- -- System.Secondary_Stack is in the enclosure of the partition.
+ if System_Secondary_Stack_Package_In_Closure then
+ -- System.Secondary_Stack is in the closure of the program
+ -- because the program uses the secondary stack or the restricted
+ -- run-time is unconditionally calling SS_Init. In both cases,
+ -- SS_Init needs to know the number of secondary stacks created by
+ -- the binder.
- if System_Secondary_Stack_Used then
WBI (" Binder_Sec_Stacks_Count : Natural;");
WBI (" pragma Import (Ada, Binder_Sec_Stacks_Count, " &
"""__gnat_binder_ss_count"");");
WBI ("");
- end if;
- if Sec_Stack_Used then
- WBI (" Default_Secondary_Stack_Size : " &
- "System.Parameters.Size_Type;");
- WBI (" pragma Import (C, Default_Secondary_Stack_Size, " &
- """__gnat_default_ss_size"");");
+ -- Import secondary stack pool variables if the secondary stack
+ -- used. They are not referenced otherwise.
- WBI (" Default_Sized_SS_Pool : System.Address;");
- WBI (" pragma Import (Ada, Default_Sized_SS_Pool, " &
- """__gnat_default_ss_pool"");");
+ if Sec_Stack_Used then
+ WBI (" Default_Secondary_Stack_Size : " &
+ "System.Parameters.Size_Type;");
+ WBI (" pragma Import (C, Default_Secondary_Stack_Size, " &
+ """__gnat_default_ss_size"");");
- WBI ("");
+ WBI (" Default_Sized_SS_Pool : System.Address;");
+ WBI (" pragma Import (Ada, Default_Sized_SS_Pool, " &
+ """__gnat_default_ss_pool"");");
+
+ WBI ("");
+ end if;
end if;
WBI (" begin");
@@ -642,48 +646,49 @@ package body Bindgen is
WBI (" null;");
end if;
- -- Generate default-sized secondary stack pool and set secondary
- -- stack globals.
-
- if Sec_Stack_Used then
+ -- Generate the default-sized secondary stack pool if the secondary
+ -- stack is used by the program.
- -- Elaborate the body of the binder to initialize the default-
- -- sized secondary stack pool.
+ if System_Secondary_Stack_Package_In_Closure then
+ if Sec_Stack_Used then
+ -- Elaborate the body of the binder to initialize the default-
+ -- sized secondary stack pool.
- WBI ("");
- WBI (" " & Get_Ada_Main_Name & "'Elab_Body;");
+ WBI ("");
+ WBI (" " & Get_Ada_Main_Name & "'Elab_Body;");
- -- Generate the default-sized secondary stack pool and set the
- -- related secondary stack globals.
+ -- Generate the default-sized secondary stack pool and set the
+ -- related secondary stack globals.
- Set_String (" Default_Secondary_Stack_Size := ");
+ Set_String (" Default_Secondary_Stack_Size := ");
- if Opt.Default_Sec_Stack_Size /= Opt.No_Stack_Size then
- Set_Int (Opt.Default_Sec_Stack_Size);
- else
- Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size");
- end if;
+ if Opt.Default_Sec_Stack_Size /= Opt.No_Stack_Size then
+ Set_Int (Opt.Default_Sec_Stack_Size);
+ else
+ Set_String
+ ("System.Parameters.Runtime_Default_Sec_Stack_Size");
+ end if;
- Set_Char (';');
- Write_Statement_Buffer;
+ Set_Char (';');
+ Write_Statement_Buffer;
- Set_String (" Binder_Sec_Stacks_Count := ");
- Set_Int (Num_Sec_Stacks);
- Set_Char (';');
- Write_Statement_Buffer;
+ Set_String (" Binder_Sec_Stacks_Count := ");
+ Set_Int (Num_Sec_Stacks);
+ Set_Char (';');
+ Write_Statement_Buffer;
- WBI (" Default_Sized_SS_Pool := " &
- "Sec_Default_Sized_Stacks'Address;");
- WBI ("");
+ WBI (" Default_Sized_SS_Pool := " &
+ "Sec_Default_Sized_Stacks'Address;");
+ WBI ("");
- -- When a restricted run-time initializes the main task's secondary
- -- stack but the program does not use it, no secondary stack is
- -- generated. Binder_Sec_Stacks_Count is set to zero so the run-time
- -- is aware that the lack of pre-allocated secondary stack is
- -- expected.
+ else
+ -- The presence of System.Secondary_Stack in the closure of the
+ -- program implies the restricted run-time is unconditionally
+ -- calling SS_Init. Let SS_Init know that no stacks were
+ -- created.
- elsif System_Secondary_Stack_Used then
- WBI (" Binder_Sec_Stacks_Count := 0;");
+ WBI (" Binder_Sec_Stacks_Count := 0;");
+ end if;
end if;
-- Normal case (standard library not suppressed). Set all global values
@@ -3086,7 +3091,8 @@ package body Bindgen is
-- Ditto for the use of System.Secondary_Stack
Check_Package
- (System_Secondary_Stack_Used, "system.secondary_stack%s");
+ (System_Secondary_Stack_Package_In_Closure,
+ "system.secondary_stack%s");
-- Ditto for use of an SMP bareboard runtime
diff --git a/gcc/ada/doc/gnat_ugn/about_this_guide.rst b/gcc/ada/doc/gnat_ugn/about_this_guide.rst
index d322b9d..1ab2f4c 100644
--- a/gcc/ada/doc/gnat_ugn/about_this_guide.rst
+++ b/gcc/ada/doc/gnat_ugn/about_this_guide.rst
@@ -90,11 +90,11 @@ following documents:
* :title:`GNAT Reference_Manual`, which contains all reference material for the GNAT
implementation of Ada.
-* :title:`Using the GNAT Programming Studio`, which describes the GPS
+* :title:`Using GNAT Studio`, which describes the GNAT Studio
Integrated Development Environment.
-* :title:`GNAT Programming Studio Tutorial`, which introduces the
- main GPS features through examples.
+* :title:`GNAT Studio Tutorial`, which introduces the
+ main GNAT Studio features through examples.
* :title:`Debugging with GDB`,
for all details on the use of the GNU source-level debugger.
diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
index 6f13452..457646a 100644
--- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst
@@ -2377,7 +2377,7 @@ file) and have the following form:
The first integer after the file name is the line number in the file,
and the second integer is the column number within the line.
-``GPS`` can parse the error messages
+``GNAT Studio`` can parse the error messages
and point to the referenced character.
The following switches provide control over the error message
format:
@@ -5139,7 +5139,7 @@ checks to be performed. The following checks are defined:
.. end of switch description (leave this comment to ease automatic parsing for
-.. GPS
+.. GNAT Studio
In the above rules, appearing in column one is always permitted, that is,
counts as meeting either a requirement for a required preceding space,
diff --git a/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst b/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst
index 756e301..34dc355 100644
--- a/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst
@@ -9,11 +9,11 @@ Getting Started with GNAT
This chapter describes how to use GNAT's command line interface to build
executable Ada programs.
On most platforms a visually oriented Integrated Development Environment
-is also available, the GNAT Programming Studio (GPS).
-GPS offers a graphical "look and feel", support for development in
+is also available, the GNAT Programming Studio (GNAT Studio).
+GNAT Studio offers a graphical "look and feel", support for development in
other programming languages, comprehensive browsing features, and
many other capabilities.
-For information on GPS please refer to
+For information on GNAT Studio please refer to
:title:`Using the GNAT Programming Studio`.
diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
index 56ee103..cae61e9 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
@@ -116,9 +116,9 @@ Running GDB
This section describes how to initiate the debugger.
-The debugger can be launched from a ``GPS`` menu or
+The debugger can be launched from a ``GNAT Studio`` menu or
directly from the command line. The description below covers the latter use.
-All the commands shown can be used in the ``GPS`` debug console window,
+All the commands shown can be used in the ``GNAT Studio`` debug console window,
but there are usually more GUI-based ways to achieve the same effect.
The command to run ``GDB`` is
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index dcbeac5..98b508f 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -629,8 +629,8 @@ package body Einfo is
-- Is_Activation_Record Flag305
-- Needs_Activation_Record Flag306
-- Is_Loop_Parameter Flag307
+ -- Invariants_Ignored Flag308
- -- (unused) Flag308
-- (unused) Flag309
-- Note: Flag310-317 are defined in atree.ads/adb, but not yet in atree.h
@@ -2077,6 +2077,12 @@ package body Einfo is
return Node21 (Id);
end Interface_Name;
+ function Invariants_Ignored (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag308 (Id);
+ end Invariants_Ignored;
+
function Is_Abstract_Subprogram (Id : E) return B is
begin
pragma Assert (Is_Overloadable (Id));
@@ -5278,6 +5284,12 @@ package body Einfo is
Set_Node21 (Id, V);
end Set_Interface_Name;
+ procedure Set_Invariants_Ignored (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag308 (Id, V);
+ end Set_Invariants_Ignored;
+
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True) is
begin
pragma Assert (Is_Overloadable (Id));
@@ -9785,6 +9797,7 @@ package body Einfo is
W ("In_Package_Body", Flag48 (Id));
W ("In_Private_Part", Flag45 (Id));
W ("In_Use", Flag8 (Id));
+ W ("Invariants_Ignored", Flag308 (Id));
W ("Is_Abstract_Subprogram", Flag19 (Id));
W ("Is_Abstract_Type", Flag146 (Id));
W ("Is_Access_Constant", Flag69 (Id));
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 3e968a2..5366631 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1739,7 +1739,7 @@ package Einfo is
-- Has_Inherited_Invariants (Flag291) [base type only]
-- Defined in all type entities. Set on private extensions and derived
--- types which inherit at least on class-wide invariant from a parent or
+-- types which inherit at least one class-wide invariant from a parent or
-- an interface type. The flag is also set on the full view of a private
-- extension for completeness.
@@ -1841,7 +1841,7 @@ package Einfo is
-- when the type is subject to pragma Default_Initial_Condition.
-- Has_Own_Invariants (Flag232) [base type only]
--- Defined in all type entities. Set on any type which defines at least
+-- Defined in all type entities. Set on any type that defines at least
-- one invariant of its own. The flag is also set on the full view of a
-- private type for completeness.
@@ -2259,6 +2259,11 @@ package Einfo is
-- implemented by a tagged type that are not already implemented by the
-- ancestors (Ada 2005: AI-251).
+-- Invariants_Ignored (Flag308)
+-- Defined on all types. Indicates whether the type declaration is in
+-- a context where Assertion_Policy is Ignore, in which case no checks
+-- (static or dynamic) must be generated for objects of the type.
+
-- Invariant_Procedure (synthesized)
-- Defined in types and subtypes. Set for private types and their full
-- views if one or more [class-wide] invariants apply to the type, or
@@ -7272,6 +7277,7 @@ package Einfo is
function Interface_Alias (Id : E) return E;
function Interface_Name (Id : E) return N;
function Interfaces (Id : E) return L;
+ function Invariants_Ignored (Id : E) return B;
function Is_Abstract_Subprogram (Id : E) return B;
function Is_Abstract_Type (Id : E) return B;
function Is_Access_Constant (Id : E) return B;
@@ -7973,6 +7979,7 @@ package Einfo is
procedure Set_Interface_Alias (Id : E; V : E);
procedure Set_Interface_Name (Id : E; V : N);
procedure Set_Interfaces (Id : E; V : L);
+ procedure Set_Invariants_Ignored (Id : E; V : B := True);
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True);
procedure Set_Is_Abstract_Type (Id : E; V : B := True);
procedure Set_Is_Access_Constant (Id : E; V : B := True);
@@ -8801,6 +8808,7 @@ package Einfo is
pragma Inline (Interface_Alias);
pragma Inline (Interface_Name);
pragma Inline (Interfaces);
+ pragma Inline (Invariants_Ignored);
pragma Inline (Is_Abstract_Subprogram);
pragma Inline (Is_Abstract_Type);
pragma Inline (Is_Access_Constant);
@@ -9338,6 +9346,7 @@ package Einfo is
pragma Inline (Set_Interface_Alias);
pragma Inline (Set_Interface_Name);
pragma Inline (Set_Interfaces);
+ pragma Inline (Set_Invariants_Ignored);
pragma Inline (Set_Is_Abstract_Subprogram);
pragma Inline (Set_Is_Abstract_Type);
pragma Inline (Set_Is_Access_Constant);
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 9a54c7c..37db3e585 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -647,8 +647,8 @@ package Errout is
-- CODEFIX Facility --
-----------------------
- -- The GPS and GNATBench IDE's have a codefix facility that allows for
- -- automatic correction of a subset of the errors and warnings issued
+ -- The GNAT Studio and GNATBench IDE's have a codefix facility that allows
+ -- for automatic correction of a subset of the errors and warnings issued
-- by the compiler. This is done by recognizing the text of specific
-- messages using appropriate matching patterns.
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 18c6aaf..82a58b7 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6335,7 +6335,8 @@ package body Exp_Ch3 is
-- would otherwise make two copies. The RM allows removing redunant
-- Adjust/Finalize calls, but does not allow insertion of extra ones.
- -- This part is disabled for now, because it breaks GPS builds
+ -- This part is disabled for now, because it breaks GNAT Studio
+ -- builds
(False -- ???
and then Nkind (Expr_Q) = N_Explicit_Dereference
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 82145b4..158dcb5 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -9577,9 +9577,9 @@ package body Exp_Ch4 is
Typ : constant Entity_Id := Etype (Left_Opnd (N));
begin
- -- Case of elementary type with standard operator. But if
- -- unnesting, handle elementary types whose Equivalent_Types are
- -- records because there may be padding or undefined fields.
+ -- Case of elementary type with standard operator. But if unnesting,
+ -- handle elementary types whose Equivalent_Types are records because
+ -- there may be padding or undefined fields.
if Is_Elementary_Type (Typ)
and then Sloc (Entity (N)) = Standard_Location
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index c569ca3..b311322 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -6895,7 +6895,12 @@ package body Exp_Ch6 is
elsif Is_Thunk (Current_Scope) and then Is_Incomplete_Type (Exptyp) then
return;
- elsif not Requires_Transient_Scope (R_Type) then
+ -- A return statement from a Ghost function does not use the secondary
+ -- stack (or any other one).
+
+ elsif not Requires_Transient_Scope (R_Type)
+ or else Is_Ignored_Ghost_Entity (Scope_Id)
+ then
-- Mutable records with variable-length components are not returned
-- on the sec-stack, so we need to make sure that the back end will
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index b00fc92..297e27d 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -364,20 +364,47 @@ package body Exp_Ch7 is
procedure Check_Unnesting_Elaboration_Code (N : Node_Id);
-- The statement part of a package body that is a compilation unit may
- -- contain blocks that declare local subprograms. In Subprogram_Unnesting
+ -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
-- Mode such subprograms must be handled as nested inside the (implicit)
-- elaboration procedure that executes that statement part. To handle
-- properly uplevel references we construct that subprogram explicitly,
-- to contain blocks and inner subprograms, The statement part becomes
-- a call to this subprogram. This is only done if blocks are present
- -- in the statement list of the body.
-
- procedure Check_Unnesting_In_Declarations (Decls : List_Id);
- -- Similarly, the declarations in the package body may have created
- -- blocks with nested subprograms. Such a block must be transformed into a
- -- procedure followed by a call to it, so that unnesting can handle uplevel
- -- references within these nested subprograms (typically generated
- -- subprograms to handle finalization actions).
+ -- in the statement list of the body. (It would be nice to unify this
+ -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
+ -- they're doing very similar work, but are structured differently. ???)
+
+ procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id);
+ -- Similarly, the declarations or statements in library-level packages may
+ -- have created blocks blocks with nested subprograms. Such a block must be
+ -- transformed into a procedure followed by a call to it, so that unnesting
+ -- can handle uplevel references within these nested subprograms (typically
+ -- subprograms that handle finalization actions). This also applies to
+ -- nested packages, including instantiations, in which case it must
+ -- recursively process inner bodies.
+
+ procedure Check_Unnesting_In_Handlers (N : Node_Id);
+ -- Similarly, check for blocks with nested subprograms occurring within
+ -- a set of exception handlers associated with a package body N.
+
+ procedure Unnest_Block (Decl : Node_Id);
+ -- Blocks that contain nested subprograms with up-level references need to
+ -- create activation records for them. We do this by rewriting the block as
+ -- a procedure, followed by a call to it in the same declarative list, to
+ -- replicate the semantics of the original block.
+ --
+ -- A common source for such block is a transient block created for a
+ -- construct (declaration, assignment, etc.) that involves controlled
+ -- actions or secondary-stack management, in which case the nested
+ -- subprogram is a finalizer.
+
+ procedure Unnest_Loop (Loop_Stmt : Node_Id);
+ -- Top-level Loops that contain nested subprograms with up-level references
+ -- need to have activation records. We do this by rewriting the loop as a
+ -- procedure containing the loop, followed by a call to the procedure in
+ -- the same library-level declarative list, to replicate the semantics of
+ -- the original loop. Such loops can occur due to aggregate expansions and
+ -- other constructs.
procedure Check_Visibly_Controlled
(Prim : Final_Primitives;
@@ -4020,27 +4047,39 @@ package body Exp_Ch7 is
--------------------------------------
procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- First_Ent : Entity_Id := Empty;
- Loop_Id : Entity_Id := Empty;
-
- function First_Local_Scope (L : List_Id) return Entity_Id;
- -- Find first entity in the elaboration code of the body that contains
- -- or represents a subprogram body. A body can appear within a block or
- -- a loop or can appear by itself if generated for an object declaration
- -- that involves controlled actions. The first such entity encountered
- -- is used to reset the scopes of all entities that become local to the
- -- new elaboration procedure. This is needed for subsequent unnesting,
- -- which depends on the scope links to determine the nesting level of
- -- each subprogram.
+ Loc : constant Source_Ptr := Sloc (N);
+ Block_Elab_Proc : Entity_Id := Empty;
+
+ procedure Set_Block_Elab_Proc;
+ -- Create a defining identifier for a procedure that will replace
+ -- a block with nested subprograms (unless it has already been created,
+ -- in which case this is a no-op).
+
+ procedure Set_Block_Elab_Proc is
+ begin
+ if No (Block_Elab_Proc) then
+ Block_Elab_Proc :=
+ Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('I'));
+ end if;
+ end Set_Block_Elab_Proc;
+
+ procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id);
+ -- Find entities in the elaboration code of a library package body that
+ -- contain or represent a subprogram body. A body can appear within a
+ -- block or a loop or can appear by itself if generated for an object
+ -- declaration that involves controlled actions. The first such entity
+ -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
+ -- that will be used to reset the scopes of all entities that become
+ -- local to the new elaboration procedure. This is needed for subsequent
+ -- unnesting actions, which depend on proper setting of the Scope links
+ -- to determine the nesting level of each subprogram.
-----------------------
-- Find_Local_Scope --
-----------------------
- function First_Local_Scope (L : List_Id) return Entity_Id is
+ procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is
Id : Entity_Id;
- Scop : Entity_Id;
Stat : Node_Id;
begin
@@ -4050,41 +4089,36 @@ package body Exp_Ch7 is
when N_Block_Statement =>
Id := Entity (Identifier (Stat));
- if No (First_Ent) then
- First_Ent := Id;
- end if;
+ -- The Scope of this block needs to be reset to the new
+ -- procedure if the block contains nested subprograms.
if Present (Id) and then Contains_Subprogram (Id) then
- return Id;
+ Set_Block_Elab_Proc;
+ Set_Scope (Id, Block_Elab_Proc);
end if;
when N_Loop_Statement =>
Id := Entity (Identifier (Stat));
- if No (First_Ent) then
- First_Ent := Id;
- end if;
-
- if Contains_Subprogram (Id) then
+ if Present (Id) and then Contains_Subprogram (Id) then
if Scope (Id) = Current_Scope then
- Loop_Id := Id;
+ Set_Block_Elab_Proc;
+ Set_Scope (Id, Block_Elab_Proc);
end if;
-
- return Id;
end if;
- when N_If_Statement =>
- Scop := First_Local_Scope (Then_Statements (Stat));
+ -- We traverse the loop's statements as well, which may
+ -- include other block (etc.) statements that need to have
+ -- their Scope set to Block_Elab_Proc. (Is this really the
+ -- case, or do such nested blocks refer to the loop scope
+ -- rather than the loop's enclosing scope???.)
- if Present (Scop) then
- return Scop;
- end if;
+ Reset_Scopes_To_Block_Elab_Proc (Statements (Stat));
- Scop := First_Local_Scope (Else_Statements (Stat));
+ when N_If_Statement =>
+ Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat));
- if Present (Scop) then
- return Scop;
- end if;
+ Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat));
declare
Elif : Node_Id;
@@ -4092,11 +4126,8 @@ package body Exp_Ch7 is
begin
Elif := First (Elsif_Parts (Stat));
while Present (Elif) loop
- Scop := First_Local_Scope (Statements (Elif));
-
- if Present (Scop) then
- return Scop;
- end if;
+ Reset_Scopes_To_Block_Elab_Proc
+ (Then_Statements (Elif));
Next (Elif);
end loop;
@@ -4109,24 +4140,19 @@ package body Exp_Ch7 is
begin
Alt := First (Alternatives (Stat));
while Present (Alt) loop
- Scop := First_Local_Scope (Statements (Alt));
-
- if Present (Scop) then
- return Scop;
- end if;
+ Reset_Scopes_To_Block_Elab_Proc (Statements (Alt));
Next (Alt);
end loop;
end;
+ -- Reset the Scope of a subprogram occurring at the top level
+
when N_Subprogram_Body =>
Id := Defining_Entity (Stat);
- if No (First_Ent) then
- First_Ent := Id;
- end if;
-
- return Id;
+ Set_Block_Elab_Proc;
+ Set_Scope (Id, Block_Elab_Proc);
when others =>
null;
@@ -4134,67 +4160,52 @@ package body Exp_Ch7 is
Next (Stat);
end loop;
-
- return Empty;
- end First_Local_Scope;
+ end Reset_Scopes_To_Block_Elab_Proc;
-- Local variables
H_Seq : constant Node_Id := Handled_Statement_Sequence (N);
Elab_Body : Node_Id;
Elab_Call : Node_Id;
- Elab_Proc : Entity_Id;
- Ent : Entity_Id;
-- Start of processing for Check_Unnesting_Elaboration_Code
begin
- if Unnest_Subprogram_Mode
- and then Present (H_Seq)
- and then Is_Compilation_Unit (Current_Scope)
- then
- Ent := First_Local_Scope (Statements (H_Seq));
+ if Present (H_Seq) then
+ Reset_Scopes_To_Block_Elab_Proc (Statements (H_Seq));
- -- There msy be subprograms declared in the exception handlers
+ -- There may be subprograms declared in the exception handlers
-- of the current body.
- if No (Ent) and then Present (Exception_Handlers (H_Seq)) then
+ if Present (Exception_Handlers (H_Seq)) then
declare
Handler : Node_Id := First (Exception_Handlers (H_Seq));
begin
while Present (Handler) loop
- Ent := First_Local_Scope (Statements (Handler));
- if Present (Ent) then
- First_Ent := Ent;
- exit;
- end if;
+ Reset_Scopes_To_Block_Elab_Proc (Statements (Handler));
Next (Handler);
end loop;
end;
end if;
- if Present (Ent) then
- Elab_Proc :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('I'));
-
+ if Present (Block_Elab_Proc) then
Elab_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Elab_Proc),
+ Defining_Unit_Name => Block_Elab_Proc),
Declarations => New_List,
Handled_Statement_Sequence =>
Relocate_Node (Handled_Statement_Sequence (N)));
Elab_Call :=
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Elab_Proc, Loc));
+ Name => New_Occurrence_Of (Block_Elab_Proc, Loc));
Append_To (Declarations (N), Elab_Body);
Analyze (Elab_Body);
- Set_Has_Nested_Subprogram (Elab_Proc);
+ Set_Has_Nested_Subprogram (Block_Elab_Proc);
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc,
@@ -4202,85 +4213,98 @@ package body Exp_Ch7 is
Analyze (Elab_Call);
- -- The scope of all blocks and loops in the elaboration code is
- -- now the constructed elaboration procedure. Nested subprograms
- -- within those blocks will have activation records if they
- -- contain references to entities in the enclosing block or
- -- the package itself.
-
- Ent := First_Ent;
- while Present (Ent) loop
- Set_Scope (Ent, Elab_Proc);
- Next_Entity (Ent);
- end loop;
-
- if Present (Loop_Id) then
- Set_Scope (Loop_Id, Elab_Proc);
- end if;
+ -- Could we reset the scopes of entities associated with the new
+ -- procedure here via a loop over entities rather than doing it in
+ -- the recursive Reset_Scopes_To_Elab_Proc procedure???
end if;
end if;
end Check_Unnesting_Elaboration_Code;
- -------------------------------------
- -- Check_Unnesting_In_Declarations --
- -------------------------------------
+ ---------------------------------------
+ -- Check_Unnesting_In_Decls_Or_Stmts --
+ ---------------------------------------
- procedure Check_Unnesting_In_Declarations (Decls : List_Id) is
- Decl : Node_Id;
- Ent : Entity_Id;
- Loc : Source_Ptr;
- Local_Body : Node_Id;
- Local_Call : Node_Id;
- Local_Proc : Entity_Id;
+ procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id) is
+ Decl_Or_Stmt : Node_Id;
begin
- Local_Call := Empty;
-
if Unnest_Subprogram_Mode
- and then Present (Decls)
- and then Is_Compilation_Unit (Current_Scope)
+ and then Present (Decls_Or_Stmts)
then
- Decl := First (Decls);
- while Present (Decl) loop
- if Nkind (Decl) = N_Block_Statement
- and then Contains_Subprogram (Entity (Identifier (Decl)))
+ Decl_Or_Stmt := First (Decls_Or_Stmts);
+ while Present (Decl_Or_Stmt) loop
+ if Nkind (Decl_Or_Stmt) = N_Block_Statement
+ and then Contains_Subprogram (Entity (Identifier (Decl_Or_Stmt)))
then
- Ent := First_Entity (Entity (Identifier (Decl)));
- Loc := Sloc (Decl);
- Local_Proc :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
-
- Local_Body :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Local_Proc),
- Declarations => Declarations (Decl),
- Handled_Statement_Sequence =>
- Handled_Statement_Sequence (Decl));
+ Unnest_Block (Decl_Or_Stmt);
- Rewrite (Decl, Local_Body);
- Analyze (Decl);
- Set_Has_Nested_Subprogram (Local_Proc);
+ elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then
+ declare
+ Id : constant Entity_Id :=
+ Entity (Identifier (Decl_Or_Stmt));
- Local_Call :=
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Local_Proc, Loc));
+ begin
+ -- When a top-level loop within declarations of a library
+ -- package spec or body contains nested subprograms, we wrap
+ -- it in a procedure to handle possible up-level references
+ -- to entities associated with the loop (such as loop
+ -- parameters).
+
+ if Present (Id) and then Contains_Subprogram (Id) then
+ Unnest_Loop (Decl_Or_Stmt);
+ end if;
+ end;
- Insert_After (Decl, Local_Call);
- Analyze (Local_Call);
+ elsif Nkind (Decl_Or_Stmt) = N_Package_Declaration
+ and then not Modify_Tree_For_C
+ then
+ Check_Unnesting_In_Decls_Or_Stmts
+ (Visible_Declarations (Specification (Decl_Or_Stmt)));
+ Check_Unnesting_In_Decls_Or_Stmts
+ (Private_Declarations (Specification (Decl_Or_Stmt)));
- while Present (Ent) loop
- Set_Scope (Ent, Local_Proc);
- Next_Entity (Ent);
- end loop;
+ elsif Nkind (Decl_Or_Stmt) = N_Package_Body
+ and then not Modify_Tree_For_C
+ then
+ Check_Unnesting_In_Decls_Or_Stmts (Declarations (Decl_Or_Stmt));
+ if Present (Statements
+ (Handled_Statement_Sequence (Decl_Or_Stmt)))
+ then
+ Check_Unnesting_In_Decls_Or_Stmts (Statements
+ (Handled_Statement_Sequence (Decl_Or_Stmt)));
+ Check_Unnesting_In_Handlers (Decl_Or_Stmt);
+ end if;
end if;
- Next (Decl);
+ Next (Decl_Or_Stmt);
end loop;
end if;
- end Check_Unnesting_In_Declarations;
+ end Check_Unnesting_In_Decls_Or_Stmts;
+
+ ---------------------------------
+ -- Check_Unnesting_In_Handlers --
+ ---------------------------------
+
+ procedure Check_Unnesting_In_Handlers (N : Node_Id) is
+ Stmt_Seq : constant Node_Id := Handled_Statement_Sequence (N);
+
+ begin
+ if Present (Stmt_Seq)
+ and then Present (Exception_Handlers (Stmt_Seq))
+ then
+ declare
+ Handler : Node_Id := First (Exception_Handlers (Stmt_Seq));
+ begin
+ while Present (Handler) loop
+ if Present (Statements (Handler)) then
+ Check_Unnesting_In_Decls_Or_Stmts (Statements (Handler));
+ end if;
+
+ Next (Handler);
+ end loop;
+ end;
+ end if;
+ end Check_Unnesting_In_Handlers;
------------------------------
-- Check_Visibly_Controlled --
@@ -5036,8 +5060,20 @@ package body Exp_Ch7 is
-- end of the body statements.
Expand_Pragma_Initial_Condition (Spec_Id, N);
- Check_Unnesting_Elaboration_Code (N);
- Check_Unnesting_In_Declarations (Declarations (N));
+
+ -- If this is a library-level package and unnesting is enabled,
+ -- check for the presence of blocks with nested subprograms occurring
+ -- in elaboration code, and generate procedures to encapsulate the
+ -- blocks in case the nested subprograms make up-level references.
+
+ if Unnest_Subprogram_Mode
+ and then
+ Is_Library_Level_Entity (Current_Scope)
+ then
+ Check_Unnesting_Elaboration_Code (N);
+ Check_Unnesting_In_Decls_Or_Stmts (Declarations (N));
+ Check_Unnesting_In_Handlers (N);
+ end if;
Pop_Scope;
end if;
@@ -5196,8 +5232,17 @@ package body Exp_Ch7 is
Set_Finalizer (Id, Fin_Id);
end if;
- Check_Unnesting_In_Declarations (Visible_Declarations (Spec));
- Check_Unnesting_In_Declarations (Private_Declarations (Spec));
+ -- If this is a library-level package and unnesting is enabled,
+ -- check for the presence of blocks with nested subprograms occurring
+ -- in elaboration code, and generate procedures to encapsulate the
+ -- blocks in case the nested subprograms make up-level references.
+
+ if Unnest_Subprogram_Mode
+ and then Is_Library_Level_Entity (Current_Scope)
+ then
+ Check_Unnesting_In_Decls_Or_Stmts (Visible_Declarations (Spec));
+ Check_Unnesting_In_Decls_Or_Stmts (Private_Declarations (Spec));
+ end if;
end Expand_N_Package_Declaration;
----------------------------
@@ -9180,6 +9225,123 @@ package body Exp_Ch7 is
Store_Actions_In_Scope (Cleanup, L);
end Store_Cleanup_Actions_In_Scope;
+ ------------------
+ -- Unnest_Block --
+ ------------------
+
+ procedure Unnest_Block (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Ent : Entity_Id;
+ Local_Body : Node_Id;
+ Local_Call : Node_Id;
+ Local_Proc : Entity_Id;
+ Local_Scop : Entity_Id;
+
+ begin
+ Local_Scop := Entity (Identifier (Decl));
+ Ent := First_Entity (Local_Scop);
+
+ Local_Proc :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
+
+ Local_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Local_Proc),
+ Declarations => Declarations (Decl),
+ Handled_Statement_Sequence =>
+ Handled_Statement_Sequence (Decl));
+
+ Rewrite (Decl, Local_Body);
+ Analyze (Decl);
+ Set_Has_Nested_Subprogram (Local_Proc);
+
+ Local_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Local_Proc, Loc));
+
+ Insert_After (Decl, Local_Call);
+ Analyze (Local_Call);
+
+ -- The new subprogram has the same scope as the original block
+
+ Set_Scope (Local_Proc, Scope (Local_Scop));
+
+ -- And the entity list of the new procedure is that of the block
+
+ Set_First_Entity (Local_Proc, Ent);
+
+ -- Reset the scopes of all the entities to the new procedure
+
+ while Present (Ent) loop
+ Set_Scope (Ent, Local_Proc);
+ Next_Entity (Ent);
+ end loop;
+ end Unnest_Block;
+
+ -----------------
+ -- Unnest_Loop --
+ -----------------
+
+ procedure Unnest_Loop (Loop_Stmt : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Loop_Stmt);
+ Ent : Entity_Id;
+ Local_Body : Node_Id;
+ Local_Call : Node_Id;
+ Local_Proc : Entity_Id;
+ Local_Scop : Entity_Id;
+ Loop_Copy : constant Node_Id :=
+ Relocate_Node (Loop_Stmt);
+ begin
+ Local_Scop := Entity (Identifier (Loop_Stmt));
+ Ent := First_Entity (Local_Scop);
+
+ Local_Proc :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
+
+ Local_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Local_Proc),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Loop_Copy)));
+
+ Set_First_Real_Statement
+ (Handled_Statement_Sequence (Local_Body), Loop_Copy);
+
+ Rewrite (Loop_Stmt, Local_Body);
+ Analyze (Loop_Stmt);
+
+ Set_Has_Nested_Subprogram (Local_Proc);
+
+ Local_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Local_Proc, Loc));
+
+ Insert_After (Loop_Stmt, Local_Call);
+ Analyze (Local_Call);
+
+ -- New procedure has the same scope as the original loop, and the scope
+ -- of the loop is the new procedure.
+
+ Set_Scope (Local_Proc, Scope (Local_Scop));
+ Set_Scope (Local_Scop, Local_Proc);
+
+ -- The entity list of the new procedure is that of the loop
+
+ Set_First_Entity (Local_Proc, Ent);
+
+ -- Note that the entities associated with the loop don't need to have
+ -- their Scope fields reset, since they're still associated with the
+ -- same loop entity that now belongs to the copied loop statement.
+ end Unnest_Loop;
+
--------------------------------
-- Wrap_Transient_Declaration --
--------------------------------
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 99bd8d2..720c1a9 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -6624,6 +6624,13 @@ package body Exp_Ch9 is
Declarations => Declarations (N),
Handled_Statement_Sequence => Build_Accept_Body (N));
+ -- Reset the Scope of local entities associated with the accept
+ -- statement (that currently reference the entry scope) to the
+ -- block scope, to avoid having references to the locals treated
+ -- as up-level references.
+
+ Reset_Scopes_To (Block, Blkent);
+
-- For the analysis of the generated declarations, the parent node
-- must be properly set.
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 6306320..36c900b 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -9388,10 +9388,16 @@ package body Exp_Util is
Proc_Id := Invariant_Procedure (Typ);
pragma Assert (Present (Proc_Id));
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Proc_Id, Loc),
- Parameter_Associations => New_List (Relocate_Node (Expr)));
+ -- Ignore the invariant if that policy is in effect
+
+ if Invariants_Ignored (Typ) then
+ return Make_Null_Statement (Loc);
+ else
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Proc_Id, Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+ end if;
end Make_Invariant_Call;
------------------------
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 93e91b2..5e1b775 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -8780,6 +8780,7 @@ package body Freeze is
-- (either in pragma CPP_Constructor or in a pragma import).
if Is_Constructor (E)
+ and then Convention (E) = Convention_CPP
and then
(No (Interface_Name (E))
or else String_Equal
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 77c6c9f..29c5a8e 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -585,6 +585,29 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gcc_unreachable ();
}
+ case E_Named_Integer:
+ case E_Named_Real:
+ {
+ tree gnu_ext_name = NULL_TREE;
+
+ if (Is_Public (gnat_entity))
+ gnu_ext_name = create_concat_name (gnat_entity, NULL);
+
+ /* All references are supposed to be folded in the front-end. */
+ gcc_assert (definition && gnu_expr);
+
+ gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
+ gnu_expr = convert (gnu_type, gnu_expr);
+
+ /* Build a CONST_DECL for debugging purposes exclusively. */
+ gnu_decl
+ = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
+ gnu_expr, true, Is_Public (gnat_entity),
+ false, false, false, artificial_p,
+ debug_info_p, NULL, gnat_entity, true);
+ }
+ break;
+
case E_Constant:
/* Ignore constant definitions already marked with the error node. See
the N_Object_Declaration case of gnat_to_gnu for the rationale. */
@@ -1519,18 +1542,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* If this is a constant and we are defining it or it generates a real
symbol at the object level and we are referencing it, we may want
or need to have a true variable to represent it:
- - if optimization isn't enabled, for debugging purposes,
- if the constant is public and not overlaid on something else,
- if its address is taken,
- - if either itself or its type is aliased. */
+ - if it is aliased,
+ - if optimization isn't enabled, for debugging purposes. */
if (TREE_CODE (gnu_decl) == CONST_DECL
&& (definition || Sloc (gnat_entity) > Standard_Location)
- && ((!optimize && debug_info_p)
- || (Is_Public (gnat_entity)
- && No (Address_Clause (gnat_entity)))
+ && ((Is_Public (gnat_entity) && No (Address_Clause (gnat_entity)))
|| Address_Taken (gnat_entity)
|| Is_Aliased (gnat_entity)
- || Is_Aliased (gnat_type)))
+ || (!optimize && debug_info_p)))
{
tree gnu_corr_var
= create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
@@ -1540,6 +1561,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
attr_list, gnat_entity, false);
SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
+ DECL_IGNORED_P (gnu_decl) = 1;
}
/* If this is a constant, even if we don't need a true variable, we
@@ -5004,6 +5026,11 @@ Gigi_Equivalent_Type (Entity_Id gnat_entity)
gnat_equiv = Etype (gnat_entity);
break;
+ case E_Array_Subtype:
+ if (!Is_Constrained (gnat_entity))
+ gnat_equiv = Etype (gnat_entity);
+ break;
+
case E_Class_Wide_Type:
gnat_equiv = Root_Type (gnat_entity);
break;
@@ -6755,6 +6782,15 @@ elaborate_reference_1 (tree ref, void *data)
elaborate_reference_1 (TREE_OPERAND (ref, 0), data),
TREE_OPERAND (ref, 1), NULL_TREE);
+ /* If this is the displacement of a pointer, elaborate the pointer and then
+ displace the result. The actual purpose here is to drop the location on
+ the expression, which may be problematic if replicated on references. */
+ if (TREE_CODE (ref) == POINTER_PLUS_EXPR
+ && TREE_CODE (TREE_OPERAND (ref, 1)) == INTEGER_CST)
+ return build2 (POINTER_PLUS_EXPR, TREE_TYPE (ref),
+ elaborate_reference_1 (TREE_OPERAND (ref, 0), data),
+ TREE_OPERAND (ref, 1));
+
sprintf (suffix, "EXP%d", ++er->n);
return
elaborate_expression_1 (ref, er->entity, suffix, er->definition, false);
@@ -7202,10 +7238,17 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
&& INTEGRAL_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_field_type))))
gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
+ orig_field_type = gnu_field_type;
gnu_field_type
= make_type_from_size (gnu_field_type, gnu_size,
Has_Biased_Representation (gnat_field));
+ /* If the type has been extended, we may need to cap the alignment. */
+ if (!needs_strict_alignment
+ && gnu_field_type != orig_field_type
+ && tree_int_cst_lt (TYPE_SIZE (orig_field_type), gnu_size))
+ packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
+
orig_field_type = gnu_field_type;
gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
false, false, definition, true);
@@ -7889,7 +7932,7 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
&& !(Is_Packed (gnat_record_type)
? has_non_packed_fixed_size_field
: Optimize_Alignment_Space (gnat_record_type))
- && !debug__debug_flag_dot_r);
+ && !Debug_Flag_Dot_R);
const bool w_reorder
= (Convention (gnat_record_type) == Convention_Ada
&& Warn_On_Questionable_Layout
@@ -8260,9 +8303,8 @@ annotate_value (tree gnu_size)
{
case INTEGER_CST:
/* For negative values, build NEGATE_EXPR of the opposite. Such values
- can appear for discriminants in expressions for variants. Note that,
- sizetype being unsigned, we don't directly use tree_int_cst_sgn. */
- if (tree_int_cst_sign_bit (gnu_size))
+ can appear for discriminants in expressions for variants. */
+ if (tree_int_cst_sgn (gnu_size) < 0)
{
tree t = wide_int_to_tree (sizetype, -wi::to_wide (gnu_size));
tcode = Negate_Expr;
@@ -8340,9 +8382,8 @@ annotate_value (tree gnu_size)
&& tree_int_cst_sign_bit (TREE_OPERAND (gnu_size, 1)))
{
tcode = Minus_Expr;
- ops[0] = annotate_value (TREE_OPERAND (gnu_size, 0));
- wide_int op1 = -wi::to_wide (TREE_OPERAND (gnu_size, 1));
- ops[1] = annotate_value (wide_int_to_tree (sizetype, op1));
+ wide_int wop1 = -wi::to_wide (TREE_OPERAND (gnu_size, 1));
+ ops[1] = annotate_value (wide_int_to_tree (sizetype, wop1));
break;
}
@@ -8383,9 +8424,9 @@ annotate_value (tree gnu_size)
Such values can appear in expressions with aligning patterns. */
if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST)
{
- wide_int op1 = wi::sext (wi::to_wide (TREE_OPERAND (gnu_size, 1)),
- TYPE_PRECISION (sizetype));
- ops[1] = annotate_value (wide_int_to_tree (sizetype, op1));
+ wide_int wop1 = -wi::to_wide (TREE_OPERAND (gnu_size, 1));
+ tree op1 = wide_int_to_tree (sizetype, wop1);
+ ops[1] = annotate_value (build1 (NEGATE_EXPR, sizetype, op1));
}
break;
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 7b842d4..61e05d5 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -6881,11 +6881,17 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
/* If the result overflows (meaning it doesn't fit in its base type),
- abort. We would like to check that the value is within the range
- of the subtype, but that causes problems with subtypes whose usage
- will raise Constraint_Error and with biased representation, so
- we don't. */
- gcc_assert (!TREE_OVERFLOW (gnu_result));
+ abort, unless this is for a named number because that's not fatal.
+ We would like to check that the value is within the range of the
+ subtype, but that causes problems with subtypes whose usage will
+ raise Constraint_Error and also with biased representation. */
+ if (TREE_OVERFLOW (gnu_result))
+ {
+ if (Nkind (Parent (gnat_node)) == N_Number_Declaration)
+ gnu_result = error_mark_node;
+ else
+ gcc_unreachable ();
+ }
}
break;
@@ -7030,6 +7036,7 @@ gnat_to_gnu (Node_Id gnat_node)
break;
case N_Object_Declaration:
+ case N_Number_Declaration:
case N_Exception_Declaration:
gnat_temp = Defining_Entity (gnat_node);
gnu_result = alloc_stmt_list ();
@@ -7052,8 +7059,15 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_expr = gnat_to_gnu (Expression (gnat_node));
- if (type_annotate_only && TREE_CODE (gnu_expr) == ERROR_MARK)
- gnu_expr = NULL_TREE;
+ if (TREE_CODE (gnu_expr) == ERROR_MARK)
+ {
+ /* If this is a named number for which we cannot manipulate
+ the value, just skip the declaration altogether. */
+ if (kind == N_Number_Declaration)
+ break;
+ else if (type_annotate_only)
+ gnu_expr = NULL_TREE;
+ }
}
else
gnu_expr = NULL_TREE;
@@ -7163,7 +7177,6 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = alloc_stmt_list ();
break;
- case N_Number_Declaration:
case N_Package_Renaming_Declaration:
/* These are fully handled in the front end. */
/* ??? For package renamings, find a way to use GENERIC namespaces so
@@ -10835,8 +10848,8 @@ Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column,
}
Source_File_Index file = Get_Source_File_Index (Sloc);
- Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
- Column_Number column = (clear_column ? 0 : Get_Column_Number (Sloc));
+ Line_Number_Type line = Get_Logical_Line_Number (Sloc);
+ Column_Number_Type column = (clear_column ? 0 : Get_Column_Number (Sloc));
line_map_ordinary *map = LINEMAPS_ORDINARY_MAP_AT (line_table, file - 1);
/* We can have zero if pragma Source_Reference is in effect. */
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index d2891f2..e14645a 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -2731,13 +2731,11 @@ create_var_decl (tree name, tree asm_name, tree type, tree init,
&& !have_global_bss_p ())
DECL_COMMON (var_decl) = 1;
- /* Do not emit debug info for a CONST_DECL if optimization isn't enabled,
- since we will create an associated variable. Likewise for an external
- constant whose initializer is not absolute, because this would mean a
- global relocation in a read-only section which runs afoul of the PE-COFF
- run-time relocation mechanism. */
+ /* Do not emit debug info if not requested, or for an external constant whose
+ initializer is not absolute because this would require a global relocation
+ in a read-only section which runs afoul of the PE-COFF run-time relocation
+ mechanism. */
if (!debug_info_p
- || (TREE_CODE (var_decl) == CONST_DECL && !optimize)
|| (extern_flag
&& constant_p
&& init
@@ -5840,6 +5838,11 @@ gnat_write_global_declarations (void)
&& DECL_FUNCTION_IS_DEF (iter))
debug_hooks->early_global_decl (iter);
+ /* Output global constants. */
+ FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter)
+ if (TREE_CODE (iter) == CONST_DECL && !DECL_IGNORED_P (iter))
+ debug_hooks->early_global_decl (iter);
+
/* Then output the global variables. We need to do that after the debug
information for global types is emitted so that they are finalized. Skip
external global variables, unless we need to emit debug info for them:
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index af07a06..7d507aa 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -1412,11 +1412,25 @@ begin
-- It is not an error to analyze in CodePeer mode a spec which requires
-- a body, in order to generate SCIL for this spec.
- -- Ditto for Generate_C_Code mode and generate a C header for a spec.
- elsif CodePeer_Mode or Generate_C_Code then
+ elsif CodePeer_Mode then
Back_End_Mode := Generate_Object;
+ -- Differentiate use of -gnatceg to generate a C header from an Ada spec
+ -- to the CCG case (standard.h found) where C code generation should
+ -- only be performed on full units.
+
+ elsif Generate_C_Code then
+ Name_Len := 10;
+ Name_Buffer (1 .. Name_Len) := "standard.h";
+
+ if Find_File (Name_Find, Osint.Source, Full_Name => True) = No_File
+ then
+ Back_End_Mode := Generate_Object;
+ else
+ Back_End_Mode := Skip;
+ end if;
+
-- It is not an error to analyze in GNATprove mode a spec which requires
-- a body, when the body is not available. During frame condition
-- generation, the corresponding ALI file is generated. During
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 5db9c76..a1ef122 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -21,7 +21,7 @@
@copying
@quotation
-GNAT User's Guide for Native Platforms , Sep 14, 2019
+GNAT User's Guide for Native Platforms , Oct 09, 2019
AdaCore
@@ -682,12 +682,12 @@ material for the several revisions of the Ada language standard.
implementation of Ada.
@item
-@cite{Using the GNAT Programming Studio}, which describes the GPS
+@cite{Using GNAT Studio}, which describes the GNAT Studio
Integrated Development Environment.
@item
-@cite{GNAT Programming Studio Tutorial}, which introduces the
-main GPS features through examples.
+@cite{GNAT Studio Tutorial}, which introduces the
+main GNAT Studio features through examples.
@item
@cite{Debugging with GDB},
@@ -897,11 +897,11 @@ the '\' character should be used instead.
This chapter describes how to use GNAT's command line interface to build
executable Ada programs.
On most platforms a visually oriented Integrated Development Environment
-is also available, the GNAT Programming Studio (GPS).
-GPS offers a graphical "look and feel", support for development in
+is also available, the GNAT Programming Studio (GNAT Studio).
+GNAT Studio offers a graphical "look and feel", support for development in
other programming languages, comprehensive browsing features, and
many other capabilities.
-For information on GPS please refer to
+For information on GNAT Studio please refer to
@cite{Using the GNAT Programming Studio}.
@menu
@@ -10446,7 +10446,7 @@ e.adb:4:20: ";" should be "is"
The first integer after the file name is the line number in the file,
and the second integer is the column number within the line.
-@code{GPS} can parse the error messages
+@code{GNAT Studio} can parse the error messages
and point to the referenced character.
The following switches provide control over the error message
format:
@@ -14110,7 +14110,7 @@ if any.
@c end of switch description (leave this comment to ease automatic parsing for
-@c GPS
+@c GNAT Studio
In the above rules, appearing in column one is always permitted, that is,
counts as meeting either a requirement for a required preceding space,
@@ -19394,9 +19394,9 @@ variables, and more generally to report on the state of execution.
This section describes how to initiate the debugger.
-The debugger can be launched from a @code{GPS} menu or
+The debugger can be launched from a @code{GNAT Studio} menu or
directly from the command line. The description below covers the latter use.
-All the commands shown can be used in the @code{GPS} debug console window,
+All the commands shown can be used in the @code{GNAT Studio} debug console window,
but there are usually more GUI-based ways to achieve the same effect.
The command to run @code{GDB} is
diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
index 4c4a019..b5782aa 100644
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -53,8 +53,9 @@ with GNAT.OS_Lib; use GNAT.OS_Lib;
procedure Gnatls is
pragma Ident (Gnat_Static_Version_String);
- -- NOTE : The following string may be used by other tools, such as GPS. So
- -- it can only be modified if these other uses are checked and coordinated.
+ -- NOTE : The following string may be used by other tools, such as
+ -- GNAT Studio. So it can only be modified if these other uses are checked
+ -- and coordinated.
Project_Search_Path : constant String := "Project Search Path:";
-- Label displayed in verbose mode before the directories in the project
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index 7e67569..7048ab4 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -32,8 +32,8 @@ with Namet; use Namet;
with Opt; use Opt;
with Uname; use Uname;
--- Note: this package body is used by GPS and GNATBench to supply a list of
--- entries for help on available library routines.
+-- Note: this package body is used by GNAT Studio and GNATBench to supply a
+-- list of entries for help on available library routines.
package body Impunit is
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index dab2275..0d80ab2 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -1493,6 +1493,12 @@ package body Inline is
(Spec_Id : Entity_Id;
Body_Id : Entity_Id) return Boolean
is
+ function Has_Formal_Or_Result_Of_Deep_Type
+ (Id : Entity_Id) return Boolean;
+ -- Returns true if the subprogram has at least one formal parameter or
+ -- a return type of a deep type: either an access type or a composite
+ -- type containing an access type.
+
function Has_Formal_With_Discriminant_Dependent_Fields
(Id : Entity_Id) return Boolean;
-- Returns true if the subprogram has at least one formal parameter of
@@ -1518,6 +1524,118 @@ package body Inline is
-- knowledge of the SPARK boundary is needed to determine exactly
-- traversal functions.
+ ---------------------------------------
+ -- Has_Formal_Or_Result_Of_Deep_Type --
+ ---------------------------------------
+
+ function Has_Formal_Or_Result_Of_Deep_Type
+ (Id : Entity_Id) return Boolean
+ is
+ function Is_Deep (Typ : Entity_Id) return Boolean;
+ -- Return True if Typ is deep: either an access type or a composite
+ -- type containing an access type.
+
+ -------------
+ -- Is_Deep --
+ -------------
+
+ function Is_Deep (Typ : Entity_Id) return Boolean is
+ begin
+ case Type_Kind'(Ekind (Typ)) is
+ when Access_Kind =>
+ return True;
+
+ when E_Array_Type
+ | E_Array_Subtype
+ =>
+ return Is_Deep (Component_Type (Typ));
+
+ when Record_Kind =>
+ declare
+ Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
+ begin
+ while Present (Comp) loop
+ if Is_Deep (Etype (Comp)) then
+ return True;
+ end if;
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end;
+ return False;
+
+ when Scalar_Kind
+ | E_String_Literal_Subtype
+ | Concurrent_Kind
+ | Incomplete_Kind
+ | E_Exception_Type
+ | E_Subprogram_Type
+ =>
+ return False;
+
+ when E_Private_Type
+ | E_Private_Subtype
+ | E_Limited_Private_Type
+ | E_Limited_Private_Subtype
+ =>
+ -- Conservatively consider that the type might be deep if
+ -- its completion has not been seen yet.
+
+ if No (Underlying_Type (Typ)) then
+ return True;
+
+ -- Do not peek under a private type if its completion has
+ -- SPARK_Mode Off. In such a case, a deep type is considered
+ -- by GNATprove to be not deep.
+
+ elsif Present (Full_View (Typ))
+ and then Present (SPARK_Pragma (Full_View (Typ)))
+ and then Get_SPARK_Mode_From_Annotation
+ (SPARK_Pragma (Full_View (Typ))) = Off
+ then
+ return False;
+
+ -- Otherwise peek under the private type.
+
+ else
+ return Is_Deep (Underlying_Type (Typ));
+ end if;
+ end case;
+ end Is_Deep;
+
+ -- Local variables
+
+ Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
+ Formal : Entity_Id;
+ Formal_Typ : Entity_Id;
+
+ -- Start of processing for Has_Formal_Or_Result_Of_Deep_Type
+
+ begin
+ -- Inspect all parameters of the subprogram looking for a formal
+ -- of a deep type.
+
+ Formal := First_Formal (Subp_Id);
+ while Present (Formal) loop
+ Formal_Typ := Etype (Formal);
+
+ if Is_Deep (Formal_Typ) then
+ return True;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ -- Check whether this is a function whose return type is deep
+
+ if Ekind (Subp_Id) = E_Function
+ and then Is_Deep (Etype (Subp_Id))
+ then
+ return True;
+ end if;
+
+ return False;
+ end Has_Formal_Or_Result_Of_Deep_Type;
+
---------------------------------------------------
-- Has_Formal_With_Discriminant_Dependent_Fields --
---------------------------------------------------
@@ -1777,6 +1895,14 @@ package body Inline is
elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
return False;
+ -- Do not inline subprograms with a formal parameter or return type of
+ -- a deep type, as in that case inlining might generate code that
+ -- violates borrow-checking rules of SPARK 3.10 even if the original
+ -- code did not.
+
+ elsif Has_Formal_Or_Result_Of_Deep_Type (Id) then
+ return False;
+
-- Do not inline subprograms which may be traversal functions. Such
-- inlining introduces temporary variables of named access type for
-- which assignments are move instead of borrow/observe, possibly
diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads
index 7248a61..5045b91 100644
--- a/gcc/ada/lib-writ.ads
+++ b/gcc/ada/lib-writ.ads
@@ -56,7 +56,8 @@ package Lib.Writ is
-- incompatible with new versions of the compiler. Any changes to ali file
-- formats must be carefully evaluated to understand any such possible
-- conflicts, and in particular, it is very undesirable to create conflicts
- -- between older versions of GPS and newer versions of the compiler.
+ -- between older versions of GNAT Studio and newer versions of the
+ -- compiler.
-- If the following guidelines are respected, downward compatibility
-- problems (old tools reading new ali files) should be minimized:
diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb
index 4dea2e6..9a2282b 100644
--- a/gcc/ada/libgnat/a-cbdlli.adb
+++ b/gcc/ada/libgnat/a-cbdlli.adb
@@ -304,7 +304,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1448,7 +1448,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -1564,7 +1564,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-cbhama.adb b/gcc/ada/libgnat/a-cbhama.adb
index 74e3d95..d5cc820 100644
--- a/gcc/ada/libgnat/a-cbhama.adb
+++ b/gcc/ada/libgnat/a-cbhama.adb
@@ -213,7 +213,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -239,7 +239,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -853,7 +853,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -987,7 +987,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
@@ -1012,7 +1012,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-cbhase.adb b/gcc/ada/libgnat/a-cbhase.adb
index 390e82b..1fa2c21 100644
--- a/gcc/ada/libgnat/a-cbhase.adb
+++ b/gcc/ada/libgnat/a-cbhase.adb
@@ -231,7 +231,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1077,7 +1077,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -1606,7 +1606,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1787,7 +1787,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is
Old_Pos => Position,
Old_Hash => Hash (Key (Position))))
do
- Lock (Container.TC);
+ Busy (Container.TC);
end return;
end;
end Reference_Preserving_Key;
@@ -1816,7 +1816,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is
Old_Pos => P,
Old_Hash => Hash (Key)))
do
- Lock (Container.TC);
+ Busy (Container.TC);
end return;
end;
end Reference_Preserving_Key;
diff --git a/gcc/ada/libgnat/a-cbmutr.adb b/gcc/ada/libgnat/a-cbmutr.adb
index 4c0f8fe..ad9edaa 100644
--- a/gcc/ada/libgnat/a-cbmutr.adb
+++ b/gcc/ada/libgnat/a-cbmutr.adb
@@ -600,7 +600,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
(Element => Container.Elements (Position.Node)'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -2291,7 +2291,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -2490,7 +2490,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
(Element => Container.Elements (Position.Node)'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-cborma.adb b/gcc/ada/libgnat/a-cborma.adb
index e4e4b57..005bca5 100644
--- a/gcc/ada/libgnat/a-cborma.adb
+++ b/gcc/ada/libgnat/a-cborma.adb
@@ -420,7 +420,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -445,7 +445,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1256,7 +1256,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -1376,7 +1376,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
@@ -1401,7 +1401,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb
index 7b98378..b553048 100644
--- a/gcc/ada/libgnat/a-cborse.adb
+++ b/gcc/ada/libgnat/a-cborse.adb
@@ -420,7 +420,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -741,7 +741,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
(Element => N.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -937,7 +937,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
- Lock (Container.TC);
+ Busy (Container.TC);
end return;
end;
end Reference_Preserving_Key;
@@ -965,7 +965,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
- Lock (Container.TC);
+ Busy (Container.TC);
end return;
end;
end Reference_Preserving_Key;
@@ -1598,7 +1598,7 @@ package body Ada.Containers.Bounded_Ordered_Sets is
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb
index 9122d57..949fb0f 100644
--- a/gcc/ada/libgnat/a-cdlili.adb
+++ b/gcc/ada/libgnat/a-cdlili.adb
@@ -255,7 +255,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
(Element => Position.Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1226,7 +1226,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -1357,7 +1357,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
(Element => Position.Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb
index fd48045..65e4c10 100644
--- a/gcc/ada/libgnat/a-cidlli.adb
+++ b/gcc/ada/libgnat/a-cidlli.adb
@@ -280,7 +280,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Element => Position.Node.Element,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1263,7 +1263,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -1405,7 +1405,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Element => Position.Node.Element,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb
index 0971a00..b33246d 100644
--- a/gcc/ada/libgnat/a-cihama.adb
+++ b/gcc/ada/libgnat/a-cihama.adb
@@ -220,7 +220,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
(Element => Position.Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -249,7 +249,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
(Element => Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -911,7 +911,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Container.HT.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -1057,7 +1057,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
(Element => Position.Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
@@ -1086,7 +1086,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
(Element => Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-cihase.adb b/gcc/ada/libgnat/a-cihase.adb
index ce158d2..bec48d0 100644
--- a/gcc/ada/libgnat/a-cihase.adb
+++ b/gcc/ada/libgnat/a-cihase.adb
@@ -239,7 +239,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
(Element => Position.Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1229,7 +1229,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Container.HT.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -2044,7 +2044,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
(Element => Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -2232,7 +2232,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Old_Pos => Position,
Old_Hash => Hash (Key (Position))))
do
- Lock (HT.TC);
+ Busy (HT.TC);
end return;
end;
end Reference_Preserving_Key;
@@ -2266,7 +2266,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
Old_Pos => P,
Old_Hash => Hash (Key)))
do
- Lock (HT.TC);
+ Busy (HT.TC);
end return;
end;
end Reference_Preserving_Key;
diff --git a/gcc/ada/libgnat/a-cimutr.adb b/gcc/ada/libgnat/a-cimutr.adb
index 18bfff0..c5cf221 100644
--- a/gcc/ada/libgnat/a-cimutr.adb
+++ b/gcc/ada/libgnat/a-cimutr.adb
@@ -488,7 +488,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
(Element => Position.Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1847,7 +1847,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -2044,7 +2044,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
(Element => Position.Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-ciorma.adb b/gcc/ada/libgnat/a-ciorma.adb
index 5cc3590..818a2ae 100644
--- a/gcc/ada/libgnat/a-ciorma.adb
+++ b/gcc/ada/libgnat/a-ciorma.adb
@@ -374,7 +374,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
(Element => Position.Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -402,7 +402,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
(Element => Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1250,7 +1250,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
Container.Tree.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -1387,7 +1387,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
(Element => Position.Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
@@ -1415,7 +1415,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
(Element => Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb
index d979e88..7cc7dca 100644
--- a/gcc/ada/libgnat/a-ciorse.adb
+++ b/gcc/ada/libgnat/a-ciorse.adb
@@ -394,7 +394,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
(Element => Position.Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -788,7 +788,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
(Element => Node.Element.all'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1017,7 +1017,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
- Lock (Tree.TC);
+ Busy (Tree.TC);
end return;
end;
end Reference_Preserving_Key;
@@ -1049,7 +1049,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
- Lock (Tree.TC);
+ Busy (Tree.TC);
end return;
end;
end Reference_Preserving_Key;
@@ -1688,7 +1688,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
Container.Tree.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
diff --git a/gcc/ada/libgnat/a-cobove.adb b/gcc/ada/libgnat/a-cobove.adb
index 3e48bc6..7508794 100644
--- a/gcc/ada/libgnat/a-cobove.adb
+++ b/gcc/ada/libgnat/a-cobove.adb
@@ -402,7 +402,7 @@ package body Ada.Containers.Bounded_Vectors is
(Element => A (J)'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -426,7 +426,7 @@ package body Ada.Containers.Bounded_Vectors is
(Element => A (J)'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -2067,7 +2067,7 @@ package body Ada.Containers.Bounded_Vectors is
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -2183,7 +2183,7 @@ package body Ada.Containers.Bounded_Vectors is
(Element => A (J)'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
@@ -2207,7 +2207,7 @@ package body Ada.Containers.Bounded_Vectors is
(Element => A (J)'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-cohama.adb b/gcc/ada/libgnat/a-cohama.adb
index 0eb6e7e..e7da020 100644
--- a/gcc/ada/libgnat/a-cohama.adb
+++ b/gcc/ada/libgnat/a-cohama.adb
@@ -213,7 +213,7 @@ package body Ada.Containers.Hashed_Maps is
(Element => Position.Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -238,7 +238,7 @@ package body Ada.Containers.Hashed_Maps is
(Element => Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -836,7 +836,7 @@ package body Ada.Containers.Hashed_Maps is
Container.HT.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -937,7 +937,7 @@ package body Ada.Containers.Hashed_Maps is
(Element => Position.Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
@@ -962,7 +962,7 @@ package body Ada.Containers.Hashed_Maps is
(Element => Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb
index 37e55b8..61ebf87 100644
--- a/gcc/ada/libgnat/a-cohase.adb
+++ b/gcc/ada/libgnat/a-cohase.adb
@@ -223,7 +223,7 @@ package body Ada.Containers.Hashed_Sets is
(Element => Position.Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1119,7 +1119,7 @@ package body Ada.Containers.Hashed_Sets is
Container.HT.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -1839,7 +1839,7 @@ package body Ada.Containers.Hashed_Sets is
(Element => Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -2025,7 +2025,7 @@ package body Ada.Containers.Hashed_Sets is
Old_Pos => Position,
Old_Hash => Hash (Key (Position))))
do
- Lock (HT.TC);
+ Busy (HT.TC);
end return;
end;
end Reference_Preserving_Key;
@@ -2055,7 +2055,7 @@ package body Ada.Containers.Hashed_Sets is
Old_Pos => P,
Old_Hash => Hash (Key)))
do
- Lock (HT.TC);
+ Busy (HT.TC);
end return;
end;
end Reference_Preserving_Key;
diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb
index 22608c1..0dfe1c6 100644
--- a/gcc/ada/libgnat/a-coinve.adb
+++ b/gcc/ada/libgnat/a-coinve.adb
@@ -324,7 +324,7 @@ package body Ada.Containers.Indefinite_Vectors is
(Element => Container.Elements.EA (Position.Index),
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -348,7 +348,7 @@ package body Ada.Containers.Indefinite_Vectors is
(Element => Container.Elements.EA (Index),
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -2586,7 +2586,7 @@ package body Ada.Containers.Indefinite_Vectors is
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -2718,7 +2718,7 @@ package body Ada.Containers.Indefinite_Vectors is
(Element => Container.Elements.EA (Position.Index),
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
@@ -2742,7 +2742,7 @@ package body Ada.Containers.Indefinite_Vectors is
(Element => Container.Elements.EA (Index),
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-comutr.adb b/gcc/ada/libgnat/a-comutr.adb
index 59ed12b..9e6a00e 100644
--- a/gcc/ada/libgnat/a-comutr.adb
+++ b/gcc/ada/libgnat/a-comutr.adb
@@ -469,7 +469,7 @@ package body Ada.Containers.Multiway_Trees is
(Element => Position.Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1830,7 +1830,7 @@ package body Ada.Containers.Multiway_Trees is
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -2023,7 +2023,7 @@ package body Ada.Containers.Multiway_Trees is
(Element => Position.Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-conhel.adb b/gcc/ada/libgnat/a-conhel.adb
index 2908530..06af0da 100644
--- a/gcc/ada/libgnat/a-conhel.adb
+++ b/gcc/ada/libgnat/a-conhel.adb
@@ -38,7 +38,7 @@ package body Ada.Containers.Helpers is
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.T_Counts /= null then
- Lock (Control.T_Counts.all);
+ Busy (Control.T_Counts.all);
end if;
end Adjust;
@@ -60,7 +60,7 @@ package body Ada.Containers.Helpers is
procedure Finalize (Control : in out Reference_Control_Type) is
begin
if Control.T_Counts /= null then
- Unlock (Control.T_Counts.all);
+ Unbusy (Control.T_Counts.all);
Control.T_Counts := null;
end if;
end Finalize;
diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb
index e15ab5d..f5e2eb4 100644
--- a/gcc/ada/libgnat/a-convec.adb
+++ b/gcc/ada/libgnat/a-convec.adb
@@ -294,7 +294,7 @@ package body Ada.Containers.Vectors is
(Element => Container.Elements.EA (Position.Index)'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -316,7 +316,7 @@ package body Ada.Containers.Vectors is
(Element => Container.Elements.EA (Index)'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -2293,7 +2293,7 @@ package body Ada.Containers.Vectors is
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -2409,7 +2409,7 @@ package body Ada.Containers.Vectors is
(Element => Container.Elements.EA (Position.Index)'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
@@ -2431,7 +2431,7 @@ package body Ada.Containers.Vectors is
(Element => Container.Elements.EA (Index)'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-coorma.adb b/gcc/ada/libgnat/a-coorma.adb
index 8275802..e49ae90 100644
--- a/gcc/ada/libgnat/a-coorma.adb
+++ b/gcc/ada/libgnat/a-coorma.adb
@@ -336,7 +336,7 @@ package body Ada.Containers.Ordered_Maps is
(Element => Position.Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -361,7 +361,7 @@ package body Ada.Containers.Ordered_Maps is
(Element => Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -1180,7 +1180,7 @@ package body Ada.Containers.Ordered_Maps is
Container.Tree.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
@@ -1307,7 +1307,7 @@ package body Ada.Containers.Ordered_Maps is
(Element => Position.Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
@@ -1332,7 +1332,7 @@ package body Ada.Containers.Ordered_Maps is
(Element => Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Reference;
diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb
index 462f7f3..d2f8a58 100644
--- a/gcc/ada/libgnat/a-coorse.adb
+++ b/gcc/ada/libgnat/a-coorse.adb
@@ -349,7 +349,7 @@ package body Ada.Containers.Ordered_Sets is
(Element => Position.Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -706,7 +706,7 @@ package body Ada.Containers.Ordered_Sets is
(Element => Node.Element'Access,
Control => (Controlled with TC))
do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end;
end Constant_Reference;
@@ -903,7 +903,7 @@ package body Ada.Containers.Ordered_Sets is
Pos => Position,
Old_Key => new Key_Type'(Key (Position))))
do
- Lock (Tree.TC);
+ Busy (Tree.TC);
end return;
end;
end Reference_Preserving_Key;
@@ -931,7 +931,7 @@ package body Ada.Containers.Ordered_Sets is
Pos => Find (Container, Key),
Old_Key => new Key_Type'(Key)))
do
- Lock (Tree.TC);
+ Busy (Tree.TC);
end return;
end;
end Reference_Preserving_Key;
@@ -1550,7 +1550,7 @@ package body Ada.Containers.Ordered_Sets is
Container.Tree.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type := (Controlled with TC) do
- Lock (TC.all);
+ Busy (TC.all);
end return;
end Pseudo_Reference;
diff --git a/gcc/ada/libgnat/a-ststio.ads b/gcc/ada/libgnat/a-ststio.ads
index 5314ce8..30be158 100644
--- a/gcc/ada/libgnat/a-ststio.ads
+++ b/gcc/ada/libgnat/a-ststio.ads
@@ -42,6 +42,7 @@ package Ada.Streams.Stream_IO is
type Stream_Access is access all Root_Stream_Type'Class;
type File_Type is limited private with Default_Initial_Condition;
+ pragma Preelaborable_Initialization (File_Type);
type File_Mode is (In_File, Out_File, Append_File);
diff --git a/gcc/ada/libgnat/g-exptty.ads b/gcc/ada/libgnat/g-exptty.ads
index 81068a6..f61ea62 100644
--- a/gcc/ada/libgnat/g-exptty.ads
+++ b/gcc/ada/libgnat/g-exptty.ads
@@ -139,7 +139,7 @@ private
Still_Active : constant Integer := -1;
type TTY_Process_Descriptor is new Process_Descriptor with record
- Process : System.Address;
+ Process : System.Address := System.Null_Address;
-- Underlying structure used in C
Exit_Status : Integer := Still_Active;
-- Hold the exit status of the process.
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index a07db75..1f068dc 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -501,7 +501,8 @@ package Opt is
Display_Compilation_Progress : Boolean := False;
-- GNATMAKE, GPRBUILD
-- Set True (-d switch) to display information on progress while compiling
- -- files. Internal flag to be used in conjunction with an IDE (e.g GPS).
+ -- files. Internal flag to be used in conjunction with an IDE
+ -- (e.g GNAT Studio).
type Distribution_Stub_Mode_Type is
-- GNAT
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index dc77590..65cc8bc 100644
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.adb
@@ -949,22 +949,16 @@ package body Rtsfind is
Install_Ghost_Region (None, Empty);
Install_SPARK_Mode (None, Empty);
- -- Note if secondary stack is used
-
- if U_Id = System_Secondary_Stack then
- Opt.Sec_Stack_Used := True;
- end if;
-
- -- Otherwise we need to load the unit, First build unit name
- -- from the enumeration literal name in type RTU_Id.
+ -- Otherwise we need to load the unit, First build unit name from the
+ -- enumeration literal name in type RTU_Id.
U.Uname := Get_Unit_Name (U_Id);
U.First_Implicit_With := Empty;
- -- Now do the load call, note that setting Error_Node to Empty is
- -- a signal to Load_Unit that we will regard a failure to find the
- -- file as a fatal error, and that it should not output any kind
- -- of diagnostics, since we will take care of it here.
+ -- Now do the load call, note that setting Error_Node to Empty is a
+ -- signal to Load_Unit that we will regard a failure to find the file as
+ -- a fatal error, and that it should not output any kind of diagnostics,
+ -- since we will take care of it here.
-- We save style checking switches and turn off style checking for
-- loading the unit, since we don't want any style checking.
@@ -1245,21 +1239,6 @@ package body Rtsfind is
---------
function RTE (E : RE_Id) return Entity_Id is
- U_Id : constant RTU_Id := RE_Unit_Table (E);
- U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
-
- Lib_Unit : Node_Id;
- Pkg_Ent : Entity_Id;
- Ename : Name_Id;
-
- -- The following flag is used to disable front-end inlining when RTE
- -- is invoked. This prevents the analysis of other runtime bodies when
- -- a particular spec is loaded through Rtsfind. This is both efficient,
- -- and it prevents spurious visibility conflicts between use-visible
- -- user entities, and entities in run-time packages.
-
- Save_Front_End_Inlining : Boolean;
-
procedure Check_RPC;
-- Reject programs that make use of distribution features not supported
-- on the current target. Also check that the PCS is compatible with the
@@ -1351,6 +1330,22 @@ package body Rtsfind is
return Ent;
end Find_Local_Entity;
+ -- Local variables
+
+ U_Id : constant RTU_Id := RE_Unit_Table (E);
+ U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
+
+ Ename : Name_Id;
+ Lib_Unit : Node_Id;
+ Pkg_Ent : Entity_Id;
+
+ Save_Front_End_Inlining : constant Boolean := Front_End_Inlining;
+ -- This flag is used to disable front-end inlining when RTE is invoked.
+ -- This prevents the analysis of other runtime bodies when a particular
+ -- spec is loaded through Rtsfind. This is both efficient, and prevents
+ -- spurious visibility conflicts between use-visible user entities, and
+ -- entities in run-time packages.
+
-- Start of processing for RTE
begin
@@ -1372,7 +1367,6 @@ package body Rtsfind is
return Check_CRT (E, Find_Local_Entity (E));
end if;
- Save_Front_End_Inlining := Front_End_Inlining;
Front_End_Inlining := False;
-- Load unit if unit not previously loaded
@@ -1435,9 +1429,19 @@ package body Rtsfind is
end if;
<<Found>>
- Maybe_Add_With (U);
+ -- Record whether the secondary stack is in use in order to generate
+ -- the proper binder code. No action is taken when the secondary stack
+ -- is pulled within an ignored Ghost context because all this code will
+ -- disappear.
+
+ if U_Id = System_Secondary_Stack and then Ghost_Mode /= Ignore then
+ Sec_Stack_Used := True;
+ end if;
+
+ Maybe_Add_With (U);
Front_End_Inlining := Save_Front_End_Inlining;
+
return Check_CRT (E, RE_Table (E));
end RTE;
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 87fe050..d6d7c59 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -614,10 +614,17 @@ package body Sem_Aggr is
if Has_Predicates (Typ) then
Set_Has_Predicates (Itype);
+ -- If the base type has a predicate, capture the predicated parent
+ -- or the existing predicate function for SPARK use.
+
if Present (Predicate_Function (Typ)) then
Set_Predicate_Function (Itype, Predicate_Function (Typ));
- else
+
+ elsif Is_Itype (Typ) then
Set_Predicated_Parent (Itype, Predicated_Parent (Typ));
+
+ else
+ Set_Predicated_Parent (Itype, Typ);
end if;
end if;
@@ -886,7 +893,6 @@ package body Sem_Aggr is
procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Pkind : constant Node_Kind := Nkind (Parent (N));
Aggr_Subtyp : Entity_Id;
-- The actual aggregate subtype. This is not necessarily the same as Typ
@@ -1071,16 +1077,17 @@ package body Sem_Aggr is
-- permit it, or the aggregate type is unconstrained, an OTHERS
-- choice is not allowed (except that it is always allowed on the
-- right-hand side of an assignment statement; in this case the
- -- constrainedness of the type doesn't matter).
+ -- constrainedness of the type doesn't matter, because an array
+ -- object is always constrained).
-- If expansion is disabled (generic context, or semantics-only
-- mode) actual subtypes cannot be constructed, and the type of an
-- object may be its unconstrained nominal type. However, if the
- -- context is an assignment, we assume that OTHERS is allowed,
- -- because the target of the assignment will have a constrained
- -- subtype when fully compiled. Ditto if the context is an
- -- initialization procedure where a component may have a predicate
- -- function that carries the base type.
+ -- context is an assignment statement, OTHERS is allowed, because
+ -- the target of the assignment will have a constrained subtype
+ -- when fully compiled. Ditto if the context is an initialization
+ -- procedure where a component may have a predicate function that
+ -- carries the base type.
-- Note that there is no node for Explicit_Actual_Parameter.
-- To test for this context we therefore have to test for node
@@ -1094,24 +1101,26 @@ package body Sem_Aggr is
Set_Etype (N, Aggr_Typ); -- May be overridden later on
- if Pkind = N_Assignment_Statement
+ if Nkind (Parent (N)) = N_Assignment_Statement
or else Inside_Init_Proc
or else (Is_Constrained (Typ)
- and then
- (Pkind = N_Parameter_Association or else
- Pkind = N_Function_Call or else
- Pkind = N_Procedure_Call_Statement or else
- Pkind = N_Generic_Association or else
- Pkind = N_Formal_Object_Declaration or else
- Pkind = N_Simple_Return_Statement or else
- Pkind = N_Object_Declaration or else
- Pkind = N_Component_Declaration or else
- Pkind = N_Parameter_Specification or else
- Pkind = N_Qualified_Expression or else
- Pkind = N_Reference or else
- Pkind = N_Aggregate or else
- Pkind = N_Extension_Aggregate or else
- Pkind = N_Component_Association))
+ and then Nkind_In (Parent (N),
+ N_Parameter_Association,
+ N_Function_Call,
+ N_Procedure_Call_Statement,
+ N_Generic_Association,
+ N_Formal_Object_Declaration,
+ N_Simple_Return_Statement,
+ N_Object_Declaration,
+ N_Component_Declaration,
+ N_Parameter_Specification,
+ N_Qualified_Expression,
+ N_Reference,
+ N_Aggregate,
+ N_Extension_Aggregate,
+ N_Component_Association,
+ N_Case_Expression_Alternative,
+ N_If_Expression))
then
Aggr_Resolved :=
Resolve_Array_Aggregate
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index 663dca4..833df88 100644
--- a/gcc/ada/sem_cat.adb
+++ b/gcc/ada/sem_cat.adb
@@ -721,9 +721,15 @@ package body Sem_Cat is
-- The purpose is to set categorization flags before analyzing the
-- unit itself, so as to diagnose violations of categorization as
-- we process each declaration, even though the pragma appears after
- -- the unit.
-
- if Nkind (P) /= N_Compilation_Unit then
+ -- the unit. This processing is only needed if compilation unit pragmas
+ -- are present.
+ -- Note: This code may be incorrect in the unlikely case a child generic
+ -- unit is instantiated as a child of its (nongeneric) parent, so that
+ -- generic and instance are siblings.
+
+ if Nkind (P) /= N_Compilation_Unit
+ or else No (First (Pragmas_After (Aux_Decls_Node (P))))
+ then
return;
end if;
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 4e74f9a..8c3559f 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -2925,6 +2925,41 @@ package body Sem_Ch12 is
Set_Ekind (Formal, E_Package);
Set_Etype (Formal, Standard_Void_Type);
Set_Inner_Instances (Formal, New_Elmt_List);
+
+ -- It is unclear that any aspects can apply to a formal package
+ -- declaration, given that they look like a hidden conformance
+ -- requirement on the corresponding actual. However, Abstract_State
+ -- must be treated specially because it generates declarations that
+ -- must appear before other declarations in the specification and
+ -- must be analyzed at once.
+
+ if Present (Aspect_Specifications (Gen_Decl)) then
+ if No (Aspect_Specifications (N)) then
+ Set_Aspect_Specifications (N, New_List);
+ Set_Has_Aspects (N);
+ end if;
+
+ declare
+ ASN : Node_Id := First (Aspect_Specifications (Gen_Decl));
+ New_A : Node_Id;
+
+ begin
+ while Present (ASN) loop
+ if Get_Aspect_Id (ASN) = Aspect_Abstract_State then
+ New_A :=
+ Copy_Generic_Node (ASN, Empty, Instantiating => True);
+ Set_Entity (New_A, Formal);
+ Set_Analyzed (New_A, False);
+ Append (New_A, Aspect_Specifications (N));
+ Analyze_Aspect_Specifications (N, Formal);
+ exit;
+ end if;
+
+ Next (ASN);
+ end loop;
+ end;
+ end if;
+
Push_Scope (Formal);
-- Manually set the SPARK_Mode from the context because the package
@@ -3023,6 +3058,9 @@ package body Sem_Ch12 is
<<Leave>>
if Has_Aspects (N) then
+ -- Unclear that any other aspects may appear here, snalyze them
+ -- for completion, given that the grammar allows their appearance.
+
Analyze_Aspect_Specifications (N, Pack_Id);
end if;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 354d068..67ec0df 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -360,11 +360,11 @@ package body Sem_Ch13 is
Num_CC : Natural;
begin
- -- Processing here used to depend on Ada version: the behavior was
- -- changed by AI95-0133. However this AI is a Binding interpretation,
- -- so we now implement it even in Ada 95 mode. The original behavior
- -- from unamended Ada 95 is still available for compatibility under
- -- debugging switch -gnatd.
+ -- The processing done here used to depend on the Ada version, but the
+ -- behavior has been changed by AI95-0133. However this AI is a Binding
+ -- Interpretation, so we now implement it even in Ada 95 mode. But the
+ -- original behavior from unamended Ada 95 is available for the sake of
+ -- compatibility under the debugging switch -gnatd.p in Ada 95 mode.
if Ada_Version < Ada_2005 and then Debug_Flag_Dot_P then
Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R);
@@ -376,6 +376,11 @@ package body Sem_Ch13 is
-- same byte offset and processing them together. Same approach is still
-- valid in later versions including Ada 2012.
+ -- Note that component clauses found on record types may be inherited,
+ -- in which case the layout of the component with such a clause still
+ -- has to be done at this point. Therefore, the processing done here
+ -- must exclusively rely on the Component_Clause of the component.
+
-- This first loop through components does two things. First it deals
-- with the case of components with component clauses whose length is
-- greater than the maximum machine scalar size (either accepting them
@@ -616,13 +621,19 @@ package body Sem_Ch13 is
Comp : constant Entity_Id := Comps (C);
CC : constant Node_Id := Component_Clause (Comp);
+ FB : constant Uint := Static_Integer (First_Bit (CC));
LB : constant Uint := Static_Integer (Last_Bit (CC));
- NFB : constant Uint := MSS - Uint_1 - LB;
- NLB : constant Uint := NFB + Esize (Comp) - 1;
+ NFB : constant Uint := MSS - 1 - LB;
+ NLB : constant Uint := NFB + LB - FB;
Pos : constant Uint := Static_Integer (Position (CC));
begin
- if Warn_On_Reverse_Bit_Order then
+ -- Do not warn for the artificial clause built for the tag
+ -- in Check_Record_Representation_Clause if it is inherited.
+
+ if Warn_On_Reverse_Bit_Order
+ and then Chars (Comp) /= Name_uTag
+ then
Error_Msg_Uint_1 := MSS;
Error_Msg_N
("info: reverse bit order in machine scalar of "
@@ -642,8 +653,9 @@ package body Sem_Ch13 is
end if;
Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
- Set_Normalized_Position (Comp, Pos + NFB / SSU);
+ Set_Esize (Comp, 1 + (NLB - NFB));
Set_Normalized_First_Bit (Comp, NFB mod SSU);
+ Set_Normalized_Position (Comp, Pos + NFB / SSU);
end;
end loop;
end loop;
@@ -6937,7 +6949,6 @@ package body Sem_Ch13 is
CC : Node_Id;
Comp : Entity_Id;
Fbit : Uint;
- Hbit : Uint := Uint_0;
Lbit : Uint;
Ocomp : Entity_Id;
Posit : Uint;
@@ -7263,6 +7274,9 @@ package body Sem_Ch13 is
Set_Normalized_First_Bit (Comp, Fbit mod SSU);
Set_Normalized_Position (Comp, Fbit / SSU);
+ Set_Normalized_Position_Max
+ (Comp, Normalized_Position (Comp));
+
if Warn_On_Overridden_Size
and then Has_Size_Clause (Etype (Comp))
and then RM_Size (Etype (Comp)) /= Esize (Comp)
@@ -7272,16 +7286,6 @@ package body Sem_Ch13 is
Component_Name (CC), Etype (Comp));
end if;
- -- This information is also set in the corresponding
- -- component of the base type, found by accessing the
- -- Original_Record_Component link if it is present.
-
- Ocomp := Original_Record_Component (Comp);
-
- if Hbit < Lbit then
- Hbit := Lbit;
- end if;
-
Check_Size
(Component_Name (CC),
Etype (Comp),
@@ -7291,12 +7295,18 @@ package body Sem_Ch13 is
Set_Biased
(Comp, First_Node (CC), "component clause", Biased);
- if Present (Ocomp) then
+ -- This information is also set in the corresponding
+ -- component of the base type, found by accessing the
+ -- Original_Record_Component link if it is present.
+
+ Ocomp := Original_Record_Component (Comp);
+
+ if Present (Ocomp) and then Ocomp /= Comp then
Set_Component_Clause (Ocomp, CC);
Set_Component_Bit_Offset (Ocomp, Fbit);
+ Set_Esize (Ocomp, 1 + (Lbit - Fbit));
Set_Normalized_First_Bit (Ocomp, Fbit mod SSU);
Set_Normalized_Position (Ocomp, Fbit / SSU);
- Set_Esize (Ocomp, 1 + (Lbit - Fbit));
Set_Normalized_Position_Max
(Ocomp, Normalized_Position (Ocomp));
@@ -10616,7 +10626,7 @@ package body Sem_Ch13 is
First_Bit => Make_Integer_Literal (Loc, Uint_0),
Last_Bit =>
Make_Integer_Literal (Loc,
- UI_From_Int (System_Address_Size))));
+ UI_From_Int (System_Address_Size - 1))));
Ccount := Ccount + 1;
end if;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index e304e72..b12f69b 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3522,6 +3522,8 @@ package body Sem_Ch3 is
Set_Etype (Id, Universal_Integer);
Set_Ekind (Id, E_Named_Integer);
Set_Is_Frozen (Id, True);
+
+ Set_Debug_Info_Needed (Id);
return;
end if;
@@ -13454,8 +13456,8 @@ package body Sem_Ch3 is
-- After expansion of discriminated task types, the value
-- of the discriminant may be converted to a run-time type
-- for restricted run-times. Propagate the value of the
- -- discriminant ss well, so that e.g. the secondary stack
- -- component has a static constraint. Necessry for LLVM.
+ -- discriminant as well, so that e.g. the secondary stack
+ -- component has a static constraint. Necessary for LLVM.
elsif Nkind (Expr) = N_Type_Conversion
and then Is_Discriminant (Expression (Expr))
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index eb6768d..5af3b7b 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4262,11 +4262,11 @@ package body Sem_Ch6 is
-- object can then be used instead of the formal in case it is used
-- in an actual to a call to a nested subprogram.
- -- This method is used to suppliment our "small integer model" for
- -- accessibility check generation (for more information see
+ -- This method is used to supplement our "small integer model" for
+ -- accessibility-check generation (for more information see
-- Dynamic_Accessibility_Level).
- -- Because we allow accesibility values greater than our expected value
+ -- Because we allow accessibility values greater than our expected value
-- passing along the same extra accessibility formal as an actual
-- to a nested subprogram becomes a problem because high values mean
-- different things to the callee even though they are the same to the
@@ -12038,7 +12038,7 @@ package body Sem_Ch6 is
-- predicate may come from an explicit aspect of be inherited.
elsif Has_Predicates (T) then
- Insert_List_Before_And_Analyze (Decl,
+ Insert_List_After_And_Analyze (Decl,
Freeze_Entity (Defining_Identifier (Decl), N));
end if;
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index db6bffd..313cb4e 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -1271,7 +1271,7 @@ package body Sem_Ch7 is
procedure Generate_Parent_References;
-- For a child unit, generate references to parent units, for
- -- GPS navigation purposes.
+ -- GNAT Studio navigation purposes.
function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
-- Child and Unit are entities of compilation units. True if Child
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 5d03f835..38cbf1c 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -4290,16 +4290,14 @@ package body Sem_Ch8 is
-- Common case for compilation unit
- elsif Defining_Entity (N => Parent (N),
- Empty_On_Errors => True) = Current_Scope
- then
+ elsif Defining_Entity (Parent (N)) = Current_Scope then
null;
else
-- If declaration appears in some other scope, it must be in some
-- parent unit when compiling a child.
- Pack := Defining_Entity (Parent (N), Empty_On_Errors => True);
+ Pack := Defining_Entity (Parent (N));
if not In_Open_Scopes (Pack) then
null;
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index 2dbf54d..0c71f59 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -9103,13 +9103,23 @@ package body Sem_Elab is
N_Procedure_Instantiation)
and then Nkind (Context) = N_Compilation_Unit
then
- return
- Related_Instance (Defining_Entity (N, Concurrent_Subunit => True));
+ return Related_Instance (Defining_Entity (N));
+
+ -- The unit denotes a concurrent body acting as a subunit. Such bodies
+ -- are generally rewritten into null statements. The proper entity is
+ -- that of the "original node".
+
+ elsif Nkind (N) = N_Subunit
+ and then Nkind (Proper_Body (N)) = N_Null_Statement
+ and then Nkind_In (Original_Node (Proper_Body (N)), N_Protected_Body,
+ N_Task_Body)
+ then
+ return Defining_Entity (Original_Node (Proper_Body (N)));
-- Otherwise the proper entity is the defining entity
else
- return Defining_Entity (N, Concurrent_Subunit => True);
+ return Defining_Entity (N);
end if;
end Find_Unit_Entity;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 5f7e6e5..7b36f8e 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -2429,8 +2429,7 @@ package body Sem_Prag is
-- Constant related checks
elsif Ekind (Item_Id) = E_Constant
- and then
- not Is_Access_Type (Underlying_Type (Etype (Item_Id)))
+ and then not Is_Access_Type (Etype (Item_Id))
then
-- Unless it is of an access type, a constant is a read-only
@@ -8195,15 +8194,16 @@ package body Sem_Prag is
Set_Convention_From_Pragma (E);
-- Treat a pragma Import as an implicit body, and pragma import
- -- as implicit reference (for navigation in GPS).
+ -- as implicit reference (for navigation in GNAT Studio).
if Prag_Id = Pragma_Import then
Generate_Reference (E, Id, 'b');
-- For exported entities we restrict the generation of references
-- to entities exported to foreign languages since entities
- -- exported to Ada do not provide further information to GPS and
- -- add undesired references to the output of the gnatxref tool.
+ -- exported to Ada do not provide further information to
+ -- GNAT Studio and add undesired references to the output of the
+ -- gnatxref tool.
elsif Prag_Id = Pragma_Export
and then Convention (E) /= Convention_Ada
@@ -13093,7 +13093,7 @@ package body Sem_Prag is
-- Infer the type to use for a string literal or a concatentation
-- of operands whose types can be inferred. For such expressions,
-- returns the "narrowest" of the three predefined string types
- -- that can represent the characters occuring in the expression.
+ -- that can represent the characters occurring in the expression.
-- For other expressions, returns Empty.
function Preferred_String_Type (Expr : Node_Id) return Entity_Id is
@@ -18816,6 +18816,15 @@ package body Sem_Prag is
Set_Has_Own_Invariants (Typ);
+ -- Set the Invariants_Ignored flag if that policy is in effect
+
+ Set_Invariants_Ignored (Typ,
+ Present (Check_Policy_List)
+ and then
+ (Policy_In_Effect (Name_Invariant) = Name_Ignore
+ and then
+ Policy_In_Effect (Name_Type_Invariant) = Name_Ignore));
+
-- If the invariant is class-wide, then it can be inherited by
-- derived or interface implementing types. The type is said to
-- have "inheritable" invariants.
@@ -32188,6 +32197,15 @@ package body Sem_Prag is
(New_Val => CTWE_Entry'(Eloc => Sloc (Arg1),
Scope => Current_Scope,
Prag => N));
+
+ -- If the Boolean expression contains T'Size, and we're not in the main
+ -- unit being compiled, then we need to copy the pragma into the main
+ -- unit, because otherwise T'Size might never be computed, leaving it
+ -- as 0.
+
+ if not In_Extended_Main_Code_Unit (N) then
+ Insert_Library_Level_Action (New_Copy_Tree (N));
+ end if;
end Defer_Compile_Time_Warning_Error_To_BE;
------------------------------------------
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 28d1352..4a50b09 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6845,7 +6845,7 @@ package body Sem_Res is
end if;
-- If this is a dispatching call, generate the appropriate reference,
- -- for better source navigation in GPS.
+ -- for better source navigation in GNAT Studio.
if Is_Overloadable (Nam)
and then Present (Controlling_Argument (N))
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 9569919..4de41d3e 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -5867,11 +5867,7 @@ package body Sem_Util is
-- Defining_Entity --
---------------------
- function Defining_Entity
- (N : Node_Id;
- Empty_On_Errors : Boolean := False;
- Concurrent_Subunit : Boolean := False) return Entity_Id
- is
+ function Defining_Entity (N : Node_Id) return Entity_Id is
begin
case Nkind (N) is
when N_Abstract_Subprogram_Declaration
@@ -5922,24 +5918,11 @@ package body Sem_Util is
=>
return Defining_Identifier (N);
- when N_Subunit =>
- declare
- Bod : constant Node_Id := Proper_Body (N);
- Orig_Bod : constant Node_Id := Original_Node (Bod);
-
- begin
- -- Retrieve the entity of the original protected or task body
- -- if requested by the caller.
+ when N_Compilation_Unit =>
+ return Defining_Entity (Unit (N));
- if Concurrent_Subunit
- and then Nkind (Bod) = N_Null_Statement
- and then Nkind_In (Orig_Bod, N_Protected_Body, N_Task_Body)
- then
- return Defining_Entity (Orig_Bod);
- else
- return Defining_Entity (Bod);
- end if;
- end;
+ when N_Subunit =>
+ return Defining_Entity (Proper_Body (N));
when N_Function_Instantiation
| N_Function_Specification
@@ -5965,14 +5948,10 @@ package body Sem_Util is
-- can continue semantic analysis.
elsif Nam = Error then
- if Empty_On_Errors then
- return Empty;
- else
- Err := Make_Temporary (Sloc (N), 'T');
- Set_Defining_Unit_Name (N, Err);
+ Err := Make_Temporary (Sloc (N), 'T');
+ Set_Defining_Unit_Name (N, Err);
- return Err;
- end if;
+ return Err;
-- If not an entity, get defining identifier
@@ -5987,11 +5966,7 @@ package body Sem_Util is
return Entity (Identifier (N));
when others =>
- if Empty_On_Errors then
- return Empty;
- else
- raise Program_Error;
- end if;
+ raise Program_Error;
end case;
end Defining_Entity;
@@ -6997,17 +6972,17 @@ package body Sem_Util is
elsif Ekind_In (Dyn_Scop, E_Block, E_Loop, E_Return_Statement) then
return Enclosing_Subprogram (Dyn_Scop);
- elsif Ekind (Dyn_Scop) = E_Entry then
+ elsif Ekind_In (Dyn_Scop, E_Entry, E_Entry_Family) then
- -- For a task entry, return the enclosing subprogram of the
- -- task itself.
+ -- For a task entry or entry family, return the enclosing subprogram
+ -- of the task itself.
if Ekind (Scope (Dyn_Scop)) = E_Task_Type then
return Enclosing_Subprogram (Dyn_Scop);
- -- A protected entry is rewritten as a protected procedure which is
- -- the desired enclosing subprogram. This is relevant when unnesting
- -- a procedure local to an entry body.
+ -- A protected entry or entry family is rewritten as a protected
+ -- procedure which is the desired enclosing subprogram. This is
+ -- relevant when unnesting a procedure local to an entry body.
else
return Protected_Body_Subprogram (Dyn_Scop);
@@ -9071,8 +9046,8 @@ package body Sem_Util is
-- components are being gathered for an aggregate, in which case
-- the caller must check Report_Errors.
--
- -- In Ada2020 the above rules are relaxed. A non-static governing
- -- discriminant is ok as long as it has a static subtype and
+ -- In Ada 2020 the above rules are relaxed. A nonstatic governing
+ -- discriminant is OK as long as it has a static subtype and
-- every value of that subtype (and there must be at least one)
-- selects the same variant.
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index b41b875..dc5e57b 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -554,10 +554,7 @@ package Sem_Util is
-- in the case of a descendant of a generic formal type (returns Int'Last
-- instead of 0).
- function Defining_Entity
- (N : Node_Id;
- Empty_On_Errors : Boolean := False;
- Concurrent_Subunit : Boolean := False) return Entity_Id;
+ function Defining_Entity (N : Node_Id) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- declaration has a specification, the entity is obtained from the
-- specification. If the declaration has a defining unit name, then the
@@ -568,22 +565,6 @@ package Sem_Util is
-- local entities declared during loop expansion. These entities need
-- debugging information, generated through Qualify_Entity_Names, and
-- the loop declaration must be placed in the table Name_Qualify_Units.
- --
- -- Set flag Empty_On_Error to change the behavior of this routine as
- -- follows:
- --
- -- * True - A declaration that lacks a defining entity returns Empty.
- -- A node that does not allow for a defining entity returns Empty.
- --
- -- * False - A declaration that lacks a defining entity is given a new
- -- internally generated entity which is subsequently returned. A node
- -- that does not allow for a defining entity raises Program_Error.
- --
- -- The former semantics is appropriate for the back end; the latter
- -- semantics is appropriate for the front end.
- --
- -- Set flag Concurrent_Subunit to handle rewritings of concurrent bodies
- -- which act as subunits. Such bodies are generally rewritten as null.
function Denotes_Discriminant
(N : Node_Id;
@@ -2991,7 +2972,7 @@ package Sem_Util is
function Choice_List_Intervals (Discrete_Choices : List_Id)
return Discrete_Interval_List;
-- Given a discrete choice list, returns the (unique) interval
- -- list representing the chosen values..
+ -- list representing the chosen values.
function Is_Subset (Subset, Of_Set : Discrete_Interval_List)
return Boolean;
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 8f85057..04e7acf 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -821,10 +821,10 @@ package body Sem_Warn is
function Generic_Body_Formal (E : Entity_Id) return Entity_Id;
-- Warnings on unused formals of subprograms are placed on the entity
-- in the subprogram body, which seems preferable because it suggests
- -- a better codefix for GPS. The analysis of generic subprogram bodies
- -- uses a different circuitry, so the choice for the proper placement
- -- of the warning in the generic case takes place here, by finding the
- -- body entity that corresponds to a formal in a spec.
+ -- a better codefix for GNAT Studio. The analysis of generic subprogram
+ -- bodies uses a different circuitry, so the choice for the proper
+ -- placement of the warning in the generic case takes place here, by
+ -- finding the body entity that corresponds to a formal in a spec.
procedure May_Need_Initialized_Actual (Ent : Entity_Id);
-- If an entity of a generic type has default initialization, then the
@@ -4546,9 +4546,15 @@ package body Sem_Warn is
-- to capture the value. We are not going to capture any value, but
-- the warning message depends on the same kind of conditions.
+ -- If the assignment appears as an out-parameter in a call within an
+ -- expression function it may be detected twice: once when expression
+ -- itself is analyzed, and once when the constructed body is analyzed.
+ -- We don't want to emit a spurious warning in this case.
+
if Is_Assignable (Ent)
and then not Is_Return_Object (Ent)
and then Present (Last_Assignment (Ent))
+ and then Last_Assignment (Ent) /= N
and then not Is_Imported (Ent)
and then not Is_Exported (Ent)
and then Safe_To_Capture_Value (N, Ent)
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index d24938c..2689ebe 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -7295,6 +7295,44 @@ package body Sinfo is
T = V11;
end Nkind_In;
+ function Nkind_In
+ (T : Node_Kind;
+ V1 : Node_Kind;
+ V2 : Node_Kind;
+ V3 : Node_Kind;
+ V4 : Node_Kind;
+ V5 : Node_Kind;
+ V6 : Node_Kind;
+ V7 : Node_Kind;
+ V8 : Node_Kind;
+ V9 : Node_Kind;
+ V10 : Node_Kind;
+ V11 : Node_Kind;
+ V12 : Node_Kind;
+ V13 : Node_Kind;
+ V14 : Node_Kind;
+ V15 : Node_Kind;
+ V16 : Node_Kind) return Boolean
+ is
+ begin
+ return T = V1 or else
+ T = V2 or else
+ T = V3 or else
+ T = V4 or else
+ T = V5 or else
+ T = V6 or else
+ T = V7 or else
+ T = V8 or else
+ T = V9 or else
+ T = V10 or else
+ T = V11 or else
+ T = V12 or else
+ T = V13 or else
+ T = V14 or else
+ T = V15 or else
+ T = V16;
+ end Nkind_In;
+
--------------------------
-- Pragma_Name_Unmapped --
--------------------------
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index dc82800..5a92066 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -11574,6 +11574,27 @@ package Sinfo is
V10 : Node_Kind;
V11 : Node_Kind) return Boolean;
+ -- 12..15-parameter versions are not yet needed
+
+ function Nkind_In
+ (T : Node_Kind;
+ V1 : Node_Kind;
+ V2 : Node_Kind;
+ V3 : Node_Kind;
+ V4 : Node_Kind;
+ V5 : Node_Kind;
+ V6 : Node_Kind;
+ V7 : Node_Kind;
+ V8 : Node_Kind;
+ V9 : Node_Kind;
+ V10 : Node_Kind;
+ V11 : Node_Kind;
+ V12 : Node_Kind;
+ V13 : Node_Kind;
+ V14 : Node_Kind;
+ V15 : Node_Kind;
+ V16 : Node_Kind) return Boolean;
+
pragma Inline (Nkind_In);
-- Inline all above functions
diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c
index 0ce3fb7..af4417f 100644
--- a/gcc/ada/terminals.c
+++ b/gcc/ada/terminals.c
@@ -170,7 +170,7 @@ struct TTY_Process {
BOOL usePipe;
};
-/* Control whether create_child cause the process to inherit GPS'
+/* Control whether create_child cause the process to inherit GNAT Studio'
error mode setting. The default is 1, to minimize the possibility of
subprocesses blocking when accessing unmounted drives. */
static int Vw32_start_process_inherit_error_mode = 1;
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index 959b990..55ecbdb 100644
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -242,6 +242,14 @@ package body Treepr is
function par (N : Union_Id) return Node_Or_Entity_Id renames p;
+ procedure ppar (N : Union_Id) is
+ begin
+ if N /= Empty_List_Or_Node then
+ pp (N);
+ ppar (Union_Id (p (N)));
+ end if;
+ end ppar;
+
--------
-- pe --
--------
diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads
index a299250..a63329b 100644
--- a/gcc/ada/treepr.ads
+++ b/gcc/ada/treepr.ads
@@ -82,6 +82,10 @@ package Treepr is
-- the definition of Union_Id. Historically this was only for printing
-- nodes, hence the name.
+ procedure ppar (N : Union_Id);
+ pragma Export (Ada, ppar);
+ -- Print the node, its parent, its parent's parent, and so on
+
procedure pt (N : Union_Id);
procedure ppp (N : Union_Id);
pragma Export (Ada, pt);