diff options
| author | Ian Lance Taylor <ian@gcc.gnu.org> | 2019-07-03 23:13:09 +0000 |
|---|---|---|
| committer | Ian Lance Taylor <ian@gcc.gnu.org> | 2019-07-03 23:13:09 +0000 |
| commit | 0baa9d1d59bf17177e80838ebe66df10a7a909c0 (patch) | |
| tree | a1b956eacf43ba6ac1d052faad8a2df8f4f6ef5a /gcc/ada | |
| parent | 133d3bd8362f0c438017ca18adb51afb7288f78b (diff) | |
| parent | 651c754cfbd1928abd8ac6b3121fc37c85907dcb (diff) | |
| download | gcc-0baa9d1d59bf17177e80838ebe66df10a7a909c0.zip gcc-0baa9d1d59bf17177e80838ebe66df10a7a909c0.tar.gz gcc-0baa9d1d59bf17177e80838ebe66df10a7a909c0.tar.bz2 | |
Merge from trunk revision 273026.
From-SVN: r273027
Diffstat (limited to 'gcc/ada')
115 files changed, 33497 insertions, 12257 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9116b92..c28a942 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,819 @@ +2019-07-03 Bob Duff <duff@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Document new flags in + GNATpp. + +2019-07-03 Hristian Kirtchev <kirtchev@adacore.com> + + * binde.adb: Remove with clause for System.OS_Lib. + (Force_Elab_Order): Refactor the majority of the code in Butil. + Use the new forced units iterator to obtain unit names. + * bindo-builders.adb: Add with and use clauses for Binderr, + Butil, Opt, Output, Types, GNAT, and GNAT.Dynamic_HTables. Add + a hash table which maps units to line number in the forced + elaboration order file. + (Add_Unit): New routine. + (Build_Library_Graph): Create forced edges between pairs of + units listed in the forced elaboration order file. + (Create_Forced_Edge, Create_Forced_Edges, Destroy_Line_Number, + Duplicate_Unit_Error, Hash_Unit, Internal_Unit_Info, + Is_Duplicate_Unit, Missing_Unit_Info): New routines. + * bindo-graphs.adb (Is_Internal_Unit, Is_Predefined_Unit): + Refactor some of the behavior to Bindo-Units. + * bindo-graphs.ads: Enable the enumeration literal for forced + edges. + * bindo-units.adb, bindo-units.ads (Is_Internal_Unit, + Is_Predefined_Unit): New routines. + * butil.adb: Add with and use clauses for Opt, GNAT, and + System.OS_Lib. Add with clause for Unchecked_Deallocation. + (Has_Next, Iterate_Forced_Units, Next, Parse_Next_Unit_Name, + Read_Forced_Elab_Order_File): New routines. + * butil.ads: Add with and use clauses for Types. Add new + iterator over the units listed in the forced elaboration order + file. + (Has_Next, Iterate_Forced_Units, Next): New routine. + * namet.adb, namet.ads (Present): New routine. + +2019-07-03 Bob Duff <duff@adacore.com> + + * sem_ch3.adb (Access_Definition): The code was creating a + master in the case where the designated type is a class-wide + interface type. Create a master in the noninterface case as + well. That is, create a master for all limited class-wide types. + +2019-07-03 Yannick Moy <moy@adacore.com> + + * erroutc.adb (Sloc_In_Range): New function to determine whether + the range of a pragma Warnings covers a location, taking + instantiations into account. + +2019-07-03 Johannes Kanig <kanig@adacore.com> + + * osint.ads, osint.adb (Get_First_Main_File_Name): New routine + to access the first file provided on the command line. + +2019-07-03 Ed Schonberg <schonberg@adacore.com> + + * inline.adb (Process_Formals_In_Aspects): New procedure within + Expand_Inlined_Call, to perform a replacement of references to + formals that appear in aspect specifications within the body + being inlined. + +2019-07-03 Justin Squirek <squirek@adacore.com> + + * sem_ch8.adb (Analyze_Object_Renaming): Add call to search for + the appropriate actual subtype of the object renaming being + analyzed. + (Check_Constrained_Object): Minor cleanup. + +2019-07-03 Yannick Moy <moy@adacore.com> + + * sem_spark.adb (Get_Observed_Or_Borrowed_Expr): New function to + return go through traversal function call. + (Check_Type): Consistently use underlying type. + (Get_Perm): Adapt for case of elaboration code where variables + are not declared in the environment. Remove incorrect handling + of borrow and observe. + +2019-07-03 Hristian Kirtchev <kirtchev@adacore.com> + + * inline.adb (Build_Return_Object_Formal): New routine. + (Can_Split_Unconstrained_Function): Code clean up. + (Copy_Formals,Copy_Return_Object): New routines. + (Split_Unconstrained_Function): Code clean up and refactoring. + +2019-07-03 Gary Dismukes <dismukes@adacore.com> + + * bindo-augmentors.adb, bindo-augmentors.ads, + bindo-builders.ads, bindo-elaborators.adb, sem_ch12.adb, + sem_ch13.adb, sem_spark.adb, sinfo.ads: Minor editorial + corrections and reformatting. + +2019-07-03 Bob Duff <duff@adacore.com> + + * sem_warn.adb (Check_Infinite_Loop_Warning): Avoid the warning + if an Iterator_Specification is present. + +2019-07-03 Bob Duff <duff@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Document default + new-line behavior. + +2019-07-03 Hristian Kirtchev <kirtchev@adacore.com> + + * ali.adb: Add with and use clauses for GNAT, + GNAT.Dynamic_HTables, and Snames. Add a map from invocation + signature records to invocation signature ids. Add various + encodings of invocation-related attributes. Sort and update + table Known_ALI_Lines. + (Add_Invocation_Construct, Add_Invocation_Relation, + Body_Placement_Kind_To_Code, Code_To_Body_Placement_Kind, + Code_To_Invocation_Construct_Kind, Code_To_Invocation_Kind, + Code_To_Invocation_Graph_Line_Kind, Destroy, Hash): New + routines. + (Initialize_ALI): Sort the initialization sequence. Add + initialization for all invocation-related tables. + (Invocation_Construct_Kind_To_Code, + Invocation_Graph_Line_Kind_To_Code, Invocation_Kind_To_Code, + Invocation_Signature_Of, Present): New routines. + (Scan_ALI): Add the default values for invocation-related ids. + Scan invocation graph lines. + (Scan_Invocation_Graph_Line): New routine. + * ali.ads: Add with clause for GNAT.Dynamic_Tables. Add types + for invocation constructs, relations, and signatures. Add + tables for invocation constructs, relations, and signatures. + Update Unit_Record to capture invocation-related ids. Relocate + table Unit_Id_Tables and subtypes Unit_Id_Table, Unit_Id_Array + from Binde. + (Add_Invocation_Construct, Add_Invocation_Relation, + Body_Placement_Kind_To_Code, Code_To_Body_Placement_Kind, + Code_To_Invocation_Construct_Kind, Code_To_Invocation_Kind, + Code_To_Invocation_Graph_Line_Kind, + Invocation_Construct_Kind_To_Code, + Invocation_Graph_Line_Kind_To_Code, Invocation_Kind_To_Code, + Invocation_Signature_Of, Present): New routines. + * binde.adb: Add with and use clause for Types. Add use clause + for ALI.Unit_Id_Tables; + * binde.ads: Relocate table Unit_Id_Tables and subtypes + Unit_Id_Table, Unit_Id_Array to ALI. + * bindgen.adb: Remove with and use clause for ALI. + * bindgen.ads: Remove with and use clause for Binde. Add with + and use clause for ALI. + * bindo.adb, bindo.ads, bindo-augmentors.adb, + bindo-augmentors.ads, bindo-builders.adb, bindo-builders.ads, + bindo-diagnostics.adb, bindo-diagnostics.ads, + bindo-elaborators.adb, bindo-elaborators.ads, bindo-graphs.adb, + bindo-graphs.ads, bindo-units.adb, bindo-units.ads, + bindo-validators.adb, bindo-validators.ads, bindo-writers.adb, + bindo-writers.ads: New units. + * debug.adb: Use and describe GNAT debug switches -gnatd_F and + -gnatd_G. Add GNATbind debug switches in the ranges dA .. dZ, + d.a .. d.z, d.A .. d.Z, d.1 .. d.9, d_a .. d_z, d_A .. d_Z, and + d_1 .. d_9. Use and describe GNATbind debug switches -d_A, + -d_I, -d_L, -d_N, -d_O, -d_T, and -d_V. + * exp_util.adb, exp_util.ads (Exceptions_OK): Relocate to + Sem_Util. + * gnatbind.adb: Add with and use clause for Bindo. Use the new + Bindo elaboration order only when -d_N is in effect. + * lib-writ.adb + (Column, Extra, Invoker, Kind, Line, Locations, Name, Placement, + Scope, Signature, Target): New routines. + (Write_ALI): Output all invocation-related data. + (Write_Invocation_Graph): New routine. + * lib-writ.ads: Document the invocation graph ALI line. + * namet.adb, namet.ads (Present): New routines. + * sem_ch8.adb (Find_Direct_Name): Capture the status of + elaboration checks and warnings of an identifier. + (Find_Expanded_Name): Capture the status of elaboration checks + and warnings of an expanded name. + * sem_ch12.adb (Analyze_Generic_Package_Declaration): Ensure + that invocation graph-related data within the body of the main + unit is encoded in the ALI file. + (Analyze_Generic_Subprogram_Declaration): Ensure that invocation + graph-related data within the body of the main unit is encoded + in the ALI file. + (Analyze_Package_Instantiation): Perform minimal decoration of + the instance entity. + (Analyze_Subprogram_Instantiation): Perform minimal decoration + of the instance entity. + * sem_elab.adb: Perform heavy refactoring of all code. The unit + is now split into "services" which specialize in one area of ABE + checks. Add processing in order to capture invocation-graph + related attributes of the main unit, and encode them in the ALI + file. The Processing phase can now operate in multiple modes, + all described by type Processing_Kind. Scenarios and targets + are now distinct at the higher level, and carry their own + representations. This eliminates the need to constantly + recompute their attributes, and offers the various processors a + uniform interface. The various initial states of the Processing + phase are now encoded using type Processing_In_State, and + xxx_State constants. + * sem_elab.ads: Update the literals of type + Enclosing_Level_Kind. Add Inline pragmas on several routines. + * sem_prag.adb (Process_Inline): Ensure that invocation + graph-related data within the body of the main unit is encoded + in the ALI file. + * sem_util.adb (Enclosing_Generic_Body, Enclosing_Generic_Unit): + Code clean up. + (Exceptions_OK): Relocated from Sem_Util. + (Mark_Save_Invocation_Graph_Of_Body): New routine. + * sem_util.ads (Exceptions_OK): Relocated from Sem_Util. + (Mark_Save_Invocation_Graph_Of_Body): New routine. + * sinfo.adb (Is_Elaboration_Checks_OK_Node): Now applicable to + N_Variable_Reference_Marker. + (Is_Elaboration_Warnings_OK_Node): Now applicable to + N_Expanded_Name, N_Identifier, N_Variable_Reference_Marker. + (Is_Read): Use Flag4. + (Is_SPARK_Mode_On_Node): New applicable to + N_Variable_Reference_Marker. + (Is_Write): Use Flag5. + (Save_Invocation_Graph_Of_Body): New routine. + (Set_Is_Elaboration_Checks_OK_Node): Now applicable to + N_Variable_Reference_Marker. + (Set_Is_Elaboration_Warnings_OK_Node): Now applicable to + N_Expanded_Name, N_Identifier, N_Variable_Reference_Marker. + (Set_Is_SPARK_Mode_On_Node): New applicable to + N_Variable_Reference_Marker. + (Set_Save_Invocation_Graph_Of_Body): New routine. + * sinfo.ads: Update the documentation of attributes + Is_Elaboration_Checks_OK_Node, Is_Elaboration_Warnings_OK_Node, + Is_SPARK_Mode_On_Node. Update the flag usage of attributes + Is_Read, Is_Write. Add attribute Save_Invocation_Graph_Of_Body + and update its occurrence in nodes. + (Save_Invocation_Graph_Of_Body): New routine along with pragma + Inline. + (Set_Save_Invocation_Graph_Of_Body): New routine along with + pragma Inline. + * switch-b.adb (Scan_Binder_Switches): Refactor the scanning of + debug switches. + (Scan_Debug_Switches): New routine. + * libgnat/g-dynhta.adb, libgnat/g-dynhta.ads (Contains): New routine. + * libgnat/g-graphs.adb (Associate_Vertices): Update the use of + Component_Vertex_Iterator. + (Contains_Component, Contains_Edge, Contains_Vertex, Has_Next): + Reimplemented. + (Iterate_Component_Vertices): New routine. + (Iterate_Vertices): Removed. + (Next): Update the parameter profile. + (Number_Of_Component_Vertices, Number_Of_Outgoing_Edges): New + routines. + * libgnat/g-graphs.ads: Update the initialization of + No_Component. Add type Component_Vertex_Iterator. Remove type + Vertex_Iterator. + (Has_Next): Add new versions and remove old ones. + (Iterate_Component_Vertices): New routine. + (Iterate_Vertices): Removed. + (Next): Add new versions and remove old ones. + (Number_Of_Component_Vertices, Number_Of_Outgoing_Edges): New + routines. + * libgnat/g-sets.adb (Contains): Reimplemented. + * gcc-interface/Make-lang.in (GNATBIND_OBJS): Add + GNAT.Dynamic_HTables, GNAT.Graphs and Bindo units. + * rtsfind.ads: Remove extra space. + +2019-07-03 Yannick Moy <moy@adacore.com> + + * sem_spark.adb: Add support for locally borrowing and observing + a path. + (Get_Root_Object): Add parameter Through_Traversal to denote + when we are interesting in getting to the traversed parameter. + (Is_Prefix_Or_Almost): New function to support detection of + illegal access to borrowed or observed paths. + (Check_Pragma): Add analysis of assertion pragmas. + +2019-07-03 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functions): In a generic context + we do not build the bodies of predicate fuctions, but the + expression in a static predicate must be elaborated to allow + case coverage checking within the generic unit. + (Build_Discrete_Static_Predicate): In a generic context, return + without building function body once the + Static_Discrete_Predicate expression for the type has been + constructed. + +2019-07-03 Hristian Kirtchev <kirtchev@adacore.com> + + * bindgen.adb, inline.adb, layout.adb, sem_ch12.adb, + sem_ch13.adb, sem_ch7.adb, styleg.adb: Minor reformatting. + +2019-07-03 Bob Duff <duff@adacore.com> + + * par-ch3.adb (P_Defining_Identifier): Call + Check_Defining_Identifier_Casing. + * style.ads, styleg.ads, styleg.adb + (Check_Defining_Identifier_Casing): New procedure to check for + mixed-case defining identifiers. + * stylesw.ads, stylesw.adb (Style_Check_Mixed_Case_Decls): New + flag for checking for mixed-case defining identifiers. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Document new feature. + * gnat_ugn.texi: Regenerate. + +2019-07-03 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst + (Warning message control): Document that -gnatw.z/Z apply to + array types. + * freeze.adb (Freeze_Entity): Give -gnatw.z warning for array + types as well, but not if the specified alignment is the minimum + one. + * gnat_ugn.texi: Regenerate. + +2019-07-03 Bob Duff <duff@adacore.com> + + * einfo.ads, exp_util.adb, layout.ads, sinfo.ads: Spell "laid" + correctly. + +2019-07-03 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): No error + message on attribute applied to a renaming when the renamed + object is an aggregate (from code reading). + (Check_Aspect_At_End_Of_Declarations): In a generic context + where freeze nodes are not generated, the original expression + for an aspect may need to be analyzed to precent spurious + conformance errors when compared with the expression that is + anakyzed at the end of the current declarative list. + +2019-07-03 Eric Botcazou <ebotcazou@adacore.com> + + * layout.adb (Layout_Type): Do not set the component size of an + array with a scalar component if the component type is + overaligned. + +2019-07-03 Ed Schonberg <schonberg@adacore.com> + + * inline.adb (Make_Loop_Labels_Unique): New procedure to modify + the source code of subprograms that are inlined by the + front-end, to prevent accidental duplication between loop labels + in the inlined code and the code surrounding the inlined call. + +2019-07-03 Hristian Kirtchev <kirtchev@adacore.com> + + * doc/gnat_ugn/elaboration_order_handling_in_gnat.rst: Update + the section on resolving elaboration circularities to eliminate + certain combinations of switches which together do not produce + the desired effect and confuse users. + * gnat_ugn.texi: Regenerate. + +2019-07-03 Arnaud Charlet <charlet@adacore.com> + + * bindgen.adb (Gen_Main): Disable generation of reference to + Ada_Main_Program_Name for CCG. + * bindusg.adb (Display): Add -G to the command-line usage for + gnatbind. + * opt.ads (Generate_C_Code): Update comment. + * switch-b.adb (Scan_Binder_Switches): Add handling for -G. + +2019-07-03 Arnaud Charlet <charlet@adacore.com> + + * sem_ch7.adb (Has_Referencer): Do not consider inlined + subprograms when generating C code, which allows us to generate + static inline subprograms. + +2019-07-03 Justin Squirek <squirek@adacore.com> + + * sem_ch6.adb (Check_Conformance): Add expression checking for + constant modifiers in anonymous access types (in addition to + "non-null" types) so that they are considered "matching" for + subsequent conformance tests. + +2019-07-03 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst: + Clarify wording on No_Multiple_Elaboration. + * gnat_rm.texi: Regenerate. + +2019-07-03 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Find_Selected_Component): If the prefix is the + current instance of a type or subtype, complete the resolution + of the name by finding the component of the type denoted by the + selector name. + +2019-07-03 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/interfacing_to_other_languages.rst (Interfacing to C): + Document that boolean types with convention C now map to C99 bool. + * gnat_rm.texi: Regenerate. + +2019-07-03 Javier Miranda <miranda@adacore.com> + + * exp_attr.adb (Expand_Min_Max_Attribute): Code cleanup: + removing code that it is now never executed in the CCG compiler + (dead code). + +2019-07-02 Iain Sandoe <iain@sandoe.co.uk> + + * libgnat/system-darwin-ppc.ads: Set Stack_Check_Probes True for + PPC Darwin. + +2019-07-01 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Is_Defaulted): New predicate in + Check_Formal_Package_Intance, to skip the conformance of checks + on parameters of a formal package that are defaulted, + +2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb, exp_ch9.adb, exp_unst.adb, sem_ch4.adb, + sem_prag.adb, sem_spark.adb: Minor reformatting. + +2019-07-01 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Analyze_Attribute, case Enum_Rep): Allow prefix + of attribute to be an attribute reference of a discrete type. + +2019-07-01 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch12.adb (Analyze_Subprogram_Instantiation): Move up + handling of Has_Pragma_Inline_Always and deal with + Has_Pragma_No_Inline. + +2019-07-01 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Build_Derived_Record_Type): If the parent type is + declared as a subtype of a private type with an inherited + discriminant constraint, its generated full base appears as a + record subtype, so we need to retrieve its oen base type so that + the inherited constraint can be applied to it. + +2019-07-01 Yannick Moy <moy@adacore.com> + + * sem_spark.adb: Completely rework the algorithm for ownership + checking, as the rules in SPARK RM have changed a lot. + * sem_spark.ads: Update comments. + +2019-07-01 Dmitriy Anisimkov <anisimko@adacore.com> + + * gsocket.h (Has_Sockaddr_Len): Use the offset of sin_family offset in + the sockaddr_in structure to determine the existence of length field + before the sin_family. + +2019-07-01 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Analyze_Pragma, case Weak_External): Pragma only + applies to entities with run-time addresses, not to types. + +2019-07-01 Piotr Trojanek <trojanek@adacore.com> + + * einfo.adb, sem_ch7.adb, sem_prag.adb, sem_util.adb: Update + references to the SPARK RM after the removal of Rule 7.1.4(5). + +2019-07-01 Piotr Trojanek <trojanek@adacore.com> + + * sysdep.c: Cleanup references to LynuxWorks in docs and + comments. + +2019-07-01 Ed Schonberg <schonberg@adacore.com> + + * checks.adb (Insert_Valid_Check): Do not apply validity check + to variable declared within a protected object that uses the + Lock_Free implementation, to prevent unwarranted constant + folding, because entities within such an object msut be treated + as volatile. + +2019-07-01 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch9.adb (Check_Inlining): Deal with Has_Pragma_No_Inline. + +2019-07-01 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb (Visit_Node, Check_Static_Type): Improve the + handling of private and incomplete types whose full view is an + access type, to detect additional uplevel references in dynamic + bounds. This is relevant to N_Free_Statement among others that + manipulate types whose full viww may be an access type. + +2019-07-01 Pat Rogers <rogers@adacore.com> + + * doc/gnat_rm/representation_clauses_and_pragmas.rst: Correct + size indicated for R as a component of an array. + * gnat_rm.texi: Regenerate. + +2019-07-01 Justin Squirek <squirek@adacore.com> + + * libgnat/s-win32.ads: Add definition for ULONG, modify + OVERLAPPED type, and add appropriate pragmas. + +2019-07-01 Bob Duff <duff@adacore.com> + + * gnat1drv.adb (gnat1drv): Call Write_ALI if the main unit is + ignored-ghost. + +2019-07-01 Yannick Moy <moy@adacore.com> + + * sem_ch4.adb (Operator_Check): Refine error message. + +2019-07-01 Piotr Trojanek <trojanek@adacore.com> + + * libgnat/a-calend.ads: Revert "Global => null" contracts on + non-pure routines. + +2019-07-01 Piotr Trojanek <trojanek@adacore.com> + + * exp_attr.adb, libgnat/g-graphs.ads: Fix typos in comments: + componant -> component. + +2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> + + * libgnat/g-graphs.adb: Use type Directed_Graph rather than + Instance in various routines. + * libgnat/g-graphs.ads: Change type Instance to Directed_Graph. + Update various routines that mention the type. + +2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> + + * libgnat/g-sets.adb: Use type Membership_Set rathern than + Instance in various routines. + * libgnat/g-sets.ads: Change type Instance to Membership_Set. + Update various routines that mention the type. + +2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> + + * libgnat/g-lists.adb: Use type Doubly_Linked_List rather than + Instance in various routines. + * libgnat/g-lists.ads: Change type Instance to + Doubly_Linked_List. Update various routines that mention the + type. + +2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> + + * libgnat/g-dynhta.adb: Use type Dynamic_Hash_Table rather than + Instance in various routines. + * libgnat/g-dynhta.ads: Change type Instance to + Dynamic_Hash_Table. Update various routines that mention the + type. + +2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb, exp_ch7.adb, exp_unst.adb, sem_ch3.adb, + sem_util.adb, uintp.adb, uintp.ads: Minor reformatting. + +2019-07-01 Javier Miranda <miranda@adacore.com> + + * exp_attr.adb (Expand_Min_Max_Attribute): Disable expansion of + 'Min/'Max on integer, enumeration, fixed point and floating + point types since the CCG backend now provides in file + standard.h routines to support it. + +2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> + + * impunit.adb: Add GNAT.Graphs to list Non_Imp_File_Names_95. + * Makefile.rtl, gcc-interface/Make-lang.in: Register unit + GNAT.Graphs. + * libgnat/g-dynhta.adb: Various minor cleanups (use Present + rather than direct comparisons). + (Delete): Reimplement to use Delete_Node. + (Delete_Node): New routine. + (Destroy_Bucket): Invoke the provided destructor. + (Present): New routines. + * libgnat/g-dynhta.ads: Add new generic formal Destroy_Value. + Use better names for the components of iterators. + * libgnat/g-graphs.adb, libgnat/g-graphs.ads: New unit. + * libgnat/g-lists.adb: Various minor cleanups (use Present + rather than direct comparisons). + (Delete_Node): Invoke the provided destructor. + (Present): New routine. + * libgnat/g-lists.ads: Add new generic formal Destroy_Element. + Use better names for the components of iterators. + (Present): New routine. + * libgnat/g-sets.adb, libgnat/g-sets.ads (Destroy, Preset, + Reset): New routines. + +2019-07-01 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/g-sothco.adb (Get_Address): Fix the case when AF_INET6 + is not defined. + +2019-07-01 Ed Schonberg <schonberg@adacore.com> + + * exp_attr.adb (Expand_Attribute_Reference, case Invalid_Value): + Resolve result of call to Get_Simple_Init_Val, which may be a + conversion of a literal. + +2019-07-01 Hristian Kirtchev <kirtchev@adacore.com> + + * freeze.adb (Freeze_Expression): Remove the horrible useless + name hiding of N. Insert the freeze nodes generated by the + expression prior to the expression when the nearest enclosing + scope is transient. + +2019-07-01 Pierre-Marie de Rodat <derodat@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Fix + formatting issues in the -gnatR section. + * gnat_ugn.texi: Regenerate. + +2019-06-30 Iain Sandoe <iain@sandoe.co.uk> + + * gnatlink.adb (Link_Step): Remove duplicate -static-libgcc switches. + Push -shared-libgcc explicitly, when it is the target default (unless + overidden by the static flag). + When the user has put an instance of shared/static-libgcc do not push + a duplicate of this. + +2019-06-29 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity): Beep up comment on SAVED, + and tweak comment on the assertion about the scopes of Itypes. Do not + skip the regular processing for Itypes that are E_Record_Subtype with + a Cloned_Subtype. Get the Cloned_Subtype for every E_Record_Subtype + if the type is dummy and hasn't got its own freeze node. + <E_Record_Subtype>: Save again the DECL of the Cloned_Subtype, if any. + <E_Access_Subtype>: Save again the DECL of the equivalent type. + (Gigi_Equivalent_Type) <E_Access_Subtype>: New case. + +2019-06-29 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (unchecked_convert): Tweak comment. Only skip + dereferences when padding to have the same size on both sides. Do it + for destination types with self-referential size too. + +2019-06-29 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: If the + type requires strict alignment, then set the RM size to the type size. + Rework handling of alignment and sizes of tagged types in ASIS mode. + (validate_size): Rename local variable and remove special handling for + strict-alignment types. + * gcc-interface/utils.c (finish_record_type): Constify local variables + and use properly typed constants. + +2019-06-29 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_field): Rework error messages for + fields requiring strict alignment, add explicit test on Storage_Unit + for position and size, and mention type alignment for position. + +2019-06-29 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (mark_visited_r): Set TYPE_SIZES_GIMPLIFIED on + the main variant of a type, if any. + +2019-06-29 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (set_nonaliased_component_on_array_type): Add + missing guard for the presence of TYPE_CANONICAL. + (set_reverse_storage_order_on_array_type): Likewise. + +2019-06-29 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/gigi.h (make_packable_type): Remove default value. + (value_factor_p): Tweak prototype. + * gcc-interface/decl.c (gnat_to_gnu_entity): Add comment. + (gnat_to_gnu_component_type): Likewise. + (gnat_to_gnu_field): Likewise. Fetch the position of the field earlier + and simplify the condition under which the type is packed. Declare + local variable is_bitfield. Pass 1 as max_align to make_packable_type + if it is set to true. + (copy_and_substitute_in_layout): Pass 0 to make_packable_type. + * gcc-interface/utils.c (make_packable_array_type): New function. + (make_packable_type): Use it to rewrite the type of array field. + (maybe_pad_type): Pass align parameter to make_packable_type. + (create_field_decl): Minor tweaks. + (value_factor_p): Assert that FACTOR is a power of 2 and replace the + modulo computation by a masking operation. + +2019-06-25 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity): Remove superfluous test + in previous change. + * gcc-interface/gigi.h (maybe_character_type): Fix formatting. + (maybe_character_value): Likewise. + +2019-06-24 Jan Hubicka <jh@suse.cz> + + * gcc-interface/decl.c (gnat_to_gnu_entity): Check that + type is array or integer prior checking string flag. + * gcc-interface/gigi.h (maybe_character_type): Likewise. + (maybe_character_value): Likewise. + +2019-06-24 Martin Sebor <msebor@redhat.com> + + * gcc-interface/utils.c (handle_nonnull_attribute): Quote attribute + name. + +2019-06-18 Arnaud Charlet <charlet@adacore.com> + + PR ada/80590 + * sem_ch5.adb (Analyze_Loop_Statement): Avoid exception propagation + during normal processing. + +2019-06-17 Arnaud Charlet <charlet@adacore.com> + + PR ada/80590 + * exp_ch9.adb (Expand_N_Delay_Relative_Statement): Swap the two + conditions to avoid a unnecessary exception propagation in the default + case. + +2019-05-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (handle_stack_protect_attribute): Move around. + +2019-05-28 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst (Machine_Attribute): + Document additional optional parameters. + * sem_prag.adb (Analyze_Pragma) <Pragma_Machine_Attribute>: Accept + more than one optional parameter. + * gcc-interface/decl.c (prepend_one_attribute_pragma): Alphabetize + the list of supported pragmas. Simplify the handling of parameters + and add support for more than one optional parameter. + * gcc-interface/utils.c (attr_cold_hot_exclusions): New constant. + (gnat_internal_attribute_table): Add entry for no_icf, noipa, flatten, + used, cold, hot, target and target_clones. + (begin_subprog_body): Do not create the RTL for the subprogram here. + (handle_noicf_attribute): New static function. + (handle_noipa_attribute): Likewise. + (handle_flatten_attribute): Likewise. + (handle_used_attribute): Likewise. + (handle_cold_attribute): Likewise. + (handle_hot_attribute): Likewise. + (handle_target_attribute): Likewise. + (handle_target_clones_attribute): Likewise. + +2019-05-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (lvalue_required_for_attribute_p): Return 0 + for 'Size too. + (Identifier_to_gnu): Use the actual subtype for a reference to a + packed array in a return statement. + (Attribute_to_gnu) <Attr_Size>: Do not strip VIEW_CONVERT_EXPRs from + the prefix in every case. + +2019-05-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (gnat_to_gnu): Remove superfluous tests on + Backend_Overflow_Checks_On_Target and rework comments. + +2019-05-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (walk_nesting_tree): New static function. + (finalize_nrv): Use it to walk the entire nesting tree. + +2019-05-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: Remove + obsolete test on Is_For_Access_Subtype. + +2019-05-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (components_to_record): Set a name on the type + created for the REP part, if any. + * gcc-interface/utils.c (finish_record_type): Only take the maximum + when merging sizes for a variant part at offset 0. + (merge_sizes): Rename has_rep parameter into max. + +2019-05-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (gnat_internal_attribute_table): Add support + for stack_protect attribute. + (handle_stack_protect_attribute): New static function. + +2019-05-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (intrin_arglists_compatible_p): Do not return + false if the internal builtin uses a variable list. + +2019-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Call_to_gnu): Do not initialize the temporary + created out of addressability concerns if it's for the _Init parameter + of an initialization procedure. + +2019-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/ada-builtin-types.def: New file. + * gcc-interface/ada-builtins.def: Likewise. + * gcc-interface/ada-tree.h (BUILT_IN_LIKELY): New macro. + (BUILT_IN_UNLIKELY): Likewise. + * gcc-interface/trans.c (independent_iterations_p): Initialize the + auto-vector to 16 elements. + (Call_to_gnu): Remove local variable and change the vector of actual + parameters to an auto-vector. Do not convert actual parameters to + the argument type for front-end built-in functions. Add support for + front-end built-in functions. + (build_noreturn_cond): Use internal instead of built-in function. + * gcc-interface/utils.c (c_builtin_type): Include ada-builtin-types.def + (install_builtin_function_types): Likewise. + (install_builtin_functions): Include ada-builtins.def first. + +2019-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (maybe_pad_type): Issue the warning for the + specific case of component types preferably. + +2019-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Identifier_to_gnu): Minor tweaks. + (gnat_to_gnu): Do not convert the result if it is a reference to an + unconstrained array used as the prefix of an attribute reference that + requires an lvalue. + +2019-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Gigi_Types_Compatible): New predicate. + (Identifier_to_gnu): Use it to assert that the type of the identifier + and that of its entity are compatible for gigi. Rename a couple of + local variables and separate the processing of the result type. + +2019-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Call_to_gnu): Use the unpadded type when + putting back an intermediate conversion the type of the actuals. + +2019-05-27 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (gnat_to_gnu) <Shift operations>: Convert the + count to the unsigned version of its base type before proceeding. + +2019-05-16 Martin Sebor <msebor@redhat.com> + + * gcc-interface/trans.c (check_inlining_for_nested_subprog): Quote + reserved names. + 2019-05-08 Arnaud Charlet <charlet@adacore.com> * standard.ads.h: New file. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 775ab98..916ae3e 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -421,6 +421,7 @@ GNATRTL_NONTASKING_OBJS= \ g-exptty$(objext) \ g-flocon$(objext) \ g-forstr$(objext) \ + g-graphs$(objext) \ g-heasor$(objext) \ g-hesora$(objext) \ g-hesorg$(objext) \ diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 818e67a..978fb3d 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -29,39 +29,328 @@ with Fname; use Fname; with Opt; use Opt; with Osint; use Osint; with Output; use Output; +with Snames; use Snames; + +with GNAT; use GNAT; +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; package body ALI is use ASCII; -- Make control characters visible + --------------------- + -- Data structures -- + --------------------- + + procedure Destroy (IS_Id : in out Invocation_Signature_Id); + -- Destroy an invocation signature with id IS_Id + + function Hash + (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type; + -- Obtain the hash of key IS_Rec + + package Sig_Map is new Dynamic_Hash_Tables + (Key_Type => Invocation_Signature_Record, + Value_Type => Invocation_Signature_Id, + No_Value => No_Invocation_Signature, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy, + Hash => Hash); + + -- The following map relates invocation signature records to invocation + -- signature ids. + + Sig_To_Sig_Map : constant Sig_Map.Dynamic_Hash_Table := + Sig_Map.Create (500); + + -- The folowing table maps body placement kinds to character codes for + -- invocation construct encoding in ALI files. + + Body_Placement_Codes : + constant array (Body_Placement_Kind) of Character := + (In_Body => 'b', + In_Spec => 's', + No_Body_Placement => 'Z'); + + -- The following table maps invocation kinds to character codes for + -- invocation relation encoding in ALI files. + + Invocation_Codes : + constant array (Invocation_Kind) of Character := + (Accept_Alternative => 'a', + Access_Taken => 'b', + Call => 'c', + Controlled_Adjustment => 'd', + Controlled_Finalization => 'e', + Controlled_Initialization => 'f', + Default_Initial_Condition_Verification => 'g', + Initial_Condition_Verification => 'h', + Instantiation => 'i', + Internal_Controlled_Adjustment => 'j', + Internal_Controlled_Finalization => 'k', + Internal_Controlled_Initialization => 'l', + Invariant_Verification => 'm', + Postcondition_Verification => 'n', + Protected_Entry_Call => 'o', + Protected_Subprogram_Call => 'p', + Task_Activation => 'q', + Task_Entry_Call => 'r', + Type_Initialization => 's', + No_Invocation => 'Z'); + + -- The following table maps invocation construct kinds to character codes + -- for invocation construct encoding in ALI files. + + Invocation_Construct_Codes : + constant array (Invocation_Construct_Kind) of Character := + (Elaborate_Body_Procedure => 'b', + Elaborate_Spec_Procedure => 's', + Regular_Construct => 'Z'); + + -- The following table maps invocation graph line kinds to character codes + -- used in ALI files. + + Invocation_Graph_Line_Codes : + constant array (Invocation_Graph_Line_Kind) of Character := + (Invocation_Construct_Line => 'c', + Invocation_Relation_Line => 'r'); + -- The following variable records which characters currently are used as -- line type markers in the ALI file. This is used in Scan_ALI to detect -- (or skip) invalid lines. The following letters are still available: -- - -- B F G H J K O Q Z + -- B F H J K O Q Z Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean := - ('V' => True, -- version - 'M' => True, -- main program - 'A' => True, -- argument - 'P' => True, -- program - 'R' => True, -- restriction - 'I' => True, -- interrupt - 'U' => True, -- unit - 'W' => True, -- with - 'L' => True, -- linker option - 'N' => True, -- notes - 'E' => True, -- external - 'D' => True, -- dependency - 'X' => True, -- xref - 'S' => True, -- specific dispatching - 'Y' => True, -- limited_with - 'Z' => True, -- implicit with from instantiation - 'C' => True, -- SCO information - 'T' => True, -- task stack information + ('A' => True, -- argument + 'C' => True, -- SCO information + 'D' => True, -- dependency + 'E' => True, -- external + 'G' => True, -- invocation graph + 'I' => True, -- interrupt + 'L' => True, -- linker option + 'M' => True, -- main program + 'N' => True, -- notes + 'P' => True, -- program + 'R' => True, -- restriction + 'S' => True, -- specific dispatching + 'T' => True, -- task stack information + 'U' => True, -- unit + 'V' => True, -- version + 'W' => True, -- with + 'X' => True, -- xref + 'Y' => True, -- limited_with + 'Z' => True, -- implicit with from instantiation others => False); + ------------------------------ + -- Add_Invocation_Construct -- + ------------------------------ + + procedure Add_Invocation_Construct + (IC_Rec : Invocation_Construct_Record; + Update_Units : Boolean := True) + is + IC_Id : Invocation_Construct_Id; + + begin + pragma Assert (Present (IC_Rec.Signature)); + + -- Create a invocation construct from the scanned attributes + + Invocation_Constructs.Append (IC_Rec); + IC_Id := Invocation_Constructs.Last; + + -- Update the invocation construct counter of the current unit only when + -- requested by the caller. + + if Update_Units then + declare + Curr_Unit : Unit_Record renames Units.Table (Units.Last); + + begin + Curr_Unit.Last_Invocation_Construct := IC_Id; + end; + end if; + end Add_Invocation_Construct; + + ----------------------------- + -- Add_Invocation_Relation -- + ----------------------------- + + procedure Add_Invocation_Relation + (IR_Rec : Invocation_Relation_Record; + Update_Units : Boolean := True) + is + IR_Id : Invocation_Relation_Id; + + begin + pragma Assert (Present (IR_Rec.Invoker)); + pragma Assert (Present (IR_Rec.Target)); + pragma Assert (IR_Rec.Kind /= No_Invocation); + + -- Create an invocation relation from the scanned attributes + + Invocation_Relations.Append (IR_Rec); + IR_Id := Invocation_Relations.Last; + + -- Update the invocation relation counter of the current unit only when + -- requested by the caller. + + if Update_Units then + declare + Curr_Unit : Unit_Record renames Units.Table (Units.Last); + + begin + Curr_Unit.Last_Invocation_Relation := IR_Id; + end; + end if; + end Add_Invocation_Relation; + + --------------------------------- + -- Body_Placement_Kind_To_Code -- + --------------------------------- + + function Body_Placement_Kind_To_Code + (Kind : Body_Placement_Kind) return Character + is + begin + return Body_Placement_Codes (Kind); + end Body_Placement_Kind_To_Code; + + --------------------------------- + -- Code_To_Body_Placement_Kind -- + --------------------------------- + + function Code_To_Body_Placement_Kind + (Code : Character) return Body_Placement_Kind + is + begin + -- Determine which body placement kind corresponds to the character code + -- by traversing the contents of the mapping table. + + for Kind in Body_Placement_Kind loop + if Body_Placement_Codes (Kind) = Code then + return Kind; + end if; + end loop; + + raise Program_Error; + end Code_To_Body_Placement_Kind; + + --------------------------------------- + -- Code_To_Invocation_Construct_Kind -- + --------------------------------------- + + function Code_To_Invocation_Construct_Kind + (Code : Character) return Invocation_Construct_Kind + is + begin + -- Determine which invocation construct kind matches the character code + -- by traversing the contents of the mapping table. + + for Kind in Invocation_Construct_Kind loop + if Invocation_Construct_Codes (Kind) = Code then + return Kind; + end if; + end loop; + + raise Program_Error; + end Code_To_Invocation_Construct_Kind; + + ----------------------------- + -- Code_To_Invocation_Kind -- + ----------------------------- + + function Code_To_Invocation_Kind + (Code : Character) return Invocation_Kind + is + begin + -- Determine which invocation kind corresponds to the character code by + -- traversing the contents of the mapping table. + + for Kind in Invocation_Kind loop + if Invocation_Codes (Kind) = Code then + return Kind; + end if; + end loop; + + raise Program_Error; + end Code_To_Invocation_Kind; + + ---------------------------------------- + -- Code_To_Invocation_Graph_Line_Kind -- + ---------------------------------------- + + function Code_To_Invocation_Graph_Line_Kind + (Code : Character) return Invocation_Graph_Line_Kind + is + begin + -- Determine which invocation graph line kind matches the character + -- code by traversing the contents of the mapping table. + + for Kind in Invocation_Graph_Line_Kind loop + if Invocation_Graph_Line_Codes (Kind) = Code then + return Kind; + end if; + end loop; + + raise Program_Error; + end Code_To_Invocation_Graph_Line_Kind; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (IS_Id : in out Invocation_Signature_Id) is + pragma Unreferenced (IS_Id); + begin + null; + end Destroy; + + ---------- + -- Hash -- + ---------- + + function Hash + (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type + is + Buffer : Bounded_String (2052); + IS_Nam : Name_Id; + + begin + -- The hash is obtained in the following manner: + -- + -- * A String signature based on the scope, name, line number, column + -- number, and locations, in the following format: + -- + -- scope__name__line_column__locations + -- + -- * The String is converted into a Name_Id + -- * The Name_Id is used as the hash + + Append (Buffer, IS_Rec.Scope); + Append (Buffer, "__"); + Append (Buffer, IS_Rec.Name); + Append (Buffer, "__"); + Append (Buffer, IS_Rec.Line); + Append (Buffer, '_'); + Append (Buffer, IS_Rec.Column); + + if IS_Rec.Locations /= No_Name then + Append (Buffer, "__"); + Append (Buffer, IS_Rec.Locations); + end if; + + IS_Nam := Name_Find (Buffer); + return Bucket_Range_Type (IS_Nam); + end Hash; + -------------------- -- Initialize_ALI -- -------------------- @@ -90,16 +379,19 @@ package body ALI is -- Initialize all tables ALIs.Init; + Invocation_Constructs.Init; + Invocation_Relations.Init; + Invocation_Signatures.Init; + Linker_Options.Init; No_Deps.Init; + Notes.Init; + Sdep.Init; Units.Init; + Version_Ref.Reset; Withs.Init; - Sdep.Init; - Linker_Options.Init; - Notes.Init; - Xref_Section.Init; Xref_Entity.Init; Xref.Init; - Version_Ref.Reset; + Xref_Section.Init; -- Add dummy zero'th item in Linker_Options and Notes for sort calls @@ -125,6 +417,131 @@ package body ALI is Zero_Cost_Exceptions_Specified := False; end Initialize_ALI; + --------------------------------------- + -- Invocation_Construct_Kind_To_Code -- + --------------------------------------- + + function Invocation_Construct_Kind_To_Code + (Kind : Invocation_Construct_Kind) return Character + is + begin + return Invocation_Construct_Codes (Kind); + end Invocation_Construct_Kind_To_Code; + + ---------------------------------------- + -- Invocation_Graph_Line_Kind_To_Code -- + ---------------------------------------- + + function Invocation_Graph_Line_Kind_To_Code + (Kind : Invocation_Graph_Line_Kind) return Character + is + begin + return Invocation_Graph_Line_Codes (Kind); + end Invocation_Graph_Line_Kind_To_Code; + + ----------------------------- + -- Invocation_Kind_To_Code -- + ----------------------------- + + function Invocation_Kind_To_Code + (Kind : Invocation_Kind) return Character + is + begin + return Invocation_Codes (Kind); + end Invocation_Kind_To_Code; + + ----------------------------- + -- Invocation_Signature_Of -- + ----------------------------- + + function Invocation_Signature_Of + (Column : Nat; + Line : Nat; + Locations : Name_Id; + Name : Name_Id; + Scope : Name_Id) return Invocation_Signature_Id + is + IS_Rec : constant Invocation_Signature_Record := + (Column => Column, + Line => Line, + Locations => Locations, + Name => Name, + Scope => Scope); + IS_Id : Invocation_Signature_Id; + + begin + IS_Id := Sig_Map.Get (Sig_To_Sig_Map, IS_Rec); + + -- The invocation signature lacks an id. This indicates that it + -- is encountered for the first time during the construction of + -- the graph. + + if not Present (IS_Id) then + Invocation_Signatures.Append (IS_Rec); + IS_Id := Invocation_Signatures.Last; + + -- Map the invocation signature record to its corresponding id + + Sig_Map.Put (Sig_To_Sig_Map, IS_Rec, IS_Id); + end if; + + return IS_Id; + end Invocation_Signature_Of; + + ------------- + -- Present -- + ------------- + + function Present (IC_Id : Invocation_Construct_Id) return Boolean is + begin + return IC_Id /= No_Invocation_Construct; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (IR_Id : Invocation_Relation_Id) return Boolean is + begin + return IR_Id /= No_Invocation_Relation; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (IS_Id : Invocation_Signature_Id) return Boolean is + begin + return IS_Id /= No_Invocation_Signature; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (Dep : Sdep_Id) return Boolean is + begin + return Dep /= No_Sdep_Id; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (U_Id : Unit_Id) return Boolean is + begin + return U_Id /= No_Unit_Id; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (W_Id : With_Id) return Boolean is + begin + return W_Id /= No_With_Id; + end Present; + -------------- -- Scan_ALI -- -------------- @@ -256,6 +673,9 @@ package body ALI is Standard_Entity : out Name_Id); -- Parse the definition of a typeref (<...>, {...} or (...)) + procedure Scan_Invocation_Graph_Line; + -- Parse a single line which encodes a piece of the invocation graph + procedure Skip_Eol; -- Skip past spaces, then skip past end of line (fatal error if not -- at end of line). Also skips past any following blank lines. @@ -771,6 +1191,202 @@ package body ALI is return T (P); end Nextc; + -------------------------------- + -- Scan_Invocation_Graph_Line -- + -------------------------------- + + procedure Scan_Invocation_Graph_Line is + procedure Scan_Invocation_Construct_Line; + pragma Inline (Scan_Invocation_Construct_Line); + -- Parse an invocation construct line and construct the corresponding + -- construct. The following data structures are updated: + -- + -- * Invocation_Constructs + -- * Units + + procedure Scan_Invocation_Relation_Line; + pragma Inline (Scan_Invocation_Relation_Line); + -- Parse an invocation relation line and construct the corresponding + -- relation. The following data structures are updated: + -- + -- * Invocation_Relations + -- * Units + + function Scan_Invocation_Signature return Invocation_Signature_Id; + pragma Inline (Scan_Invocation_Signature); + -- Parse a single invocation signature while populating the following + -- data structures: + -- + -- * Invocation_Signatures + -- * Sig_To_Sig_Map + + ------------------------------------ + -- Scan_Invocation_Construct_Line -- + ------------------------------------ + + procedure Scan_Invocation_Construct_Line is + IC_Rec : Invocation_Construct_Record; + + begin + -- construct-kind + + IC_Rec.Kind := Code_To_Invocation_Construct_Kind (Getc); + Checkc (' '); + Skip_Space; + + -- construct-body-placement + + IC_Rec.Placement := Code_To_Body_Placement_Kind (Getc); + Checkc (' '); + Skip_Space; + + -- construct-signature + + IC_Rec.Signature := Scan_Invocation_Signature; + pragma Assert (Present (IC_Rec.Signature)); + + Skip_Eol; + + Add_Invocation_Construct (IC_Rec); + end Scan_Invocation_Construct_Line; + + ----------------------------------- + -- Scan_Invocation_Relation_Line -- + ----------------------------------- + + procedure Scan_Invocation_Relation_Line is + IR_Rec : Invocation_Relation_Record; + + begin + -- relation-kind + + IR_Rec.Kind := Code_To_Invocation_Kind (Getc); + Checkc (' '); + Skip_Space; + + -- (extra-name | "none") + + IR_Rec.Extra := Get_Name; + + if IR_Rec.Extra = Name_None then + IR_Rec.Extra := No_Name; + end if; + + Checkc (' '); + Skip_Space; + + -- invoker-signature + + IR_Rec.Invoker := Scan_Invocation_Signature; + pragma Assert (Present (IR_Rec.Invoker)); + + Checkc (' '); + Skip_Space; + + -- target-signature + + IR_Rec.Target := Scan_Invocation_Signature; + pragma Assert (Present (IR_Rec.Target)); + + Skip_Eol; + + Add_Invocation_Relation (IR_Rec); + end Scan_Invocation_Relation_Line; + + ------------------------------- + -- Scan_Invocation_Signature -- + ------------------------------- + + function Scan_Invocation_Signature return Invocation_Signature_Id is + Column : Nat; + Line : Nat; + Locations : Name_Id; + Name : Name_Id; + Scope : Name_Id; + + begin + -- [ + + Checkc ('['); + + -- name + + Name := Get_Name; + Checkc (' '); + Skip_Space; + + -- scope + + Scope := Get_Name; + Checkc (' '); + Skip_Space; + + -- line + + Line := Get_Nat; + Checkc (' '); + Skip_Space; + + -- column + + Column := Get_Nat; + Checkc (' '); + Skip_Space; + + -- (locations | "none") + + Locations := Get_Name; + + if Locations = Name_None then + Locations := No_Name; + end if; + + -- ] + + Checkc (']'); + + -- Create an invocation signature from the scanned attributes + + return + Invocation_Signature_Of + (Column => Column, + Line => Line, + Locations => Locations, + Name => Name, + Scope => Scope); + end Scan_Invocation_Signature; + + -- Local variables + + Line : Invocation_Graph_Line_Kind; + + -- Start of processing for Scan_Invocation_Graph_Line + + begin + if Ignore ('G') then + return; + end if; + + Checkc (' '); + Skip_Space; + + -- line-kind + + Line := Code_To_Invocation_Graph_Line_Kind (Getc); + Checkc (' '); + Skip_Space; + + -- line-attributes + + if Line = Invocation_Construct_Line then + Scan_Invocation_Construct_Line; + + else + pragma Assert (Line = Invocation_Relation_Line); + Scan_Invocation_Relation_Line; + end if; + end Scan_Invocation_Graph_Line; + -------------- -- Skip_Eol -- -------------- @@ -1716,38 +2332,42 @@ package body ALI is UL : Unit_Record renames Units.Table (Units.Last); begin - UL.Uname := Get_Unit_Name; - UL.Predefined := Is_Predefined_Unit; - UL.Internal := Is_Internal_Unit; - UL.My_ALI := Id; - UL.Sfile := Get_File_Name (Lower => True); - UL.Pure := False; - UL.Preelab := False; - UL.No_Elab := False; - UL.Shared_Passive := False; - UL.RCI := False; - UL.Remote_Types := False; - UL.Serious_Errors := False; - UL.Has_RACW := False; - UL.Init_Scalars := False; - UL.Is_Generic := False; - UL.Icasing := Mixed_Case; - UL.Kcasing := All_Lower_Case; - UL.Dynamic_Elab := False; - UL.Elaborate_Body := False; - UL.Set_Elab_Entity := False; - UL.Version := "00000000"; - UL.First_With := Withs.Last + 1; - UL.First_Arg := First_Arg; - UL.Elab_Position := 0; - UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; - UL.Directly_Scanned := Directly_Scanned; - UL.Body_Needed_For_SAL := False; - UL.Elaborate_Body_Desirable := False; - UL.Optimize_Alignment := 'O'; - UL.Has_Finalizer := False; - UL.Primary_Stack_Count := 0; - UL.Sec_Stack_Count := 0; + UL.Uname := Get_Unit_Name; + UL.Predefined := Is_Predefined_Unit; + UL.Internal := Is_Internal_Unit; + UL.My_ALI := Id; + UL.Sfile := Get_File_Name (Lower => True); + UL.Pure := False; + UL.Preelab := False; + UL.No_Elab := False; + UL.Shared_Passive := False; + UL.RCI := False; + UL.Remote_Types := False; + UL.Serious_Errors := False; + UL.Has_RACW := False; + UL.Init_Scalars := False; + UL.Is_Generic := False; + UL.Icasing := Mixed_Case; + UL.Kcasing := All_Lower_Case; + UL.Dynamic_Elab := False; + UL.Elaborate_Body := False; + UL.Set_Elab_Entity := False; + UL.Version := "00000000"; + UL.First_With := Withs.Last + 1; + UL.First_Arg := First_Arg; + UL.First_Invocation_Construct := Invocation_Constructs.Last + 1; + UL.Last_Invocation_Construct := No_Invocation_Construct; + UL.First_Invocation_Relation := Invocation_Relations.Last + 1; + UL.Last_Invocation_Relation := No_Invocation_Relation; + UL.Elab_Position := 0; + UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; + UL.Directly_Scanned := Directly_Scanned; + UL.Body_Needed_For_SAL := False; + UL.Elaborate_Body_Desirable := False; + UL.Optimize_Alignment := 'O'; + UL.Has_Finalizer := False; + UL.Primary_Stack_Count := 0; + UL.Sec_Stack_Count := 0; if Debug_Flag_U then Write_Str (" ----> reading unit "); @@ -2444,6 +3064,17 @@ package body ALI is ALIs.Table (Id).Last_Sdep := Sdep.Last; + -- Loop through invocation graph lines + + G_Loop : loop + Check_Unknown_Line; + exit G_Loop when C /= 'G'; + + Scan_Invocation_Graph_Line; + + C := Getc; + end loop G_Loop; + -- We must at this stage be at an Xref line or the end of file if C = EOF then @@ -2786,7 +3417,6 @@ package body ALI is -- Record last entity XS.Last_Entity := Xref_Entity.Last; - end Read_Refs_For_One_File; C := Getc; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 7835857..79eabb1 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -34,6 +34,7 @@ with Rident; use Rident; with Table; with Types; use Types; +with GNAT.Dynamic_Tables; with GNAT.HTable; use GNAT.HTable; package ALI is @@ -66,6 +67,39 @@ package ALI is type Priority_Specific_Dispatching_Id is range 0 .. 99_999_999; -- Id values used for Priority_Specific_Dispatching table entries + type Invocation_Construct_Id is range 0 .. 99_999_999; + -- Id values used for Invocation_Constructs table entries + + type Invocation_Relation_Id is range 0 .. 99_999_999; + -- Id values used for Invocation_Relations table entries + + type Invocation_Signature_Id is range 0 .. 99_999_999; + -- Id values used for Invocation_Signatures table entries + + function Present (IC_Id : Invocation_Construct_Id) return Boolean; + pragma Inline (Present); + -- Determine whether invocation construct IC_Id exists + + function Present (IR_Id : Invocation_Relation_Id) return Boolean; + pragma Inline (Present); + -- Determine whether invocation relation IR_Id exists + + function Present (IS_Id : Invocation_Signature_Id) return Boolean; + pragma Inline (Present); + -- Determine whether invocation signature IS_Id exists + + function Present (Dep : Sdep_Id) return Boolean; + pragma Inline (Present); + -- Determine whether dependant Dep exists + + function Present (U_Id : Unit_Id) return Boolean; + pragma Inline (Present); + -- Determine whether unit U_Id exists + + function Present (W_Id : With_Id) return Boolean; + pragma Inline (Present); + -- Determine whether with W_Id exists + -------------------- -- ALI File Table -- -------------------- @@ -334,6 +368,18 @@ package ALI is Last_Arg : Arg_Id; -- Id of last args table entry for this file + First_Invocation_Construct : Invocation_Construct_Id; + -- Id of the first invocation construct for this unit + + Last_Invocation_Construct : Invocation_Construct_Id; + -- Id of the last invocation construct for this unit + + First_Invocation_Relation : Invocation_Relation_Id; + -- Id of the first invocation relation for this unit + + Last_Invocation_Relation : Invocation_Relation_Id; + -- Id of the last invocation relation for this unit + Utype : Unit_Type; -- Type of entry @@ -408,6 +454,16 @@ package ALI is Table_Increment => 200, Table_Name => "Unit"); + package Unit_Id_Tables is new GNAT.Dynamic_Tables + (Table_Component_Type => Unit_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 500, + Table_Increment => 200); + + subtype Unit_Id_Table is Unit_Id_Tables.Instance; + subtype Unit_Id_Array is Unit_Id_Tables.Table_Type; + --------------------------- -- Interrupt State Table -- --------------------------- @@ -794,6 +850,7 @@ package ALI is Unit_Name : Name_Id; -- Name_Id for the unit name if not a subunit (No_Name for a subunit) + Rfile : File_Name_Type; -- Reference file name. Same as Sfile unless a Source_Reference pragma -- was used, in which case it reflects the name used in the pragma. @@ -1026,6 +1083,265 @@ package ALI is Table_Increment => 300, Table_Name => "Xref"); + ---------------------------- + -- Invocation Graph Types -- + ---------------------------- + + -- The following type identifies an invocation signature + + No_Invocation_Signature : constant Invocation_Signature_Id := + Invocation_Signature_Id'First; + First_Invocation_Signature : constant Invocation_Signature_Id := + No_Invocation_Signature + 1; + + -- The following type represents an invocation signature. Its purpose is + -- to uniquely identify an invocation construct within the ALI space. The + -- signature is comprised out of several pieces, some of which are used in + -- error diagnostics by the binder. Identification issues are resolved as + -- follows: + -- + -- * The Column, Line, and Locations attributes together differentiate + -- between homonyms. In most cases, the Column and Line are sufficient + -- except when generic instantiations are involved. Together, the three + -- attributes offer a sequence of column-line pairs which eventually + -- reflect the location within the generic template. + -- + -- * The Name attribute differentiates between invocation constructs at + -- the scope level. Since it is illegal for two entities with the same + -- name to coexist in the same scope, the Name attribute is sufficient + -- to distinguish them. Overloaded entities are already handled by the + -- Column, Line, and Locations attributes. + -- + -- * The Scope attribute differentiates between invocation constructs at + -- various levels of nesting. + + type Invocation_Signature_Record is record + Column : Nat := 0; + -- The column number where the invocation construct is declared + + Line : Nat := 0; + -- The line number where the invocation construct is declared + + Locations : Name_Id := No_Name; + -- Sequence of column and line numbers within nested instantiations + + Name : Name_Id := No_Name; + -- The name of the invocation construct + + Scope : Name_Id := No_Name; + -- The qualified name of the scope where the invocation construct is + -- declared. + end record; + + -- The following type enumerates all possible placements of an invocation + -- construct's body body with respect to the unit it is declared in. + + type Body_Placement_Kind is + (In_Body, + -- The body of the invocation construct is within the body of the unit + -- it is declared in. + + In_Spec, + -- The body of the invocation construct is within the spec of the unit + -- it is declared in. + + No_Body_Placement); + -- The invocation construct does not have a body + + -- The following type enumerates all possible invocation construct kinds + + type Invocation_Construct_Kind is + (Elaborate_Body_Procedure, + -- The invocation construct denotes the procedure which elaborates a + -- package body. + + Elaborate_Spec_Procedure, + -- The invocation construct denotes the procedure which elaborates a + -- package spec. + + Regular_Construct); + -- The invocation construct is a normal invocation construct + + -- The following type identifies an invocation construct + + No_Invocation_Construct : constant Invocation_Construct_Id := + Invocation_Construct_Id'First; + First_Invocation_Construct : constant Invocation_Construct_Id := + No_Invocation_Construct + 1; + + -- The following type represents an invocation construct + + type Invocation_Construct_Record is record + Kind : Invocation_Construct_Kind := Regular_Construct; + -- The nature of the invocation construct + + Placement : Body_Placement_Kind := No_Body_Placement; + -- The location of the invocation construct's body with respect to the + -- body of the unit it is declared in. + + Signature : Invocation_Signature_Id := No_Invocation_Signature; + -- The invocation signature which uniquely identifies the invocation + -- construct in the ALI space. + end record; + + -- The following type identifies an invocation relation + + No_Invocation_Relation : constant Invocation_Relation_Id := + Invocation_Relation_Id'First; + First_Invocation_Relation : constant Invocation_Relation_Id := + No_Invocation_Relation + 1; + + -- The following type enumerates all possible invocation kinds + + type Invocation_Kind is + (Accept_Alternative, + Access_Taken, + Call, + Controlled_Adjustment, + Controlled_Finalization, + Controlled_Initialization, + Default_Initial_Condition_Verification, + Initial_Condition_Verification, + Instantiation, + Internal_Controlled_Adjustment, + Internal_Controlled_Finalization, + Internal_Controlled_Initialization, + Invariant_Verification, + Postcondition_Verification, + Protected_Entry_Call, + Protected_Subprogram_Call, + Task_Activation, + Task_Entry_Call, + Type_Initialization, + No_Invocation); + + subtype Internal_Controlled_Invocation_Kind is Invocation_Kind range + Internal_Controlled_Adjustment .. + -- Internal_Controlled_Finalization + Internal_Controlled_Initialization; + + -- The following type represents an invocation relation. It associates an + -- invoker which activates/calls/instantiates with a target. + + type Invocation_Relation_Record is record + Extra : Name_Id := No_Name; + -- The name of an additional entity used in error diagnostics + + Invoker : Invocation_Signature_Id := No_Invocation_Signature; + -- The invocation signature which uniquely identifies the invoker within + -- the ALI space. + + Kind : Invocation_Kind := No_Invocation; + -- The nature of the invocation + + Target : Invocation_Signature_Id := No_Invocation_Signature; + -- The invocation signature which uniquely identifies the target within + -- the ALI space. + end record; + + -- The following type enumerates all possible invocation graph ALI lines + + type Invocation_Graph_Line_Kind is + (Invocation_Construct_Line, + Invocation_Relation_Line); + + -------------------------------------- + -- Invocation Graph Data Structures -- + -------------------------------------- + + package Invocation_Constructs is new Table.Table + (Table_Index_Type => Invocation_Construct_Id, + Table_Component_Type => Invocation_Construct_Record, + Table_Low_Bound => First_Invocation_Construct, + Table_Initial => 2500, + Table_Increment => 200, + Table_Name => "Invocation_Constructs"); + + package Invocation_Relations is new Table.Table + (Table_Index_Type => Invocation_Relation_Id, + Table_Component_Type => Invocation_Relation_Record, + Table_Low_Bound => First_Invocation_Relation, + Table_Initial => 2500, + Table_Increment => 200, + Table_Name => "Invocation_Relation"); + + package Invocation_Signatures is new Table.Table + (Table_Index_Type => Invocation_Signature_Id, + Table_Component_Type => Invocation_Signature_Record, + Table_Low_Bound => First_Invocation_Signature, + Table_Initial => 2500, + Table_Increment => 200, + Table_Name => "Invocation_Signatures"); + + ---------------------------------- + -- Invocation Graph Subprograms -- + ---------------------------------- + + procedure Add_Invocation_Construct + (IC_Rec : Invocation_Construct_Record; + Update_Units : Boolean := True); + pragma Inline (Add_Invocation_Construct); + -- Add invocation construct attributes IC_Rec to internal data structures. + -- Flag Undate_Units should be set when this addition must be reflected in + -- the attributes of the current unit. + + procedure Add_Invocation_Relation + (IR_Rec : Invocation_Relation_Record; + Update_Units : Boolean := True); + pragma Inline (Add_Invocation_Relation); + -- Add invocation relation attributes IR_Rec to internal data structures. + -- Flag Undate_Units should be set when this addition must be reflected in + -- the attributes of the current unit. + + function Body_Placement_Kind_To_Code + (Kind : Body_Placement_Kind) return Character; + pragma Inline (Body_Placement_Kind_To_Code); + -- Obtain the character encoding of body placement kind Kind + + function Code_To_Body_Placement_Kind + (Code : Character) return Body_Placement_Kind; + pragma Inline (Code_To_Body_Placement_Kind); + -- Obtain the body placement kind of character encoding Code + + function Code_To_Invocation_Construct_Kind + (Code : Character) return Invocation_Construct_Kind; + pragma Inline (Code_To_Invocation_Construct_Kind); + -- Obtain the invocation construct kind of character encoding Code + + function Code_To_Invocation_Kind + (Code : Character) return Invocation_Kind; + pragma Inline (Code_To_Invocation_Kind); + -- Obtain the invocation kind of character encoding Code + + function Code_To_Invocation_Graph_Line_Kind + (Code : Character) return Invocation_Graph_Line_Kind; + pragma Inline (Code_To_Invocation_Graph_Line_Kind); + -- Obtain the invocation graph line kind of character encoding Code + + function Invocation_Construct_Kind_To_Code + (Kind : Invocation_Construct_Kind) return Character; + pragma Inline (Invocation_Construct_Kind_To_Code); + -- Obtain the character encoding of invocation kind Kind + + function Invocation_Graph_Line_Kind_To_Code + (Kind : Invocation_Graph_Line_Kind) return Character; + pragma Inline (Invocation_Graph_Line_Kind_To_Code); + -- Obtain the character encoding for invocation like kind Kind + + function Invocation_Kind_To_Code + (Kind : Invocation_Kind) return Character; + pragma Inline (Invocation_Kind_To_Code); + -- Obtain the character encoding of invocation kind Kind + + function Invocation_Signature_Of + (Column : Nat; + Line : Nat; + Locations : Name_Id; + Name : Name_Id; + Scope : Name_Id) return Invocation_Signature_Id; + pragma Inline (Invocation_Signature_Of); + -- Obtain the invocation signature that corresponds to the input attributes + -------------------------------------- -- Subprograms for Reading ALI File -- -------------------------------------- diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index f5bd4b8..5caee49 100644 --- a/gcc/ada/binde.adb +++ b/gcc/ada/binde.adb @@ -23,20 +23,21 @@ -- -- ------------------------------------------------------------------------------ -with Binderr; use Binderr; -with Butil; use Butil; -with Debug; use Debug; -with Fname; use Fname; -with Opt; use Opt; +with Binderr; use Binderr; +with Butil; use Butil; +with Debug; use Debug; +with Fname; use Fname; +with Opt; use Opt; with Osint; -with Output; use Output; +with Output; use Output; with Table; +with Types; use Types; with System.Case_Util; use System.Case_Util; with System.HTable; -with System.OS_Lib; package body Binde is + use Unit_Id_Tables; -- We now have Elab_New, a new elaboration-order algorithm. -- @@ -113,7 +114,7 @@ package body Binde is -- elaborated before After is elaborated. Forced, - -- Before and After come from a pair of lines in the forced elaboration + -- Before and After come from a pair of lines in the forced-elaboration- -- order file. Elab, @@ -380,7 +381,7 @@ package body Binde is -- "$ must be elaborated before $ ..." where ... is the reason. procedure Force_Elab_Order; - -- Gather dependencies from the forced elaboration order file (-f switch) + -- Gather dependencies from the forced-elaboration-order file (-f switch) procedure Gather_Dependencies; -- Compute dependencies, building the Succ and UNR tables @@ -1793,30 +1794,13 @@ package body Binde is ---------------------- procedure Force_Elab_Order is - use System.OS_Lib; - -- There is a lot of fiddly string manipulation below, because we don't - -- want to depend on misc utility packages like Ada.Characters.Handling. - - function Get_Line return String; - -- Read the next line from the file content read by Read_File. Strip - -- all leading and trailing blanks. Convert "(spec)" or "(body)" to - -- "%s"/"%b". Remove comments (Ada style; "--" to end of line). - - function Read_File (Name : String) return String_Ptr; - -- Read the entire contents of the named file - subtype Header_Num is Unit_Name_Type'Base range 0 .. 2**16 - 1; - type Line_Number is new Nat; - No_Line_Number : constant Line_Number := 0; - Cur_Line_Number : Line_Number := 0; - -- Current line number in the Force_Elab_Order_File. - -- Incremented by Get_Line. Used in error messages. function Hash (N : Unit_Name_Type) return Header_Num; package Name_Map is new System.HTable.Simple_HTable (Header_Num => Header_Num, - Element => Line_Number, + Element => Logical_Line_Number, No_Element => No_Line_Number, Key => Unit_Name_Type, Hash => Hash, @@ -1837,234 +1821,86 @@ package body Binde is return (N - Unit_Name_Type'First) mod (Header_Num'Last + 1); end Hash; - --------------- - -- Read_File -- - --------------- - - function Read_File (Name : String) return String_Ptr is - - -- All of the following calls should succeed, because we checked the - -- file in Switch.B, but we double check and raise Program_Error on - -- failure, just in case. - - F : constant File_Descriptor := Open_Read (Name, Binary); - - begin - if F = Invalid_FD then - raise Program_Error; - end if; - - declare - Len : constant Natural := Natural (File_Length (F)); - Result : constant String_Ptr := new String (1 .. Len); - Len_Read : constant Natural := - Read (F, Result (1)'Address, Len); - - Status : Boolean; - - begin - if Len_Read /= Len then - raise Program_Error; - end if; - - Close (F, Status); - - if not Status then - raise Program_Error; - end if; - - return Result; - end; - end Read_File; - - Cur : Positive := 1; - S : String_Ptr := Read_File (Force_Elab_Order_File.all); - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return String is - First : Positive := Cur; - Last : Natural; - - begin - Cur_Line_Number := Cur_Line_Number + 1; - - -- Skip to end of line - - while Cur <= S'Last - and then S (Cur) /= ASCII.LF - and then S (Cur) /= ASCII.CR - loop - Cur := Cur + 1; - end loop; - - -- Strip leading blanks - - while First <= S'Last and then S (First) = ' ' loop - First := First + 1; - end loop; - - -- Strip trailing blanks and comment + -- Local variables - Last := Cur - 1; + Cur_Line_Number : Logical_Line_Number; + Error : Boolean := False; + Iter : Forced_Units_Iterator; + Prev_Unit : Unit_Id := No_Unit_Id; + Uname : Unit_Name_Type; - for J in First .. Last - 1 loop - if S (J .. J + 1) = "--" then - Last := J - 1; - exit; - end if; - end loop; - - while Last >= First and then S (Last) = ' ' loop - Last := Last - 1; - end loop; + -- Start of processing for Force_Elab_Order - -- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks - -- again. + begin + Iter := Iterate_Forced_Units; + while Has_Next (Iter) loop + Next (Iter, Uname, Cur_Line_Number); declare - Body_String : constant String := "(body)"; - BL : constant Positive := Body_String'Length; - Spec_String : constant String := "(spec)"; - SL : constant Positive := Spec_String'Length; - - Line : String renames S (First .. Last); - - Is_Body : Boolean := False; - Is_Spec : Boolean := False; - + Dup : constant Logical_Line_Number := Name_Map.Get (Uname); begin - if Line'Length >= SL - and then Line (Last - SL + 1 .. Last) = Spec_String - then - Is_Spec := True; - Last := Last - SL; - elsif Line'Length >= BL - and then Line (Last - BL + 1 .. Last) = Body_String - then - Is_Body := True; - Last := Last - BL; - end if; - - while Last >= First and then S (Last) = ' ' loop - Last := Last - 1; - end loop; + if Dup = No_Line_Number then + Name_Map.Set (Uname, Cur_Line_Number); - -- Skip past LF or CR/LF + -- We don't need to give the "not present" message in the case + -- of "duplicate unit", because we would have already given the + -- "not present" message on the first occurrence. - if Cur <= S'Last and then S (Cur) = ASCII.CR then - Cur := Cur + 1; - end if; - - if Cur <= S'Last and then S (Cur) = ASCII.LF then - Cur := Cur + 1; - end if; + if Get_Name_Table_Int (Uname) = 0 + or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id + then + Error := True; + if Doing_New then + Write_Line + ("""" & Get_Name_String (Uname) + & """: not present; ignored"); + end if; + end if; - if Is_Spec then - return Line (First .. Last) & "%s"; - elsif Is_Body then - return Line (First .. Last) & "%b"; else - return Line; + Error := True; + if Doing_New then + Error_Msg_Nat_1 := Nat (Cur_Line_Number); + Error_Msg_Unit_1 := Uname; + Error_Msg_Nat_2 := Nat (Dup); + Error_Msg + (Force_Elab_Order_File.all + & ":#: duplicate unit name $ from line #"); + end if; end if; end; - end Get_Line; - -- Local variables - - Empty_Name : constant Unit_Name_Type := Name_Find (""); - Prev_Unit : Unit_Id := No_Unit_Id; - - -- Start of processing for Force_Elab_Order - - begin - -- Loop through the file content, and build a dependency link for each - -- pair of lines. Ignore lines that should be ignored. - - while Cur <= S'Last loop - declare - Uname : constant Unit_Name_Type := Name_Find (Get_Line); - Error : Boolean := False; - - begin - if Uname = Empty_Name then - null; -- silently skip blank lines - else - declare - Dup : constant Line_Number := Name_Map.Get (Uname); - begin - if Dup = No_Line_Number then - Name_Map.Set (Uname, Cur_Line_Number); - - -- We don't need to give the "not present" message in - -- the case of "duplicate unit", because we would have - -- already given the "not present" message on the - -- first occurrence. - - if Get_Name_Table_Int (Uname) = 0 - or else Unit_Id (Get_Name_Table_Int (Uname)) = - No_Unit_Id - then - Error := True; - if Doing_New then - Write_Line - ("""" & Get_Name_String (Uname) - & """: not present; ignored"); - end if; - end if; + if not Error then + declare + Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname); + begin + if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then + if Doing_New then + Write_Line + ("""" & Get_Name_String (Uname) + & """: predefined unit ignored"); + end if; - else - Error := True; + else + if Prev_Unit /= No_Unit_Id then if Doing_New then - Error_Msg_Nat_1 := Nat (Cur_Line_Number); - Error_Msg_Unit_1 := Uname; - Error_Msg_Nat_2 := Nat (Dup); - Error_Msg - (Force_Elab_Order_File.all - & ":#: duplicate unit name $ from line #"); + Write_Unit_Name (Units.Table (Prev_Unit).Uname); + Write_Str (" <-- "); + Write_Unit_Name (Units.Table (Cur_Unit).Uname); + Write_Eol; end if; - end if; - end; - - if not Error then - declare - Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname); - begin - if Is_Internal_File_Name - (Units.Table (Cur_Unit).Sfile) - then - if Doing_New then - Write_Line - ("""" & Get_Name_String (Uname) - & """: predefined unit ignored"); - end if; - else - if Prev_Unit /= No_Unit_Id then - if Doing_New then - Write_Unit_Name (Units.Table (Prev_Unit).Uname); - Write_Str (" <-- "); - Write_Unit_Name (Units.Table (Cur_Unit).Uname); - Write_Eol; - end if; - - Build_Link - (Before => Prev_Unit, - After => Cur_Unit, - R => Forced); - end if; + Build_Link + (Before => Prev_Unit, + After => Cur_Unit, + R => Forced); + end if; - Prev_Unit := Cur_Unit; - end if; - end; + Prev_Unit := Cur_Unit; end if; - end if; - end; + end; + end if; end loop; - - Free (S); end Force_Elab_Order; ------------------------- diff --git a/gcc/ada/binde.ads b/gcc/ada/binde.ads index 6412d26..bdea7dc 100644 --- a/gcc/ada/binde.ads +++ b/gcc/ada/binde.ads @@ -28,23 +28,9 @@ with ALI; use ALI; with Namet; use Namet; -with Types; use Types; - -with GNAT.Dynamic_Tables; package Binde is - package Unit_Id_Tables is new GNAT.Dynamic_Tables - (Table_Component_Type => Unit_Id, - Table_Index_Type => Nat, - Table_Low_Bound => 1, - Table_Initial => 500, - Table_Increment => 200); - use Unit_Id_Tables; - - subtype Unit_Id_Table is Unit_Id_Tables.Instance; - subtype Unit_Id_Array is Unit_Id_Tables.Table_Type; - procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table; First_Main_Lib_File : File_Name_Type); diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index b5637a4..e135540 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with ALI; use ALI; with Casing; use Casing; with Fname; use Fname; with Gnatvsn; use Gnatvsn; @@ -1805,13 +1804,18 @@ package body Bindgen is -- referenced elsewhere in the generated program, but is needed by -- the debugger (that's why it is generated in the first place). The -- reference stops Ada_Main_Program_Name from being optimized away by - -- smart linkers, such as the AiX linker. + -- smart linkers. -- Because this variable is unused, we make this variable "aliased" -- with a pragma Volatile in order to tell the compiler to preserve -- this variable at any level of optimization. - if Bind_Main_Program and not CodePeer_Mode then + -- CodePeer and CCG do not need this extra code on the other hand + + if Bind_Main_Program + and then not CodePeer_Mode + and then not Generate_C_Code + then WBI (" Ensure_Reference : aliased System.Address := " & "Ada_Main_Program_Name'Address;"); WBI (" pragma Volatile (Ensure_Reference);"); diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads index 86466f4..722cfad 100644 --- a/gcc/ada/bindgen.ads +++ b/gcc/ada/bindgen.ads @@ -32,10 +32,9 @@ -- See the body for exact details of the file that is generated -with Binde; use Binde; +with ALI; use ALI; package Bindgen is - procedure Gen_Output_File (Filename : String; Elab_Order : Unit_Id_Array); diff --git a/gcc/ada/bindo-augmentors.adb b/gcc/ada/bindo-augmentors.adb new file mode 100644 index 0000000..f97f0d0 --- /dev/null +++ b/gcc/ada/bindo-augmentors.adb @@ -0,0 +1,372 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . A U G M E N T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Output; use Output; +with Types; use Types; + +with Bindo.Writers; use Bindo.Writers; + +with GNAT; use GNAT; +with GNAT.Sets; use GNAT.Sets; + +package body Bindo.Augmentors is + + ------------------------------ + -- Library_Graph_Augmentors -- + ------------------------------ + + package body Library_Graph_Augmentors is + + ----------------- + -- Visited set -- + ----------------- + + package VS is new Membership_Sets + (Element_Type => Invocation_Graph_Vertex_Id, + "=" => "=", + Hash => Hash_Invocation_Graph_Vertex); + use VS; + + ----------------- + -- Global data -- + ----------------- + + Inv_Graph : Invocation_Graph := Invocation_Graphs.Nil; + Lib_Graph : Library_Graph := Library_Graphs.Nil; + Visited : Membership_Set := VS.Nil; + + ---------------- + -- Statistics -- + ---------------- + + Longest_Path : Natural := 0; + -- The length of the longest path found during the traversal of the + -- invocation graph. + + Total_Visited : Natural := 0; + -- The number of visited invocation graph vertices during the process + -- of augmentation. + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Is_Visited + (IGV_Id : Invocation_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Visited); + -- Determine whether invocation graph vertex IGV_Id has been visited + -- during the traversal. + + procedure Set_Is_Visited + (IGV_Id : Invocation_Graph_Vertex_Id; + Val : Boolean := True); + pragma Inline (Set_Is_Visited); + -- Mark invocation graph vertex IGV_Id as visited during the traversal + -- depending on value Val. + + procedure Visit_Elaboration_Root (Root : Invocation_Graph_Vertex_Id); + pragma Inline (Visit_Elaboration_Root); + -- Start a DFS traversal from elaboration root Root to: + -- + -- * Detect transitions between units. + -- + -- * Create invocation edges for each such transition where the + -- successor is Root. + + procedure Visit_Elaboration_Roots; + pragma Inline (Visit_Elaboration_Roots); + -- Start a DFS traversal from all elaboration roots to: + -- + -- * Detect transitions between units. + -- + -- * Create invocation edges for each such transition where the + -- successor is the current root. + + procedure Visit_Vertex + (Curr_IGV_Id : Invocation_Graph_Vertex_Id; + Last_LGV_Id : Library_Graph_Vertex_Id; + Root_LGV_Id : Library_Graph_Vertex_Id; + Internal_Ctrl : Boolean; + Path : Natural); + pragma Inline (Visit_Vertex); + -- Visit invocation graph vertex Curr_IGV_Id to: + -- + -- * Detect a transition from the last library graph vertex denoted by + -- Last_LGV_Id to the library graph vertex of Curr_IGV_Id. + -- + -- * Create an invocation edge in library graph Lib_Graph to reflect + -- the transition, where the predecessor is the library graph vertex + -- or Curr_IGV_Id, and the successor is Root_LGV_Id. + -- + -- * Visit the neighbours of Curr_IGV_Id. + -- + -- Flag Internal_Ctrl should be set when the DFS traversal visited an + -- internal controlled invocation edge. Path denotes the length of the + -- path. + + procedure Write_Statistics; + pragma Inline (Write_Statistics); + -- Write the statistical information of the augmentation to standard + -- output. + + --------------------------- + -- Augment_Library_Graph -- + --------------------------- + + procedure Augment_Library_Graph + (Inv_G : Invocation_Graph; + Lib_G : Library_Graph) + is + begin + pragma Assert (Present (Lib_G)); + + -- Nothing to do when there is no invocation graph + + if not Present (Inv_G) then + return; + end if; + + -- Prepare the global data. Note that Visited is initialized for each + -- elaboration root. + + Inv_Graph := Inv_G; + Lib_Graph := Lib_G; + Longest_Path := 0; + Total_Visited := 0; + + Visit_Elaboration_Roots; + Write_Statistics; + end Augment_Library_Graph; + + ---------------- + -- Is_Visited -- + ---------------- + + function Is_Visited + (IGV_Id : Invocation_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (Visited)); + pragma Assert (Present (IGV_Id)); + + return Contains (Visited, IGV_Id); + end Is_Visited; + + -------------------- + -- Set_Is_Visited -- + -------------------- + + procedure Set_Is_Visited + (IGV_Id : Invocation_Graph_Vertex_Id; + Val : Boolean := True) + is + begin + pragma Assert (Present (Visited)); + pragma Assert (Present (IGV_Id)); + + if Val then + Insert (Visited, IGV_Id); + else + Delete (Visited, IGV_Id); + end if; + end Set_Is_Visited; + + ---------------------------- + -- Visit_Elaboration_Root -- + ---------------------------- + + procedure Visit_Elaboration_Root (Root : Invocation_Graph_Vertex_Id) is + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Root)); + pragma Assert (Present (Lib_Graph)); + + Root_LGV_Id : constant Library_Graph_Vertex_Id := + Lib_Vertex (Inv_Graph, Root); + + pragma Assert (Present (Root_LGV_Id)); + + begin + -- Prepare the global data + + Visited := Create (Number_Of_Vertices (Inv_Graph)); + + Visit_Vertex + (Curr_IGV_Id => Root, + Last_LGV_Id => Root_LGV_Id, + Root_LGV_Id => Root_LGV_Id, + Internal_Ctrl => False, + Path => 0); + + Destroy (Visited); + end Visit_Elaboration_Root; + + ----------------------------- + -- Visit_Elaboration_Roots -- + ----------------------------- + + procedure Visit_Elaboration_Roots is + Iter : Elaboration_Root_Iterator; + Root : Invocation_Graph_Vertex_Id; + + begin + pragma Assert (Present (Inv_Graph)); + + Iter := Iterate_Elaboration_Roots (Inv_Graph); + while Has_Next (Iter) loop + Next (Iter, Root); + pragma Assert (Present (Root)); + + Visit_Elaboration_Root (Root); + end loop; + end Visit_Elaboration_Roots; + + ------------------ + -- Visit_Vertex -- + ------------------ + + procedure Visit_Vertex + (Curr_IGV_Id : Invocation_Graph_Vertex_Id; + Last_LGV_Id : Library_Graph_Vertex_Id; + Root_LGV_Id : Library_Graph_Vertex_Id; + Internal_Ctrl : Boolean; + Path : Natural) + is + New_Path : constant Natural := Path + 1; + + Curr_LGV_Id : Library_Graph_Vertex_Id; + IGE_Id : Invocation_Graph_Edge_Id; + Iter : Edges_To_Targets_Iterator; + Targ : Invocation_Graph_Vertex_Id; + + begin + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Curr_IGV_Id)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Last_LGV_Id)); + pragma Assert (Present (Root_LGV_Id)); + + -- Nothing to do when the current invocation graph vertex has already + -- been visited. + + if Is_Visited (Curr_IGV_Id) then + return; + end if; + + Set_Is_Visited (Curr_IGV_Id); + + -- Update the statistics + + Longest_Path := Natural'Max (Longest_Path, New_Path); + Total_Visited := Total_Visited + 1; + + -- The library graph vertex of the current invocation graph vertex + -- differs from that of the previous invocation graph vertex. This + -- indicates that elaboration is transitioning from one unit to + -- another. Add a library graph edge to capture this dependency. + + Curr_LGV_Id := Lib_Vertex (Inv_Graph, Curr_IGV_Id); + pragma Assert (Present (Curr_LGV_Id)); + + if Curr_LGV_Id /= Last_LGV_Id then + + -- The path ultimately reaches back into the unit where the root + -- resides, resulting in a self dependency. In most cases this is + -- a valid circularity, except when the path went through one of + -- the Deep_xxx finalization-related routines. Do not create a + -- library graph edge because the circularity is the result of + -- expansion and thus spurious. + + if Curr_LGV_Id = Root_LGV_Id and then Internal_Ctrl then + null; + + -- Otherwise create the library graph edge, even if this results + -- in a self dependency. + + else + Add_Edge + (G => Lib_Graph, + Pred => Curr_LGV_Id, + Succ => Root_LGV_Id, + Kind => Invocation_Edge); + end if; + end if; + + -- Extend the DFS traversal to all targets of the invocation graph + -- vertex. + + Iter := Iterate_Edges_To_Targets (Inv_Graph, Curr_IGV_Id); + while Has_Next (Iter) loop + Next (Iter, IGE_Id); + pragma Assert (Present (IGE_Id)); + + Targ := Target (Inv_Graph, IGE_Id); + pragma Assert (Present (Targ)); + + Visit_Vertex + (Curr_IGV_Id => Targ, + Last_LGV_Id => Curr_LGV_Id, + Root_LGV_Id => Root_LGV_Id, + Internal_Ctrl => + Internal_Ctrl + or else Kind (Inv_Graph, IGE_Id) in + Internal_Controlled_Invocation_Kind, + Path => New_Path); + end loop; + end Visit_Vertex; + + ---------------------- + -- Write_Statistics -- + ---------------------- + + procedure Write_Statistics is + begin + -- Nothing to do when switch -d_L (output library item graph) is not + -- in effect. + + if not Debug_Flag_Underscore_LL then + return; + end if; + + Write_Str ("Library Graph Augmentation"); + Write_Eol; + Write_Eol; + + Write_Str ("Vertices visited : "); + Write_Num (Int (Total_Visited)); + Write_Eol; + + Write_Str ("Longest path length: "); + Write_Num (Int (Longest_Path)); + Write_Eol; + Write_Eol; + + Write_Str ("Library Graph Augmentation end"); + Write_Eol; + Write_Eol; + end Write_Statistics; + end Library_Graph_Augmentors; + +end Bindo.Augmentors; diff --git a/gcc/ada/bindo-augmentors.ads b/gcc/ada/bindo-augmentors.ads new file mode 100644 index 0000000..de6317c --- /dev/null +++ b/gcc/ada/bindo-augmentors.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . A U G M E N T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to enhance the library graph, which +-- reflects source dependencies between units, with information obtained from +-- the invocation graph, which reflects all activations of tasks, calls, and +-- instantiations within units. + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Invocation_Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Augmentors is + + ------------------------------ + -- Library_Graph_Augmentors -- + ------------------------------ + + package Library_Graph_Augmentors is + procedure Augment_Library_Graph + (Inv_G : Invocation_Graph; + Lib_G : Library_Graph); + -- Augment library graph Lib_G with information from invocation graph + -- Inv_G as follows: + -- + -- 1) Traverse the invocation graph starting from each elaboration + -- procedure of unit Root. + -- + -- 2) Each time the traversal transitions from one unit into another + -- unit Curr, add an invocation edge between predecessor Curr and + -- successor Root in the library graph. + -- + -- 3) Do the above steps for all units with an elaboration procedure. + + end Library_Graph_Augmentors; + +end Bindo.Augmentors; diff --git a/gcc/ada/bindo-builders.adb b/gcc/ada/bindo-builders.adb new file mode 100644 index 0000000..c0340c0 --- /dev/null +++ b/gcc/ada/bindo-builders.adb @@ -0,0 +1,748 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . B U I L D E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Binderr; use Binderr; +with Butil; use Butil; +with Opt; use Opt; +with Output; use Output; +with Types; use Types; + +with Bindo.Units; use Bindo.Units; + +with GNAT; use GNAT; +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; + +package body Bindo.Builders is + + ------------------------------- + -- Invocation_Graph_Builders -- + ------------------------------- + + package body Invocation_Graph_Builders is + + ----------------- + -- Global data -- + ----------------- + + Inv_Graph : Invocation_Graph := Invocation_Graphs.Nil; + Lib_Graph : Library_Graph := Library_Graphs.Nil; + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Create_Edge (IR_Id : Invocation_Relation_Id); + pragma Inline (Create_Edge); + -- Create a new edge for invocation relation IR_Id in invocation graph + -- Inv_Graph. + + procedure Create_Edges (U_Id : Unit_Id); + pragma Inline (Create_Edges); + -- Create new edges for all invocation relations of unit U_Id + + procedure Create_Vertex + (IC_Id : Invocation_Construct_Id; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Create_Vertex); + -- Create a new vertex for invocation construct IC_Id in invocation + -- graph Inv_Graph. The vertex is linked to vertex LGV_Id of library + -- graph Lib_Graph. + + procedure Create_Vertices (U_Id : Unit_Id); + pragma Inline (Create_Vertices); + -- Create new vertices for all invocation constructs of unit U_Id in + -- invocation graph Inv_Graph. + + ---------------------------- + -- Build_Invocation_Graph -- + ---------------------------- + + function Build_Invocation_Graph + (Lib_G : Library_Graph) return Invocation_Graph + is + begin + pragma Assert (Present (Lib_G)); + + -- Prepare the global data + + Inv_Graph := + Create (Initial_Vertices => Number_Of_Elaborable_Units, + Initial_Edges => Number_Of_Elaborable_Units); + Lib_Graph := Lib_G; + + For_Each_Elaborable_Unit (Create_Vertices'Access); + For_Each_Elaborable_Unit (Create_Edges'Access); + + return Inv_Graph; + end Build_Invocation_Graph; + + ----------------- + -- Create_Edge -- + ----------------- + + procedure Create_Edge (IR_Id : Invocation_Relation_Id) is + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (IR_Id)); + + IR_Rec : Invocation_Relation_Record renames + Invocation_Relations.Table (IR_Id); + + pragma Assert (Present (IR_Rec.Invoker)); + pragma Assert (Present (IR_Rec.Target)); + + Invoker : Invocation_Graph_Vertex_Id; + Target : Invocation_Graph_Vertex_Id; + + begin + -- Nothing to do when the target denotes an invocation construct that + -- resides in a unit which will never be elaborated. + + if not Needs_Elaboration (IR_Rec.Target) then + return; + end if; + + Invoker := Corresponding_Vertex (Inv_Graph, IR_Rec.Invoker); + Target := Corresponding_Vertex (Inv_Graph, IR_Rec.Target); + + pragma Assert (Present (Invoker)); + pragma Assert (Present (Target)); + + Add_Edge + (G => Inv_Graph, + Source => Invoker, + Target => Target, + IR_Id => IR_Id); + end Create_Edge; + + ------------------ + -- Create_Edges -- + ------------------ + + procedure Create_Edges (U_Id : Unit_Id) is + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + for IR_Id in U_Rec.First_Invocation_Relation .. + U_Rec.Last_Invocation_Relation + loop + Create_Edge (IR_Id); + end loop; + end Create_Edges; + + ------------------- + -- Create_Vertex -- + ------------------- + + procedure Create_Vertex + (IC_Id : Invocation_Construct_Id; + LGV_Id : Library_Graph_Vertex_Id) + is + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (IC_Id)); + pragma Assert (Present (LGV_Id)); + + IC_Rec : Invocation_Construct_Record renames + Invocation_Constructs.Table (IC_Id); + + Body_LGV_Id : Library_Graph_Vertex_Id; + + begin + -- Determine the proper library graph vertex which holds the body of + -- the invocation construct. + + if IC_Rec.Placement = In_Body then + Body_LGV_Id := Proper_Body (Lib_Graph, LGV_Id); + else + pragma Assert (IC_Rec.Placement = In_Spec); + Body_LGV_Id := Proper_Spec (Lib_Graph, LGV_Id); + end if; + + pragma Assert (Present (Body_LGV_Id)); + + Add_Vertex + (G => Inv_Graph, + IC_Id => IC_Id, + LGV_Id => Body_LGV_Id); + end Create_Vertex; + + --------------------- + -- Create_Vertices -- + --------------------- + + procedure Create_Vertices (U_Id : Unit_Id) is + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + LGV_Id : constant Library_Graph_Vertex_Id := + Corresponding_Vertex (Lib_Graph, U_Id); + + pragma Assert (Present (LGV_Id)); + + begin + for IC_Id in U_Rec.First_Invocation_Construct .. + U_Rec.Last_Invocation_Construct + loop + Create_Vertex (IC_Id, LGV_Id); + end loop; + end Create_Vertices; + end Invocation_Graph_Builders; + + ---------------------------- + -- Library_Graph_Builders -- + ---------------------------- + + package body Library_Graph_Builders is + + --------------------- + -- Data structures -- + --------------------- + + procedure Destroy_Line_Number (Line : in out Logical_Line_Number); + pragma Inline (Destroy_Line_Number); + -- Destroy line number Line + + function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type; + pragma Inline (Hash_Unit); + -- Obtain the hash value of key U_Id + + package UL is new Dynamic_Hash_Tables + (Key_Type => Unit_Id, + Value_Type => Logical_Line_Number, + No_Value => No_Line_Number, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Line_Number, + Hash => Hash_Unit); + + ----------------- + -- Global data -- + ----------------- + + Lib_Graph : Library_Graph := Library_Graphs.Nil; + + Unit_To_Line : UL.Dynamic_Hash_Table := UL.Nil; + -- The map of unit name -> line number, used to detect duplicate unit + -- names and report errors. + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Add_Unit + (U_Id : Unit_Id; + Line : Logical_Line_Number); + pragma Inline (Add_Unit); + -- Create a relationship between unit U_Id and its declaration line in + -- map Unit_To_Line. + + procedure Create_Forced_Edge + (Pred : Unit_Id; + Succ : Unit_Id); + pragma Inline (Create_Forced_Edge); + -- Create a new forced edge between predecessor unit Pred and successor + -- unit Succ. + + procedure Create_Forced_Edges; + pragma Inline (Create_Forced_Edges); + -- Inspect the contents of the forced-elaboration-order file, and create + -- specialized edges for each valid pair of units listed within. + + procedure Create_Spec_And_Body_Edge (U_Id : Unit_Id); + pragma Inline (Create_Spec_And_Body_Edge); + -- Establish a link between the spec and body of unit U_Id. In certain + -- cases this may result in a new edge which is added to library graph + -- Lib_Graph. + + procedure Create_Vertex (U_Id : Unit_Id); + pragma Inline (Create_Vertex); + -- Create a new vertex for unit U_Id in library graph Lib_Graph + + procedure Create_With_Edge + (W_Id : With_Id; + Succ : Library_Graph_Vertex_Id); + pragma Inline (Create_With_Edge); + -- Create a new edge for with W_Id where the predecessor is the library + -- graph vertex of the withed unit, and the successor is Succ. The edge + -- is added to library graph Lib_Graph. + + procedure Create_With_Edges (U_Id : Unit_Id); + pragma Inline (Create_With_Edges); + -- Establish links between unit U_Id and its predecessor units. The new + -- edges are added to library graph Lib_Graph. + + procedure Create_With_Edges + (U_Id : Unit_Id; + Succ : Library_Graph_Vertex_Id); + pragma Inline (Create_With_Edges); + -- Create new edges for all withs of unit U_Id where the predecessor is + -- some withed unit, and the successor is Succ. The edges are added to + -- library graph Lib_Graph. + + procedure Duplicate_Unit_Error + (U_Id : Unit_Id; + Nam : Unit_Name_Type; + Line : Logical_Line_Number); + pragma Inline (Duplicate_Unit_Error); + -- Emit an error concerning the duplication of unit U_Id with name Nam + -- that is redeclared in the forced-elaboration-order file at line Line. + + procedure Internal_Unit_Info (Nam : Unit_Name_Type); + pragma Inline (Internal_Unit_Info); + -- Emit an information message concerning the omission of an internal + -- unit with name Nam from the creation of forced edges. + + function Is_Duplicate_Unit (U_Id : Unit_Id) return Boolean; + pragma Inline (Is_Duplicate_Unit); + -- Determine whether unit U_Id is already recorded in map Unit_To_Line + + function Is_Significant_With (W_Id : With_Id) return Boolean; + pragma Inline (Is_Significant_With); + -- Determine whether with W_Id plays a significant role in elaboration + + procedure Missing_Unit_Info (Nam : Unit_Name_Type); + pragma Inline (Missing_Unit_Info); + -- Emit an information message concerning the omission of an undefined + -- unit found in the forced-elaboration-order file. + + -------------- + -- Add_Unit -- + -------------- + + procedure Add_Unit + (U_Id : Unit_Id; + Line : Logical_Line_Number) + is + begin + pragma Assert (Present (U_Id)); + + UL.Put (Unit_To_Line, U_Id, Line); + end Add_Unit; + + ------------------------- + -- Build_Library_Graph -- + ------------------------- + + function Build_Library_Graph return Library_Graph is + begin + -- Prepare the global data + + Lib_Graph := + Create (Initial_Vertices => Number_Of_Elaborable_Units, + Initial_Edges => Number_Of_Elaborable_Units); + + For_Each_Elaborable_Unit (Create_Vertex'Access); + For_Each_Elaborable_Unit (Create_Spec_And_Body_Edge'Access); + For_Each_Elaborable_Unit (Create_With_Edges'Access); + + Create_Forced_Edges; + + return Lib_Graph; + end Build_Library_Graph; + + ------------------------ + -- Create_Forced_Edge -- + ------------------------ + + procedure Create_Forced_Edge + (Pred : Unit_Id; + Succ : Unit_Id) + is + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + + Pred_LGV_Id : constant Library_Graph_Vertex_Id := + Corresponding_Vertex (Lib_Graph, Pred); + Succ_LGV_Id : constant Library_Graph_Vertex_Id := + Corresponding_Vertex (Lib_Graph, Succ); + + pragma Assert (Present (Pred_LGV_Id)); + pragma Assert (Present (Succ_LGV_Id)); + + begin + Write_Unit_Name (Name (Pred)); + Write_Str (" <-- "); + Write_Unit_Name (Name (Succ)); + Write_Eol; + + Add_Edge + (G => Lib_Graph, + Pred => Pred_LGV_Id, + Succ => Succ_LGV_Id, + Kind => Forced_Edge); + end Create_Forced_Edge; + + ------------------------- + -- Create_Forced_Edges -- + ------------------------- + + procedure Create_Forced_Edges is + Curr_Unit : Unit_Id; + Iter : Forced_Units_Iterator; + Prev_Unit : Unit_Id; + Unit_Line : Logical_Line_Number; + Unit_Name : Unit_Name_Type; + + begin + Prev_Unit := No_Unit_Id; + Unit_To_Line := UL.Create (20); + + -- Inspect the contents of the forced-elaboration-order file supplied + -- to the binder using switch -f, and diagnose each unit accordingly. + + Iter := Iterate_Forced_Units; + while Has_Next (Iter) loop + Next (Iter, Unit_Name, Unit_Line); + pragma Assert (Present (Unit_Name)); + + Curr_Unit := Corresponding_Unit (Unit_Name); + + if not Present (Curr_Unit) then + Missing_Unit_Info (Unit_Name); + + elsif Is_Internal_Unit (Curr_Unit) then + Internal_Unit_Info (Unit_Name); + + elsif Is_Duplicate_Unit (Curr_Unit) then + Duplicate_Unit_Error (Curr_Unit, Unit_Name, Unit_Line); + + -- Otherwise the unit is a valid candidate for a vertex. Create a + -- forced edge between each pair of units. + + else + Add_Unit (Curr_Unit, Unit_Line); + + if Present (Prev_Unit) then + Create_Forced_Edge + (Pred => Prev_Unit, + Succ => Curr_Unit); + end if; + + Prev_Unit := Curr_Unit; + end if; + end loop; + + UL.Destroy (Unit_To_Line); + end Create_Forced_Edges; + + ------------------------------- + -- Create_Spec_And_Body_Edge -- + ------------------------------- + + procedure Create_Spec_And_Body_Edge (U_Id : Unit_Id) is + Aux_LGV_Id : Library_Graph_Vertex_Id; + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (U_Id)); + + LGV_Id := Corresponding_Vertex (Lib_Graph, U_Id); + pragma Assert (Present (LGV_Id)); + + -- The unit denotes a body that completes a previous spec. Link the + -- spec and body. Add an edge between the predecessor spec and the + -- successor body. + + if Is_Body_With_Spec (Lib_Graph, LGV_Id) then + Aux_LGV_Id := + Corresponding_Vertex (Lib_Graph, Corresponding_Spec (U_Id)); + pragma Assert (Present (Aux_LGV_Id)); + + Set_Corresponding_Item (Lib_Graph, LGV_Id, Aux_LGV_Id); + + Add_Edge + (G => Lib_Graph, + Pred => Aux_LGV_Id, + Succ => LGV_Id, + Kind => Spec_Before_Body_Edge); + + -- The unit denotes a spec with a completing body. Link the spec and + -- body. + + elsif Is_Spec_With_Body (Lib_Graph, LGV_Id) then + Aux_LGV_Id := + Corresponding_Vertex (Lib_Graph, Corresponding_Body (U_Id)); + pragma Assert (Present (Aux_LGV_Id)); + + Set_Corresponding_Item (Lib_Graph, LGV_Id, Aux_LGV_Id); + end if; + end Create_Spec_And_Body_Edge; + + ------------------- + -- Create_Vertex -- + ------------------- + + procedure Create_Vertex (U_Id : Unit_Id) is + begin + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (U_Id)); + + Add_Vertex + (G => Lib_Graph, + U_Id => U_Id); + end Create_Vertex; + + ---------------------- + -- Create_With_Edge -- + ---------------------- + + procedure Create_With_Edge + (W_Id : With_Id; + Succ : Library_Graph_Vertex_Id) + is + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (W_Id)); + pragma Assert (Present (Succ)); + + Withed_Rec : With_Record renames Withs.Table (W_Id); + Withed_U_Id : constant Unit_Id := + Corresponding_Unit (Withed_Rec.Uname); + + pragma Assert (Present (Withed_U_Id)); + + Aux_LGV_Id : Library_Graph_Vertex_Id; + Kind : Library_Graph_Edge_Kind; + Withed_LGV_Id : Library_Graph_Vertex_Id; + + begin + -- Nothing to do when the withed unit does not need to be elaborated. + -- This prevents spurious dependencies that can never be satisfied. + + if not Needs_Elaboration (Withed_U_Id) then + return; + end if; + + Withed_LGV_Id := Corresponding_Vertex (Lib_Graph, Withed_U_Id); + pragma Assert (Present (Withed_LGV_Id)); + + -- The with comes with pragma Elaborate + + if Withed_Rec.Elaborate then + Kind := Elaborate_Edge; + + -- The withed unit is a spec with a completing body. Add an edge + -- between the body of the withed predecessor and the withing + -- successor. + + if Is_Spec_With_Body (Lib_Graph, Withed_LGV_Id) then + Aux_LGV_Id := + Corresponding_Vertex + (Lib_Graph, Corresponding_Body (Withed_U_Id)); + pragma Assert (Present (Aux_LGV_Id)); + + Add_Edge + (G => Lib_Graph, + Pred => Aux_LGV_Id, + Succ => Succ, + Kind => Kind); + end if; + + -- The with comes with pragma Elaborate_All + + elsif Withed_Rec.Elaborate_All then + Kind := Elaborate_All_Edge; + + -- Otherwise this is a regular with + + else + Kind := With_Edge; + end if; + + -- Add an edge between the withed predecessor unit and the withing + -- successor. + + Add_Edge + (G => Lib_Graph, + Pred => Withed_LGV_Id, + Succ => Succ, + Kind => Kind); + end Create_With_Edge; + + ----------------------- + -- Create_With_Edges -- + ----------------------- + + procedure Create_With_Edges (U_Id : Unit_Id) is + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (U_Id)); + + LGV_Id := Corresponding_Vertex (Lib_Graph, U_Id); + pragma Assert (Present (LGV_Id)); + + Create_With_Edges + (U_Id => U_Id, + Succ => LGV_Id); + end Create_With_Edges; + + ----------------------- + -- Create_With_Edges -- + ----------------------- + + procedure Create_With_Edges + (U_Id : Unit_Id; + Succ : Library_Graph_Vertex_Id) + is + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (U_Id)); + pragma Assert (Present (Succ)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + for W_Id in U_Rec.First_With .. U_Rec.Last_With loop + if Is_Significant_With (W_Id) then + Create_With_Edge (W_Id, Succ); + end if; + end loop; + end Create_With_Edges; + + ------------------ + -- Destroy_Unit -- + ------------------ + + procedure Destroy_Line_Number (Line : in out Logical_Line_Number) is + pragma Unreferenced (Line); + begin + null; + end Destroy_Line_Number; + + -------------------------- + -- Duplicate_Unit_Error -- + -------------------------- + + procedure Duplicate_Unit_Error + (U_Id : Unit_Id; + Nam : Unit_Name_Type; + Line : Logical_Line_Number) + is + pragma Assert (Present (U_Id)); + pragma Assert (Present (Nam)); + + Prev_Line : constant Logical_Line_Number := + UL.Get (Unit_To_Line, U_Id); + + begin + Error_Msg_Nat_1 := Nat (Line); + Error_Msg_Nat_2 := Nat (Prev_Line); + Error_Msg_Unit_1 := Nam; + + Error_Msg + (Force_Elab_Order_File.all + & ":#: duplicate unit name $ from line #"); + end Duplicate_Unit_Error; + + --------------- + -- Hash_Unit -- + --------------- + + function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type is + begin + pragma Assert (Present (U_Id)); + + return Bucket_Range_Type (U_Id); + end Hash_Unit; + + ------------------------ + -- Internal_Unit_Info -- + ------------------------ + + procedure Internal_Unit_Info (Nam : Unit_Name_Type) is + begin + pragma Assert (Present (Nam)); + + Write_Line + ("""" & Get_Name_String (Nam) & """: predefined unit ignored"); + end Internal_Unit_Info; + + ----------------------- + -- Is_Duplicate_Unit -- + ----------------------- + + function Is_Duplicate_Unit (U_Id : Unit_Id) return Boolean is + begin + pragma Assert (Present (U_Id)); + + return UL.Contains (Unit_To_Line, U_Id); + end Is_Duplicate_Unit; + + ------------------------- + -- Is_Significant_With -- + ------------------------- + + function Is_Significant_With (W_Id : With_Id) return Boolean is + pragma Assert (Present (W_Id)); + + Withed_Rec : With_Record renames Withs.Table (W_Id); + Withed_U_Id : constant Unit_Id := + Corresponding_Unit (Withed_Rec.Uname); + + begin + -- Nothing to do for a unit which does not exist any more + + if not Present (Withed_U_Id) then + return False; + + -- Nothing to do for a limited with + + elsif Withed_Rec.Limited_With then + return False; + + -- Nothing to do when the unit does not need to be elaborated + + elsif not Needs_Elaboration (Withed_U_Id) then + return False; + end if; + + return True; + end Is_Significant_With; + + ----------------------- + -- Missing_Unit_Info -- + ----------------------- + + procedure Missing_Unit_Info (Nam : Unit_Name_Type) is + begin + pragma Assert (Present (Nam)); + + Write_Line + ("""" & Get_Name_String (Nam) & """: not present; ignored"); + end Missing_Unit_Info; + end Library_Graph_Builders; + +end Bindo.Builders; diff --git a/gcc/ada/bindo-builders.ads b/gcc/ada/bindo-builders.ads new file mode 100644 index 0000000..54c39e4 --- /dev/null +++ b/gcc/ada/bindo-builders.ads @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . B U I L D E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to create various graphs that +-- reflect dependencies between units, as well as activations of tasks, +-- calls, and instantiations within them. + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Invocation_Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Builders is + + ------------------------------- + -- Invocation_Graph_Builders -- + ------------------------------- + + package Invocation_Graph_Builders is + function Build_Invocation_Graph + (Lib_G : Library_Graph) return Invocation_Graph; + -- Return a new invocation graph that reflects the activations of + -- tasks, calls, and instantiations in all units of the bind. Each + -- invocation graph vertex is linked with the corresponding vertex + -- of library graph Lib_G, which contains the body of the activated + -- task, invoked subprogram, or instantiated generic. + + end Invocation_Graph_Builders; + + ---------------------------- + -- Library_Graph_Builders -- + ---------------------------- + + package Library_Graph_Builders is + function Build_Library_Graph return Library_Graph; + -- Return a new library graph that reflects the dependencies between + -- all units of the bind. + + end Library_Graph_Builders; + +end Bindo.Builders; diff --git a/gcc/ada/bindo-diagnostics.adb b/gcc/ada/bindo-diagnostics.adb new file mode 100644 index 0000000..bf11d39 --- /dev/null +++ b/gcc/ada/bindo-diagnostics.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . D I A G N O S T I C S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Bindo.Diagnostics is + + ----------------------- + -- Cycle_Diagnostics -- + ----------------------- + + package body Cycle_Diagnostics is + + ----------------------------- + -- Has_Elaborate_All_Cycle -- + ----------------------------- + + function Has_Elaborate_All_Cycle (G : Library_Graph) return Boolean is + Has_Cycle : Boolean; + Iter : All_Edge_Iterator; + LGE_Id : Library_Graph_Edge_Id; + + begin + pragma Assert (Present (G)); + + -- Assume that the graph lacks a cycle + + Has_Cycle := False; + + -- The library graph has an Elaborate_All cycle when one of its edges + -- represents a with clause for a unit with pragma Elaborate_All, and + -- both the predecessor and successor reside in the same component. + -- Note that the iteration must run to completion in order to unlock + -- the graph. + + Iter := Iterate_All_Edges (G); + while Has_Next (Iter) loop + Next (Iter, LGE_Id); + pragma Assert (Present (LGE_Id)); + + if Kind (G, LGE_Id) = Elaborate_All_Edge + and then Links_Vertices_In_Same_Component (G, LGE_Id) + then + Has_Cycle := True; + end if; + end loop; + + return Has_Cycle; + end Has_Elaborate_All_Cycle; + end Cycle_Diagnostics; + +end Bindo.Diagnostics; diff --git a/gcc/ada/bindo-diagnostics.ads b/gcc/ada/bindo-diagnostics.ads new file mode 100644 index 0000000..3b1d01c --- /dev/null +++ b/gcc/ada/bindo-diagnostics.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . D I A G N O S T I C S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to diagnose various issues with the +-- elaboration order. + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Diagnostics is + + ----------- + -- Types -- + ----------- + + -- The following type enumerates all possible statuses of the elaboration + -- order. + + type Elaboration_Order_Status is + (Order_Has_Circularity, + Order_Has_Elaborate_All_Circularity, + Order_OK); + + ----------------------- + -- Cycle_Diagnostics -- + ----------------------- + + package Cycle_Diagnostics is + function Has_Elaborate_All_Cycle (G : Library_Graph) return Boolean; + pragma Inline (Has_Elaborate_All_Cycle); + -- Determine whether library graph G contains a cycle where pragma + -- Elaborate_All appears within a component. + + end Cycle_Diagnostics; + +end Bindo.Diagnostics; diff --git a/gcc/ada/bindo-elaborators.adb b/gcc/ada/bindo-elaborators.adb new file mode 100644 index 0000000..b11598c --- /dev/null +++ b/gcc/ada/bindo-elaborators.adb @@ -0,0 +1,1418 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . E L A B O R A T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Binderr; use Binderr; +with Butil; use Butil; +with Debug; use Debug; +with Output; use Output; +with Types; use Types; + +with Bindo.Augmentors; +use Bindo.Augmentors; +use Bindo.Augmentors.Library_Graph_Augmentors; + +with Bindo.Builders; +use Bindo.Builders; +use Bindo.Builders.Invocation_Graph_Builders; +use Bindo.Builders.Library_Graph_Builders; + +with Bindo.Diagnostics; +use Bindo.Diagnostics; +use Bindo.Diagnostics.Cycle_Diagnostics; + +with Bindo.Units; +use Bindo.Units; + +with Bindo.Validators; +use Bindo.Validators; +use Bindo.Validators.Elaboration_Order_Validators; +use Bindo.Validators.Invocation_Graph_Validators; +use Bindo.Validators.Library_Graph_Validators; + +with Bindo.Writers; +use Bindo.Writers; +use Bindo.Writers.ALI_Writers; +use Bindo.Writers.Elaboration_Order_Writers; +use Bindo.Writers.Invocation_Graph_Writers; +use Bindo.Writers.Library_Graph_Writers; +use Bindo.Writers.Unit_Closure_Writers; + +with GNAT; use GNAT; +with GNAT.Graphs; use GNAT.Graphs; +with GNAT.Sets; use GNAT.Sets; + +package body Bindo.Elaborators is + + -- The following type defines the advancement of the elaboration order + -- algorithm in terms of steps. + + type Elaboration_Order_Step is new Natural; + + Initial_Step : constant Elaboration_Order_Step := + Elaboration_Order_Step'First; + + ---------------------------------------------- + -- Invocation_And_Library_Graph_Elaborators -- + ---------------------------------------------- + + package body Invocation_And_Library_Graph_Elaborators is + Add_To_All_Candidates_Msg : aliased String := + "add vertex to all candidates"; + Add_To_Comp_Candidates_Msg : aliased String := + "add vertex to component candidates"; + + ----------- + -- Types -- + ----------- + + type String_Ptr is access all String; + + ----------------- + -- Visited set -- + ----------------- + + package VS is new Membership_Sets + (Element_Type => Library_Graph_Vertex_Id, + "=" => "=", + Hash => Hash_Library_Graph_Vertex); + use VS; + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Add_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Set : Membership_Set; + Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); + pragma Inline (Add_Vertex); + -- Add vertex LGV_Id of library graph G to membership set Set. Msg is + -- a message emitted for tracing purposes. Step is the current step in + -- the elaboration order. Indent is the desired indentation level for + -- tracing. + + procedure Add_Vertex_If_Elaborable + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Set : Membership_Set; + Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); + pragma Inline (Add_Vertex_If_Elaborable); + -- Add vertex LGV_Id of library graph G to membership set Set if it can + -- be elaborated. Msg is a message emitted for tracing purposes. Step is + -- the current step in the elaboration order. Indent is the desired + -- indentation level for tracing. + + function Create_All_Candidates_Set + (G : Library_Graph; + Step : Elaboration_Order_Step) return Membership_Set; + pragma Inline (Create_All_Candidates_Set); + -- Collect all elaborable candidate vertices of library graph G in a + -- set. Step is the current step in the elaboration order. + + function Create_Component_Candidates_Set + (G : Library_Graph; + Comp : Component_Id; + Step : Elaboration_Order_Step) return Membership_Set; + pragma Inline (Create_Component_Candidates_Set); + -- Collect all elaborable candidate vertices that appear in component + -- Comp of library graph G in a set. Step is the current step in the + -- elaboration order. + + procedure Elaborate_Component + (G : Library_Graph; + Comp : Component_Id; + All_Candidates : Membership_Set; + Remaining_Vertices : in out Natural; + Order : in out Unit_Id_Table; + Step : Elaboration_Order_Step); + pragma Inline (Elaborate_Component); + -- Elaborate as many vertices as possible that appear in component + -- Comp of library graph G. All_Candidates is the set of all elaborable + -- vertices across the whole library graph. Remaining_Vertices is the + -- number of vertices that remain to be elaborated. Order denotes the + -- elaboration order. Step is the current step in the elaboration order. + + procedure Elaborate_Library_Graph + (G : Library_Graph; + Order : out Unit_Id_Table; + Status : out Elaboration_Order_Status); + pragma Inline (Elaborate_Library_Graph); + -- Elaborate as many vertices as possible of library graph G. Order is + -- the elaboration order. Status is the condition of the elaboration + -- order. + + procedure Elaborate_Units_Common + (Use_Inv_Graph : Boolean; + Inv_Graph : out Invocation_Graph; + Lib_Graph : out Library_Graph; + Order : out Unit_Id_Table; + Status : out Elaboration_Order_Status); + pragma Inline (Elaborate_Units_Common); + -- Find the elaboration order of all units in the bind. Use_Inv_Graph + -- should be set when library graph Lib_Graph is to be augmented with + -- information from invocation graph Inv_Graph. Order is the elaboration + -- order. Status is the condition of the elaboration order. + + procedure Elaborate_Units_Dynamic (Order : out Unit_Id_Table); + pragma Inline (Elaborate_Units_Dynamic); + -- Find the elaboration order of all units in the bind using the dynamic + -- model. Order is the elaboration order. In the event where no ordering + -- is possible, this routine diagnoses the issue(s) and raises exception + -- Unrecoverable_Error. + + procedure Elaborate_Units_Static (Order : out Unit_Id_Table); + pragma Inline (Elaborate_Units_Static); + -- Find the elaboration order of all units in the bind using the static + -- model. Order is the elaboration order. In the event where no ordering + -- is possible, this routine diagnoses the issue(s) and raises exception + -- Unrecoverable_Error. + + procedure Elaborate_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + All_Candidates : Membership_Set; + Comp_Candidates : Membership_Set; + Remaining_Vertices : in out Natural; + Order : in out Unit_Id_Table; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); + pragma Inline (Elaborate_Vertex); + -- Elaborate vertex LGV_Id of library graph G by adding its unit to + -- elaboration order Order. The routine updates awaiting successors + -- where applicable. All_Candidates denotes the set of all elaborable + -- vertices across the whole library graph. Comp_Candidates is the set + -- of all elaborable vertices in the component of LGV_Id. Parameter + -- Remaining_Vertices denotes the number of vertices that remain to + -- be elaborated. Step is the current step in the elaboration order. + -- Indent is the desired indentation level for tracing. + + function Find_Best_Candidate + (G : Library_Graph; + Set : Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) return Library_Graph_Vertex_Id; + pragma Inline (Find_Best_Candidate); + -- Find the most suitable vertex of library graph G for elaboration from + -- membership set Set. Step denotes the current step in the elaboration + -- order. Indent is the desired indentation level for tracing. + + function Is_Better_Candidate + (G : Library_Graph; + Best_Candid : Library_Graph_Vertex_Id; + New_Candid : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Better_Candidate); + -- Determine whether new candidate vertex New_Candid of library graph + -- G is a more suitable choice for elaboration compared to the current + -- best candidate Best_Candid. + + procedure Trace_Candidate_Vertices + (G : Library_Graph; + Set : Membership_Set; + Step : Elaboration_Order_Step); + pragma Inline (Trace_Candidate_Vertices); + -- Write the candidate vertices of library graph G present in membership + -- set Set to standard output. Formal Step denotes the current step in + -- the elaboration order. + + procedure Trace_Component + (G : Library_Graph; + Comp : Component_Id; + Msg : String; + Step : Elaboration_Order_Step); + pragma Inline (Trace_Component); + -- Write elaboration-related information for component Comp of library + -- graph G to standard output, starting with message Msg. Step is the + -- current step in the elaboration order. + + procedure Trace_Step (Step : Elaboration_Order_Step); + pragma Inline (Trace_Step); + -- Write current step Step of the elaboration order to standard output + + procedure Trace_Unelaborated_Vertices + (G : Library_Graph; + Count : Natural; + Step : Elaboration_Order_Step); + pragma Inline (Trace_Unelaborated_Vertices); + -- Write the remaining unelaborated vertices of library graph G to + -- standard output. Count is the number of vertices that remain to + -- be elaborated. Step is the current step in the elaboration order. + + procedure Trace_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); + pragma Inline (Trace_Vertex); + -- Write elaboration-related information for vertex LGV_Id of library + -- graph G to standard output, starting with message Msg. Step is the + -- current step in the elaboration order. Indent denotes the desired + -- indentation level for tracing. + + procedure Update_Successor + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + All_Candidates : Membership_Set; + Comp_Candidates : Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); + pragma Inline (Update_Successor); + -- Notify successor vertex Succ of library graph G along with its + -- component that their predecessor Pred has just been elaborated. + -- This may cause new vertices to become elaborable, and thus be added + -- to one of the two sets. All_Candidates is the set of all elaborable + -- vertices across the whole library graph. Comp_Candidates is the set + -- of all elaborable vertices in the component of Pred. Step is the + -- current step in the elaboration order. Indent denotes the desired + -- indentation level for tracing. + + procedure Update_Successors + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + All_Candidates : Membership_Set; + Comp_Candidates : Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); + pragma Inline (Update_Successors); + -- Notify all successors along with their components that their + -- predecessor vertex Pred of ligrary graph G has just been elaborated. + -- This may cause new vertices to become elaborable, and thus be added + -- to one of the two sets. All_Candidates is the set of all elaborable + -- vertices across the whole library graph. Comp_Candidates is the set + -- of all elaborable vertices in the component of Pred. Step is the + -- current step in the elaboration order. Indent denotes the desired + -- indentation level for tracing. + + ---------------- + -- Add_Vertex -- + ---------------- + + procedure Add_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Set : Membership_Set; + Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + is + begin + pragma Assert (Present (LGV_Id)); + pragma Assert (Needs_Elaboration (G, LGV_Id)); + pragma Assert (Present (Set)); + + -- Add vertex only when it is not present in the set. This is not + -- strictly necessary because the set implementation handles this + -- case, however the check eliminates spurious traces. + + if not Contains (Set, LGV_Id) then + Trace_Vertex + (G => G, + LGV_Id => LGV_Id, + Msg => Msg, + Step => Step, + Indent => Indent); + + Insert (Set, LGV_Id); + end if; + end Add_Vertex; + + ------------------------------ + -- Add_Vertex_If_Elaborable -- + ------------------------------ + + procedure Add_Vertex_If_Elaborable + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Set : Membership_Set; + Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + is + Aux_LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + pragma Assert (Needs_Elaboration (G, LGV_Id)); + pragma Assert (Present (Set)); + + if Is_Elaborable_Vertex (G, LGV_Id) then + Add_Vertex + (G => G, + LGV_Id => LGV_Id, + Set => Set, + Msg => Msg, + Step => Step, + Indent => Indent); + + -- Assume that there is no extra vertex that needs to be added + + Aux_LGV_Id := No_Library_Graph_Vertex; + + -- A spec-body pair where the spec carries pragma Elaborate_Body + -- must be treated as one vertex for elaboration purposes. If one + -- of them is elaborable, then the other is also elaborable. This + -- property is guaranteed by predicate Is_Elaborable_Vertex. + + if Is_Body_Of_Spec_With_Elaborate_Body (G, LGV_Id) then + Aux_LGV_Id := Proper_Spec (G, LGV_Id); + pragma Assert (Present (Aux_LGV_Id)); + + elsif Is_Spec_With_Elaborate_Body (G, LGV_Id) then + Aux_LGV_Id := Proper_Body (G, LGV_Id); + pragma Assert (Present (Aux_LGV_Id)); + end if; + + if Present (Aux_LGV_Id) then + pragma Assert (Needs_Elaboration (G, Aux_LGV_Id)); + + Add_Vertex + (G => G, + LGV_Id => Aux_LGV_Id, + Set => Set, + Msg => Msg, + Step => Step, + Indent => Indent); + end if; + end if; + end Add_Vertex_If_Elaborable; + + ------------------------------- + -- Create_All_Candidates_Set -- + ------------------------------- + + function Create_All_Candidates_Set + (G : Library_Graph; + Step : Elaboration_Order_Step) return Membership_Set + is + Iter : Library_Graphs.All_Vertex_Iterator; + LGV_Id : Library_Graph_Vertex_Id; + Set : Membership_Set; + + begin + pragma Assert (Present (G)); + + Set := Create (Number_Of_Vertices (G)); + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, LGV_Id); + pragma Assert (Present (LGV_Id)); + + Add_Vertex_If_Elaborable + (G => G, + LGV_Id => LGV_Id, + Set => Set, + Msg => Add_To_All_Candidates_Msg, + Step => Step, + Indent => No_Indentation); + end loop; + + return Set; + end Create_All_Candidates_Set; + + ------------------------------------- + -- Create_Component_Candidates_Set -- + ------------------------------------- + + function Create_Component_Candidates_Set + (G : Library_Graph; + Comp : Component_Id; + Step : Elaboration_Order_Step) return Membership_Set + is + Iter : Component_Vertex_Iterator; + LGV_Id : Library_Graph_Vertex_Id; + Set : Membership_Set; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + Set := Create (Number_Of_Component_Vertices (G, Comp)); + Iter := Iterate_Component_Vertices (G, Comp); + while Has_Next (Iter) loop + Next (Iter, LGV_Id); + pragma Assert (Present (LGV_Id)); + + Add_Vertex_If_Elaborable + (G => G, + LGV_Id => LGV_Id, + Set => Set, + Msg => Add_To_Comp_Candidates_Msg, + Step => Step, + Indent => No_Indentation); + end loop; + + return Set; + end Create_Component_Candidates_Set; + + ------------------------- + -- Elaborate_Component -- + ------------------------- + + procedure Elaborate_Component + (G : Library_Graph; + Comp : Component_Id; + All_Candidates : Membership_Set; + Remaining_Vertices : in out Natural; + Order : in out Unit_Id_Table; + Step : Elaboration_Order_Step) + is + Candidate : Library_Graph_Vertex_Id; + Comp_Candidates : Membership_Set; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + pragma Assert (Present (All_Candidates)); + + Trace_Component + (G => G, + Comp => Comp, + Msg => "elaborating component", + Step => Step); + + Comp_Candidates := Create_Component_Candidates_Set (G, Comp, Step); + + loop + Candidate := + Find_Best_Candidate + (G => G, + Set => Comp_Candidates, + Step => Step, + Indent => Nested_Indentation); + + -- Stop the elaboration of the component when there is no suitable + -- candidate. This indicates that either all vertices within the + -- component have been elaborated, or the library graph contains a + -- circularity. + + exit when not Present (Candidate); + + Elaborate_Vertex + (G => G, + LGV_Id => Candidate, + All_Candidates => All_Candidates, + Comp_Candidates => Comp_Candidates, + Remaining_Vertices => Remaining_Vertices, + Order => Order, + Step => Step, + Indent => Nested_Indentation); + end loop; + + Destroy (Comp_Candidates); + end Elaborate_Component; + + ----------------------------- + -- Elaborate_Library_Graph -- + ----------------------------- + + procedure Elaborate_Library_Graph + (G : Library_Graph; + Order : out Unit_Id_Table; + Status : out Elaboration_Order_Status) + is + All_Candidates : Membership_Set; + Candidate : Library_Graph_Vertex_Id; + Comp : Component_Id; + Remaining_Vertices : Natural; + Step : Elaboration_Order_Step; + + begin + pragma Assert (Present (G)); + + Step := Initial_Step; + + All_Candidates := Create_All_Candidates_Set (G, Step); + Remaining_Vertices := Number_Of_Vertices (G); + + loop + Step := Step + 1; + + Trace_Candidate_Vertices + (G => G, + Set => All_Candidates, + Step => Step); + + Trace_Unelaborated_Vertices + (G => G, + Count => Remaining_Vertices, + Step => Step); + + Candidate := + Find_Best_Candidate + (G => G, + Set => All_Candidates, + Step => Step, + Indent => No_Indentation); + + -- Stop the elaboration when there is no suitable candidate. This + -- indicates that either all units were elaborated or the library + -- graph contains a circularity. + + exit when not Present (Candidate); + + -- Elaborate the component of the candidate vertex by trying to + -- elaborate as many vertices within the component as possible. + -- Each successful elaboration signals the appropriate successors + -- and their components that they have one less predecessor to + -- wait on. This may add new candidates to set All_Candidates. + + Comp := Component (G, Candidate); + pragma Assert (Present (Comp)); + + Elaborate_Component + (G => G, + Comp => Comp, + All_Candidates => All_Candidates, + Remaining_Vertices => Remaining_Vertices, + Order => Order, + Step => Step); + end loop; + + Destroy (All_Candidates); + + -- The library graph contains an Elaborate_All circularity when + -- at least one edge subject to the related pragma appears in a + -- component. + + if Has_Elaborate_All_Cycle (G) then + Status := Order_Has_Elaborate_All_Circularity; + + -- The library contains a circularity when at least one vertex failed + -- to elaborate. + + elsif Remaining_Vertices /= 0 then + Status := Order_Has_Circularity; + + -- Otherwise the elaboration order is satisfactory + + else + Status := Order_OK; + end if; + end Elaborate_Library_Graph; + + --------------------- + -- Elaborate_Units -- + --------------------- + + procedure Elaborate_Units + (Order : out Unit_Id_Table; + Main_Lib_File : File_Name_Type) + is + Main_Lib_Unit : constant Unit_Id := + Corresponding_Unit (Unit_Name_Type (Main_Lib_File)); + + begin + pragma Assert (Present (Main_Lib_Unit)); + + -- Initialize all unit-related data structures and gather all units + -- that need elaboration. + + Initialize_Units; + Collect_Elaborable_Units; + + Write_ALI_Tables; + + -- Choose the proper elaboration strategy based on whether the main + -- library unit was compiled with dynamic elaboration checks. + + if Is_Dynamically_Elaborated (Main_Lib_Unit) then + Elaborate_Units_Dynamic (Order); + else + Elaborate_Units_Static (Order); + end if; + + Validate_Elaboration_Order (Order); + Write_Elaboration_Order (Order); + + -- Enumerate the sources referenced in the closure of the order + + Write_Unit_Closure (Order); + + -- Destroy all unit-delated data structures + + Finalize_Units; + + exception + when others => + Finalize_Units; + raise; + end Elaborate_Units; + + ---------------------------- + -- Elaborate_Units_Common -- + ---------------------------- + + procedure Elaborate_Units_Common + (Use_Inv_Graph : Boolean; + Inv_Graph : out Invocation_Graph; + Lib_Graph : out Library_Graph; + Order : out Unit_Id_Table; + Status : out Elaboration_Order_Status) + is + begin + -- Create, validate, and output the library graph that captures the + -- dependencies between library items. + + Lib_Graph := Build_Library_Graph; + Validate_Library_Graph (Lib_Graph); + Write_Library_Graph (Lib_Graph); + + -- Create, validate, output, and use the invocation graph that + -- represents the flow of execusion only when requested by the + -- caller. + + if Use_Inv_Graph then + Inv_Graph := Build_Invocation_Graph (Lib_Graph); + Validate_Invocation_Graph (Inv_Graph); + Write_Invocation_Graph (Inv_Graph); + + -- Otherwise the invocation graph is not used. Create a dummy graph + -- as this allows for a uniform behavior on the caller side. + + else + Inv_Graph := + Invocation_Graphs.Create + (Initial_Vertices => 1, + Initial_Edges => 1); + end if; + + -- Traverse the invocation graph starting from elaboration code in + -- order to discover transitions of the execution flow from a unit + -- to a unit that result in extra edges within the library graph. + + Augment_Library_Graph (Inv_Graph, Lib_Graph); + + -- Create and output the component graph by collapsing all library + -- items into library units and traversing the library graph. + + Find_Components (Lib_Graph); + Write_Library_Graph (Lib_Graph); + + -- Traverse the library graph to determine the elaboration order of + -- units. + + Elaborate_Library_Graph + (G => Lib_Graph, + Order => Order, + Status => Status); + end Elaborate_Units_Common; + + ----------------------------- + -- Elaborate_Units_Dynamic -- + ----------------------------- + + procedure Elaborate_Units_Dynamic (Order : out Unit_Id_Table) is + Dyn_Inv_Graph : Invocation_Graph; + Dyn_Lib_Graph : Library_Graph; + Dyn_Order : Unit_Id_Table; + Mix_Inv_Graph : Invocation_Graph; + Mix_Lib_Graph : Library_Graph; + Mix_Order : Unit_Id_Table; + Status : Elaboration_Order_Status; + + begin + -- Attempt to elaborate the units in the library graph by mixing in + -- the information from the invocation graph. This assumes that all + -- invocations will take place at elaboration time. + + Elaborate_Units_Common + (Use_Inv_Graph => True, + Inv_Graph => Mix_Inv_Graph, + Lib_Graph => Mix_Lib_Graph, + Order => Mix_Order, + Status => Status); + + -- The elaboration order is satisfactory + + if Status = Order_OK then + Order := Mix_Order; + + -- The library graph contains an Elaborate_All circularity. There is + -- no point in re-elaborating the units without the information from + -- the invocation graph because the circularity will persist. + + elsif Status = Order_Has_Elaborate_All_Circularity then + Error_Msg ("elaboration circularity detected"); + + -- Report error here + + -- Otherwise the library graph contains a circularity, or the extra + -- information provided by the invocation graph caused a circularity. + -- Re-elaborate the units without using the invocation graph. This + -- assumes that all invocations will not take place at elaboration + -- time. + + else + pragma Assert (Status = Order_Has_Circularity); + + Elaborate_Units_Common + (Use_Inv_Graph => False, + Inv_Graph => Dyn_Inv_Graph, + Lib_Graph => Dyn_Lib_Graph, + Order => Dyn_Order, + Status => Status); + + -- The elaboration order is satisfactory. The elaboration of the + -- program may still fail at runtime with an ABE. + + if Status = Order_OK then + Order := Dyn_Order; + + -- Otherwise the library graph contains a circularity without the + -- extra information provided by the invocation graph. Diagnose + -- the circularity. + + else + Error_Msg ("elaboration circularity detected"); + + -- Report error here + end if; + + Destroy (Dyn_Inv_Graph); + Destroy (Dyn_Lib_Graph); + end if; + + Destroy (Mix_Inv_Graph); + Destroy (Mix_Lib_Graph); + + -- Halt the bind as there is no satisfactory elaboration order + + if Status /= Order_OK then + raise Unrecoverable_Error; + end if; + end Elaborate_Units_Dynamic; + + ---------------------------- + -- Elaborate_Units_Static -- + ---------------------------- + + procedure Elaborate_Units_Static (Order : out Unit_Id_Table) is + Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Status : Elaboration_Order_Status; + + begin + -- Attempt to elaborate the units in the library graph by mixing in + -- the information from the invocation graph. This assumes that all + -- invocations will take place at elaboration time. + + Elaborate_Units_Common + (Use_Inv_Graph => True, + Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Order => Order, + Status => Status); + + -- The augmented library graph contains a circularity + + if Status /= Order_OK then + Error_Msg ("elaboration circularity detected"); + + -- Report error here + end if; + + Destroy (Inv_Graph); + Destroy (Lib_Graph); + + -- Halt the bind as there is no satisfactory elaboration order + + if Status /= Order_OK then + raise Unrecoverable_Error; + end if; + end Elaborate_Units_Static; + + ---------------------- + -- Elaborate_Vertex -- + ---------------------- + + procedure Elaborate_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + All_Candidates : Membership_Set; + Comp_Candidates : Membership_Set; + Remaining_Vertices : in out Natural; + Order : in out Unit_Id_Table; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + is + Body_LGV_Id : Library_Graph_Vertex_Id; + U_Id : Unit_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + pragma Assert (Needs_Elaboration (G, LGV_Id)); + pragma Assert (Present (All_Candidates)); + pragma Assert (Present (Comp_Candidates)); + + Trace_Vertex + (G => G, + LGV_Id => LGV_Id, + Msg => "elaborating vertex", + Step => Step, + Indent => Indent); + + -- Remove the vertex from both candidate sets. This is needed when + -- the vertex is both an overall best candidate among all vertices, + -- and the best candidate within the component. There is no need to + -- check that the vertex is present in either set because the set + -- implementation handles this case. + + Delete (All_Candidates, LGV_Id); + Delete (Comp_Candidates, LGV_Id); + + -- Mark the vertex as elaborated in order to prevent further attempts + -- to re-elaborate it. + + Set_In_Elaboration_Order (G, LGV_Id); + + -- Add the unit represented by the vertex to the elaboration order + + U_Id := Unit (G, LGV_Id); + pragma Assert (Present (U_Id)); + + Unit_Id_Tables.Append (Order, U_Id); + + -- There is now one fewer vertex to elaborate + + Remaining_Vertices := Remaining_Vertices - 1; + + -- Notify all successors and their components that they have one + -- fewer predecessor to wait on. This may cause some successors to + -- be included in one of the sets. + + Update_Successors + (G => G, + Pred => LGV_Id, + All_Candidates => All_Candidates, + Comp_Candidates => Comp_Candidates, + Step => Step, + Indent => Indent + Nested_Indentation); + + -- The vertex denotes a spec with a completing body, and is subject + -- to pragma Elaborate_Body. Elaborate the body in order to satisfy + -- the semantics of the pragma. + + if Is_Spec_With_Elaborate_Body (G, LGV_Id) then + Body_LGV_Id := Proper_Body (G, LGV_Id); + pragma Assert (Present (Body_LGV_Id)); + + Elaborate_Vertex + (G => G, + LGV_Id => Body_LGV_Id, + All_Candidates => All_Candidates, + Comp_Candidates => Comp_Candidates, + Remaining_Vertices => Remaining_Vertices, + Order => Order, + Step => Step, + Indent => Indent); + end if; + end Elaborate_Vertex; + + ------------------------- + -- Find_Best_Candidate -- + ------------------------- + + function Find_Best_Candidate + (G : Library_Graph; + Set : Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) return Library_Graph_Vertex_Id + is + Best : Library_Graph_Vertex_Id; + Curr : Library_Graph_Vertex_Id; + Iter : Iterator; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Set)); + + -- Assume that there is no candidate + + Best := No_Library_Graph_Vertex; + + -- Inspect all vertices in the set, looking for the best candidate to + -- elaborate. + + Iter := Iterate (Set); + while Has_Next (Iter) loop + Next (Iter, Curr); + + pragma Assert (Present (Curr)); + pragma Assert (Needs_Elaboration (G, Curr)); + + -- Update the best candidate when there is no such candidate + + if not Present (Best) then + Best := Curr; + + Trace_Vertex + (G => G, + LGV_Id => Best, + Msg => "initial best candidate vertex", + Step => Step, + Indent => Indent); + + -- Update the best candidate when the current vertex is a better + -- choice. + + elsif Is_Better_Candidate + (G => G, + Best_Candid => Best, + New_Candid => Curr) + then + Best := Curr; + + Trace_Vertex + (G => G, + LGV_Id => Best, + Msg => "best candidate vertex", + Step => Step, + Indent => Indent); + end if; + end loop; + + return Best; + end Find_Best_Candidate; + + ------------------------- + -- Is_Better_Candidate -- + ------------------------- + + function Is_Better_Candidate + (G : Library_Graph; + Best_Candid : Library_Graph_Vertex_Id; + New_Candid : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Best_Candid)); + pragma Assert (Present (New_Candid)); + + -- Prefer a predefined unit over a non-predefined unit + + if Is_Predefined_Unit (G, Best_Candid) + and then not Is_Predefined_Unit (G, New_Candid) + then + return False; + + elsif not Is_Predefined_Unit (G, Best_Candid) + and then Is_Predefined_Unit (G, New_Candid) + then + return True; + + -- Prefer an internal unit over a non-iternal unit + + elsif Is_Internal_Unit (G, Best_Candid) + and then not Is_Internal_Unit (G, New_Candid) + then + return False; + + elsif not Is_Internal_Unit (G, Best_Candid) + and then Is_Internal_Unit (G, New_Candid) + then + return True; + + -- Prefer a preelaborated unit over a non-preelaborated unit + + elsif Is_Preelaborated_Unit (G, Best_Candid) + and then not Is_Preelaborated_Unit (G, New_Candid) + then + return False; + + elsif not Is_Preelaborated_Unit (G, Best_Candid) + and then Is_Preelaborated_Unit (G, New_Candid) + then + return True; + + -- Otherwise default to lexicographical order to ensure deterministic + -- behavior. + + else + return Uname_Less (Name (G, Best_Candid), Name (G, New_Candid)); + end if; + end Is_Better_Candidate; + + ------------------------------ + -- Trace_Candidate_Vertices -- + ------------------------------ + + procedure Trace_Candidate_Vertices + (G : Library_Graph; + Set : Membership_Set; + Step : Elaboration_Order_Step) + is + Iter : Iterator; + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Set)); + + -- Nothing to do when switch -d_T (output elaboration order trace + -- information) is not in effect. + + if not Debug_Flag_Underscore_TT then + return; + end if; + + Trace_Step (Step); + Write_Str ("candidate vertices: "); + Write_Int (Int (Size (Set))); + Write_Eol; + + Iter := Iterate (Set); + while Has_Next (Iter) loop + Next (Iter, LGV_Id); + pragma Assert (Present (LGV_Id)); + + Trace_Vertex + (G => G, + LGV_Id => LGV_Id, + Msg => "candidate vertex", + Step => Step, + Indent => Nested_Indentation); + end loop; + end Trace_Candidate_Vertices; + + --------------------- + -- Trace_Component -- + --------------------- + + procedure Trace_Component + (G : Library_Graph; + Comp : Component_Id; + Msg : String; + Step : Elaboration_Order_Step) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + -- Nothing to do when switch -d_T (output elaboration order trace + -- information) is not in effect. + + if not Debug_Flag_Underscore_TT then + return; + end if; + + Trace_Step (Step); + Write_Str (Msg); + Write_Str (" (Comp_Id_"); + Write_Int (Int (Comp)); + Write_Str (")"); + Write_Eol; + + Trace_Step (Step); + Indent_By (Nested_Indentation); + Write_Str ("pending predecessors: "); + Write_Num (Int (Pending_Predecessors (G, Comp))); + Write_Eol; + end Trace_Component; + + ---------------- + -- Trace_Step -- + ---------------- + + procedure Trace_Step (Step : Elaboration_Order_Step) is + begin + -- Nothing to do when switch -d_T (output elaboration order trace + -- information) is not in effect. + + if not Debug_Flag_Underscore_TT then + return; + end if; + + Write_Num + (Val => Int (Step), + Val_Indent => Step_Column); + Write_Str (": "); + end Trace_Step; + + --------------------------------- + -- Trace_Unelaborated_Vertices -- + --------------------------------- + + procedure Trace_Unelaborated_Vertices + (G : Library_Graph; + Count : Natural; + Step : Elaboration_Order_Step) + is + Iter : Library_Graphs.All_Vertex_Iterator; + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -d_T (output elaboration order trace + -- information) is not in effect. + + if not Debug_Flag_Underscore_TT then + return; + end if; + + Trace_Step (Step); + Write_Str ("remaining unelaborated vertices: "); + Write_Int (Int (Count)); + Write_Eol; + + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, LGV_Id); + pragma Assert (Present (LGV_Id)); + + if Needs_Elaboration (G, LGV_Id) + and then not In_Elaboration_Order (G, LGV_Id) + then + Trace_Vertex + (G => G, + LGV_Id => LGV_Id, + Msg => "remaining vertex", + Step => Step, + Indent => Nested_Indentation); + end if; + end loop; + end Trace_Unelaborated_Vertices; + + ------------------ + -- Trace_Vertex -- + ------------------ + + procedure Trace_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Comp : constant Component_Id := Component (G, LGV_Id); + + pragma Assert (Present (Comp)); + + begin + -- Nothing to do when switch -d_T (output elaboration order trace + -- information) is not in effect. + + if not Debug_Flag_Underscore_TT then + return; + end if; + + Trace_Step (Step); + Indent_By (Indent); + Write_Str (Msg); + Write_Str (" (LGV_Id_"); + Write_Int (Int (LGV_Id)); + Write_Str (")"); + Write_Eol; + + Trace_Step (Step); + Indent_By (Indent + Nested_Indentation); + Write_Str ("name = "); + Write_Name (Name (G, LGV_Id)); + Write_Eol; + + Trace_Step (Step); + Indent_By (Indent + Nested_Indentation); + Write_Str ("Component (Comp_Id_"); + Write_Int (Int (Comp)); + Write_Str (")"); + Write_Eol; + + Trace_Step (Step); + Indent_By (Indent + Nested_Indentation); + Write_Str ("pending predecessors: "); + Write_Num (Int (Pending_Predecessors (G, LGV_Id))); + Write_Eol; + + Trace_Step (Step); + Indent_By (Indent + Nested_Indentation); + Write_Str ("pending components : "); + Write_Num (Int (Pending_Predecessors (G, Comp))); + Write_Eol; + end Trace_Vertex; + + ---------------------- + -- Update_Successor -- + ---------------------- + + procedure Update_Successor + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + All_Candidates : Membership_Set; + Comp_Candidates : Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + is + pragma Assert (Present (G)); + pragma Assert (Present (Pred)); + pragma Assert (Needs_Elaboration (G, Pred)); + pragma Assert (Present (Succ)); + pragma Assert (Needs_Elaboration (G, Succ)); + pragma Assert (Present (All_Candidates)); + pragma Assert (Present (Comp_Candidates)); + + Pred_Comp : constant Component_Id := Component (G, Pred); + Succ_Comp : constant Component_Id := Component (G, Succ); + + pragma Assert (Present (Pred_Comp)); + pragma Assert (Present (Succ_Comp)); + + In_Different_Components : constant Boolean := Pred_Comp /= Succ_Comp; + + Candidate : Library_Graph_Vertex_Id; + Iter : Component_Vertex_Iterator; + Msg : String_Ptr; + Set : Membership_Set; + + begin + Trace_Vertex + (G => G, + LGV_Id => Succ, + Msg => "updating successor", + Step => Step, + Indent => Indent); + + -- Notify the successor that it has one less predecessor to wait on. + -- This effectively eliminates the edge that links the two. + + Decrement_Pending_Predecessors (G, Succ); + + -- The predecessor and successor reside in different components. + -- Notify the successor component it has one fewer components to + -- wait on. + + if In_Different_Components then + Decrement_Pending_Predecessors (G, Succ_Comp); + end if; + + -- At this point the successor may become elaborable when its final + -- predecessor or final predecessor component is elaborated. + + -- The predecessor and successor reside in different components. + -- The successor must not be added to the candidates of Pred's + -- component because this will mix units from the two components. + -- Instead, the successor is added to the set of all candidates + -- that must be elaborated. + + if In_Different_Components then + Msg := Add_To_All_Candidates_Msg'Access; + Set := All_Candidates; + + -- Otherwise the predecessor and successor reside within the same + -- component. Pred's component gains another elaborable node. + + else + Msg := Add_To_Comp_Candidates_Msg'Access; + Set := Comp_Candidates; + end if; + + Add_Vertex_If_Elaborable + (G => G, + LGV_Id => Succ, + Set => Set, + Msg => Msg.all, + Step => Step, + Indent => Indent + Nested_Indentation); + + -- At this point the successor component may become elaborable when + -- its final predecessor component is elaborated. This in turn may + -- allow vertices of the successor component to be elaborated. + + if In_Different_Components + and then Is_Elaborable_Component (G, Succ_Comp) + then + Iter := Iterate_Component_Vertices (G, Succ_Comp); + while Has_Next (Iter) loop + Next (Iter, Candidate); + pragma Assert (Present (Candidate)); + + Add_Vertex_If_Elaborable + (G => G, + LGV_Id => Candidate, + Set => All_Candidates, + Msg => Add_To_All_Candidates_Msg, + Step => Step, + Indent => Indent + Nested_Indentation); + end loop; + end if; + end Update_Successor; + + ----------------------- + -- Update_Successors -- + ----------------------- + + procedure Update_Successors + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + All_Candidates : Membership_Set; + Comp_Candidates : Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + is + Iter : Edges_To_Successors_Iterator; + LGE_Id : Library_Graph_Edge_Id; + Succ : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Pred)); + pragma Assert (Needs_Elaboration (G, Pred)); + pragma Assert (Present (All_Candidates)); + pragma Assert (Present (Comp_Candidates)); + + Iter := Iterate_Edges_To_Successors (G, Pred); + while Has_Next (Iter) loop + Next (Iter, LGE_Id); + + pragma Assert (Present (LGE_Id)); + pragma Assert (Predecessor (G, LGE_Id) = Pred); + + Succ := Successor (G, LGE_Id); + pragma Assert (Present (Succ)); + + Update_Successor + (G => G, + Pred => Pred, + Succ => Succ, + All_Candidates => All_Candidates, + Comp_Candidates => Comp_Candidates, + Step => Step, + Indent => Indent); + end loop; + end Update_Successors; + end Invocation_And_Library_Graph_Elaborators; + +end Bindo.Elaborators; diff --git a/gcc/ada/bindo-elaborators.ads b/gcc/ada/bindo-elaborators.ads new file mode 100644 index 0000000..c65f593 --- /dev/null +++ b/gcc/ada/bindo-elaborators.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . E L A B O R A T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to find the elaboration order of +-- units based on various graphs. + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Invocation_Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Elaborators is + + ---------------------------------------------- + -- Invocation_And_Library_Graph_Elaborators -- + ---------------------------------------------- + + package Invocation_And_Library_Graph_Elaborators is + procedure Elaborate_Units + (Order : out Unit_Id_Table; + Main_Lib_File : File_Name_Type); + -- Find an order of all units in the bind that need to be elaborated + -- such that elaboration code flow, pragmas Elaborate, Elaborate_All, + -- and Elaborate_Body, and with clause dependencies are all honoured. + -- Main_Lib_File is the argument of the bind. If a satisfactory order + -- exists, it is returned in Order, otherwise Unrecoverable_Error is + -- raised. + + end Invocation_And_Library_Graph_Elaborators; + +end Bindo.Elaborators; diff --git a/gcc/ada/bindo-graphs.adb b/gcc/ada/bindo-graphs.adb new file mode 100644 index 0000000..b2f458c --- /dev/null +++ b/gcc/ada/bindo-graphs.adb @@ -0,0 +1,2886 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . G R A P H S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with GNAT.Lists; use GNAT.Lists; + +package body Bindo.Graphs is + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Sequence_Next_IGE_Id return Invocation_Graph_Edge_Id; + pragma Inline (Sequence_Next_IGE_Id); + -- Generate a new unique invocation graph edge handle + + function Sequence_Next_IGV_Id return Invocation_Graph_Vertex_Id; + pragma Inline (Sequence_Next_IGV_Id); + -- Generate a new unique invocation graph vertex handle + + function Sequence_Next_LGE_Id return Library_Graph_Edge_Id; + pragma Inline (Sequence_Next_LGE_Id); + -- Generate a new unique library graph edge handle + + function Sequence_Next_LGV_Id return Library_Graph_Vertex_Id; + pragma Inline (Sequence_Next_LGV_Id); + -- Generate a new unique library graph vertex handle + + -------------------------------- + -- Hash_Invocation_Graph_Edge -- + -------------------------------- + + function Hash_Invocation_Graph_Edge + (IGE_Id : Invocation_Graph_Edge_Id) return Bucket_Range_Type + is + begin + pragma Assert (Present (IGE_Id)); + + return Bucket_Range_Type (IGE_Id); + end Hash_Invocation_Graph_Edge; + + ---------------------------------- + -- Hash_Invocation_Graph_Vertex -- + ---------------------------------- + + function Hash_Invocation_Graph_Vertex + (IGV_Id : Invocation_Graph_Vertex_Id) return Bucket_Range_Type + is + begin + pragma Assert (Present (IGV_Id)); + + return Bucket_Range_Type (IGV_Id); + end Hash_Invocation_Graph_Vertex; + + ----------------------------- + -- Hash_Library_Graph_Edge -- + ----------------------------- + + function Hash_Library_Graph_Edge + (LGE_Id : Library_Graph_Edge_Id) return Bucket_Range_Type + is + begin + pragma Assert (Present (LGE_Id)); + + return Bucket_Range_Type (LGE_Id); + end Hash_Library_Graph_Edge; + + ------------------------------- + -- Hash_Library_Graph_Vertex -- + ------------------------------- + + function Hash_Library_Graph_Vertex + (LGV_Id : Library_Graph_Vertex_Id) return Bucket_Range_Type + is + begin + pragma Assert (Present (LGV_Id)); + + return Bucket_Range_Type (LGV_Id); + end Hash_Library_Graph_Vertex; + + ----------------------- + -- Invocation_Graphs -- + ----------------------- + + package body Invocation_Graphs is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Free is + new Ada.Unchecked_Deallocation + (Invocation_Graph_Attributes, Invocation_Graph); + + function Get_IGE_Attributes + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) + return Invocation_Graph_Edge_Attributes; + pragma Inline (Get_IGE_Attributes); + -- Obtain the attributes of edge IGE_Id of invocation graph G + + function Get_IGV_Attributes + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) + return Invocation_Graph_Vertex_Attributes; + pragma Inline (Get_IGV_Attributes); + -- Obtain the attributes of vertex IGV_Id of invocation graph G + + procedure Increment_Invocation_Graph_Edge_Count + (G : Invocation_Graph; + Kind : Invocation_Kind); + pragma Inline (Increment_Invocation_Graph_Edge_Count); + -- Increment the number of edges of king Kind in invocation graph G by + -- one. + + function Is_Elaboration_Root + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Elaboration_Root); + -- Determine whether vertex IGV_Id of invocation graph denotes the + -- elaboration procedure of a spec or a body. + + function Is_Existing_Source_Target_Relation + (G : Invocation_Graph; + Rel : Source_Target_Relation) return Boolean; + pragma Inline (Is_Existing_Source_Target_Relation); + -- Determine whether a source vertex and a target vertex desctibed by + -- relation Rel are already related in invocation graph G. + + procedure Save_Elaboration_Root + (G : Invocation_Graph; + Root : Invocation_Graph_Vertex_Id); + pragma Inline (Save_Elaboration_Root); + -- Save elaboration root Root of invocation graph G + + procedure Set_Corresponding_Vertex + (G : Invocation_Graph; + IS_Id : Invocation_Signature_Id; + IGV_Id : Invocation_Graph_Vertex_Id); + pragma Inline (Set_Corresponding_Vertex); + -- Associate vertex IGV_Id of invocation graph G with signature IS_Id + + procedure Set_Is_Existing_Source_Target_Relation + (G : Invocation_Graph; + Rel : Source_Target_Relation; + Val : Boolean := True); + pragma Inline (Set_Is_Existing_Source_Target_Relation); + -- Mark a source vertex and a target vertex desctibed by relation Rel as + -- already related in invocation graph G depending on value Val. + + procedure Set_IGE_Attributes + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id; + Val : Invocation_Graph_Edge_Attributes); + pragma Inline (Set_IGE_Attributes); + -- Set the attributes of edge IGE_Id of invocation graph G to value Val + + procedure Set_IGV_Attributes + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id; + Val : Invocation_Graph_Vertex_Attributes); + pragma Inline (Set_IGV_Attributes); + -- Set the attributes of vertex IGV_Id of invocation graph G to value + -- Val. + + -------------- + -- Add_Edge -- + -------------- + + procedure Add_Edge + (G : Invocation_Graph; + Source : Invocation_Graph_Vertex_Id; + Target : Invocation_Graph_Vertex_Id; + IR_Id : Invocation_Relation_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (Source)); + pragma Assert (Present (Target)); + pragma Assert (Present (IR_Id)); + + Rel : constant Source_Target_Relation := + (Source => Source, + Target => Target); + + IR_Rec : Invocation_Relation_Record renames + Invocation_Relations.Table (IR_Id); + + IGE_Id : Invocation_Graph_Edge_Id; + + begin + -- Nothing to do when the source and target are already related by an + -- edge. + + if Is_Existing_Source_Target_Relation (G, Rel) then + return; + end if; + + IGE_Id := Sequence_Next_IGE_Id; + + -- Add the edge to the underlying graph + + DG.Add_Edge + (G => G.Graph, + E => IGE_Id, + Source => Source, + Destination => Target); + + -- Build and save the attributes of the edge + + Set_IGE_Attributes + (G => G, + IGE_Id => IGE_Id, + Val => (Relation => IR_Id)); + + -- Mark the source and target as related by the new edge. This + -- prevents all further attempts to link the same source and target. + + Set_Is_Existing_Source_Target_Relation (G, Rel); + + -- Update the edge statistics + + Increment_Invocation_Graph_Edge_Count (G, IR_Rec.Kind); + end Add_Edge; + + ---------------- + -- Add_Vertex -- + ---------------- + + procedure Add_Vertex + (G : Invocation_Graph; + IC_Id : Invocation_Construct_Id; + LGV_Id : Library_Graph_Vertex_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (IC_Id)); + pragma Assert (Present (LGV_Id)); + + IC_Rec : Invocation_Construct_Record renames + Invocation_Constructs.Table (IC_Id); + + pragma Assert (Present (IC_Rec.Signature)); + + IGV_Id : Invocation_Graph_Vertex_Id; + + begin + -- Nothing to do when the construct already has a vertex + + if Present (Corresponding_Vertex (G, IC_Rec.Signature)) then + return; + end if; + + IGV_Id := Sequence_Next_IGV_Id; + + -- Add the vertex to the underlying graph + + DG.Add_Vertex (G.Graph, IGV_Id); + + -- Build and save the attributes of the vertex + + Set_IGV_Attributes + (G => G, + IGV_Id => IGV_Id, + Val => (Construct => IC_Id, + Lib_Vertex => LGV_Id)); + + -- Associate the construct with its corresponding vertex + + Set_Corresponding_Vertex (G, IC_Rec.Signature, IGV_Id); + + -- Save the vertex for later processing when it denotes a spec or + -- body elaboration procedure. + + if Is_Elaboration_Root (G, IGV_Id) then + Save_Elaboration_Root (G, IGV_Id); + end if; + end Add_Vertex; + + --------------- + -- Construct -- + --------------- + + function Construct + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + return Get_IGV_Attributes (G, IGV_Id).Construct; + end Construct; + + -------------------------- + -- Corresponding_Vertex -- + -------------------------- + + function Corresponding_Vertex + (G : Invocation_Graph; + IS_Id : Invocation_Signature_Id) return Invocation_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IS_Id)); + + return SV.Get (G.Signature_To_Vertex, IS_Id); + end Corresponding_Vertex; + + ------------ + -- Create -- + ------------ + + function Create + (Initial_Vertices : Positive; + Initial_Edges : Positive) return Invocation_Graph + is + G : constant Invocation_Graph := new Invocation_Graph_Attributes; + + begin + G.Edge_Attributes := EA.Create (Initial_Edges); + G.Graph := + DG.Create + (Initial_Vertices => Initial_Vertices, + Initial_Edges => Initial_Edges); + G.Relations := ST.Create (Initial_Edges); + G.Roots := ER.Create (Initial_Vertices); + G.Signature_To_Vertex := SV.Create (Initial_Vertices); + G.Vertex_Attributes := VA.Create (Initial_Vertices); + + return G; + end Create; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (G : in out Invocation_Graph) is + begin + pragma Assert (Present (G)); + + EA.Destroy (G.Edge_Attributes); + DG.Destroy (G.Graph); + ST.Destroy (G.Relations); + ER.Destroy (G.Roots); + SV.Destroy (G.Signature_To_Vertex); + VA.Destroy (G.Vertex_Attributes); + + Free (G); + end Destroy; + + ----------------------------------- + -- Destroy_Invocation_Graph_Edge -- + ----------------------------------- + + procedure Destroy_Invocation_Graph_Edge + (IGE_Id : in out Invocation_Graph_Edge_Id) + is + pragma Unreferenced (IGE_Id); + begin + null; + end Destroy_Invocation_Graph_Edge; + + ---------------------------------------------- + -- Destroy_Invocation_Graph_Edge_Attributes -- + ---------------------------------------------- + + procedure Destroy_Invocation_Graph_Edge_Attributes + (Attrs : in out Invocation_Graph_Edge_Attributes) + is + pragma Unreferenced (Attrs); + begin + null; + end Destroy_Invocation_Graph_Edge_Attributes; + + ------------------------------------- + -- Destroy_Invocation_Graph_Vertex -- + ------------------------------------- + + procedure Destroy_Invocation_Graph_Vertex + (IGV_Id : in out Invocation_Graph_Vertex_Id) + is + pragma Unreferenced (IGV_Id); + begin + null; + end Destroy_Invocation_Graph_Vertex; + + ------------------------------------------------ + -- Destroy_Invocation_Graph_Vertex_Attributes -- + ------------------------------------------------ + + procedure Destroy_Invocation_Graph_Vertex_Attributes + (Attrs : in out Invocation_Graph_Vertex_Attributes) + is + pragma Unreferenced (Attrs); + begin + null; + end Destroy_Invocation_Graph_Vertex_Attributes; + + ------------------------ + -- Get_IGE_Attributes -- + ------------------------ + + function Get_IGE_Attributes + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) + return Invocation_Graph_Edge_Attributes + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGE_Id)); + + return EA.Get (G.Edge_Attributes, IGE_Id); + end Get_IGE_Attributes; + + ------------------------ + -- Get_IGV_Attributes -- + ------------------------ + + function Get_IGV_Attributes + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) + return Invocation_Graph_Vertex_Attributes + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + return VA.Get (G.Vertex_Attributes, IGV_Id); + end Get_IGV_Attributes; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : All_Edge_Iterator) return Boolean is + begin + return DG.Has_Next (DG.All_Edge_Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : All_Vertex_Iterator) return Boolean is + begin + return DG.Has_Next (DG.All_Vertex_Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Edges_To_Targets_Iterator) return Boolean is + begin + return DG.Has_Next (DG.Outgoing_Edge_Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Elaboration_Root_Iterator) return Boolean is + begin + return ER.Has_Next (ER.Iterator (Iter)); + end Has_Next; + + ------------------------------- + -- Hash_Invocation_Signature -- + ------------------------------- + + function Hash_Invocation_Signature + (IS_Id : Invocation_Signature_Id) return Bucket_Range_Type + is + begin + pragma Assert (Present (IS_Id)); + + return Bucket_Range_Type (IS_Id); + end Hash_Invocation_Signature; + + --------------------------------- + -- Hash_Source_Target_Relation -- + --------------------------------- + + function Hash_Source_Target_Relation + (Rel : Source_Target_Relation) return Bucket_Range_Type + is + begin + pragma Assert (Present (Rel.Source)); + pragma Assert (Present (Rel.Target)); + + return + Hash_Two_Keys + (Bucket_Range_Type (Rel.Source), + Bucket_Range_Type (Rel.Target)); + end Hash_Source_Target_Relation; + + ------------------------------------------- + -- Increment_Invocation_Graph_Edge_Count -- + ------------------------------------------- + + procedure Increment_Invocation_Graph_Edge_Count + (G : Invocation_Graph; + Kind : Invocation_Kind) + is + pragma Assert (Present (G)); + + Count : Natural renames G.Counts (Kind); + + begin + Count := Count + 1; + end Increment_Invocation_Graph_Edge_Count; + + --------------------------------- + -- Invocation_Graph_Edge_Count -- + --------------------------------- + + function Invocation_Graph_Edge_Count + (G : Invocation_Graph; + Kind : Invocation_Kind) return Natural + is + begin + pragma Assert (Present (G)); + + return G.Counts (Kind); + end Invocation_Graph_Edge_Count; + + ------------------------- + -- Is_Elaboration_Root -- + ------------------------- + + function Is_Elaboration_Root + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + IC_Id : constant Invocation_Construct_Id := Construct (G, IGV_Id); + + pragma Assert (Present (IC_Id)); + + IC_Rec : Invocation_Construct_Record renames + Invocation_Constructs.Table (IC_Id); + + begin + return + IC_Rec.Kind = Elaborate_Body_Procedure + or else + IC_Rec.Kind = Elaborate_Spec_Procedure; + end Is_Elaboration_Root; + + ---------------------------------------- + -- Is_Existing_Source_Target_Relation -- + ---------------------------------------- + + function Is_Existing_Source_Target_Relation + (G : Invocation_Graph; + Rel : Source_Target_Relation) return Boolean + is + begin + pragma Assert (Present (G)); + + return ST.Contains (G.Relations, Rel); + end Is_Existing_Source_Target_Relation; + + ----------------------- + -- Iterate_All_Edges -- + ----------------------- + + function Iterate_All_Edges + (G : Invocation_Graph) return All_Edge_Iterator + is + begin + pragma Assert (Present (G)); + + return All_Edge_Iterator (DG.Iterate_All_Edges (G.Graph)); + end Iterate_All_Edges; + + -------------------------- + -- Iterate_All_Vertices -- + -------------------------- + + function Iterate_All_Vertices + (G : Invocation_Graph) return All_Vertex_Iterator + is + begin + pragma Assert (Present (G)); + + return All_Vertex_Iterator (DG.Iterate_All_Vertices (G.Graph)); + end Iterate_All_Vertices; + + ------------------------------ + -- Iterate_Edges_To_Targets -- + ------------------------------ + + function Iterate_Edges_To_Targets + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + return + Edges_To_Targets_Iterator + (DG.Iterate_Outgoing_Edges (G.Graph, IGV_Id)); + end Iterate_Edges_To_Targets; + + ------------------------------- + -- Iterate_Elaboration_Roots -- + ------------------------------- + + function Iterate_Elaboration_Roots + (G : Invocation_Graph) return Elaboration_Root_Iterator + is + begin + pragma Assert (Present (G)); + + return Elaboration_Root_Iterator (ER.Iterate (G.Roots)); + end Iterate_Elaboration_Roots; + + ---------- + -- Kind -- + ---------- + + function Kind + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Kind + is + pragma Assert (Present (G)); + pragma Assert (Present (IGE_Id)); + + IR_Id : constant Invocation_Relation_Id := Relation (G, IGE_Id); + + pragma Assert (Present (IR_Id)); + + IR_Rec : Invocation_Relation_Record renames + Invocation_Relations.Table (IR_Id); + + begin + return IR_Rec.Kind; + end Kind; + + ---------------- + -- Lib_Vertex -- + ---------------- + + function Lib_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + return Get_IGV_Attributes (G, IGV_Id).Lib_Vertex; + end Lib_Vertex; + + ---------- + -- Name -- + ---------- + + function Name + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Name_Id + is + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + IC_Id : constant Invocation_Construct_Id := Construct (G, IGV_Id); + + pragma Assert (Present (IC_Id)); + + IC_Rec : Invocation_Construct_Record renames + Invocation_Constructs.Table (IC_Id); + + pragma Assert (Present (IC_Rec.Signature)); + + IS_Rec : Invocation_Signature_Record renames + Invocation_Signatures.Table (IC_Rec.Signature); + + begin + return IS_Rec.Name; + end Name; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out All_Edge_Iterator; + IGE_Id : out Invocation_Graph_Edge_Id) + is + begin + DG.Next (DG.All_Edge_Iterator (Iter), IGE_Id); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out All_Vertex_Iterator; + IGV_Id : out Invocation_Graph_Vertex_Id) + is + begin + DG.Next (DG.All_Vertex_Iterator (Iter), IGV_Id); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Edges_To_Targets_Iterator; + IGE_Id : out Invocation_Graph_Edge_Id) + is + begin + DG.Next (DG.Outgoing_Edge_Iterator (Iter), IGE_Id); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Elaboration_Root_Iterator; + Root : out Invocation_Graph_Vertex_Id) + is + begin + ER.Next (ER.Iterator (Iter), Root); + end Next; + + --------------------- + -- Number_Of_Edges -- + --------------------- + + function Number_Of_Edges (G : Invocation_Graph) return Natural is + begin + pragma Assert (Present (G)); + + return DG.Number_Of_Edges (G.Graph); + end Number_Of_Edges; + + -------------------------------- + -- Number_Of_Edges_To_Targets -- + -------------------------------- + + function Number_Of_Edges_To_Targets + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Natural + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + return DG.Number_Of_Outgoing_Edges (G.Graph, IGV_Id); + end Number_Of_Edges_To_Targets; + + --------------------------------- + -- Number_Of_Elaboration_Roots -- + --------------------------------- + + function Number_Of_Elaboration_Roots + (G : Invocation_Graph) return Natural + is + begin + pragma Assert (Present (G)); + + return ER.Size (G.Roots); + end Number_Of_Elaboration_Roots; + + ------------------------ + -- Number_Of_Vertices -- + ------------------------ + + function Number_Of_Vertices (G : Invocation_Graph) return Natural is + begin + pragma Assert (Present (G)); + + return DG.Number_Of_Vertices (G.Graph); + end Number_Of_Vertices; + + ------------- + -- Present -- + ------------- + + function Present (G : Invocation_Graph) return Boolean is + begin + return G /= Nil; + end Present; + + -------------- + -- Relation -- + -------------- + + function Relation + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Relation_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGE_Id)); + + return Get_IGE_Attributes (G, IGE_Id).Relation; + end Relation; + + --------------------------- + -- Save_Elaboration_Root -- + --------------------------- + + procedure Save_Elaboration_Root + (G : Invocation_Graph; + Root : Invocation_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Root)); + + ER.Insert (G.Roots, Root); + end Save_Elaboration_Root; + + ------------------------------ + -- Set_Corresponding_Vertex -- + ------------------------------ + + procedure Set_Corresponding_Vertex + (G : Invocation_Graph; + IS_Id : Invocation_Signature_Id; + IGV_Id : Invocation_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IS_Id)); + pragma Assert (Present (IGV_Id)); + + SV.Put (G.Signature_To_Vertex, IS_Id, IGV_Id); + end Set_Corresponding_Vertex; + + -------------------------------------------- + -- Set_Is_Existing_Source_Target_Relation -- + -------------------------------------------- + + procedure Set_Is_Existing_Source_Target_Relation + (G : Invocation_Graph; + Rel : Source_Target_Relation; + Val : Boolean := True) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Rel.Source)); + pragma Assert (Present (Rel.Target)); + + if Val then + ST.Insert (G.Relations, Rel); + else + ST.Delete (G.Relations, Rel); + end if; + end Set_Is_Existing_Source_Target_Relation; + + ------------------------ + -- Set_IGE_Attributes -- + ------------------------ + + procedure Set_IGE_Attributes + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id; + Val : Invocation_Graph_Edge_Attributes) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGE_Id)); + + EA.Put (G.Edge_Attributes, IGE_Id, Val); + end Set_IGE_Attributes; + + ------------------------ + -- Set_IGV_Attributes -- + ------------------------ + + procedure Set_IGV_Attributes + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id; + Val : Invocation_Graph_Vertex_Attributes) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + VA.Put (G.Vertex_Attributes, IGV_Id, Val); + end Set_IGV_Attributes; + + ------------ + -- Target -- + ------------ + + function Target + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGE_Id)); + + return DG.Destination_Vertex (G.Graph, IGE_Id); + end Target; + end Invocation_Graphs; + + -------------------- + -- Library_Graphs -- + -------------------- + + package body Library_Graphs is + + --------------- + -- Edge list -- + --------------- + + package EL is new Doubly_Linked_Lists + (Element_Type => Library_Graph_Edge_Id, + "=" => "=", + Destroy_Element => Destroy_Library_Graph_Edge); + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Add_Body_Before_Spec_Edge + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Edges : EL.Doubly_Linked_List); + pragma Inline (Add_Body_Before_Spec_Edge); + -- Create a new edge in library graph G between vertex LGV_Id and its + -- corresponding spec or body, where the body is a predecessor and the + -- spec a successor. Add the edge to list Edges. + + procedure Add_Body_Before_Spec_Edges + (G : Library_Graph; + Edges : EL.Doubly_Linked_List); + pragma Inline (Add_Body_Before_Spec_Edges); + -- Create new edges in library graph G for all vertices and their + -- corresponding specs or bodies, where the body is a predecessor + -- and the spec is a successor. Add all edges to list Edges. + + function Add_Edge_With_Return + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + Kind : Library_Graph_Edge_Kind) return Library_Graph_Edge_Id; + pragma Inline (Add_Edge_With_Return); + -- Create a new edge in library graph G with source vertex Pred and + -- destination vertex Succ, and return its handle. Kind denotes the + -- nature of the edge. If Pred and Succ are already related, no edge + -- is created and No_Library_Graph_Edge is returned. + + procedure Decrement_Library_Graph_Edge_Count + (G : Library_Graph; + Kind : Library_Graph_Edge_Kind); + pragma Inline (Decrement_Library_Graph_Edge_Count); + -- Decrement the number of edges of kind King in library graph G by one + + procedure Delete_Body_Before_Spec_Edges + (G : Library_Graph; + Edges : EL.Doubly_Linked_List); + pragma Inline (Delete_Body_Before_Spec_Edges); + -- Delete all edges in list Edges from library graph G, that link spec + -- and bodies, where the body acts as the predecessor and the spec as a + -- successor. + + procedure Delete_Edge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id); + pragma Inline (Delete_Edge); + -- Delete edge LGE_Id from library graph G + + procedure Free is + new Ada.Unchecked_Deallocation + (Library_Graph_Attributes, Library_Graph); + + function Get_Component_Attributes + (G : Library_Graph; + Comp : Component_Id) return Component_Attributes; + pragma Inline (Get_Component_Attributes); + -- Obtain the attributes of component Comp of library graph G + + function Get_LGE_Attributes + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) + return Library_Graph_Edge_Attributes; + pragma Inline (Get_LGE_Attributes); + -- Obtain the attributes of edge LGE_Id of library graph G + + function Get_LGV_Attributes + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + return Library_Graph_Vertex_Attributes; + pragma Inline (Get_LGV_Attributes); + -- Obtain the attributes of vertex LGE_Id of library graph G + + function Has_Elaborate_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Has_Elaborate_Body); + -- Determine whether vertex LGV_Id of library graph G is subject to + -- pragma Elaborate_Body. + + procedure Increment_Library_Graph_Edge_Count + (G : Library_Graph; + Kind : Library_Graph_Edge_Kind); + pragma Inline (Increment_Library_Graph_Edge_Count); + -- Increment the number of edges of king Kind in library graph G by one + + procedure Increment_Pending_Predecessors + (G : Library_Graph; + Comp : Component_Id); + pragma Inline (Increment_Pending_Predecessors); + -- Increment the number of pending precedessors component Comp of + -- library graph G must wait on before it can be elaborated by one. + + procedure Increment_Pending_Predecessors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Increment_Pending_Predecessors); + -- Increment the number of pending precedessors vertex LGV_Id of library + -- graph G must wait on before it can be elaborated by one. + + procedure Initialize_Components (G : Library_Graph); + pragma Inline (Initialize_Components); + -- Initialize on the initial call or re-initialize on subsequent calls + -- all components of library graph G. + + function Is_Elaborable_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Predecessors : Natural) return Boolean; + pragma Inline (Is_Elaborable_Vertex); + -- Determine whether vertex LGV_Id of library graph G can be elaborated + -- given that it meets number of predecessors Predecessors. + + function Is_Existing_Predecessor_Successor_Relation + (G : Library_Graph; + Rel : Predecessor_Successor_Relation) return Boolean; + pragma Inline (Is_Existing_Predecessor_Successor_Relation); + -- Determine whether a predecessor vertex and a successor vertex + -- desctibed by relation Rel are already related in library graph G. + + procedure Set_Component_Attributes + (G : Library_Graph; + Comp : Component_Id; + Val : Component_Attributes); + pragma Inline (Set_Component_Attributes); + -- Set the attributes of component Comp of library graph G to value Val + + procedure Set_Corresponding_Vertex + (G : Library_Graph; + U_Id : Unit_Id; + Val : Library_Graph_Vertex_Id); + pragma Inline (Set_Corresponding_Vertex); + -- Associate vertex Val of library graph G with unit U_Id + + procedure Set_Is_Existing_Predecessor_Successor_Relation + (G : Library_Graph; + Rel : Predecessor_Successor_Relation; + Val : Boolean := True); + pragma Inline (Set_Is_Existing_Predecessor_Successor_Relation); + -- Mark a a predecessor vertex and a successor vertex desctibed by + -- relation Rel as already related depending on value Val. + + procedure Set_LGE_Attributes + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id; + Val : Library_Graph_Edge_Attributes); + pragma Inline (Set_LGE_Attributes); + -- Set the attributes of edge LGE_Id of library graph G to value Val + + procedure Set_LGV_Attributes + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Val : Library_Graph_Vertex_Attributes); + pragma Inline (Set_LGV_Attributes); + -- Set the attributes of vertex LGV_Id of library graph G to value Val + + procedure Update_Pending_Predecessors_Of_Components (G : Library_Graph); + pragma Inline (Update_Pending_Predecessors_Of_Components); + -- Update the number of pending predecessors all components of library + -- graph G must wait on before they can be elaborated. + + procedure Update_Pending_Predecessors_Of_Components + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id); + pragma Inline (Update_Pending_Predecessors_Of_Components); + -- Update the number of pending predecessors the component of edge + -- LGE_Is's successor vertex of library graph G must wait on before + -- it can be elaborated. + + ------------------------------- + -- Add_Body_Before_Spec_Edge -- + ------------------------------- + + procedure Add_Body_Before_Spec_Edge + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Edges : EL.Doubly_Linked_List) + is + LGE_Id : Library_Graph_Edge_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + pragma Assert (EL.Present (Edges)); + + -- A vertex requires a special Body_Before_Spec edge to its + -- Corresponging_Item when it either denotes a + -- + -- * Body that completes a previous spec + -- + -- * Spec with a completing body + -- + -- The edge creates an intentional circularity between the spec and + -- body in order to emulate a library unit, and guarantees that both + -- will appear in the same component. + -- + -- Due to the structure of the library graph, either the spec or + -- the body may be visited first, yet Corresponding_Item will still + -- attempt to create the Body_Before_Spec edge. This is OK because + -- successor and predecessor are kept consistent in both cases, and + -- Add_Edge_With_Return will prevent the creation of the second edge. + + -- Assume that that no Body_Before_Spec is necessary + + LGE_Id := No_Library_Graph_Edge; + + -- A body that completes a previous spec + + if Is_Body_With_Spec (G, LGV_Id) then + LGE_Id := + Add_Edge_With_Return + (G => G, + Pred => LGV_Id, -- body + Succ => Corresponding_Item (G, LGV_Id), -- spec + Kind => Body_Before_Spec_Edge); + + -- A spec with a completing body + + elsif Is_Spec_With_Body (G, LGV_Id) then + LGE_Id := + Add_Edge_With_Return + (G => G, + Pred => Corresponding_Item (G, LGV_Id), -- body + Succ => LGV_Id, -- spec + Kind => Body_Before_Spec_Edge); + end if; + + if Present (LGE_Id) then + EL.Append (Edges, LGE_Id); + end if; + end Add_Body_Before_Spec_Edge; + + -------------------------------- + -- Add_Body_Before_Spec_Edges -- + -------------------------------- + + procedure Add_Body_Before_Spec_Edges + (G : Library_Graph; + Edges : EL.Doubly_Linked_List) + is + Iter : Elaborable_Units_Iterator; + LGV_Id : Library_Graph_Vertex_Id; + U_Id : Unit_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (EL.Present (Edges)); + + Iter := Iterate_Elaborable_Units; + while Has_Next (Iter) loop + Next (Iter, U_Id); + + LGV_Id := Corresponding_Vertex (G, U_Id); + pragma Assert (Present (LGV_Id)); + + Add_Body_Before_Spec_Edge (G, LGV_Id, Edges); + end loop; + end Add_Body_Before_Spec_Edges; + + -------------- + -- Add_Edge -- + -------------- + + procedure Add_Edge + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + Kind : Library_Graph_Edge_Kind) + is + LGE_Id : Library_Graph_Edge_Id; + pragma Unreferenced (LGE_Id); + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + pragma Assert (Kind /= No_Edge); + + LGE_Id := + Add_Edge_With_Return + (G => G, + Pred => Pred, + Succ => Succ, + Kind => Kind); + end Add_Edge; + + -------------------------- + -- Add_Edge_With_Return -- + -------------------------- + + function Add_Edge_With_Return + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + Kind : Library_Graph_Edge_Kind) return Library_Graph_Edge_Id + is + pragma Assert (Present (G)); + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + pragma Assert (Kind /= No_Edge); + + Rel : constant Predecessor_Successor_Relation := + (Predecessor => Pred, + Successor => Succ); + + LGE_Id : Library_Graph_Edge_Id; + + begin + -- Nothing to do when the predecessor and successor are already + -- related by an edge. + + if Is_Existing_Predecessor_Successor_Relation (G, Rel) then + return No_Library_Graph_Edge; + end if; + + LGE_Id := Sequence_Next_LGE_Id; + + -- Add the edge to the underlying graph. Note that the predecessor + -- is the source of the edge because it will later need to notify + -- all its successors that it has been elaborated. + + DG.Add_Edge + (G => G.Graph, + E => LGE_Id, + Source => Pred, + Destination => Succ); + + -- Construct and save the attributes of the edge + + Set_LGE_Attributes + (G => G, + LGE_Id => LGE_Id, + Val => (Kind => Kind)); + + -- Mark the predecessor and successor as related by the new edge. + -- This prevents all further attempts to link the same predecessor + -- and successor. + + Set_Is_Existing_Predecessor_Successor_Relation (G, Rel); + + -- Update the number of pending predecessors the successor must wait + -- on before it is elaborated. + + Increment_Pending_Predecessors (G, Succ); + + -- Update the edge statistics + + Increment_Library_Graph_Edge_Count (G, Kind); + + return LGE_Id; + end Add_Edge_With_Return; + + ---------------- + -- Add_Vertex -- + ---------------- + + procedure Add_Vertex + (G : Library_Graph; + U_Id : Unit_Id) + is + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (U_Id)); + + -- Nothing to do when the unit already has a vertex + + if Present (Corresponding_Vertex (G, U_Id)) then + return; + end if; + + LGV_Id := Sequence_Next_LGV_Id; + + -- Add the vertex to the underlying graph + + DG.Add_Vertex (G.Graph, LGV_Id); + + -- Construct and save the attributes of the vertex + + Set_LGV_Attributes + (G => G, + LGV_Id => LGV_Id, + Val => (Corresponding_Item => No_Library_Graph_Vertex, + In_Elaboration_Order => False, + Pending_Predecessors => 0, + Unit => U_Id)); + + -- Associate the unit with its corresponding vertex + + Set_Corresponding_Vertex (G, U_Id, LGV_Id); + end Add_Vertex; + + --------------- + -- Component -- + --------------- + + function Component + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Component_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + return DG.Component (G.Graph, LGV_Id); + end Component; + + ------------------------ + -- Corresponding_Item -- + ------------------------ + + function Corresponding_Item + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + return Get_LGV_Attributes (G, LGV_Id).Corresponding_Item; + end Corresponding_Item; + + -------------------------- + -- Corresponding_Vertex -- + -------------------------- + + function Corresponding_Vertex + (G : Library_Graph; + U_Id : Unit_Id) return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (U_Id)); + + return UV.Get (G.Unit_To_Vertex, U_Id); + end Corresponding_Vertex; + + ------------ + -- Create -- + ------------ + + function Create + (Initial_Vertices : Positive; + Initial_Edges : Positive) return Library_Graph + is + G : constant Library_Graph := new Library_Graph_Attributes; + + begin + G.Component_Attributes := CA.Create (Initial_Vertices); + G.Edge_Attributes := EA.Create (Initial_Edges); + G.Graph := + DG.Create + (Initial_Vertices => Initial_Vertices, + Initial_Edges => Initial_Edges); + G.Relations := PS.Create (Initial_Edges); + G.Unit_To_Vertex := UV.Create (Initial_Vertices); + G.Vertex_Attributes := VA.Create (Initial_Vertices); + + return G; + end Create; + + ---------------------------------------- + -- Decrement_Library_Graph_Edge_Count -- + ---------------------------------------- + + procedure Decrement_Library_Graph_Edge_Count + (G : Library_Graph; + Kind : Library_Graph_Edge_Kind) + is + pragma Assert (Present (G)); + + Count : Natural renames G.Counts (Kind); + + begin + Count := Count - 1; + end Decrement_Library_Graph_Edge_Count; + + ------------------------------------ + -- Decrement_Pending_Predecessors -- + ------------------------------------ + + procedure Decrement_Pending_Predecessors + (G : Library_Graph; + Comp : Component_Id) + is + Attrs : Component_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + Attrs := Get_Component_Attributes (G, Comp); + Attrs.Pending_Predecessors := Attrs.Pending_Predecessors - 1; + Set_Component_Attributes (G, Comp, Attrs); + end Decrement_Pending_Predecessors; + + ------------------------------------ + -- Decrement_Pending_Predecessors -- + ------------------------------------ + + procedure Decrement_Pending_Predecessors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + is + Attrs : Library_Graph_Vertex_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Attrs := Get_LGV_Attributes (G, LGV_Id); + Attrs.Pending_Predecessors := Attrs.Pending_Predecessors - 1; + Set_LGV_Attributes (G, LGV_Id, Attrs); + end Decrement_Pending_Predecessors; + + ----------------------------------- + -- Delete_Body_Before_Spec_Edges -- + ----------------------------------- + + procedure Delete_Body_Before_Spec_Edges + (G : Library_Graph; + Edges : EL.Doubly_Linked_List) + is + Iter : EL.Iterator; + LGE_Id : Library_Graph_Edge_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (EL.Present (Edges)); + + Iter := EL.Iterate (Edges); + while EL.Has_Next (Iter) loop + EL.Next (Iter, LGE_Id); + pragma Assert (Present (LGE_Id)); + pragma Assert (Kind (G, LGE_Id) = Body_Before_Spec_Edge); + + Delete_Edge (G, LGE_Id); + end loop; + end Delete_Body_Before_Spec_Edges; + + ----------------- + -- Delete_Edge -- + ----------------- + + procedure Delete_Edge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (LGE_Id)); + + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, LGE_Id); + Succ : constant Library_Graph_Vertex_Id := Successor (G, LGE_Id); + + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + + Rel : constant Predecessor_Successor_Relation := + (Predecessor => Pred, + Successor => Succ); + + begin + -- Update the edge statistics + + Decrement_Library_Graph_Edge_Count (G, Kind (G, LGE_Id)); + + -- Update the number of pending predecessors the successor must wait + -- on before it is elaborated. + + Decrement_Pending_Predecessors (G, Succ); + + -- Delete the link between the predecessor and successor. This allows + -- for further attempts to link the same predecessor and successor. + + PS.Delete (G.Relations, Rel); + + -- Delete the attributes of the edge + + EA.Delete (G.Edge_Attributes, LGE_Id); + + -- Delete the edge from the underlying graph + + DG.Delete_Edge (G.Graph, LGE_Id); + end Delete_Edge; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (G : in out Library_Graph) is + begin + pragma Assert (Present (G)); + + CA.Destroy (G.Component_Attributes); + EA.Destroy (G.Edge_Attributes); + DG.Destroy (G.Graph); + PS.Destroy (G.Relations); + UV.Destroy (G.Unit_To_Vertex); + VA.Destroy (G.Vertex_Attributes); + + Free (G); + end Destroy; + + ---------------------------------- + -- Destroy_Component_Attributes -- + ---------------------------------- + + procedure Destroy_Component_Attributes + (Attrs : in out Component_Attributes) + is + pragma Unreferenced (Attrs); + begin + null; + end Destroy_Component_Attributes; + + -------------------------------- + -- Destroy_Library_Graph_Edge -- + -------------------------------- + + procedure Destroy_Library_Graph_Edge + (LGE_Id : in out Library_Graph_Edge_Id) + is + pragma Unreferenced (LGE_Id); + begin + null; + end Destroy_Library_Graph_Edge; + + ------------------------------------------- + -- Destroy_Library_Graph_Edge_Attributes -- + ------------------------------------------- + + procedure Destroy_Library_Graph_Edge_Attributes + (Attrs : in out Library_Graph_Edge_Attributes) + is + pragma Unreferenced (Attrs); + begin + null; + end Destroy_Library_Graph_Edge_Attributes; + + ---------------------------------- + -- Destroy_Library_Graph_Vertex -- + ---------------------------------- + + procedure Destroy_Library_Graph_Vertex + (LGV_Id : in out Library_Graph_Vertex_Id) + is + pragma Unreferenced (LGV_Id); + begin + null; + end Destroy_Library_Graph_Vertex; + + --------------------------------------------- + -- Destroy_Library_Graph_Vertex_Attributes -- + --------------------------------------------- + + procedure Destroy_Library_Graph_Vertex_Attributes + (Attrs : in out Library_Graph_Vertex_Attributes) + is + pragma Unreferenced (Attrs); + begin + null; + end Destroy_Library_Graph_Vertex_Attributes; + + --------------------- + -- Find_Components -- + --------------------- + + procedure Find_Components (G : Library_Graph) is + Edges : EL.Doubly_Linked_List; + + begin + pragma Assert (Present (G)); + + -- Initialize or reinitialize the components of the graph + + Initialize_Components (G); + + -- Create a set of special edges that link a predecessor body with a + -- successor spec. This is an illegal dependency, however using such + -- edges eliminates the need to create yet another graph, where both + -- spec and body are collapsed into a single vertex. + + Edges := EL.Create; + Add_Body_Before_Spec_Edges (G, Edges); + + DG.Find_Components (G.Graph); + + -- Remove the special edges that link a predecessor body with a + -- successor spec because they cause unresolvable circularities. + + Delete_Body_Before_Spec_Edges (G, Edges); + EL.Destroy (Edges); + + -- Update the number of predecessors various components must wait on + -- before they can be elaborated. + + Update_Pending_Predecessors_Of_Components (G); + end Find_Components; + + ------------------------------ + -- Get_Component_Attributes -- + ------------------------------ + + function Get_Component_Attributes + (G : Library_Graph; + Comp : Component_Id) return Component_Attributes + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + return CA.Get (G.Component_Attributes, Comp); + end Get_Component_Attributes; + + ------------------------ + -- Get_LGE_Attributes -- + ------------------------ + + function Get_LGE_Attributes + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) + return Library_Graph_Edge_Attributes + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGE_Id)); + + return EA.Get (G.Edge_Attributes, LGE_Id); + end Get_LGE_Attributes; + + ------------------------ + -- Get_LGV_Attributes -- + ------------------------ + + function Get_LGV_Attributes + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + return Library_Graph_Vertex_Attributes + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + return VA.Get (G.Vertex_Attributes, LGV_Id); + end Get_LGV_Attributes; + + ------------------------ + -- Has_Elaborate_Body -- + ------------------------ + + function Has_Elaborate_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Elaborate_Body; + end Has_Elaborate_Body; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : All_Edge_Iterator) return Boolean is + begin + return DG.Has_Next (DG.All_Edge_Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : All_Vertex_Iterator) return Boolean is + begin + return DG.Has_Next (DG.All_Vertex_Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Component_Iterator) return Boolean is + begin + return DG.Has_Next (DG.Component_Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Component_Vertex_Iterator) return Boolean is + begin + return DG.Has_Next (DG.Component_Vertex_Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Edges_To_Successors_Iterator) return Boolean is + begin + return DG.Has_Next (DG.Outgoing_Edge_Iterator (Iter)); + end Has_Next; + + ----------------------------------------- + -- Hash_Predecessor_Successor_Relation -- + ----------------------------------------- + + function Hash_Predecessor_Successor_Relation + (Rel : Predecessor_Successor_Relation) return Bucket_Range_Type + is + begin + pragma Assert (Present (Rel.Predecessor)); + pragma Assert (Present (Rel.Successor)); + + return + Hash_Two_Keys + (Bucket_Range_Type (Rel.Predecessor), + Bucket_Range_Type (Rel.Successor)); + end Hash_Predecessor_Successor_Relation; + + -------------------------- + -- In_Elaboration_Order -- + -------------------------- + + function In_Elaboration_Order + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + return Get_LGV_Attributes (G, LGV_Id).In_Elaboration_Order; + end In_Elaboration_Order; + + ---------------------------------------- + -- Increment_Library_Graph_Edge_Count -- + ---------------------------------------- + + procedure Increment_Library_Graph_Edge_Count + (G : Library_Graph; + Kind : Library_Graph_Edge_Kind) + is + pragma Assert (Present (G)); + + Count : Natural renames G.Counts (Kind); + + begin + Count := Count + 1; + end Increment_Library_Graph_Edge_Count; + + ------------------------------------ + -- Increment_Pending_Predecessors -- + ------------------------------------ + + procedure Increment_Pending_Predecessors + (G : Library_Graph; + Comp : Component_Id) + is + Attrs : Component_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + Attrs := Get_Component_Attributes (G, Comp); + Attrs.Pending_Predecessors := Attrs.Pending_Predecessors + 1; + Set_Component_Attributes (G, Comp, Attrs); + end Increment_Pending_Predecessors; + + ------------------------------------ + -- Increment_Pending_Predecessors -- + ------------------------------------ + + procedure Increment_Pending_Predecessors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + is + Attrs : Library_Graph_Vertex_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Attrs := Get_LGV_Attributes (G, LGV_Id); + Attrs.Pending_Predecessors := Attrs.Pending_Predecessors + 1; + Set_LGV_Attributes (G, LGV_Id, Attrs); + end Increment_Pending_Predecessors; + + --------------------------- + -- Initialize_Components -- + --------------------------- + + procedure Initialize_Components (G : Library_Graph) is + begin + pragma Assert (Present (G)); + + -- The graph already contains a set of components. Reinitialize + -- them in order to accomodate the new set of components about to + -- be computed. + + if Number_Of_Components (G) > 0 then + CA.Destroy (G.Component_Attributes); + G.Component_Attributes := CA.Create (Number_Of_Vertices (G)); + end if; + end Initialize_Components; + + ------------- + -- Is_Body -- + ------------- + + function Is_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Utype = Is_Body or else U_Rec.Utype = Is_Body_Only; + end Is_Body; + + ----------------------------------------- + -- Is_Body_Of_Spec_With_Elaborate_Body -- + ----------------------------------------- + + function Is_Body_Of_Spec_With_Elaborate_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + Spec_LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + if Is_Body_With_Spec (G, LGV_Id) then + Spec_LGV_Id := Proper_Spec (G, LGV_Id); + pragma Assert (Present (Spec_LGV_Id)); + + return Is_Spec_With_Elaborate_Body (G, Spec_LGV_Id); + end if; + + return False; + end Is_Body_Of_Spec_With_Elaborate_Body; + + ----------------------- + -- Is_Body_With_Spec -- + ----------------------- + + function Is_Body_With_Spec + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Utype = Is_Body; + end Is_Body_With_Spec; + + ----------------------------- + -- Is_Elaborable_Component -- + ----------------------------- + + function Is_Elaborable_Component + (G : Library_Graph; + Comp : Component_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + -- A component can be elaborated when + -- + -- * The component is no longer wanting on any of its predecessors + -- to be elaborated. + + return Pending_Predecessors (G, Comp) = 0; + end Is_Elaborable_Component; + + -------------------------- + -- Is_Elaborable_Vertex -- + -------------------------- + + function Is_Elaborable_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + Check_LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Check_LGV_Id := LGV_Id; + + -- A spec-body pair where the spec carries pragma Elaborate_Body must + -- be treated as one vertex for elaboration purposes. Use the spec as + -- the point of reference for the composite vertex. + + if Is_Body_Of_Spec_With_Elaborate_Body (G, Check_LGV_Id) then + Check_LGV_Id := Proper_Spec (G, Check_LGV_Id); + pragma Assert (Present (Check_LGV_Id)); + end if; + + return + Is_Elaborable_Vertex + (G => G, + LGV_Id => Check_LGV_Id, + Predecessors => 0); + end Is_Elaborable_Vertex; + + -------------------------- + -- Is_Elaborable_Vertex -- + -------------------------- + + function Is_Elaborable_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Predecessors : Natural) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Comp : constant Component_Id := Component (G, LGV_Id); + + pragma Assert (Present (Comp)); + + Body_LGV_Id : Library_Graph_Vertex_Id; + + begin + -- The vertex must not be re-elaborated once it has been elaborated + + if In_Elaboration_Order (G, LGV_Id) then + return False; + + -- The vertex must not be waiting on more precedessors than requested + -- to be elaborated. + + elsif Pending_Predecessors (G, LGV_Id) /= Predecessors then + return False; + + -- The component where the vertex resides must not be waiting on any + -- of its precedessors to be elaborated. + + elsif not Is_Elaborable_Component (G, Comp) then + return False; + + -- The vertex denotes a spec with a completing body, and is subject + -- to pragma Elaborate_Body. The body must be elaborable for the + -- vertex to be elaborated. Account for the sole predecessor of the + -- body which is the vertex itself. + + elsif Is_Spec_With_Elaborate_Body (G, LGV_Id) then + Body_LGV_Id := Proper_Body (G, LGV_Id); + pragma Assert (Present (Body_LGV_Id)); + + return + Is_Elaborable_Vertex + (G => G, + LGV_Id => Body_LGV_Id, + Predecessors => 1); + end if; + + -- At this point it is known that the vertex can be elaborated + + return True; + end Is_Elaborable_Vertex; + + ------------------------------------------------ + -- Is_Existing_Predecessor_Successor_Relation -- + ------------------------------------------------ + + function Is_Existing_Predecessor_Successor_Relation + (G : Library_Graph; + Rel : Predecessor_Successor_Relation) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Rel.Predecessor)); + pragma Assert (Present (Rel.Successor)); + + return PS.Contains (G.Relations, Rel); + end Is_Existing_Predecessor_Successor_Relation; + + ---------------------- + -- Is_Internal_Unit -- + ---------------------- + + function Is_Internal_Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + begin + return Is_Internal_Unit (U_Id); + end Is_Internal_Unit; + + ------------------------ + -- Is_Predefined_Unit -- + ------------------------ + + function Is_Predefined_Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + begin + return Is_Predefined_Unit (U_Id); + end Is_Predefined_Unit; + + --------------------------- + -- Is_Preelaborated_Unit -- + --------------------------- + + function Is_Preelaborated_Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Preelab or else U_Rec.Pure; + end Is_Preelaborated_Unit; + + ------------- + -- Is_Spec -- + ------------- + + function Is_Spec + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Utype = Is_Spec or else U_Rec.Utype = Is_Spec_Only; + end Is_Spec; + + ----------------------- + -- Is_Spec_With_Body -- + ----------------------- + + function Is_Spec_With_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Utype = Is_Spec; + end Is_Spec_With_Body; + + --------------------------------- + -- Is_Spec_With_Elaborate_Body -- + --------------------------------- + + function Is_Spec_With_Elaborate_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + return + Is_Spec_With_Body (G, LGV_Id) + and then Has_Elaborate_Body (G, LGV_Id); + end Is_Spec_With_Elaborate_Body; + + ----------------------- + -- Iterate_All_Edges -- + ----------------------- + + function Iterate_All_Edges + (G : Library_Graph) return All_Edge_Iterator + is + begin + pragma Assert (Present (G)); + + return All_Edge_Iterator (DG.Iterate_All_Edges (G.Graph)); + end Iterate_All_Edges; + + -------------------------- + -- Iterate_All_Vertices -- + -------------------------- + + function Iterate_All_Vertices + (G : Library_Graph) return All_Vertex_Iterator + is + begin + pragma Assert (Present (G)); + + return All_Vertex_Iterator (DG.Iterate_All_Vertices (G.Graph)); + end Iterate_All_Vertices; + + ------------------------ + -- Iterate_Components -- + ------------------------ + + function Iterate_Components + (G : Library_Graph) return Component_Iterator + is + begin + pragma Assert (Present (G)); + + return Component_Iterator (DG.Iterate_Components (G.Graph)); + end Iterate_Components; + + -------------------------------- + -- Iterate_Component_Vertices -- + -------------------------------- + + function Iterate_Component_Vertices + (G : Library_Graph; + Comp : Component_Id) return Component_Vertex_Iterator + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + return + Component_Vertex_Iterator + (DG.Iterate_Component_Vertices (G.Graph, Comp)); + end Iterate_Component_Vertices; + + --------------------------------- + -- Iterate_Edges_To_Successors -- + --------------------------------- + + function Iterate_Edges_To_Successors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + return Edges_To_Successors_Iterator + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + return + Edges_To_Successors_Iterator + (DG.Iterate_Outgoing_Edges (G.Graph, LGV_Id)); + end Iterate_Edges_To_Successors; + + ---------- + -- Kind -- + ---------- + + function Kind + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Edge_Kind + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGE_Id)); + + return Get_LGE_Attributes (G, LGE_Id).Kind; + end Kind; + + ------------------------------ + -- Library_Graph_Edge_Count -- + ------------------------------ + + function Library_Graph_Edge_Count + (G : Library_Graph; + Kind : Library_Graph_Edge_Kind) return Natural + is + begin + pragma Assert (Present (G)); + + return G.Counts (Kind); + end Library_Graph_Edge_Count; + + -------------------------------------- + -- Links_Vertices_In_Same_Component -- + -------------------------------------- + + function Links_Vertices_In_Same_Component + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGE_Id)); + + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, LGE_Id); + Succ : constant Library_Graph_Vertex_Id := Successor (G, LGE_Id); + + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + + Pred_Comp : constant Component_Id := Component (G, Pred); + Succ_Comp : constant Component_Id := Component (G, Succ); + + pragma Assert (Present (Pred_Comp)); + pragma Assert (Present (Succ_Comp)); + + begin + return Pred_Comp = Succ_Comp; + end Links_Vertices_In_Same_Component; + + ---------- + -- Name -- + ---------- + + function Name + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Unit_Name_Type + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + begin + return Name (U_Id); + end Name; + + ----------------------- + -- Needs_Elaboration -- + ----------------------- + + function Needs_Elaboration + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + begin + return Needs_Elaboration (U_Id); + end Needs_Elaboration; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out All_Edge_Iterator; + LGE_Id : out Library_Graph_Edge_Id) + is + begin + DG.Next (DG.All_Edge_Iterator (Iter), LGE_Id); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out All_Vertex_Iterator; + LGV_Id : out Library_Graph_Vertex_Id) + is + begin + DG.Next (DG.All_Vertex_Iterator (Iter), LGV_Id); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Component_Iterator; + Comp : out Component_Id) + is + begin + DG.Next (DG.Component_Iterator (Iter), Comp); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Edges_To_Successors_Iterator; + LGE_Id : out Library_Graph_Edge_Id) + is + begin + DG.Next (DG.Outgoing_Edge_Iterator (Iter), LGE_Id); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Component_Vertex_Iterator; + LGV_Id : out Library_Graph_Vertex_Id) + is + begin + DG.Next (DG.Component_Vertex_Iterator (Iter), LGV_Id); + end Next; + + ---------------------------------- + -- Number_Of_Component_Vertices -- + ---------------------------------- + + function Number_Of_Component_Vertices + (G : Library_Graph; + Comp : Component_Id) return Natural + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + return DG.Number_Of_Component_Vertices (G.Graph, Comp); + end Number_Of_Component_Vertices; + + -------------------------- + -- Number_Of_Components -- + -------------------------- + + function Number_Of_Components (G : Library_Graph) return Natural is + begin + pragma Assert (Present (G)); + + return DG.Number_Of_Components (G.Graph); + end Number_Of_Components; + + --------------------- + -- Number_Of_Edges -- + --------------------- + + function Number_Of_Edges (G : Library_Graph) return Natural is + begin + pragma Assert (Present (G)); + + return DG.Number_Of_Edges (G.Graph); + end Number_Of_Edges; + + ----------------------------------- + -- Number_Of_Edges_To_Successors -- + ----------------------------------- + + function Number_Of_Edges_To_Successors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Natural + is + begin + pragma Assert (Present (G)); + + return DG.Number_Of_Outgoing_Edges (G.Graph, LGV_Id); + end Number_Of_Edges_To_Successors; + + ------------------------ + -- Number_Of_Vertices -- + ------------------------ + + function Number_Of_Vertices (G : Library_Graph) return Natural is + begin + pragma Assert (Present (G)); + + return DG.Number_Of_Vertices (G.Graph); + end Number_Of_Vertices; + + -------------------------- + -- Pending_Predecessors -- + -------------------------- + + function Pending_Predecessors + (G : Library_Graph; + Comp : Component_Id) return Natural + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + return Get_Component_Attributes (G, Comp).Pending_Predecessors; + end Pending_Predecessors; + + -------------------------- + -- Pending_Predecessors -- + -------------------------- + + function Pending_Predecessors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Natural + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + return Get_LGV_Attributes (G, LGV_Id).Pending_Predecessors; + end Pending_Predecessors; + + ----------------- + -- Predecessor -- + ----------------- + + function Predecessor + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGE_Id)); + + return DG.Source_Vertex (G.Graph, LGE_Id); + end Predecessor; + + ------------- + -- Present -- + ------------- + + function Present (G : Library_Graph) return Boolean is + begin + return G /= Nil; + end Present; + + ----------------- + -- Proper_Body -- + ----------------- + + function Proper_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + -- When the vertex denotes a spec with a completing body, return the + -- body. + + if Is_Spec_With_Body (G, LGV_Id) then + return Corresponding_Item (G, LGV_Id); + + -- Otherwise the vertex must be a body + + else + pragma Assert (Is_Body (G, LGV_Id)); + return LGV_Id; + end if; + end Proper_Body; + + ----------------- + -- Proper_Spec -- + ----------------- + + function Proper_Spec + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + -- When the vertex denotes a body that completes a spec, return the + -- spec. + + if Is_Body_With_Spec (G, LGV_Id) then + return Corresponding_Item (G, LGV_Id); + + -- Otherwise the vertex must denote a spec + + else + pragma Assert (Is_Spec (G, LGV_Id)); + return LGV_Id; + end if; + end Proper_Spec; + + ------------------------------ + -- Set_Component_Attributes -- + ------------------------------ + + procedure Set_Component_Attributes + (G : Library_Graph; + Comp : Component_Id; + Val : Component_Attributes) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + CA.Put (G.Component_Attributes, Comp, Val); + end Set_Component_Attributes; + + ---------------------------- + -- Set_Corresponding_Item -- + ---------------------------- + + procedure Set_Corresponding_Item + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Val : Library_Graph_Vertex_Id) + is + Attrs : Library_Graph_Vertex_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Attrs := Get_LGV_Attributes (G, LGV_Id); + Attrs.Corresponding_Item := Val; + Set_LGV_Attributes (G, LGV_Id, Attrs); + end Set_Corresponding_Item; + + ------------------------------ + -- Set_Corresponding_Vertex -- + ------------------------------ + + procedure Set_Corresponding_Vertex + (G : Library_Graph; + U_Id : Unit_Id; + Val : Library_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (U_Id)); + + UV.Put (G.Unit_To_Vertex, U_Id, Val); + end Set_Corresponding_Vertex; + + ------------------------------ + -- Set_In_Elaboration_Order -- + ------------------------------ + + procedure Set_In_Elaboration_Order + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Val : Boolean := True) + is + Attrs : Library_Graph_Vertex_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Attrs := Get_LGV_Attributes (G, LGV_Id); + Attrs.In_Elaboration_Order := Val; + Set_LGV_Attributes (G, LGV_Id, Attrs); + end Set_In_Elaboration_Order; + + ---------------------------------------------------- + -- Set_Is_Existing_Predecessor_Successor_Relation -- + ---------------------------------------------------- + + procedure Set_Is_Existing_Predecessor_Successor_Relation + (G : Library_Graph; + Rel : Predecessor_Successor_Relation; + Val : Boolean := True) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Rel.Predecessor)); + pragma Assert (Present (Rel.Successor)); + + if Val then + PS.Insert (G.Relations, Rel); + else + PS.Delete (G.Relations, Rel); + end if; + end Set_Is_Existing_Predecessor_Successor_Relation; + + ------------------------ + -- Set_LGE_Attributes -- + ------------------------ + + procedure Set_LGE_Attributes + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id; + Val : Library_Graph_Edge_Attributes) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGE_Id)); + + EA.Put (G.Edge_Attributes, LGE_Id, Val); + end Set_LGE_Attributes; + + ------------------------ + -- Set_LGV_Attributes -- + ------------------------ + + procedure Set_LGV_Attributes + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Val : Library_Graph_Vertex_Attributes) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + VA.Put (G.Vertex_Attributes, LGV_Id, Val); + end Set_LGV_Attributes; + + --------------- + -- Successor -- + --------------- + + function Successor + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGE_Id)); + + return DG.Destination_Vertex (G.Graph, LGE_Id); + end Successor; + + ---------- + -- Unit -- + ---------- + + function Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Unit_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + return Get_LGV_Attributes (G, LGV_Id).Unit; + end Unit; + + ----------------------------------------------- + -- Update_Pending_Predecessors_Of_Components -- + ----------------------------------------------- + + procedure Update_Pending_Predecessors_Of_Components + (G : Library_Graph) + is + Iter : All_Edge_Iterator; + LGE_Id : Library_Graph_Edge_Id; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Edges (G); + while Has_Next (Iter) loop + Next (Iter, LGE_Id); + pragma Assert (Present (LGE_Id)); + + Update_Pending_Predecessors_Of_Components (G, LGE_Id); + end loop; + end Update_Pending_Predecessors_Of_Components; + + ----------------------------------------------- + -- Update_Pending_Predecessors_Of_Components -- + ----------------------------------------------- + + procedure Update_Pending_Predecessors_Of_Components + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (LGE_Id)); + + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, LGE_Id); + Succ : constant Library_Graph_Vertex_Id := Successor (G, LGE_Id); + + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + + Pred_Comp : constant Component_Id := Component (G, Pred); + Succ_Comp : constant Component_Id := Component (G, Succ); + + pragma Assert (Present (Pred_Comp)); + pragma Assert (Present (Succ_Comp)); + + begin + -- The edge links a successor and a predecessor coming from two + -- different SCCs. This indicates that the SCC of the successor + -- must wait on another predecessor until it can be elaborated. + + if Pred_Comp /= Succ_Comp then + Increment_Pending_Predecessors (G, Succ_Comp); + end if; + end Update_Pending_Predecessors_Of_Components; + end Library_Graphs; + + ------------- + -- Present -- + ------------- + + function Present (IGE_Id : Invocation_Graph_Edge_Id) return Boolean is + begin + return IGE_Id /= No_Invocation_Graph_Edge; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (IGV_Id : Invocation_Graph_Vertex_Id) return Boolean is + begin + return IGV_Id /= No_Invocation_Graph_Vertex; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (LGE_Id : Library_Graph_Edge_Id) return Boolean is + begin + return LGE_Id /= No_Library_Graph_Edge; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (LGV_Id : Library_Graph_Vertex_Id) return Boolean is + begin + return LGV_Id /= No_Library_Graph_Vertex; + end Present; + + -------------------------- + -- Sequence_Next_IGE_Id -- + -------------------------- + + IGE_Sequencer : Invocation_Graph_Edge_Id := First_Invocation_Graph_Edge; + -- The counter for invocation graph edges. Do not directly manipulate its + -- value. + + function Sequence_Next_IGE_Id return Invocation_Graph_Edge_Id is + IGE_Id : constant Invocation_Graph_Edge_Id := IGE_Sequencer; + + begin + IGE_Sequencer := IGE_Sequencer + 1; + return IGE_Id; + end Sequence_Next_IGE_Id; + + -------------------------- + -- Sequence_Next_IGV_Id -- + -------------------------- + + IGV_Sequencer : Invocation_Graph_Vertex_Id := First_Invocation_Graph_Vertex; + -- The counter for invocation graph vertices. Do not directly manipulate + -- its value. + + -------------------------- + -- Sequence_Next_IGV_Id -- + -------------------------- + + function Sequence_Next_IGV_Id return Invocation_Graph_Vertex_Id is + IGV_Id : constant Invocation_Graph_Vertex_Id := IGV_Sequencer; + + begin + IGV_Sequencer := IGV_Sequencer + 1; + return IGV_Id; + end Sequence_Next_IGV_Id; + + -------------------------- + -- Sequence_Next_LGE_Id -- + -------------------------- + + LGE_Sequencer : Library_Graph_Edge_Id := First_Library_Graph_Edge; + -- The counter for library graph edges. Do not directly manipulate its + -- value. + + function Sequence_Next_LGE_Id return Library_Graph_Edge_Id is + LGE_Id : constant Library_Graph_Edge_Id := LGE_Sequencer; + + begin + LGE_Sequencer := LGE_Sequencer + 1; + return LGE_Id; + end Sequence_Next_LGE_Id; + + -------------------------- + -- Sequence_Next_LGV_Id -- + -------------------------- + + LGV_Sequencer : Library_Graph_Vertex_Id := First_Library_Graph_Vertex; + -- The counter for library graph vertices. Do not directly manipulate its + -- value. + + function Sequence_Next_LGV_Id return Library_Graph_Vertex_Id is + LGV_Id : constant Library_Graph_Vertex_Id := LGV_Sequencer; + + begin + LGV_Sequencer := LGV_Sequencer + 1; + return LGV_Id; + end Sequence_Next_LGV_Id; + +end Bindo.Graphs; diff --git a/gcc/ada/bindo-graphs.ads b/gcc/ada/bindo-graphs.ads new file mode 100644 index 0000000..a5dc6ea --- /dev/null +++ b/gcc/ada/bindo-graphs.ads @@ -0,0 +1,1248 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . G R A P H S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit defines the various graphs used in determining the +-- elaboration order of units. + +with Bindo.Units; use Bindo.Units; + +with GNAT; use GNAT; +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; +with GNAT.Graphs; use GNAT.Graphs; +with GNAT.Sets; use GNAT.Sets; + +package Bindo.Graphs is + + --------------------------- + -- Invocation graph edge -- + --------------------------- + + -- The following type denotes an invocation graph edge handle + + type Invocation_Graph_Edge_Id is new Natural; + No_Invocation_Graph_Edge : constant Invocation_Graph_Edge_Id := + Invocation_Graph_Edge_Id'First; + First_Invocation_Graph_Edge : constant Invocation_Graph_Edge_Id := + No_Invocation_Graph_Edge + 1; + + function Hash_Invocation_Graph_Edge + (IGE_Id : Invocation_Graph_Edge_Id) return Bucket_Range_Type; + pragma Inline (Hash_Invocation_Graph_Edge); + -- Obtain the hash value of key IGE_Id + + function Present (IGE_Id : Invocation_Graph_Edge_Id) return Boolean; + pragma Inline (Present); + -- Determine whether invocation graph edge IGE_Id exists + + ------------------------------ + -- Invocation graph vertex -- + ------------------------------ + + -- The following type denotes an invocation graph vertex handle + + type Invocation_Graph_Vertex_Id is new Natural; + No_Invocation_Graph_Vertex : constant Invocation_Graph_Vertex_Id := + Invocation_Graph_Vertex_Id'First; + First_Invocation_Graph_Vertex : constant Invocation_Graph_Vertex_Id := + No_Invocation_Graph_Vertex + 1; + + function Hash_Invocation_Graph_Vertex + (IGV_Id : Invocation_Graph_Vertex_Id) return Bucket_Range_Type; + pragma Inline (Hash_Invocation_Graph_Vertex); + -- Obtain the hash value of key IGV_Id + + function Present (IGV_Id : Invocation_Graph_Vertex_Id) return Boolean; + pragma Inline (Present); + -- Determine whether invocation graph vertex IGV_Id exists + + ------------------------ + -- Library graph edge -- + ------------------------ + + -- The following type denotes a library graph edge handle + + type Library_Graph_Edge_Id is new Natural; + No_Library_Graph_Edge : constant Library_Graph_Edge_Id := + Library_Graph_Edge_Id'First; + First_Library_Graph_Edge : constant Library_Graph_Edge_Id := + No_Library_Graph_Edge + 1; + + function Hash_Library_Graph_Edge + (LGE_Id : Library_Graph_Edge_Id) return Bucket_Range_Type; + pragma Inline (Hash_Library_Graph_Edge); + -- Obtain the hash value of key LGE_Id + + function Present (LGE_Id : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Present); + -- Determine whether library graph edge LGE_Id exists + + -------------------------- + -- Library graph vertex -- + -------------------------- + + -- The following type denotes a library graph vertex handle + + type Library_Graph_Vertex_Id is new Natural; + No_Library_Graph_Vertex : constant Library_Graph_Vertex_Id := + Library_Graph_Vertex_Id'First; + First_Library_Graph_Vertex : constant Library_Graph_Vertex_Id := + No_Library_Graph_Vertex + 1; + + function Hash_Library_Graph_Vertex + (LGV_Id : Library_Graph_Vertex_Id) return Bucket_Range_Type; + pragma Inline (Hash_Library_Graph_Vertex); + -- Obtain the hash value of key LGV_Id + + function Present (LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Present); + -- Determine whether library graph vertex LGV_Id exists + + ----------------------- + -- Invocation_Graphs -- + ----------------------- + + package Invocation_Graphs is + + ----------- + -- Graph -- + ----------- + + -- The following type denotes an invocation graph handle. Each instance + -- must be created using routine Create. + + type Invocation_Graph is private; + Nil : constant Invocation_Graph; + + ---------------------- + -- Graph operations -- + ---------------------- + + procedure Add_Edge + (G : Invocation_Graph; + Source : Invocation_Graph_Vertex_Id; + Target : Invocation_Graph_Vertex_Id; + IR_Id : Invocation_Relation_Id); + pragma Inline (Add_Edge); + -- Create a new edge in invocation graph G with source vertex Source and + -- destination vertex Target. IR_Id is the invocation relation the edge + -- describes. + + procedure Add_Vertex + (G : Invocation_Graph; + IC_Id : Invocation_Construct_Id; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Add_Vertex); + -- Create a new vertex in invocation graph G. IC_Id is the invocation + -- construct the vertex describes. LGV_Id is the library graph vertex + -- where the invocation construct appears. + + function Create + (Initial_Vertices : Positive; + Initial_Edges : Positive) return Invocation_Graph; + pragma Inline (Create); + -- Create a new empty graph with vertex capacity Initial_Vertices and + -- edge capacity Initial_Edges. + + procedure Destroy (G : in out Invocation_Graph); + pragma Inline (Destroy); + -- Destroy the contents of invocation graph G, rendering it unusable + + function Present (G : Invocation_Graph) return Boolean; + pragma Inline (Present); + -- Determine whether invocation graph G exists + + ----------------------- + -- Vertex attributes -- + ----------------------- + + function Construct + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id; + pragma Inline (Construct); + -- Obtain the invocation construct vertex IGV_Id of invocation graph G + -- describes. + + function Corresponding_Vertex + (G : Invocation_Graph; + IS_Id : Invocation_Signature_Id) return Invocation_Graph_Vertex_Id; + pragma Inline (Corresponding_Vertex); + -- Obtain the vertex of invocation graph G that corresponds to signature + -- IS_Id. + + function Lib_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + pragma Inline (Lib_Vertex); + -- Obtain the library graph vertex where vertex IGV_Id of invocation + -- graph appears. + + function Name + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Name_Id; + pragma Inline (Name); + -- Obtain the name of the construct vertex IGV_Id of invocation graph G + -- describes. + + --------------------- + -- Edge attributes -- + --------------------- + + function Kind + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Kind; + pragma Inline (Kind); + -- Obtain the nature of edge IGE_Id of invocation graph G + + function Relation + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Relation_Id; + pragma Inline (Relation); + -- Obtain the relation edge IGE_Id of invocation graph G describes + + function Target + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id; + pragma Inline (Target); + -- Obtain the target vertex edge IGE_Id of invocation graph G designates + + ---------------- + -- Statistics -- + ---------------- + + function Invocation_Graph_Edge_Count + (G : Invocation_Graph; + Kind : Invocation_Kind) return Natural; + pragma Inline (Invocation_Graph_Edge_Count); + -- Obtain the total number of edges of kind Kind in invocation graph G + + function Number_Of_Edges (G : Invocation_Graph) return Natural; + pragma Inline (Number_Of_Edges); + -- Obtain the total number of edges in invocation graph G + + function Number_Of_Edges_To_Targets + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Natural; + pragma Inline (Number_Of_Edges_To_Targets); + -- Obtain the total number of edges to targets vertex IGV_Id of + -- invocation graph G has. + + function Number_Of_Elaboration_Roots + (G : Invocation_Graph) return Natural; + pragma Inline (Number_Of_Elaboration_Roots); + -- Obtain the total number of elaboration roots in invocation graph G + + function Number_Of_Vertices (G : Invocation_Graph) return Natural; + pragma Inline (Number_Of_Vertices); + -- Obtain the total number of vertices in invocation graph G + + --------------- + -- Iterators -- + --------------- + + -- The following type represents an iterator over all edges of an + -- invocation graph. + + type All_Edge_Iterator is private; + + function Has_Next (Iter : All_Edge_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more edges to examine + + function Iterate_All_Edges + (G : Invocation_Graph) return All_Edge_Iterator; + pragma Inline (Iterate_All_Edges); + -- Obtain an iterator over all edges of invocation graph G + + procedure Next + (Iter : in out All_Edge_Iterator; + IGE_Id : out Invocation_Graph_Edge_Id); + pragma Inline (Next); + -- Return the current edge referenced by iterator Iter and advance to + -- the next available edge. + + -- The following type represents an iterator over all vertices of an + -- invocation graph. + + type All_Vertex_Iterator is private; + + function Has_Next (Iter : All_Vertex_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more vertices to examine + + function Iterate_All_Vertices + (G : Invocation_Graph) return All_Vertex_Iterator; + pragma Inline (Iterate_All_Vertices); + -- Obtain an iterator over all vertices of invocation graph G + + procedure Next + (Iter : in out All_Vertex_Iterator; + IGV_Id : out Invocation_Graph_Vertex_Id); + pragma Inline (Next); + -- Return the current vertex referenced by iterator Iter and advance + -- to the next available vertex. + + -- The following type represents an iterator over all edges that reach + -- targets starting from a particular source vertex. + + type Edges_To_Targets_Iterator is private; + + function Has_Next (Iter : Edges_To_Targets_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more edges to examine + + function Iterate_Edges_To_Targets + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator; + pragma Inline (Iterate_Edges_To_Targets); + -- Obtain an iterator over all edges to targets with source vertex + -- IGV_Id of invocation graph G. + + procedure Next + (Iter : in out Edges_To_Targets_Iterator; + IGE_Id : out Invocation_Graph_Edge_Id); + pragma Inline (Next); + -- Return the current edge referenced by iterator Iter and advance to + -- the next available edge. + + -- The following type represents an iterator over all vertices of an + -- invocation graph that denote the elaboration procedure or a spec or + -- a body, referred to as elaboration root. + + type Elaboration_Root_Iterator is private; + + function Has_Next (Iter : Elaboration_Root_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more elaboration roots to examine + + function Iterate_Elaboration_Roots + (G : Invocation_Graph) return Elaboration_Root_Iterator; + pragma Inline (Iterate_Elaboration_Roots); + -- Obtain an iterator over all elaboration roots of invocation graph G + + procedure Next + (Iter : in out Elaboration_Root_Iterator; + Root : out Invocation_Graph_Vertex_Id); + pragma Inline (Next); + -- Return the current elaboration root referenced by iterator Iter and + -- advance to the next available elaboration root. + + private + + -------------- + -- Vertices -- + -------------- + + procedure Destroy_Invocation_Graph_Vertex + (IGV_Id : in out Invocation_Graph_Vertex_Id); + pragma Inline (Destroy_Invocation_Graph_Vertex); + -- Destroy invocation graph vertex IGV_Id + + -- The following type represents the attributes of an invocation graph + -- vertex. + + type Invocation_Graph_Vertex_Attributes is record + Construct : Invocation_Construct_Id := No_Invocation_Construct; + -- Reference to the invocation construct this vertex represents + + Lib_Vertex : Library_Graph_Vertex_Id := No_Library_Graph_Vertex; + -- Reference to the library graph vertex where this vertex resides + end record; + + No_Invocation_Graph_Vertex_Attributes : + constant Invocation_Graph_Vertex_Attributes := + (Construct => No_Invocation_Construct, + Lib_Vertex => No_Library_Graph_Vertex); + + procedure Destroy_Invocation_Graph_Vertex_Attributes + (Attrs : in out Invocation_Graph_Vertex_Attributes); + pragma Inline (Destroy_Invocation_Graph_Vertex_Attributes); + -- Destroy the contents of attributes Attrs + + package VA is new Dynamic_Hash_Tables + (Key_Type => Invocation_Graph_Vertex_Id, + Value_Type => Invocation_Graph_Vertex_Attributes, + No_Value => No_Invocation_Graph_Vertex_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Invocation_Graph_Vertex_Attributes, + Hash => Hash_Invocation_Graph_Vertex); + + ----------- + -- Edges -- + ----------- + + procedure Destroy_Invocation_Graph_Edge + (IGE_Id : in out Invocation_Graph_Edge_Id); + pragma Inline (Destroy_Invocation_Graph_Edge); + -- Destroy invocation graph edge IGE_Id + + -- The following type represents the attributes of an invocation graph + -- edge. + + type Invocation_Graph_Edge_Attributes is record + Relation : Invocation_Relation_Id := No_Invocation_Relation; + -- Reference to the invocation relation this edge represents + end record; + + No_Invocation_Graph_Edge_Attributes : + constant Invocation_Graph_Edge_Attributes := + (Relation => No_Invocation_Relation); + + procedure Destroy_Invocation_Graph_Edge_Attributes + (Attrs : in out Invocation_Graph_Edge_Attributes); + pragma Inline (Destroy_Invocation_Graph_Edge_Attributes); + -- Destroy the contents of attributes Attrs + + package EA is new Dynamic_Hash_Tables + (Key_Type => Invocation_Graph_Edge_Id, + Value_Type => Invocation_Graph_Edge_Attributes, + No_Value => No_Invocation_Graph_Edge_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Invocation_Graph_Edge_Attributes, + Hash => Hash_Invocation_Graph_Edge); + + --------------- + -- Relations -- + --------------- + + -- The following type represents a relation between a source and target + -- vertices. + + type Source_Target_Relation is record + Source : Invocation_Graph_Vertex_Id := No_Invocation_Graph_Vertex; + -- The source vertex + + Target : Invocation_Graph_Vertex_Id := No_Invocation_Graph_Vertex; + -- The destination vertex + end record; + + No_Source_Target_Relation : + constant Source_Target_Relation := + (Source => No_Invocation_Graph_Vertex, + Target => No_Invocation_Graph_Vertex); + + function Hash_Source_Target_Relation + (Rel : Source_Target_Relation) return Bucket_Range_Type; + pragma Inline (Hash_Source_Target_Relation); + -- Obtain the hash value of key Rel + + package ST is new Membership_Sets + (Element_Type => Source_Target_Relation, + "=" => "=", + Hash => Hash_Source_Target_Relation); + + ---------------- + -- Statistics -- + ---------------- + + type Invocation_Graph_Edge_Counts is array (Invocation_Kind) of Natural; + + ---------------- + -- Signatures -- + ---------------- + + function Hash_Invocation_Signature + (IS_Id : Invocation_Signature_Id) return Bucket_Range_Type; + pragma Inline (Hash_Invocation_Signature); + -- Obtain the hash value of key IS_Id + + package SV is new Dynamic_Hash_Tables + (Key_Type => Invocation_Signature_Id, + Value_Type => Invocation_Graph_Vertex_Id, + No_Value => No_Invocation_Graph_Vertex, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Invocation_Graph_Vertex, + Hash => Hash_Invocation_Signature); + + ----------------------- + -- Elaboration roots -- + ----------------------- + + package ER is new Membership_Sets + (Element_Type => Invocation_Graph_Vertex_Id, + "=" => "=", + Hash => Hash_Invocation_Graph_Vertex); + + ----------- + -- Graph -- + ----------- + + package DG is new Directed_Graphs + (Vertex_Id => Invocation_Graph_Vertex_Id, + No_Vertex => No_Invocation_Graph_Vertex, + Hash_Vertex => Hash_Invocation_Graph_Vertex, + Same_Vertex => "=", + Edge_id => Invocation_Graph_Edge_Id, + No_Edge => No_Invocation_Graph_Edge, + Hash_Edge => Hash_Invocation_Graph_Edge, + Same_Edge => "="); + + -- The following type represents the attributes of an invocation graph + + type Invocation_Graph_Attributes is record + Counts : Invocation_Graph_Edge_Counts := (others => 0); + -- Edge statistics + + Edge_Attributes : EA.Dynamic_Hash_Table := EA.Nil; + -- The map of edge -> edge attributes for all edges in the graph + + Graph : DG.Directed_Graph := DG.Nil; + -- The underlying graph describing the relations between edges and + -- vertices. + + Relations : ST.Membership_Set := ST.Nil; + -- The set of relations between source and targets, used to prevent + -- duplicate edges in the graph. + + Roots : ER.Membership_Set := ER.Nil; + -- The set of elaboration root vertices + + Signature_To_Vertex : SV.Dynamic_Hash_Table := SV.Nil; + -- The map of signature -> vertex + + Vertex_Attributes : VA.Dynamic_Hash_Table := VA.Nil; + -- The map of vertex -> vertex attributes for all vertices in the + -- graph. + end record; + + type Invocation_Graph is access Invocation_Graph_Attributes; + Nil : constant Invocation_Graph := null; + + --------------- + -- Iterators -- + --------------- + + type All_Edge_Iterator is new DG.All_Edge_Iterator; + type All_Vertex_Iterator is new DG.All_Vertex_Iterator; + type Edges_To_Targets_Iterator is new DG.Outgoing_Edge_Iterator; + type Elaboration_Root_Iterator is new ER.Iterator; + end Invocation_Graphs; + + -------------------- + -- Library_Graphs -- + -------------------- + + package Library_Graphs is + + -- The following type represents the various kinds of library edges + + type Library_Graph_Edge_Kind is + (Body_Before_Spec_Edge, + -- Successor denotes spec, Predecessor denotes a body. This is a + -- special edge kind used only during the discovery of components. + -- Note that a body can never be elaborated before its spec. + + Elaborate_Edge, + -- Successor withs Predecessor, and has pragma Elaborate for it + + Elaborate_All_Edge, + -- Successor withs Predecessor, and has pragma Elaborate_All for it + + Forced_Edge, + -- Successor is forced to with Predecessor by virtue of an existing + -- elaboration order provided in a file. + + Invocation_Edge, + -- An invocation construct in unit Successor invokes a target in unit + -- Predecessor. + + Spec_Before_Body_Edge, + -- Successor denotes a body, Predecessor denotes a spec + + With_Edge, + -- Successor withs Predecessor + + No_Edge); + + ----------- + -- Graph -- + ----------- + + -- The following type denotes a library graph handle. Each instance must + -- be created using routine Create. + + type Library_Graph is private; + Nil : constant Library_Graph; + + ---------------------- + -- Graph operations -- + ---------------------- + + procedure Add_Edge + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + Kind : Library_Graph_Edge_Kind); + pragma Inline (Add_Edge); + -- Create a new edge in library graph G with source vertex Pred and + -- destination vertex Succ. Kind denotes the nature of the edge. + + procedure Add_Vertex + (G : Library_Graph; + U_Id : Unit_Id); + pragma Inline (Add_Vertex); + -- Create a new vertex in library graph G. U_Id is the unit the vertex + -- describes. + + function Create + (Initial_Vertices : Positive; + Initial_Edges : Positive) return Library_Graph; + pragma Inline (Create); + -- Create a new empty graph with vertex capacity Initial_Vertices and + -- edge capacity Initial_Edges. + + procedure Destroy (G : in out Library_Graph); + pragma Inline (Destroy); + -- Destroy the contents of library graph G, rendering it unusable + + procedure Find_Components (G : Library_Graph); + pragma Inline (Find_Components); + -- Find all components in library graph G + + function Present (G : Library_Graph) return Boolean; + pragma Inline (Present); + -- Determine whether library graph G exists + + ----------------------- + -- Vertex attributes -- + ----------------------- + + function Component + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Component_Id; + pragma Inline (Component); + -- Obtain the component where vertex LGV_Id of library graph G resides + + function Corresponding_Item + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + pragma Inline (Corresponding_Item); + -- Obtain the complementary vertex which represents the corresponding + -- spec or body of vertex LGV_Id of library graph G. + + function Corresponding_Vertex + (G : Library_Graph; + U_Id : Unit_Id) return Library_Graph_Vertex_Id; + pragma Inline (Corresponding_Vertex); + -- Obtain the corresponding vertex of library graph G which represents + -- unit U_Id. + + procedure Decrement_Pending_Predecessors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Decrement_Pending_Predecessors); + -- Decrease the number of pending predecessors vertex LGV_Id of library + -- graph G must wait on until it can be elaborated. + + function In_Elaboration_Order + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (In_Elaboration_Order); + -- Determine whether vertex LGV_Id of library graph G is already in some + -- elaboration order. + + function Name + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Unit_Name_Type; + pragma Inline (Name); + -- Obtain the name of the unit which vertex LGV_Id of library graph G + -- represents. + + function Pending_Predecessors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Natural; + pragma Inline (Pending_Predecessors); + -- Obtain the number of pending predecessors vertex LGV_Id of library + -- graph G must wait on until it can be elaborated. + + procedure Set_Corresponding_Item + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Val : Library_Graph_Vertex_Id); + pragma Inline (Set_Corresponding_Item); + -- Set the complementary vertex which represents the corresponding + -- spec or body of vertex LGV_Id of library graph G to value Val. + + procedure Set_In_Elaboration_Order + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Val : Boolean := True); + pragma Inline (Set_In_Elaboration_Order); + -- Mark vertex LGV_Id of library graph G as included in some elaboration + -- order depending on value Val. + + function Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Unit_Id; + pragma Inline (Unit); + -- Obtain the unit vertex LGV_Id of library graph G represents + + --------------------- + -- Edge attributes -- + --------------------- + + function Kind + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Edge_Kind; + pragma Inline (Kind); + -- Obtain the nature of edge LGE_Id of library graph G + + function Predecessor + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id; + pragma Inline (Predecessor); + -- Obtain the predecessor vertex of edge LGE_Id of library graph G + + function Successor + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id; + pragma Inline (Successor); + -- Obtain the successor vertex of edge LGE_Id of library graph G + + -------------------------- + -- Component attributes -- + -------------------------- + + procedure Decrement_Pending_Predecessors + (G : Library_Graph; + Comp : Component_Id); + pragma Inline (Decrement_Pending_Predecessors); + -- Decrease the number of pending predecessors component Comp of library + -- graph G must wait on until it can be elaborated. + + function Pending_Predecessors + (G : Library_Graph; + Comp : Component_Id) return Natural; + pragma Inline (Pending_Predecessors); + -- Obtain the number of pending predecessors component Comp of library + -- graph G must wait on until it can be elaborated. + + --------------- + -- Semantics -- + --------------- + + function Is_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Body); + -- Determine whether vertex LGV_Id of library graph G denotes a body + + function Is_Body_Of_Spec_With_Elaborate_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Body_Of_Spec_With_Elaborate_Body); + -- Determine whether vertex LGV_Id of library graph G denotes a body + -- with a corresponding spec, and the spec has pragma Elaborate_Body. + + function Is_Body_With_Spec + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Body_With_Spec); + -- Determine whether vertex LGV_Id of library graph G denotes a body + -- with a corresponding spec. + + function Is_Elaborable_Component + (G : Library_Graph; + Comp : Component_Id) return Boolean; + pragma Inline (Is_Elaborable_Component); + -- Determine whether component Comp of library graph G can be elaborated + + function Is_Elaborable_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Elaborable_Vertex); + -- Determine whether vertex LGV_Id of library graph G can be elaborated + + function Is_Internal_Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Internal_Unit); + -- Determine whether vertex LGV_Id of library graph G denotes an + -- internal unit. + + function Is_Predefined_Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Predefined_Unit); + -- Determine whether vertex LGV_Id of library graph G denotes a + -- predefined unit. + + function Is_Preelaborated_Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Preelaborated_Unit); + -- Determine whether vertex LGV_Id of library graph G denotes a unit + -- subjec to pragma Pure or Preelaborable. + + function Is_Spec + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Spec); + -- Determine whether vertex LGV_Id of library graph G denotes a spec + + function Is_Spec_With_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Spec_With_Body); + -- Determine whether vertex LGV_Id of library graph G denotes a spec + -- with a corresponding body. + + function Is_Spec_With_Elaborate_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Spec_With_Elaborate_Body); + -- Determine whether vertex LGV_Id of library graph G denotes a spec + -- with a corresponding body, and is subject to pragma Elaborate_Body. + + function Links_Vertices_In_Same_Component + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Links_Vertices_In_Same_Component); + -- Determine whether edge LGE_Id of library graph G links a predecessor + -- and a successor that reside within the same component. + + function Needs_Elaboration + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Needs_Elaboration); + -- Determine whether vertex LGV_Id of library graph G represents a unit + -- that needs to be elaborated. + + function Proper_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + pragma Inline (Proper_Body); + -- Obtain the body of vertex LGV_Id of library graph G + + function Proper_Spec + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + pragma Inline (Proper_Spec); + -- Obtain the spec of vertex LGV_Id of library graph G + + ---------------- + -- Statistics -- + ---------------- + + function Library_Graph_Edge_Count + (G : Library_Graph; + Kind : Library_Graph_Edge_Kind) return Natural; + pragma Inline (Library_Graph_Edge_Count); + -- Obtain the total number of edges of kind Kind in library graph G + + function Number_Of_Component_Vertices + (G : Library_Graph; + Comp : Component_Id) return Natural; + pragma Inline (Number_Of_Component_Vertices); + -- Obtain the total number of vertices component Comp of library graph + -- contains. + + function Number_Of_Components (G : Library_Graph) return Natural; + pragma Inline (Number_Of_Components); + -- Obtain the total number of components in library graph G + + function Number_Of_Edges (G : Library_Graph) return Natural; + pragma Inline (Number_Of_Edges); + -- Obtain the total number of edges in library graph G + + function Number_Of_Edges_To_Successors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Natural; + pragma Inline (Number_Of_Edges_To_Successors); + -- Obtain the total number of edges to successors vertex LGV_Id of + -- library graph G has. + + function Number_Of_Vertices (G : Library_Graph) return Natural; + pragma Inline (Number_Of_Vertices); + -- Obtain the total number of vertices in library graph G + + --------------- + -- Iterators -- + --------------- + + -- The following type represents an iterator over all edges of a library + -- graph. + + type All_Edge_Iterator is private; + + function Has_Next (Iter : All_Edge_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more edges to examine + + function Iterate_All_Edges (G : Library_Graph) return All_Edge_Iterator; + pragma Inline (Iterate_All_Edges); + -- Obtain an iterator over all edges of library graph G + + procedure Next + (Iter : in out All_Edge_Iterator; + LGE_Id : out Library_Graph_Edge_Id); + pragma Inline (Next); + -- Return the current edge referenced by iterator Iter and advance to + -- the next available edge. + + -- The following type represents an iterator over all vertices of a + -- library graph. + + type All_Vertex_Iterator is private; + + function Has_Next (Iter : All_Vertex_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more vertices to examine + + function Iterate_All_Vertices + (G : Library_Graph) return All_Vertex_Iterator; + pragma Inline (Iterate_All_Vertices); + -- Obtain an iterator over all vertices of library graph G + + procedure Next + (Iter : in out All_Vertex_Iterator; + LGV_Id : out Library_Graph_Vertex_Id); + pragma Inline (Next); + -- Return the current vertex referenced by iterator Iter and advance + -- to the next available vertex. + + -- The following type represents an iterator over all components of a + -- library graph. + + type Component_Iterator is private; + + function Has_Next (Iter : Component_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more components to examine + + function Iterate_Components + (G : Library_Graph) return Component_Iterator; + pragma Inline (Iterate_Components); + -- Obtain an iterator over all components of library graph G + + procedure Next + (Iter : in out Component_Iterator; + Comp : out Component_Id); + pragma Inline (Next); + -- Return the current component referenced by iterator Iter and advance + -- to the next available component. + + -- The following type represents an iterator over all vertices of a + -- component. + + type Component_Vertex_Iterator is private; + + function Has_Next (Iter : Component_Vertex_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more vertices to examine + + function Iterate_Component_Vertices + (G : Library_Graph; + Comp : Component_Id) return Component_Vertex_Iterator; + pragma Inline (Iterate_Component_Vertices); + -- Obtain an iterator over all vertices of component Comp of library + -- graph G. + + procedure Next + (Iter : in out Component_Vertex_Iterator; + LGV_Id : out Library_Graph_Vertex_Id); + pragma Inline (Next); + -- Return the current vertex referenced by iterator Iter and advance + -- to the next available vertex. + + -- The following type represents an iterator over all edges that reach + -- successors starting from a particular predecessor vertex. + + type Edges_To_Successors_Iterator is private; + + function Has_Next (Iter : Edges_To_Successors_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more edges to examine + + function Iterate_Edges_To_Successors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Edges_To_Successors_Iterator; + pragma Inline (Iterate_Components); + -- Obtain an iterator over all edges to successors with predecessor + -- vertex LGV_Id of library graph G. + + procedure Next + (Iter : in out Edges_To_Successors_Iterator; + LGE_Id : out Library_Graph_Edge_Id); + pragma Inline (Next); + -- Return the current edge referenced by iterator Iter and advance to + -- the next available edge. + + private + + -------------- + -- Vertices -- + -------------- + + procedure Destroy_Library_Graph_Vertex + (LGV_Id : in out Library_Graph_Vertex_Id); + pragma Inline (Destroy_Library_Graph_Vertex); + -- Destroy library graph vertex LGV_Id + + -- The following type represents the attributes of a library graph + -- vertex. + + type Library_Graph_Vertex_Attributes is record + Corresponding_Item : Library_Graph_Vertex_Id := + No_Library_Graph_Vertex; + -- The reference to the corresponding spec or body. This attribute is + -- set as follows: + -- + -- * If predicate Is_Body_With_Spec is True, the reference denotes + -- the corresponding spec. + -- + -- * If predicate Is_Spec_With_Body is True, the reference denotes + -- the corresponding body. + -- + -- * Otherwise the attribute remains empty. + + In_Elaboration_Order : Boolean := False; + -- Set when this vertex is elaborated + + Pending_Predecessors : Natural := 0; + -- The number of pending predecessor vertices this vertex must wait + -- on before it can be elaborated. + + Unit : Unit_Id := No_Unit_Id; + -- The reference to unit this vertex represents + end record; + + No_Library_Graph_Vertex_Attributes : + constant Library_Graph_Vertex_Attributes := + (Corresponding_Item => No_Library_Graph_Vertex, + In_Elaboration_Order => False, + Pending_Predecessors => 0, + Unit => No_Unit_Id); + + procedure Destroy_Library_Graph_Vertex_Attributes + (Attrs : in out Library_Graph_Vertex_Attributes); + pragma Inline (Destroy_Library_Graph_Vertex_Attributes); + -- Destroy the contents of attributes Attrs + + package VA is new Dynamic_Hash_Tables + (Key_Type => Library_Graph_Vertex_Id, + Value_Type => Library_Graph_Vertex_Attributes, + No_Value => No_Library_Graph_Vertex_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Library_Graph_Vertex_Attributes, + Hash => Hash_Library_Graph_Vertex); + + ----------- + -- Edges -- + ----------- + + procedure Destroy_Library_Graph_Edge + (LGE_Id : in out Library_Graph_Edge_Id); + pragma Inline (Destroy_Library_Graph_Edge); + -- Destroy library graph edge LGE_Id + + -- The following type represents the attributes of a library graph edge + + type Library_Graph_Edge_Attributes is record + Kind : Library_Graph_Edge_Kind := No_Edge; + -- The nature of the library graph edge + end record; + + No_Library_Graph_Edge_Attributes : + constant Library_Graph_Edge_Attributes := + (Kind => No_Edge); + + procedure Destroy_Library_Graph_Edge_Attributes + (Attrs : in out Library_Graph_Edge_Attributes); + pragma Inline (Destroy_Library_Graph_Edge_Attributes); + -- Destroy the contents of attributes Attrs + + package EA is new Dynamic_Hash_Tables + (Key_Type => Library_Graph_Edge_Id, + Value_Type => Library_Graph_Edge_Attributes, + No_Value => No_Library_Graph_Edge_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Library_Graph_Edge_Attributes, + Hash => Hash_Library_Graph_Edge); + + ---------------- + -- Components -- + ---------------- + + -- The following type represents the attributes of a component + + type Component_Attributes is record + Pending_Predecessors : Natural := 0; + -- The number of pending predecessor components this component must + -- wait on before it can be elaborated. + end record; + + No_Component_Attributes : constant Component_Attributes := + (Pending_Predecessors => 0); + + procedure Destroy_Component_Attributes + (Attrs : in out Component_Attributes); + pragma Inline (Destroy_Component_Attributes); + -- Destroy the contents of attributes Attrs + + package CA is new Dynamic_Hash_Tables + (Key_Type => Component_Id, + Value_Type => Component_Attributes, + No_Value => No_Component_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Component_Attributes, + Hash => Hash_Component); + + --------------- + -- Relations -- + --------------- + + -- The following type represents a relation between a predecessor and + -- successor vertices. + + type Predecessor_Successor_Relation is record + Predecessor : Library_Graph_Vertex_Id := No_Library_Graph_Vertex; + -- The source vertex + + Successor : Library_Graph_Vertex_Id := No_Library_Graph_Vertex; + -- The destination vertex + end record; + + No_Predecessor_Successor_Relation : + constant Predecessor_Successor_Relation := + (Predecessor => No_Library_Graph_Vertex, + Successor => No_Library_Graph_Vertex); + + function Hash_Predecessor_Successor_Relation + (Rel : Predecessor_Successor_Relation) return Bucket_Range_Type; + pragma Inline (Hash_Predecessor_Successor_Relation); + -- Obtain the hash value of key Rel + + package PS is new Membership_Sets + (Element_Type => Predecessor_Successor_Relation, + "=" => "=", + Hash => Hash_Predecessor_Successor_Relation); + + ---------------- + -- Statistics -- + ---------------- + + type Library_Graph_Edge_Counts is + array (Library_Graph_Edge_Kind) of Natural; + + ----------- + -- Units -- + ----------- + + package UV is new Dynamic_Hash_Tables + (Key_Type => Unit_Id, + Value_Type => Library_Graph_Vertex_Id, + No_Value => No_Library_Graph_Vertex, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Library_Graph_Vertex, + Hash => Hash_Unit); + + ----------- + -- Graph -- + ----------- + + package DG is new Directed_Graphs + (Vertex_Id => Library_Graph_Vertex_Id, + No_Vertex => No_Library_Graph_Vertex, + Hash_Vertex => Hash_Library_Graph_Vertex, + Same_Vertex => "=", + Edge_Id => Library_Graph_Edge_Id, + No_Edge => No_Library_Graph_Edge, + Hash_Edge => Hash_Library_Graph_Edge, + Same_Edge => "="); + + -- The following type represents the attributes of a library graph + + type Library_Graph_Attributes is record + Component_Attributes : CA.Dynamic_Hash_Table := CA.Nil; + -- The map of component -> component attributes for all components in + -- the graph. + + Counts : Library_Graph_Edge_Counts := (others => 0); + -- Edge statistics + + Edge_Attributes : EA.Dynamic_Hash_Table := EA.Nil; + -- The map of edge -> edge attributes for all edges in the graph + + Graph : DG.Directed_Graph := DG.Nil; + -- The underlying graph describing the relations between edges and + -- vertices. + + Relations : PS.Membership_Set := PS.Nil; + -- The set of relations between successors and predecessors, used to + -- prevent duplicate edges in the graph. + + Unit_To_Vertex : UV.Dynamic_Hash_Table := UV.Nil; + -- The map of unit -> vertex + + Vertex_Attributes : VA.Dynamic_Hash_Table := VA.Nil; + -- The map of vertex -> vertex attributes for all vertices in the + -- graph. + end record; + + type Library_Graph is access Library_Graph_Attributes; + Nil : constant Library_Graph := null; + + --------------- + -- Iterators -- + --------------- + + type All_Edge_Iterator is new DG.All_Edge_Iterator; + type All_Vertex_Iterator is new DG.All_Vertex_Iterator; + type Component_Iterator is new DG.Component_Iterator; + type Component_Vertex_Iterator is new DG.Component_Vertex_Iterator; + type Edges_To_Successors_Iterator is new DG.Outgoing_Edge_Iterator; + end Library_Graphs; + +end Bindo.Graphs; diff --git a/gcc/ada/bindo-units.adb b/gcc/ada/bindo-units.adb new file mode 100644 index 0000000..de0afb9 --- /dev/null +++ b/gcc/ada/bindo-units.adb @@ -0,0 +1,410 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . U N I T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Bindo.Units is + + ------------------- + -- Signature set -- + ------------------- + + package SS is new Membership_Sets + (Element_Type => Invocation_Signature_Id, + "=" => "=", + Hash => Hash_Invocation_Signature); + + ----------------- + -- Global data -- + ----------------- + + -- The following set stores all invocation signatures that appear in + -- elaborable units. + + Elaborable_Constructs : SS.Membership_Set := SS.Nil; + + -- The following set stores all units the need to be elaborated + + Elaborable_Units : US.Membership_Set := US.Nil; + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Corresponding_Unit (Nam : Name_Id) return Unit_Id; + pragma Inline (Corresponding_Unit); + -- Obtain the unit which corresponds to name Nam + + function Is_Stand_Alone_Library_Unit (U_Id : Unit_Id) return Boolean; + pragma Inline (Is_Stand_Alone_Library_Unit); + -- Determine whether unit U_Id is part of a stand-alone library + + procedure Process_Invocation_Construct (IC_Id : Invocation_Construct_Id); + pragma Inline (Process_Invocation_Construct); + -- Process invocation construct IC_Id by adding its signature to set + -- Elaborable_Constructs_Set. + + procedure Process_Invocation_Constructs (U_Id : Unit_Id); + pragma Inline (Process_Invocation_Constructs); + -- Process all invocation constructs of unit U_Id for classification + -- purposes. + + procedure Process_Unit (U_Id : Unit_Id); + pragma Inline (Process_Unit); + -- Process unit U_Id for unit classification purposes + + ------------------------------ + -- Collect_Elaborable_Units -- + ------------------------------ + + procedure Collect_Elaborable_Units is + begin + for U_Id in ALI.Units.First .. ALI.Units.Last loop + Process_Unit (U_Id); + end loop; + end Collect_Elaborable_Units; + + ------------------------ + -- Corresponding_Body -- + ------------------------ + + function Corresponding_Body (U_Id : Unit_Id) return Unit_Id is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + pragma Assert (U_Rec.Utype = Is_Spec); + return U_Id - 1; + end Corresponding_Body; + + ------------------------ + -- Corresponding_Spec -- + ------------------------ + + function Corresponding_Spec (U_Id : Unit_Id) return Unit_Id is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + pragma Assert (U_Rec.Utype = Is_Body); + return U_Id + 1; + end Corresponding_Spec; + + ------------------------ + -- Corresponding_Unit -- + ------------------------ + + function Corresponding_Unit (FNam : File_Name_Type) return Unit_Id is + begin + return Corresponding_Unit (Name_Id (FNam)); + end Corresponding_Unit; + + ------------------------ + -- Corresponding_Unit -- + ------------------------ + + function Corresponding_Unit (Nam : Name_Id) return Unit_Id is + begin + return Unit_Id (Get_Name_Table_Int (Nam)); + end Corresponding_Unit; + + ------------------------ + -- Corresponding_Unit -- + ------------------------ + + function Corresponding_Unit (UNam : Unit_Name_Type) return Unit_Id is + begin + return Corresponding_Unit (Name_Id (UNam)); + end Corresponding_Unit; + + -------------------- + -- Finalize_Units -- + -------------------- + + procedure Finalize_Units is + begin + SS.Destroy (Elaborable_Constructs); + US.Destroy (Elaborable_Units); + end Finalize_Units; + + ------------------------------ + -- For_Each_Elaborable_Unit -- + ------------------------------ + + procedure For_Each_Elaborable_Unit (Processor : Unit_Processor_Ptr) is + Iter : Elaborable_Units_Iterator; + U_Id : Unit_Id; + + begin + Iter := Iterate_Elaborable_Units; + while Has_Next (Iter) loop + Next (Iter, U_Id); + + Processor.all (U_Id); + end loop; + end For_Each_Elaborable_Unit; + + ------------------- + -- For_Each_Unit -- + ------------------- + + procedure For_Each_Unit (Processor : Unit_Processor_Ptr) is + begin + for U_Id in ALI.Units.First .. ALI.Units.Last loop + Processor.all (U_Id); + end loop; + end For_Each_Unit; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Elaborable_Units_Iterator) return Boolean is + begin + return US.Has_Next (US.Iterator (Iter)); + end Has_Next; + + ------------------------------- + -- Hash_Invocation_Signature -- + ------------------------------- + + function Hash_Invocation_Signature + (IS_Id : Invocation_Signature_Id) return Bucket_Range_Type + is + begin + pragma Assert (Present (IS_Id)); + + return Bucket_Range_Type (IS_Id); + end Hash_Invocation_Signature; + + --------------- + -- Hash_Unit -- + --------------- + + function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type is + begin + pragma Assert (Present (U_Id)); + + return Bucket_Range_Type (U_Id); + end Hash_Unit; + + ---------------------- + -- Initialize_Units -- + ---------------------- + + procedure Initialize_Units is + begin + Elaborable_Constructs := SS.Create (Number_Of_Units); + Elaborable_Units := US.Create (Number_Of_Units); + end Initialize_Units; + + ------------------------------- + -- Is_Dynamically_Elaborated -- + ------------------------------- + + function Is_Dynamically_Elaborated (U_Id : Unit_Id) return Boolean is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Dynamic_Elab; + end Is_Dynamically_Elaborated; + + ---------------------- + -- Is_Internal_Unit -- + ---------------------- + + function Is_Internal_Unit (U_Id : Unit_Id) return Boolean is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Internal; + end Is_Internal_Unit; + + ------------------------ + -- Is_Predefined_Unit -- + ------------------------ + + function Is_Predefined_Unit (U_Id : Unit_Id) return Boolean is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Predefined; + end Is_Predefined_Unit; + + --------------------------------- + -- Is_Stand_Alone_Library_Unit -- + --------------------------------- + + function Is_Stand_Alone_Library_Unit (U_Id : Unit_Id) return Boolean is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.SAL_Interface; + end Is_Stand_Alone_Library_Unit; + + ------------------------------ + -- Iterate_Elaborable_Units -- + ------------------------------ + + function Iterate_Elaborable_Units return Elaborable_Units_Iterator is + begin + return Elaborable_Units_Iterator (US.Iterate (Elaborable_Units)); + end Iterate_Elaborable_Units; + + ---------- + -- Name -- + ---------- + + function Name (U_Id : Unit_Id) return Unit_Name_Type is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Uname; + end Name; + + ----------------------- + -- Needs_Elaboration -- + ----------------------- + + function Needs_Elaboration + (IS_Id : Invocation_Signature_Id) return Boolean + is + begin + pragma Assert (Present (IS_Id)); + + return SS.Contains (Elaborable_Constructs, IS_Id); + end Needs_Elaboration; + + ----------------------- + -- Needs_Elaboration -- + ----------------------- + + function Needs_Elaboration (U_Id : Unit_Id) return Boolean is + begin + pragma Assert (Present (U_Id)); + + return US.Contains (Elaborable_Units, U_Id); + end Needs_Elaboration; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Elaborable_Units_Iterator; + U_Id : out Unit_Id) + is + begin + US.Next (US.Iterator (Iter), U_Id); + end Next; + + -------------------------------- + -- Number_Of_Elaborable_Units -- + -------------------------------- + + function Number_Of_Elaborable_Units return Natural is + begin + return US.Size (Elaborable_Units); + end Number_Of_Elaborable_Units; + + --------------------- + -- Number_Of_Units -- + --------------------- + + function Number_Of_Units return Natural is + begin + return Natural (ALI.Units.Last) - Natural (ALI.Units.First) + 1; + end Number_Of_Units; + + ---------------------------------- + -- Process_Invocation_Construct -- + ---------------------------------- + + procedure Process_Invocation_Construct (IC_Id : Invocation_Construct_Id) is + pragma Assert (Present (IC_Id)); + + IC_Rec : Invocation_Construct_Record renames + Invocation_Constructs.Table (IC_Id); + IC_Sig : constant Invocation_Signature_Id := IC_Rec.Signature; + + pragma Assert (Present (IC_Sig)); + + begin + SS.Insert (Elaborable_Constructs, IC_Sig); + end Process_Invocation_Construct; + + ----------------------------------- + -- Process_Invocation_Constructs -- + ----------------------------------- + + procedure Process_Invocation_Constructs (U_Id : Unit_Id) is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + for IC_Id in U_Rec.First_Invocation_Construct .. + U_Rec.Last_Invocation_Construct + loop + Process_Invocation_Construct (IC_Id); + end loop; + end Process_Invocation_Constructs; + + ------------------ + -- Process_Unit -- + ------------------ + + procedure Process_Unit (U_Id : Unit_Id) is + begin + pragma Assert (Present (U_Id)); + + -- A stand-alone library unit must not be elaborated as part of the + -- current compilation because the library already carries its own + -- elaboration code. + + if Is_Stand_Alone_Library_Unit (U_Id) then + null; + + -- Otherwise the unit needs to be elaborated. Add it to the set + -- of units that require elaboration, as well as all invocation + -- signatures of constructs it declares. + + else + US.Insert (Elaborable_Units, U_Id); + Process_Invocation_Constructs (U_Id); + end if; + end Process_Unit; + +end Bindo.Units; diff --git a/gcc/ada/bindo-units.ads b/gcc/ada/bindo-units.ads new file mode 100644 index 0000000..93caadf --- /dev/null +++ b/gcc/ada/bindo-units.ads @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . U N I T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to collect all elaborable units in +-- the bind and inspect their properties. + +with GNAT; use GNAT; +with GNAT.Sets; use GNAT.Sets; + +package Bindo.Units is + + procedure Collect_Elaborable_Units; + pragma Inline (Collect_Elaborable_Units); + -- Gather all units in the bind that require elaboration. The units are + -- accessible via iterator Elaborable_Units_Iterator. + + function Corresponding_Body (U_Id : Unit_Id) return Unit_Id; + pragma Inline (Corresponding_Body); + -- Return the body of a spec unit U_Id + + function Corresponding_Spec (U_Id : Unit_Id) return Unit_Id; + pragma Inline (Corresponding_Spec); + -- Return the spec of a body unit U_Id + + function Corresponding_Unit (FNam : File_Name_Type) return Unit_Id; + pragma Inline (Corresponding_Unit); + -- Obtain the unit which corresponds to name FNam + + function Corresponding_Unit (UNam : Unit_Name_Type) return Unit_Id; + pragma Inline (Corresponding_Unit); + -- Obtain the unit which corresponds to name FNam + + type Unit_Processor_Ptr is access procedure (U_Id : Unit_Id); + + procedure For_Each_Elaborable_Unit (Processor : Unit_Processor_Ptr); + pragma Inline (For_Each_Elaborable_Unit); + -- Invoke Processor on each elaborable unit in the bind + + procedure For_Each_Unit (Processor : Unit_Processor_Ptr); + pragma Inline (For_Each_Unit); + -- Invoke Processor on each unit in the bind + + function Hash_Invocation_Signature + (IS_Id : Invocation_Signature_Id) return Bucket_Range_Type; + pragma Inline (Hash_Invocation_Signature); + -- Obtain the hash value of key IS_Id + + function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type; + pragma Inline (Hash_Unit); + -- Obtain the hash value of key U_Id + + function Is_Dynamically_Elaborated (U_Id : Unit_Id) return Boolean; + pragma Inline (Is_Dynamically_Elaborated); + -- Determine whether unit U_Id was compiled using the dynamic elaboration + -- model. + + function Is_Internal_Unit (U_Id : Unit_Id) return Boolean; + pragma Inline (Is_Internal_Unit); + -- Determine whether unit U_Id is internal + + function Is_Predefined_Unit (U_Id : Unit_Id) return Boolean; + pragma Inline (Is_Predefined_Unit); + -- Determine whether unit U_Id is predefined + + function Name (U_Id : Unit_Id) return Unit_Name_Type; + pragma Inline (Name); + -- Obtain the name of unit U_Id + + function Needs_Elaboration (IS_Id : Invocation_Signature_Id) return Boolean; + pragma Inline (Needs_Elaboration); + -- Determine whether invocation signature IS_Id belongs to a construct that + -- appears in a unit which needs to be elaborated. + + function Needs_Elaboration (U_Id : Unit_Id) return Boolean; + pragma Inline (Needs_Elaboration); + -- Determine whether unit U_Id needs to be elaborated + + function Number_Of_Elaborable_Units return Natural; + pragma Inline (Number_Of_Elaborable_Units); + -- Obtain the number of units in the bind that need to be elaborated + + function Number_Of_Units return Natural; + pragma Inline (Number_Of_Units); + -- Obtain the number of units in the bind + + --------------- + -- Iterators -- + --------------- + + -- The following type represents an iterator over all units that need to be + -- elaborated. + + type Elaborable_Units_Iterator is private; + + function Has_Next (Iter : Elaborable_Units_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more units to examine + + function Iterate_Elaborable_Units return Elaborable_Units_Iterator; + pragma Inline (Iterate_Elaborable_Units); + -- Obtain an iterator over all units that need to be elaborated + + procedure Next + (Iter : in out Elaborable_Units_Iterator; + U_Id : out Unit_Id); + pragma Inline (Next); + -- Return the current unit referenced by iterator Iter and advance to the + -- next available unit. + + ----------------- + -- Maintenance -- + ----------------- + + procedure Finalize_Units; + pragma Inline (Finalize_Units); + -- Destroy the internal structures of this unit + + procedure Initialize_Units; + pragma Inline (Initialize_Units); + -- Initialize the internal structures of this unit + +private + package US is new Membership_Sets + (Element_Type => Unit_Id, + "=" => "=", + Hash => Hash_Unit); + + type Elaborable_Units_Iterator is new US.Iterator; + +end Bindo.Units; diff --git a/gcc/ada/bindo-validators.adb b/gcc/ada/bindo-validators.adb new file mode 100644 index 0000000..54d2fc6 --- /dev/null +++ b/gcc/ada/bindo-validators.adb @@ -0,0 +1,679 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . V A L I D A T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Output; use Output; +with Types; use Types; + +with Bindo.Units; use Bindo.Units; + +with GNAT; use GNAT; +with GNAT.Sets; use GNAT.Sets; + +package body Bindo.Validators is + + ---------------------------------- + -- Elaboration_Order_Validators -- + ---------------------------------- + + package body Elaboration_Order_Validators is + package US is new Membership_Sets + (Element_Type => Unit_Id, + "=" => "=", + Hash => Hash_Unit); + use US; + + Has_Invalid_Data : Boolean := False; + -- Flag set when the elaboration order contains invalid data + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Build_Elaborable_Unit_Set return Membership_Set; + pragma Inline (Build_Elaborable_Unit_Set); + -- Create a set from all units that need to be elaborated + + procedure Report_Missing_Elaboration (U_Id : Unit_Id); + pragma Inline (Report_Missing_Elaboration); + -- Emit an error concerning unit U_Id that must be elaborated, but was + -- not. + + procedure Report_Missing_Elaborations (Set : Membership_Set); + pragma Inline (Report_Missing_Elaborations); + -- Emit errors on all units in set Set that must be elaborated, but were + -- not. + + procedure Report_Spurious_Elaboration (U_Id : Unit_Id); + pragma Inline (Report_Spurious_Elaboration); + -- Emit an error concerning unit U_Id that is incorrectly elaborated + + procedure Validate_Unit (U_Id : Unit_Id; Elab_Set : Membership_Set); + pragma Inline (Validate_Unit); + -- Validate the elaboration status of unit U_Id. Elab_Set is the set of + -- all units that need to be elaborated. + + procedure Validate_Units (Order : Unit_Id_Table); + pragma Inline (Validate_Units); + -- Validate all units in elaboration order Order + + procedure Write_Error (Msg : String); + pragma Inline (Write_Error); + -- Write error message Msg to standard output and signal that the + -- elaboration order is incorrect. + + ------------------------------- + -- Build_Elaborable_Unit_Set -- + ------------------------------- + + function Build_Elaborable_Unit_Set return Membership_Set is + Iter : Elaborable_Units_Iterator; + Set : Membership_Set; + U_Id : Unit_Id; + + begin + Set := Create (Number_Of_Elaborable_Units); + Iter := Iterate_Elaborable_Units; + while Has_Next (Iter) loop + Next (Iter, U_Id); + pragma Assert (Present (U_Id)); + + Insert (Set, U_Id); + end loop; + + return Set; + end Build_Elaborable_Unit_Set; + + -------------------------------- + -- Report_Missing_Elaboration -- + -------------------------------- + + procedure Report_Missing_Elaboration (U_Id : Unit_Id) is + Msg : constant String := "Report_Missing_Elaboration"; + + begin + pragma Assert (Present (U_Id)); + Write_Error (Msg); + + Write_Str ("unit (U_Id_"); + Write_Int (Int (U_Id)); + Write_Str (") name = "); + Write_Name (Name (U_Id)); + Write_Str (" must be elaborated"); + Write_Eol; + end Report_Missing_Elaboration; + + --------------------------------- + -- Report_Missing_Elaborations -- + --------------------------------- + + procedure Report_Missing_Elaborations (Set : Membership_Set) is + Iter : Iterator; + U_Id : Unit_Id; + + begin + Iter := Iterate (Set); + while Has_Next (Iter) loop + Next (Iter, U_Id); + pragma Assert (Present (U_Id)); + + Report_Missing_Elaboration (U_Id); + end loop; + end Report_Missing_Elaborations; + + --------------------------------- + -- Report_Spurious_Elaboration -- + --------------------------------- + + procedure Report_Spurious_Elaboration (U_Id : Unit_Id) is + Msg : constant String := "Report_Spurious_Elaboration"; + + begin + pragma Assert (Present (U_Id)); + Write_Error (Msg); + + Write_Str ("unit (U_Id_"); + Write_Int (Int (U_Id)); + Write_Str (") name = "); + Write_Name (Name (U_Id)); + Write_Str (" must not be elaborated"); + end Report_Spurious_Elaboration; + + -------------------------------- + -- Validate_Elaboration_Order -- + -------------------------------- + + procedure Validate_Elaboration_Order (Order : Unit_Id_Table) is + begin + -- Nothing to do when switch -d_V (validate bindo graphs and order) + -- is not in effect. + + if not Debug_Flag_Underscore_VV then + return; + end if; + + Validate_Units (Order); + + if Has_Invalid_Data then + raise Invalid_Elaboration_Order; + end if; + end Validate_Elaboration_Order; + + ------------------- + -- Validate_Unit -- + ------------------- + + procedure Validate_Unit (U_Id : Unit_Id; Elab_Set : Membership_Set) is + begin + pragma Assert (Present (U_Id)); + + -- The current unit in the elaboration order appears within the set + -- of units that require elaboration. Remove it from the set. + + if Contains (Elab_Set, U_Id) then + Delete (Elab_Set, U_Id); + + -- Otherwise the current unit in the elaboration order must not be + -- elaborated. + + else + Report_Spurious_Elaboration (U_Id); + end if; + end Validate_Unit; + + -------------------- + -- Validate_Units -- + -------------------- + + procedure Validate_Units (Order : Unit_Id_Table) is + Elab_Set : Membership_Set; + + begin + -- Collect all units in the compilation that need to be elaborated + -- in a set. + + Elab_Set := Build_Elaborable_Unit_Set; + + -- Validate each unit in the elaboration order against the set of + -- units that need to be elaborated. + + for Index in Unit_Id_Tables.First .. Unit_Id_Tables.Last (Order) loop + Validate_Unit + (U_Id => Order.Table (Index), + Elab_Set => Elab_Set); + end loop; + + -- At this point all units that need to be elaborated should have + -- been eliminated from the set. Report any units that are missing + -- their elaboration. + + Report_Missing_Elaborations (Elab_Set); + Destroy (Elab_Set); + end Validate_Units; + + ----------------- + -- Write_Error -- + ----------------- + + procedure Write_Error (Msg : String) is + begin + Has_Invalid_Data := True; + + Write_Str ("ERROR: "); + Write_Str (Msg); + Write_Eol; + end Write_Error; + end Elaboration_Order_Validators; + + --------------------------------- + -- Invocation_Graph_Validators -- + --------------------------------- + + package body Invocation_Graph_Validators is + Has_Invalid_Data : Boolean := False; + -- Flag set when the invocation graph contains invalid data + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Validate_Invocation_Graph_Edge + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id); + pragma Inline (Validate_Invocation_Graph_Edge); + -- Verify that the attributes of edge IGE_Id of invocation graph G are + -- properly set. + + procedure Validate_Invocation_Graph_Edges (G : Invocation_Graph); + pragma Inline (Validate_Invocation_Graph_Edges); + -- Verify that the attributes of all edges of invocation graph G are + -- properly set. + + procedure Validate_Invocation_Graph_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id); + pragma Inline (Validate_Invocation_Graph_Vertex); + -- Verify that the attributes of vertex IGV_Id of inbocation graph G are + -- properly set. + + procedure Validate_Invocation_Graph_Vertices (G : Invocation_Graph); + pragma Inline (Validate_Invocation_Graph_Vertices); + -- Verify that the attributes of all vertices of invocation graph G are + -- properly set. + + procedure Write_Error (Msg : String); + pragma Inline (Write_Error); + -- Write error message Msg to standard output and signal that the + -- invocation graph is incorrect. + + ------------------------------- + -- Validate_Invocation_Graph -- + ------------------------------- + + procedure Validate_Invocation_Graph (G : Invocation_Graph) is + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -d_V (validate bindo graphs and order) + -- is not in effect. + + if not Debug_Flag_Underscore_VV then + return; + end if; + + Validate_Invocation_Graph_Vertices (G); + Validate_Invocation_Graph_Edges (G); + + if Has_Invalid_Data then + raise Invalid_Invocation_Graph; + end if; + end Validate_Invocation_Graph; + + ------------------------------------ + -- Validate_Invocation_Graph_Edge -- + ------------------------------------ + + procedure Validate_Invocation_Graph_Edge + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) + is + Msg : constant String := "Validate_Invocation_Graph_Edge"; + + begin + pragma Assert (Present (G)); + + if not Present (IGE_Id) then + Write_Error (Msg); + + Write_Str (" emply invocation graph edge"); + Write_Eol; + Write_Eol; + return; + end if; + + if not Present (Relation (G, IGE_Id)) then + Write_Error (Msg); + + Write_Str (" invocation graph edge (IGE_Id_"); + Write_Int (Int (IGE_Id)); + Write_Str (") lacks Relation"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Target (G, IGE_Id)) then + Write_Error (Msg); + + Write_Str (" invocation graph edge (IGE_Id_"); + Write_Int (Int (IGE_Id)); + Write_Str (") lacks Target"); + Write_Eol; + Write_Eol; + end if; + end Validate_Invocation_Graph_Edge; + + ------------------------------------- + -- Validate_Invocation_Graph_Edges -- + ------------------------------------- + + procedure Validate_Invocation_Graph_Edges (G : Invocation_Graph) is + IGE_Id : Invocation_Graph_Edge_Id; + Iter : Invocation_Graphs.All_Edge_Iterator; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Edges (G); + while Has_Next (Iter) loop + Next (Iter, IGE_Id); + + Validate_Invocation_Graph_Edge (G, IGE_Id); + end loop; + end Validate_Invocation_Graph_Edges; + + -------------------------------------- + -- Validate_Invocation_Graph_Vertex -- + -------------------------------------- + + procedure Validate_Invocation_Graph_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) + is + Msg : constant String := "Validate_Invocation_Graph_Vertex"; + + begin + pragma Assert (Present (G)); + + if not Present (IGV_Id) then + Write_Error (Msg); + + Write_Str (" emply invocation graph vertex"); + Write_Eol; + Write_Eol; + return; + end if; + + if not Present (Construct (G, IGV_Id)) then + Write_Error (Msg); + + Write_Str (" invocation graph vertex (IGV_Id_"); + Write_Int (Int (IGV_Id)); + Write_Str (") lacks Construct"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Lib_Vertex (G, IGV_Id)) then + Write_Error (Msg); + + Write_Str (" invocation graph vertex (IGV_Id_"); + Write_Int (Int (IGV_Id)); + Write_Str (") lacks Lib_Vertex"); + Write_Eol; + Write_Eol; + end if; + end Validate_Invocation_Graph_Vertex; + + ---------------------------------------- + -- Validate_Invocation_Graph_Vertices -- + ---------------------------------------- + + procedure Validate_Invocation_Graph_Vertices (G : Invocation_Graph) is + IGV_Id : Invocation_Graph_Vertex_Id; + Iter : Invocation_Graphs.All_Vertex_Iterator; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, IGV_Id); + + Validate_Invocation_Graph_Vertex (G, IGV_Id); + end loop; + end Validate_Invocation_Graph_Vertices; + + ----------------- + -- Write_Error -- + ----------------- + + procedure Write_Error (Msg : String) is + begin + Has_Invalid_Data := True; + + Write_Str ("ERROR: "); + Write_Str (Msg); + Write_Eol; + end Write_Error; + end Invocation_Graph_Validators; + + ------------------------------ + -- Library_Graph_Validators -- + ------------------------------ + + package body Library_Graph_Validators is + Has_Invalid_Data : Boolean := False; + -- Flag set when the library graph contains invalid data + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Validate_Library_Graph_Edge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id); + pragma Inline (Validate_Library_Graph_Edge); + -- Verify that the attributes of edge LGE_Id of library graph G are + -- properly set. + + procedure Validate_Library_Graph_Edges (G : Library_Graph); + pragma Inline (Validate_Library_Graph_Edges); + -- Verify that the attributes of all edges of library graph G are + -- properly set. + + procedure Validate_Library_Graph_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Validate_Library_Graph_Vertex); + -- Verify that the attributes of vertex LGV_Id of library graph G are + -- properly set. + + procedure Validate_Library_Graph_Vertices (G : Library_Graph); + pragma Inline (Validate_Library_Graph_Vertices); + -- Verify that the attributes of all vertices of library graph G are + -- properly set. + + procedure Write_Error (Msg : String); + pragma Inline (Write_Error); + -- Write error message Msg to standard output and signal that the + -- library graph is incorrect. + + ---------------------------- + -- Validate_Library_Graph -- + ---------------------------- + + procedure Validate_Library_Graph (G : Library_Graph) is + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -d_V (validate bindo graphs and order) + -- is not in effect. + + if not Debug_Flag_Underscore_VV then + return; + end if; + + Validate_Library_Graph_Vertices (G); + Validate_Library_Graph_Edges (G); + + if Has_Invalid_Data then + raise Invalid_Library_Graph; + end if; + end Validate_Library_Graph; + + --------------------------------- + -- Validate_Library_Graph_Edge -- + --------------------------------- + + procedure Validate_Library_Graph_Edge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) + is + Msg : constant String := "Validate_Library_Graph_Edge"; + + begin + pragma Assert (Present (G)); + + if not Present (LGE_Id) then + Write_Error (Msg); + + Write_Str (" emply library graph edge"); + Write_Eol; + Write_Eol; + return; + end if; + + if Kind (G, LGE_Id) = No_Edge then + Write_Error (Msg); + + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (LGE_Id)); + Write_Str (") is not a valid edge"); + Write_Eol; + Write_Eol; + + elsif Kind (G, LGE_Id) = Body_Before_Spec_Edge then + Write_Error (Msg); + + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (LGE_Id)); + Write_Str (") is a Body_Before_Spec edge"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Predecessor (G, LGE_Id)) then + Write_Error (Msg); + + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (LGE_Id)); + Write_Str (") lacks Predecessor"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Successor (G, LGE_Id)) then + Write_Error (Msg); + + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (LGE_Id)); + Write_Str (") lacks Successor"); + Write_Eol; + Write_Eol; + end if; + end Validate_Library_Graph_Edge; + + ---------------------------------- + -- Validate_Library_Graph_Edges -- + ---------------------------------- + + procedure Validate_Library_Graph_Edges (G : Library_Graph) is + Iter : Library_Graphs.All_Edge_Iterator; + LGE_Id : Library_Graph_Edge_Id; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Edges (G); + while Has_Next (Iter) loop + Next (Iter, LGE_Id); + pragma Assert (Present (LGE_Id)); + + Validate_Library_Graph_Edge (G, LGE_Id); + end loop; + end Validate_Library_Graph_Edges; + + ----------------------------------- + -- Validate_Library_Graph_Vertex -- + ----------------------------------- + + procedure Validate_Library_Graph_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + is + Msg : constant String := "Validate_Library_Graph_Vertex"; + + begin + pragma Assert (Present (G)); + + if not Present (LGV_Id) then + Write_Error (Msg); + + Write_Str (" empty library graph vertex"); + Write_Eol; + Write_Eol; + return; + end if; + + if (Is_Body_With_Spec (G, LGV_Id) + or else + Is_Spec_With_Body (G, LGV_Id)) + and then not Present (Corresponding_Item (G, LGV_Id)) + then + Write_Error (Msg); + + Write_Str (" library graph vertex (LGV_Id_"); + Write_Int (Int (LGV_Id)); + Write_Str (") lacks Corresponding_Item"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Unit (G, LGV_Id)) then + Write_Error (Msg); + + Write_Str (" library graph vertex (LGV_Id_"); + Write_Int (Int (LGV_Id)); + Write_Str (") lacks Unit"); + Write_Eol; + Write_Eol; + end if; + end Validate_Library_Graph_Vertex; + + ------------------------------------- + -- Validate_Library_Graph_Vertices -- + ------------------------------------- + + procedure Validate_Library_Graph_Vertices (G : Library_Graph) is + Iter : Library_Graphs.All_Vertex_Iterator; + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, LGV_Id); + pragma Assert (Present (LGV_Id)); + + Validate_Library_Graph_Vertex (G, LGV_Id); + end loop; + end Validate_Library_Graph_Vertices; + + ----------------- + -- Write_Error -- + ----------------- + + procedure Write_Error (Msg : String) is + begin + Has_Invalid_Data := True; + + Write_Str ("ERROR: "); + Write_Str (Msg); + Write_Eol; + end Write_Error; + end Library_Graph_Validators; + +end Bindo.Validators; diff --git a/gcc/ada/bindo-validators.ads b/gcc/ada/bindo-validators.ads new file mode 100644 index 0000000..39fccc6 --- /dev/null +++ b/gcc/ada/bindo-validators.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . V A L I D A T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to verify the validity of the +-- various graphs used in determining the elaboration order of units. + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Invocation_Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Validators is + + ---------------------------------- + -- Elaboration_Order_Validators -- + ---------------------------------- + + package Elaboration_Order_Validators is + Invalid_Elaboration_Order : exception; + -- Exception raised when the elaboration order contains invalid data + + procedure Validate_Elaboration_Order (Order : Unit_Id_Table); + -- Ensure that elaboration order Order meets the following requirements: + -- + -- * All units that must be elaborated appear in the order + -- * No other units appear in the order + -- + -- Diagnose issues and raise Invalid_Elaboration_Order if this is not + -- the case. + + end Elaboration_Order_Validators; + + --------------------------------- + -- Invocation_Graph_Validators -- + --------------------------------- + + package Invocation_Graph_Validators is + Invalid_Invocation_Graph : exception; + -- Exception raised when the invocation graph contains invalid data + + procedure Validate_Invocation_Graph (G : Invocation_Graph); + -- Ensure that invocation graph G meets the following requirements: + -- + -- * All attributes of edges are properly set + -- * All attributes of vertices are properly set + -- + -- Diagnose issues and raise Invalid_Invocation_Graph if this is not the + -- case. + + end Invocation_Graph_Validators; + + ------------------------------ + -- Library_Graph_Validators -- + ------------------------------ + + package Library_Graph_Validators is + Invalid_Library_Graph : exception; + -- Exception raised when the library graph contains invalid data + + procedure Validate_Library_Graph (G : Library_Graph); + -- Ensure that library graph G meets the following requirements: + -- + -- * All attributes edges are properly set + -- * All attributes of vertices are properly set + -- + -- Diagnose issues and raise Invalid_Library_Graph if this is not the + -- case. + + end Library_Graph_Validators; + +end Bindo.Validators; diff --git a/gcc/ada/bindo-writers.adb b/gcc/ada/bindo-writers.adb new file mode 100644 index 0000000..7450c15 --- /dev/null +++ b/gcc/ada/bindo-writers.adb @@ -0,0 +1,1333 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . W R I T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Fname; use Fname; +with Opt; use Opt; +with Output; use Output; + +with Bindo.Units; use Bindo.Units; + +with GNAT; use GNAT; +with GNAT.Graphs; use GNAT.Graphs; +with GNAT.Sets; use GNAT.Sets; + +package body Bindo.Writers is + + ----------------- + -- ALI_Writers -- + ----------------- + + package body ALI_Writers is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_All_Units; + pragma Inline (Write_All_Units); + -- Write the common form of units to standard output + + procedure Write_Invocation_Construct (IC_Id : Invocation_Construct_Id); + pragma Inline (Write_Invocation_Construct); + -- Write invocation construct IC_Id to standard output + + procedure Write_Invocation_Relation (IR_Id : Invocation_Relation_Id); + pragma Inline (Write_Invocation_Relation); + -- Write invocation relation IR_Id to standard output + + procedure Write_Invocation_Signature (IS_Id : Invocation_Signature_Id); + pragma Inline (Write_Invocation_Signature); + -- Write invocation signature IS_Id to standard output + + procedure Write_Statistics; + pragma Inline (Write_Statistics); + -- Write the statistical information of units to standard output + + procedure Write_Unit (U_Id : Unit_Id); + pragma Inline (Write_Unit); + -- Write the invocation constructs and relations of unit U_Id to + -- standard output. + + procedure Write_Unit_Common (U_Id : Unit_Id); + pragma Inline (Write_Unit_Common); + -- Write the common form of unit U_Id to standard output + + ----------- + -- Debug -- + ----------- + + procedure pau renames Write_All_Units; + pragma Unreferenced (pau); + + procedure pu (U_Id : Unit_Id) renames Write_Unit_Common; + pragma Unreferenced (pu); + + ---------------------- + -- Write_ALI_Tables -- + ---------------------- + + procedure Write_ALI_Tables is + begin + -- Nothing to do when switch -d_A (output invocation tables) is not + -- in effect. + + if not Debug_Flag_Underscore_AA then + return; + end if; + + Write_Str ("ALI Tables"); + Write_Eol; + Write_Eol; + + Write_Statistics; + For_Each_Unit (Write_Unit'Access); + + Write_Str ("ALI Tables end"); + Write_Eol; + Write_Eol; + end Write_ALI_Tables; + + --------------------- + -- Write_All_Units -- + --------------------- + + procedure Write_All_Units is + begin + For_Each_Unit (Write_Unit_Common'Access); + end Write_All_Units; + + -------------------------------- + -- Write_Invocation_Construct -- + -------------------------------- + + procedure Write_Invocation_Construct (IC_Id : Invocation_Construct_Id) is + pragma Assert (Present (IC_Id)); + + IC_Rec : Invocation_Construct_Record renames + Invocation_Constructs.Table (IC_Id); + + begin + Write_Str (" invocation construct (IC_Id_"); + Write_Int (Int (IC_Id)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Kind = "); + Write_Str (IC_Rec.Kind'Img); + Write_Eol; + + Write_Str (" Placement = "); + Write_Str (IC_Rec.Placement'Img); + Write_Eol; + + Write_Invocation_Signature (IC_Rec.Signature); + Write_Eol; + end Write_Invocation_Construct; + + ------------------------------- + -- Write_Invocation_Relation -- + ------------------------------- + + procedure Write_Invocation_Relation (IR_Id : Invocation_Relation_Id) is + pragma Assert (Present (IR_Id)); + + IR_Rec : Invocation_Relation_Record renames + Invocation_Relations.Table (IR_Id); + + begin + Write_Str (" invocation relation (IR_Id_"); + Write_Int (Int (IR_Id)); + Write_Str (")"); + Write_Eol; + + if Present (IR_Rec.Extra) then + Write_Str (" Extra = "); + Write_Name (IR_Rec.Extra); + else + Write_Str (" Extra = none"); + end if; + + Write_Eol; + Write_Str (" Invoker"); + Write_Eol; + + Write_Invocation_Signature (IR_Rec.Invoker); + + Write_Str (" Kind = "); + Write_Str (IR_Rec.Kind'Img); + Write_Eol; + + Write_Str (" Target"); + Write_Eol; + + Write_Invocation_Signature (IR_Rec.Target); + Write_Eol; + end Write_Invocation_Relation; + + -------------------------------- + -- Write_Invocation_Signature -- + -------------------------------- + + procedure Write_Invocation_Signature (IS_Id : Invocation_Signature_Id) is + pragma Assert (Present (IS_Id)); + + IS_Rec : Invocation_Signature_Record renames + Invocation_Signatures.Table (IS_Id); + + begin + Write_Str (" Signature (IS_Id_"); + Write_Int (Int (IS_Id)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Column = "); + Write_Int (Int (IS_Rec.Column)); + Write_Eol; + + Write_Str (" Line = "); + Write_Int (Int (IS_Rec.Line)); + Write_Eol; + + if Present (IS_Rec.Locations) then + Write_Str (" Locations = "); + Write_Name (IS_Rec.Locations); + else + Write_Str (" Locations = none"); + end if; + + Write_Eol; + Write_Str (" Name = "); + Write_Name (IS_Rec.Name); + Write_Eol; + + Write_Str (" Scope = "); + Write_Name (IS_Rec.Scope); + Write_Eol; + end Write_Invocation_Signature; + + ---------------------- + -- Write_Statistics -- + ---------------------- + + procedure Write_Statistics is + begin + Write_Str ("Units : "); + Write_Num (Int (Number_Of_Units)); + Write_Eol; + + Write_Str ("Units to elaborate: "); + Write_Num (Int (Number_Of_Elaborable_Units)); + Write_Eol; + Write_Eol; + end Write_Statistics; + + ---------------- + -- Write_Unit -- + ---------------- + + procedure Write_Unit (U_Id : Unit_Id) is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + Write_Unit_Common (U_Id); + + Write_Str (" First_Invocation_Construct (IC_Id_"); + Write_Int (Int (U_Rec.First_Invocation_Construct)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Last_Invocation_Construct (IC_Id_"); + Write_Int (Int (U_Rec.Last_Invocation_Construct)); + Write_Str (")"); + Write_Eol; + + Write_Str (" First_Invocation_Relation (IR_Id_"); + Write_Int (Int (U_Rec.First_Invocation_Relation)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Last_Invocation_Relation (IR_Id_"); + Write_Int (Int (U_Rec.Last_Invocation_Relation)); + Write_Str (")"); + Write_Eol; + Write_Eol; + + for IC_Id in U_Rec.First_Invocation_Construct .. + U_Rec.Last_Invocation_Construct + loop + Write_Invocation_Construct (IC_Id); + end loop; + + for IR_Id in U_Rec.First_Invocation_Relation .. + U_Rec.Last_Invocation_Relation + loop + Write_Invocation_Relation (IR_Id); + end loop; + end Write_Unit; + + ----------------------- + -- Write_Unit_Common -- + ----------------------- + + procedure Write_Unit_Common (U_Id : Unit_Id) is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + Write_Str ("unit (U_Id_"); + Write_Int (Int (U_Id)); + Write_Str (") name = "); + Write_Name (U_Rec.Uname); + Write_Eol; + + if U_Rec.SAL_Interface then + Write_Str (" SAL_Interface = True"); + Write_Eol; + end if; + end Write_Unit_Common; + end ALI_Writers; + + ------------------------------- + -- Elaboration_Order_Writers -- + ------------------------------- + + package body Elaboration_Order_Writers is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_Unit (U_Id : Unit_Id); + pragma Inline (Write_Unit); + -- Write unit U_Id to standard output + + procedure Write_Units (Order : Unit_Id_Table); + pragma Inline (Write_Units); + -- Write all units found in elaboration order Order to standard output + + ----------------------------- + -- Write_Elaboration_Order -- + ----------------------------- + + procedure Write_Elaboration_Order (Order : Unit_Id_Table) is + begin + -- Nothing to do when switch -d_O (output elaboration order) is not + -- in effect. + + if not Debug_Flag_Underscore_OO then + return; + end if; + + Write_Str ("Elaboration Order"); + Write_Eol; + Write_Eol; + + Write_Units (Order); + + Write_Eol; + Write_Str ("Elaboration Order end"); + Write_Eol; + + Write_Eol; + end Write_Elaboration_Order; + + ---------------- + -- Write_Unit -- + ---------------- + + procedure Write_Unit (U_Id : Unit_Id) is + begin + pragma Assert (Present (U_Id)); + + Write_Str ("unit (U_Id_"); + Write_Int (Int (U_Id)); + Write_Str (") name = "); + Write_Name (Name (U_Id)); + Write_Eol; + end Write_Unit; + + ----------------- + -- Write_Units -- + ----------------- + + procedure Write_Units (Order : Unit_Id_Table) is + begin + for Index in Unit_Id_Tables.First .. Unit_Id_Tables.Last (Order) loop + Write_Unit (Order.Table (Index)); + end loop; + end Write_Units; + end Elaboration_Order_Writers; + + --------------- + -- Indent_By -- + --------------- + + procedure Indent_By (Indent : Indentation_Level) is + begin + for Count in 1 .. Indent loop + Write_Char (' '); + end loop; + end Indent_By; + + ------------------------------ + -- Invocation_Graph_Writers -- + ------------------------------ + + package body Invocation_Graph_Writers is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_Elaboration_Root + (G : Invocation_Graph; + Root : Invocation_Graph_Vertex_Id); + pragma Inline (Write_Elaboration_Root); + -- Write elaboration root Root of invocation graph G to standard output + + procedure Write_Elaboration_Roots (G : Invocation_Graph); + pragma Inline (Write_Elaboration_Roots); + -- Write all elaboration roots of invocation graph G to standard output + + procedure Write_Invocation_Graph_Edge + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id); + pragma Inline (Write_Invocation_Graph_Edge); + -- Write edge IGE_Id of invocation graph G to standard output + + procedure Write_Invocation_Graph_Edges + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id); + pragma Inline (Write_Invocation_Graph_Edges); + -- Write all edges of invocation graph G to standard output + + procedure Write_Invocation_Graph_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id); + pragma Inline (Write_Invocation_Graph_Vertex); + -- Write vertex IGV_Id of invocation graph G to standard output + + procedure Write_Invocation_Graph_Vertices (G : Invocation_Graph); + pragma Inline (Write_Invocation_Graph_Vertices); + -- Write all vertices of invocation graph G to standard output + + procedure Write_Statistics (G : Invocation_Graph); + pragma Inline (Write_Statistics); + -- Write the statistical information of invocation graph G to standard + -- output. + + ----------- + -- Debug -- + ----------- + + procedure pige + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) + renames Write_Invocation_Graph_Edge; + pragma Unreferenced (pige); + + procedure pigv + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) + renames Write_Invocation_Graph_Vertex; + pragma Unreferenced (pigv); + + ---------------------------- + -- Write_Elaboration_Root -- + ---------------------------- + + procedure Write_Elaboration_Root + (G : Invocation_Graph; + Root : Invocation_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Root)); + + Write_Str ("elaboration root (IGV_Id_"); + Write_Int (Int (Root)); + Write_Str (") name = "); + Write_Name (Name (G, Root)); + Write_Eol; + end Write_Elaboration_Root; + + ----------------------------- + -- Write_Elaboration_Roots -- + ----------------------------- + + procedure Write_Elaboration_Roots (G : Invocation_Graph) is + pragma Assert (Present (G)); + + Num_Of_Roots : constant Natural := Number_Of_Elaboration_Roots (G); + + Iter : Elaboration_Root_Iterator; + Root : Invocation_Graph_Vertex_Id; + + begin + Write_Str ("Elaboration roots: "); + Write_Int (Int (Num_Of_Roots)); + Write_Eol; + + if Num_Of_Roots > 0 then + Iter := Iterate_Elaboration_Roots (G); + while Has_Next (Iter) loop + Next (Iter, Root); + pragma Assert (Present (Root)); + + Write_Elaboration_Root (G, Root); + end loop; + else + Write_Eol; + end if; + end Write_Elaboration_Roots; + + ---------------------------- + -- Write_Invocation_Graph -- + ---------------------------- + + procedure Write_Invocation_Graph (G : Invocation_Graph) is + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -d_I (output invocation graph) is not in + -- effect. + + if not Debug_Flag_Underscore_II then + return; + end if; + + Write_Str ("Invocation Graph"); + Write_Eol; + Write_Eol; + + Write_Statistics (G); + Write_Invocation_Graph_Vertices (G); + Write_Elaboration_Roots (G); + + Write_Str ("Invocation Graph end"); + Write_Eol; + + Write_Eol; + end Write_Invocation_Graph; + + --------------------------------- + -- Write_Invocation_Graph_Edge -- + --------------------------------- + + procedure Write_Invocation_Graph_Edge + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (IGE_Id)); + + Targ : constant Invocation_Graph_Vertex_Id := Target (G, IGE_Id); + + pragma Assert (Present (Targ)); + + begin + Write_Str (" invocation graph edge (IGE_Id_"); + Write_Int (Int (IGE_Id)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Relation (IR_Id_"); + Write_Int (Int (Relation (G, IGE_Id))); + Write_Str (")"); + Write_Eol; + + Write_Str (" Target (IGV_Id_"); + Write_Int (Int (Targ)); + Write_Str (") name = "); + Write_Name (Name (G, Targ)); + Write_Eol; + + Write_Eol; + end Write_Invocation_Graph_Edge; + + ---------------------------------- + -- Write_Invocation_Graph_Edges -- + ---------------------------------- + + procedure Write_Invocation_Graph_Edges + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + Num_Of_Edges : constant Natural := + Number_Of_Edges_To_Targets (G, IGV_Id); + + IGE_Id : Invocation_Graph_Edge_Id; + Iter : Invocation_Graphs.Edges_To_Targets_Iterator; + + begin + Write_Str (" Edges to targets: "); + Write_Int (Int (Num_Of_Edges)); + Write_Eol; + + if Num_Of_Edges > 0 then + Iter := Iterate_Edges_To_Targets (G, IGV_Id); + while Has_Next (Iter) loop + Next (Iter, IGE_Id); + pragma Assert (Present (IGE_Id)); + + Write_Invocation_Graph_Edge (G, IGE_Id); + end loop; + else + Write_Eol; + end if; + end Write_Invocation_Graph_Edges; + + ----------------------------------- + -- Write_Invocation_Graph_Vertex -- + ----------------------------------- + + procedure Write_Invocation_Graph_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + Write_Str ("invocation graph vertex (IGV_Id_"); + Write_Int (Int (IGV_Id)); + Write_Str (") name = "); + Write_Name (Name (G, IGV_Id)); + Write_Eol; + + Write_Str (" Construct (IC_Id_"); + Write_Int (Int (Construct (G, IGV_Id))); + Write_Str (")"); + Write_Eol; + + Write_Str (" Lib_Vertex (LGV_Id_"); + Write_Int (Int (Lib_Vertex (G, IGV_Id))); + Write_Str (")"); + Write_Eol; + + Write_Invocation_Graph_Edges (G, IGV_Id); + end Write_Invocation_Graph_Vertex; + + ------------------------------------- + -- Write_Invocation_Graph_Vertices -- + ------------------------------------- + + procedure Write_Invocation_Graph_Vertices (G : Invocation_Graph) is + IGV_Id : Invocation_Graph_Vertex_Id; + Iter : Invocation_Graphs.All_Vertex_Iterator; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, IGV_Id); + pragma Assert (Present (IGV_Id)); + + Write_Invocation_Graph_Vertex (G, IGV_Id); + end loop; + end Write_Invocation_Graph_Vertices; + + ---------------------- + -- Write_Statistics -- + ---------------------- + + procedure Write_Statistics (G : Invocation_Graph) is + begin + pragma Assert (Present (G)); + + Write_Str ("Edges : "); + Write_Num (Int (Number_Of_Edges (G))); + Write_Eol; + + Write_Str ("Roots : "); + Write_Num (Int (Number_Of_Elaboration_Roots (G))); + Write_Eol; + + Write_Str ("Vertices: "); + Write_Num (Int (Number_Of_Vertices (G))); + Write_Eol; + Write_Eol; + + for Kind in Invocation_Kind'Range loop + Write_Str (" "); + Write_Num (Int (Invocation_Graph_Edge_Count (G, Kind))); + Write_Str (" - "); + Write_Str (Kind'Img); + Write_Eol; + end loop; + + Write_Eol; + end Write_Statistics; + end Invocation_Graph_Writers; + + --------------------------- + -- Library_Graph_Writers -- + --------------------------- + + package body Library_Graph_Writers is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_Component + (G : Library_Graph; + Comp : Component_Id); + pragma Inline (Write_Component); + -- Write component Comp of library graph G to standard output + + procedure Write_Component_Vertices + (G : Library_Graph; + Comp : Component_Id); + pragma Inline (Write_Component_Vertices); + -- Write all vertices of component Comp of library graph G to standard + -- output. + + procedure Write_Components (G : Library_Graph); + pragma Inline (Write_Components); + -- Write all components of library graph G to standard output + + procedure Write_Edges_To_Successors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Write_Edges_To_Successors); + -- Write all edges to successors of predecessor LGV_Id of library graph + -- G to standard output. + + procedure Write_Library_Graph_Edge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id); + pragma Inline (Write_Library_Graph_Edge); + -- Write edge LGE_Id of library graph G to standard output + + procedure Write_Library_Graph_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Write_Library_Graph_Vertex); + -- Write vertex LGV_Id of library graph G to standard output + + procedure Write_Library_Graph_Vertices (G : Library_Graph); + pragma Inline (Write_Library_Graph_Vertices); + -- Write all vertices of library graph G to standard output + + procedure Write_Statistics (G : Library_Graph); + pragma Inline (Write_Statistics); + -- Write the statistical information of library graph G to standard + -- output. + + ----------- + -- Debug -- + ----------- + + procedure pc + (G : Library_Graph; + Comp : Component_Id) renames Write_Component; + pragma Unreferenced (pc); + + procedure plge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) renames Write_Library_Graph_Edge; + pragma Unreferenced (plge); + + procedure plgv + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) renames Write_Library_Graph_Vertex; + pragma Unreferenced (plgv); + + --------------------- + -- Write_Component -- + --------------------- + + procedure Write_Component + (G : Library_Graph; + Comp : Component_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + Write_Str ("component (Comp_"); + Write_Int (Int (Comp)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Pending_Predecessors = "); + Write_Int (Int (Pending_Predecessors (G, Comp))); + Write_Eol; + + Write_Component_Vertices (G, Comp); + end Write_Component; + + ------------------------------ + -- Write_Component_Vertices -- + ------------------------------ + + procedure Write_Component_Vertices + (G : Library_Graph; + Comp : Component_Id) + is + Iter : Component_Vertex_Iterator; + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + Iter := Iterate_Component_Vertices (G, Comp); + while Has_Next (Iter) loop + Next (Iter, LGV_Id); + pragma Assert (Present (LGV_Id)); + + Write_Str (" library graph vertex (LGV_Id_"); + Write_Int (Int (LGV_Id)); + Write_Str (") name = "); + Write_Name (Name (G, LGV_Id)); + Write_Eol; + end loop; + + Write_Eol; + end Write_Component_Vertices; + + ---------------------- + -- Write_Components -- + ---------------------- + + procedure Write_Components (G : Library_Graph) is + pragma Assert (Present (G)); + + Num_Of_Comps : constant Natural := Number_Of_Components (G); + + Comp : Component_Id; + Iter : Component_Iterator; + + begin + if Num_Of_Comps > 0 then + Iter := Iterate_Components (G); + while Has_Next (Iter) loop + Next (Iter, Comp); + pragma Assert (Present (Comp)); + + Write_Component (G, Comp); + end loop; + else + Write_Eol; + end if; + end Write_Components; + + ------------------------------- + -- Write_Edges_To_Successors -- + ------------------------------- + + procedure Write_Edges_To_Successors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Num_Of_Edges : constant Natural := + Number_Of_Edges_To_Successors (G, LGV_Id); + + Iter : Edges_To_Successors_Iterator; + LGE_Id : Library_Graph_Edge_Id; + + begin + Write_Str (" Edges to successors: "); + Write_Int (Int (Num_Of_Edges)); + Write_Eol; + + if Num_Of_Edges > 0 then + Iter := Iterate_Edges_To_Successors (G, LGV_Id); + while Has_Next (Iter) loop + Next (Iter, LGE_Id); + pragma Assert (Present (LGE_Id)); + + Write_Library_Graph_Edge (G, LGE_Id); + end loop; + else + Write_Eol; + end if; + end Write_Edges_To_Successors; + + ------------------------- + -- Write_Library_Graph -- + ------------------------- + + procedure Write_Library_Graph (G : Library_Graph) is + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -d_L (output library item graph) is not + -- in effect. + + if not Debug_Flag_Underscore_LL then + return; + end if; + + Write_Str ("Library Graph"); + Write_Eol; + Write_Eol; + + Write_Statistics (G); + Write_Library_Graph_Vertices (G); + Write_Components (G); + + Write_Str ("Library Graph end"); + Write_Eol; + + Write_Eol; + end Write_Library_Graph; + + ------------------------------ + -- Write_Library_Graph_Edge -- + ------------------------------ + + procedure Write_Library_Graph_Edge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (LGE_Id)); + + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, LGE_Id); + Succ : constant Library_Graph_Vertex_Id := Successor (G, LGE_Id); + + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + + begin + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (LGE_Id)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Kind = "); + Write_Str (Kind (G, LGE_Id)'Img); + Write_Eol; + + Write_Str (" Predecessor (LGV_Id_"); + Write_Int (Int (Pred)); + Write_Str (") name = "); + Write_Name (Name (G, Pred)); + Write_Eol; + + Write_Str (" Successor (LGV_Id_"); + Write_Int (Int (Succ)); + Write_Str (") name = "); + Write_Name (Name (G, Succ)); + Write_Eol; + + Write_Eol; + end Write_Library_Graph_Edge; + + -------------------------------- + -- Write_Library_Graph_Vertex -- + -------------------------------- + + procedure Write_Library_Graph_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Item : constant Library_Graph_Vertex_Id := + Corresponding_Item (G, LGV_Id); + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + begin + Write_Str ("library graph vertex (LGV_Id_"); + Write_Int (Int (LGV_Id)); + Write_Str (") name = "); + Write_Name (Name (G, LGV_Id)); + Write_Eol; + + if Present (Item) then + Write_Str (" Corresponding_Item (LGV_Id_"); + Write_Int (Int (Item)); + Write_Str (") name = "); + Write_Name (Name (G, Item)); + else + Write_Str (" Corresponding_Item = none"); + end if; + + Write_Eol; + Write_Str (" In_Elaboration_Order = "); + + if In_Elaboration_Order (G, LGV_Id) then + Write_Str ("True"); + else + Write_Str ("False"); + end if; + + Write_Eol; + Write_Str (" Pending_Predecessors = "); + Write_Int (Int (Pending_Predecessors (G, LGV_Id))); + Write_Eol; + + Write_Str (" Component (Comp_Id_"); + Write_Int (Int (Component (G, LGV_Id))); + Write_Str (")"); + Write_Eol; + + Write_Str (" Unit (U_Id_"); + Write_Int (Int (U_Id)); + Write_Str (") name = "); + Write_Name (Name (U_Id)); + Write_Eol; + + Write_Edges_To_Successors (G, LGV_Id); + end Write_Library_Graph_Vertex; + + ---------------------------------- + -- Write_Library_Graph_Vertices -- + ---------------------------------- + + procedure Write_Library_Graph_Vertices (G : Library_Graph) is + Iter : Library_Graphs.All_Vertex_Iterator; + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, LGV_Id); + pragma Assert (Present (LGV_Id)); + + Write_Library_Graph_Vertex (G, LGV_Id); + end loop; + end Write_Library_Graph_Vertices; + + ---------------------- + -- Write_Statistics -- + ---------------------- + + procedure Write_Statistics (G : Library_Graph) is + begin + Write_Str ("Components: "); + Write_Num (Int (Number_Of_Components (G))); + Write_Eol; + + Write_Str ("Edges : "); + Write_Num (Int (Number_Of_Edges (G))); + Write_Eol; + + Write_Str ("Vertices : "); + Write_Num (Int (Number_Of_Vertices (G))); + Write_Eol; + Write_Eol; + + for Kind in Library_Graph_Edge_Kind'Range loop + Write_Str (" "); + Write_Num (Int (Library_Graph_Edge_Count (G, Kind))); + Write_Str (" - "); + Write_Str (Kind'Img); + Write_Eol; + end loop; + + Write_Eol; + end Write_Statistics; + end Library_Graph_Writers; + + -------------------------- + -- Unit_Closure_Writers -- + -------------------------- + + package body Unit_Closure_Writers is + function Hash_File_Name (Nam : File_Name_Type) return Bucket_Range_Type; + pragma Inline (Hash_File_Name); + -- Obtain the hash value of key Nam + + package FS is new Membership_Sets + (Element_Type => File_Name_Type, + "=" => "=", + Hash => Hash_File_Name); + use FS; + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_File_Name (Nam : File_Name_Type); + pragma Inline (Write_File_Name); + -- Write file name Nam to standard output + + procedure Write_Subunit_Closure + (Dep : Sdep_Id; + Set : Membership_Set); + pragma Inline (Write_Subunit_Closure); + -- Write the subunit which corresponds to dependency Dep to standard + -- output if it does not appear in set Set. + + procedure Write_Subunits_Closure (Set : Membership_Set); + pragma Inline (Write_Subunits_Closure); + -- Write all subunits to standard output if they do not appear in set + -- Set. + + procedure Write_Unit_Closure + (U_Id : Unit_Id; + Set : Membership_Set); + pragma Inline (Write_Unit_Closure); + -- Write unit U_Id to standard output if it does not appear in set Set + + procedure Write_Units_Closure + (Order : Unit_Id_Table; + Set : Membership_Set); + pragma Inline (Write_Units_Closure); + -- Write all units of elaboration order Order to standard output if they + -- do not appear in set Set. + + -------------------- + -- Hash_File_Name -- + -------------------- + + function Hash_File_Name + (Nam : File_Name_Type) return Bucket_Range_Type + is + begin + pragma Assert (Present (Nam)); + + return Bucket_Range_Type (Nam); + end Hash_File_Name; + + --------------------- + -- Write_File_Name -- + --------------------- + + procedure Write_File_Name (Nam : File_Name_Type) is + begin + pragma Assert (Present (Nam)); + + if not Zero_Formatting then + Write_Str (" "); + end if; + + Write_Line (Get_Name_String (Nam)); + end Write_File_Name; + + --------------------------- + -- Write_Subunit_Closure -- + --------------------------- + + procedure Write_Subunit_Closure + (Dep : Sdep_Id; + Set : Membership_Set) + is + pragma Assert (Present (Dep)); + pragma Assert (Present (Set)); + + Dep_Rec : Sdep_Record renames Sdep.Table (Dep); + Source : constant File_Name_Type := Dep_Rec.Sfile; + + pragma Assert (Present (Source)); + + begin + -- Nothing to do when the source file has already been written + + if Contains (Set, Source) then + return; + + -- Nothing to do when the source file does not denote a non-internal + -- subunit. + + elsif not Present (Dep_Rec.Subunit_Name) + or else Is_Internal_File_Name (Source) + then + return; + end if; + + -- Mark the subunit as written + + Insert (Set, Source); + Write_File_Name (Source); + end Write_Subunit_Closure; + + ---------------------------- + -- Write_Subunits_Closure -- + ---------------------------- + + procedure Write_Subunits_Closure (Set : Membership_Set) is + begin + pragma Assert (Present (Set)); + + for Dep in Sdep.First .. Sdep.Last loop + Write_Subunit_Closure (Dep, Set); + end loop; + end Write_Subunits_Closure; + + ------------------------ + -- Write_Unit_Closure -- + ------------------------ + + procedure Write_Unit_Closure (Order : Unit_Id_Table) is + Set : Membership_Set; + + begin + -- Nothing to do when switch -R (list sources referenced in closure) + -- is not in effect. + + if not List_Closure then + return; + end if; + + if not Zero_Formatting then + Write_Eol; + Write_Line ("REFERENCED SOURCES"); + end if; + + -- Use a set to avoid writing duplicate units and subunits + + Set := Create (Number_Of_Elaborable_Units); + + Write_Units_Closure (Order, Set); + Write_Subunits_Closure (Set); + + Destroy (Set); + + if not Zero_Formatting then + Write_Eol; + end if; + end Write_Unit_Closure; + + ------------------------ + -- Write_Unit_Closure -- + ------------------------ + + procedure Write_Unit_Closure + (U_Id : Unit_Id; + Set : Membership_Set) + is + pragma Assert (Present (U_Id)); + pragma Assert (Present (Set)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + Source : constant File_Name_Type := U_Rec.Sfile; + + pragma Assert (Present (Source)); + + begin + -- Nothing to do when the source file has already been written + + if Contains (Set, Source) then + return; + + -- Nothing to do for internal source files unless switch -Ra (???) is + -- in effect. + + elsif Is_Internal_File_Name (Source) + and then not List_Closure_All + then + return; + end if; + + -- Mark the source file as written + + Insert (Set, Source); + Write_File_Name (Source); + end Write_Unit_Closure; + + ------------------------- + -- Write_Units_Closure -- + ------------------------- + + procedure Write_Units_Closure + (Order : Unit_Id_Table; + Set : Membership_Set) + is + begin + pragma Assert (Present (Set)); + + for Index in reverse Unit_Id_Tables.First .. + Unit_Id_Tables.Last (Order) + loop + Write_Unit_Closure + (U_Id => Order.Table (Index), + Set => Set); + end loop; + end Write_Units_Closure; + end Unit_Closure_Writers; + + --------------- + -- Write_Num -- + --------------- + + procedure Write_Num + (Val : Int; + Val_Indent : Indentation_Level := Number_Column) + is + function Digits_Indentation return Indentation_Level; + pragma Inline (Digits_Indentation); + -- Determine the level of indentation the number requies in order to + -- be right-justified by Val_Indent. + + ------------------------ + -- Digits_Indentation -- + ------------------------ + + function Digits_Indentation return Indentation_Level is + Indent : Indentation_Level; + Num : Int; + + begin + -- Treat zero as a single digit + + if Val = 0 then + Indent := 1; + + else + Indent := 0; + Num := Val; + + -- Shrink the input value by dividing it until all of its digits + -- are exhausted. + + while Num /= 0 loop + Indent := Indent + 1; + Num := Num / 10; + end loop; + end if; + + return Val_Indent - Indent; + end Digits_Indentation; + + -- Start of processing for Write_Num + + begin + Indent_By (Digits_Indentation); + Write_Int (Val); + end Write_Num; + +end Bindo.Writers; diff --git a/gcc/ada/bindo-writers.ads b/gcc/ada/bindo-writers.ads new file mode 100644 index 0000000..9ed598e --- /dev/null +++ b/gcc/ada/bindo-writers.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . W R I T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to output the various graphs used in +-- determining the elaboration order, as well as the elaboration order itself +-- to standard output. + +with Types; use Types; + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Invocation_Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Writers is + + ----------------- + -- Indentation -- + ----------------- + + -- The following type defines the level of indentation used in various + -- output routines. + + type Indentation_Level is new Natural; + No_Indentation : constant Indentation_Level := Indentation_Level'First; + + Nested_Indentation : constant Indentation_Level := 2; + -- The level of indentation for a nested new line + + Number_Column : constant Indentation_Level := 6; + -- The level of right justification of numbers + + Step_Column : constant Indentation_Level := 4; + -- The level of right justification of the elaboration order step + + procedure Indent_By (Indent : Indentation_Level); + pragma Inline (Indent_By); + -- Indent the current line by Indent spaces + + procedure Write_Num + (Val : Int; + Val_Indent : Indentation_Level := Number_Column); + pragma Inline (Write_Num); + -- Output integer value Val in a right-justified form based on the value of + -- Val_Col. + + ----------------- + -- ALI_Writers -- + ----------------- + + package ALI_Writers is + procedure Write_ALI_Tables; + -- Write the contents of the following tables to standard output: + -- + -- * ALI.Invocation_Constructs + -- * ALI.Invocation_Relations + + end ALI_Writers; + + ------------------------------- + -- Elaboration_Order_Writers -- + ------------------------------- + + package Elaboration_Order_Writers is + procedure Write_Elaboration_Order (Order : Unit_Id_Table); + -- Write elaboration order Order to standard output + + end Elaboration_Order_Writers; + + ------------------------------ + -- Invocation_Graph_Writers -- + ------------------------------ + + package Invocation_Graph_Writers is + procedure Write_Invocation_Graph (G : Invocation_Graph); + -- Write invocation graph G to standard output + + end Invocation_Graph_Writers; + + --------------------------- + -- Library_Graph_Writers -- + --------------------------- + + package Library_Graph_Writers is + procedure Write_Library_Graph (G : Library_Graph); + -- Write library graph G to standard output + + end Library_Graph_Writers; + + -------------------------- + -- Unit_Closure_Writers -- + -------------------------- + + package Unit_Closure_Writers is + procedure Write_Unit_Closure (Order : Unit_Id_Table); + -- Write all sources in the closure of the main unit as enumerated in + -- elaboration order Order. + + end Unit_Closure_Writers; + +end Bindo.Writers; diff --git a/gcc/ada/bindo.adb b/gcc/ada/bindo.adb new file mode 100644 index 0000000..7d26476 --- /dev/null +++ b/gcc/ada/bindo.adb @@ -0,0 +1,287 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Bindo.Elaborators; +use Bindo.Elaborators.Invocation_And_Library_Graph_Elaborators; + +package body Bindo is + + --------------------------------- + -- Elaboration order mechanism -- + --------------------------------- + + -- The elaboration order (EO) mechanism implemented in this unit and its + -- children has the following objectives: + -- + -- * Find an ordering of all library items (historically referred to as + -- "units") in the bind which require elaboration, taking into account: + -- + -- - The dependencies between units expressed in the form of with + -- clauses. + -- + -- - Pragmas Elaborate, Elaborate_All, Elaborate_Body, Preelaborable, + -- and Pure. + -- + -- - The flow of execution at elaboration time. + -- + -- - Additional dependencies between units supplied to the binder by + -- means of a file. + -- + -- The high-level idea is to construct two graphs: + -- + -- - Invocation graph - Models the flow of execution at elaboration + -- time. + -- + -- - Library graph - Represents with clause and pragma dependencies + -- between units. + -- + -- The library graph is further augmented with additional information + -- from the invocation graph by exploring the execution paths from a + -- unit with elaboration code to other external units. All strongly + -- connected components of the library graph are discovered. Finally, + -- the order is obtained via a topological sort-like algorithm which + -- attempts to order available units while enabling other units to be + -- ordered. + -- + -- * Diagnose elaboration circularities between units + -- + -- The library graph may contain at least one cycle, in which case no + -- ordering is possible. + -- + -- ??? more on this later + + ----------------- + -- Terminology -- + ----------------- + + -- * Component - A strongly connected component of a graph. + -- + -- * Elaboration root - A special invocation construct which denotes the + -- elaboration procedure of a unit. + -- + -- * Invocation - The act of activating a task, calling a subprogram, or + -- instantiating a generic. + -- + -- * Invocation construct - An entry declaration, [single] protected type, + -- subprogram declaration, subprogram instantiation, or a [single] task + -- type declared in the visible, private, or body declarations of some + -- unit. The construct is encoded in the ALI file of the related unit. + -- + -- * Invocation graph - A directed graph which models the flow of execution + -- at elaboration time. + -- + -- - Vertices - Invocation constructs plus extra information. Certain + -- vertices act as elaboration roots. + -- + -- - Edges - Invocation relations plus extra information. + -- + -- * Invocation relation - A flow link between two invocation constructs. + -- This link is encoded in the ALI file of unit that houses the invoker. + -- + -- * Invocation signature - A set of attributes that uniquely identify an + -- invocation construct within the namespace of all ALI files. + -- + -- * Invoker - The source construct of an invocation relation (the caller, + -- instantiator, or task activator). + -- + -- * Library graph - A directed graph which captures with clause and pragma + -- dependencies between units. + -- + -- - Vertices - Units plus extra information. + -- + -- - Edges - With clause, pragma, and additional dependencies between + -- units. + -- + -- * Pending predecessor - A vertex that must be elaborated before another + -- vertex can be elaborated. + -- + -- * Target - The destination construct of an invocation relation (the + -- generic, subprogram, or task type). + + ------------------ + -- Architecture -- + ------------------ + + -- Find_Elaboration_Order + -- | + -- +--> Collect_Elaborable_Units + -- +--> Write_ALI_Tables + -- +--> Elaborate_Units + -- | + -- +------ | -------------- Construction phase ------------------------+ + -- | | | + -- | +--> Build_Library_Graph | + -- | +--> Validate_Library_Graph | + -- | +--> Write_Library_Graph | + -- | | | + -- | +--> Build_Invocation_Graph | + -- | +--> Validate_Invocation_Graph | + -- | +--> Write_Invocation_Graph | + -- | | | + -- +------ | ----------------------------------------------------------+ + -- | + -- +------ | -------------- Augmentation phase ------------------------+ + -- | | | + -- | +--> Augment_Library_Graph | + -- | | | + -- +------ | ----------------------------------------------------------+ + -- | + -- +------ | -------------- Ordering phase ----------------------------+ + -- | | | + -- | +--> Find_Components | + -- | | | + -- | +--> Elaborate_Library_Graph | + -- | +--> Validate_Elaboration_Order | + -- | +--> Write_Elaboration_Order | + -- | | | + -- | +--> Write_Unit_Closure | + -- | | | + -- +------ | ----------------------------------------------------------+ + -- | + -- +------ | -------------- Diagnostics phase -------------------------+ + -- | | | + -- | +--> ??? more on this later | + -- | | + -- +-------------------------------------------------------------------+ + + ------------------------ + -- Construction phase -- + ------------------------ + + -- The Construction phase has the following objectives: + -- + -- * Build the library graph by inspecting the ALI file of each unit that + -- requires elaboration. + -- + -- * Validate the consistency of the library graph, only when switch -d_V + -- is in effect. + -- + -- * Write the contents of the invocation graph in human-readable form to + -- standard output when switch -d_L is in effect. + -- + -- * Build the invocation graph by inspecting invocation constructs and + -- relations in the ALI file of each unit that requires elaboration. + -- + -- * Validate the consistency of the invocation graph, only when switch + -- -d_V is in effect. + -- + -- * Write the contents of the invocation graph in human-readable form to + -- standard output when switch -d_I is in effect. + + ------------------------ + -- Augmentation phase -- + ------------------------ + + -- The Augmentation phase has the following objectives: + -- + -- * Discover transitions of the elaboration flow from a unit with an + -- elaboration root to other units. Augment the library graph with + -- extra edges for each such transition. + + -------------------- + -- Ordering phase -- + -------------------- + + -- The Ordering phase has the following objectives: + -- + -- * Discover all components of the library graph by treating specs and + -- bodies as single vertices. + -- + -- * Try to order as many vertices of the library graph as possible by + -- peforming a topological sort based on the pending predecessors of + -- vertices across all components and within a single component. + -- + -- * Validate the consistency of the order, only when switch -d_V is in + -- effect. + -- + -- * Write the contents of the order in human-readable form to standard + -- output when switch -d_O is in effect. + -- + -- * Write the sources of the order closure when switch -R is in effect. + + ----------------------- + -- Diagnostics phase -- + ----------------------- + + -- ??? more on this later + + -------------- + -- Switches -- + -------------- + + -- -d_A Output ALI invocation tables + -- + -- GNATbind outputs the contents of ALI table Invocation_Constructs + -- and Invocation_Edges in textual format to standard output. + -- + -- -d_I Output invocation graph + -- + -- GNATbind outputs the invocation graph in text format to standard + -- output. + -- + -- -d_L Output library graph + -- + -- GNATbind outputs the library graph in textual format to standard + -- output. + -- + -- -d_N New bindo order + -- + -- GNATbind utilizes the new bindo elaboration order + -- + -- -d_O Output elaboration order + -- + -- GNATbind outputs the elaboration order in text format to standard + -- output. + -- + -- -d_T Output elaboration order trace information + -- + -- GNATbind outputs trace information on elaboration order activities + -- to standard output. + -- + -- -d_V Validate bindo graphs and order + -- + -- GNATbind validates the invocation graph, library graph, SCC graph + -- and elaboration order by detecting inconsistencies and producing + -- error reports. + + ---------------------------------------- + -- Debugging elaboration order issues -- + ---------------------------------------- + + -- ??? more on this later + + ---------------------------- + -- Find_Elaboration_Order -- + ---------------------------- + + procedure Find_Elaboration_Order + (Order : out Unit_Id_Table; + Main_Lib_File : File_Name_Type) + is + begin + Elaborate_Units (Order, Main_Lib_File); + end Find_Elaboration_Order; + +end Bindo; diff --git a/gcc/ada/bindo.ads b/gcc/ada/bindo.ads new file mode 100644 index 0000000..39cf7a4 --- /dev/null +++ b/gcc/ada/bindo.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The following unit contains the main entry point into the elaboration order +-- mechanism. See the body for details. + +with ALI; use ALI; +with Namet; use Namet; + +package Bindo is + + procedure Find_Elaboration_Order + (Order : out Unit_Id_Table; + Main_Lib_File : File_Name_Type); + -- Find an order of all units in the bind that need to be elaborated + -- such that elaboration code flow, pragmas Elaborate, Elaborate_All, + -- and Elaborate_Body, and with clause dependencies are all honoured. + -- Main_Lib_File is the argument of the bind. If a satisfactory order + -- exists, it is returned in Order, otherwise Unrecoverable_Error is + -- raised. + +end Bindo; diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index d4ac1b3..8c51d11 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -133,6 +133,11 @@ package body Bindusg is Write_Line (" -F Force checking of elaboration Flags"); + -- Line for -G switch + + Write_Line + (" -G Generate binder file suitable for CCG"); + -- Line for -h switch Write_Line diff --git a/gcc/ada/butil.adb b/gcc/ada/butil.adb index d0cb41c..9427ddd 100644 --- a/gcc/ada/butil.adb +++ b/gcc/ada/butil.adb @@ -23,10 +23,38 @@ -- -- ------------------------------------------------------------------------------ +with Opt; use Opt; with Output; use Output; +with Unchecked_Deallocation; + +with GNAT; use GNAT; + +with System.OS_Lib; use System.OS_Lib; package body Butil is + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator); + -- Parse the name of the next available unit accessible through iterator + -- Iter and save it in the iterator. + + function Read_Forced_Elab_Order_File return String_Ptr; + -- Read the contents of the forced-elaboration-order file supplied to the + -- binder via switch -f and return them as a string. Return null if the + -- file is not available. + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Forced_Units_Iterator) return Boolean is + begin + return Present (Iter.Unit_Name); + end Has_Next; + ---------------------- -- Is_Internal_Unit -- ---------------------- @@ -71,6 +99,499 @@ package body Butil is or else (L > 4 and then B (1 .. 5) = "gnat."); end Is_Predefined_Unit; + -------------------------- + -- Iterate_Forced_Units -- + -------------------------- + + function Iterate_Forced_Units return Forced_Units_Iterator is + Iter : Forced_Units_Iterator; + + begin + Iter.Order := Read_Forced_Elab_Order_File; + Parse_Next_Unit_Name (Iter); + + return Iter; + end Iterate_Forced_Units; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Forced_Units_Iterator; + Unit_Name : out Unit_Name_Type; + Unit_Line : out Logical_Line_Number) + is + begin + if not Has_Next (Iter) then + raise Iterator_Exhausted; + end if; + + Unit_Line := Iter.Unit_Line; + Unit_Name := Iter.Unit_Name; + pragma Assert (Present (Unit_Name)); + + Parse_Next_Unit_Name (Iter); + end Next; + + -------------------------- + -- Parse_Next_Unit_Name -- + -------------------------- + + procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator) is + Body_Suffix : constant String := " (body)"; + Body_Type : constant String := "%b"; + Body_Length : constant Positive := Body_Suffix'Length; + Body_Offset : constant Natural := Body_Length - 1; + + Comment_Header : constant String := "--"; + Comment_Offset : constant Natural := Comment_Header'Length - 1; + + Spec_Suffix : constant String := " (spec)"; + Spec_Type : constant String := "%s"; + Spec_Length : constant Positive := Spec_Suffix'Length; + Spec_Offset : constant Natural := Spec_Length - 1; + + Index : Positive renames Iter.Order_Index; + Line : Logical_Line_Number renames Iter.Order_Line; + Order : String_Ptr renames Iter.Order; + + function At_Comment return Boolean; + pragma Inline (At_Comment); + -- Determine whether iterator Iter is positioned over the start of a + -- comment. + + function At_Terminator return Boolean; + pragma Inline (At_Terminator); + -- Determine whether iterator Iter is positioned over a line terminator + -- character. + + function At_Whitespace return Boolean; + pragma Inline (At_Whitespace); + -- Determine whether iterator Iter is positioned over a whitespace + -- character. + + function Is_Terminator (C : Character) return Boolean; + pragma Inline (Is_Terminator); + -- Determine whether character C denotes a line terminator + + function Is_Whitespace (C : Character) return Boolean; + pragma Inline (Is_Whitespace); + -- Determine whether character C denotes a whitespace + + procedure Parse_Unit_Name; + pragma Inline (Parse_Unit_Name); + -- Find and parse the first available unit name + + procedure Skip_Comment; + pragma Inline (Skip_Comment); + -- Skip a comment by reaching a line terminator + + procedure Skip_Terminator; + pragma Inline (Skip_Terminator); + -- Skip a line terminator and deal with the logical line numbering + + procedure Skip_Whitespace; + pragma Inline (Skip_Whitespace); + -- Skip whitespace + + function Within_Order + (Low_Offset : Natural := 0; + High_Offset : Natural := 0) return Boolean; + pragma Inline (Within_Order); + -- Determine whether index of iterator Iter is still within the range of + -- the order string. Low_Offset may be used to inspect the area that is + -- less than the index. High_Offset may be used to inspect the area that + -- is greater than the index. + + ---------------- + -- At_Comment -- + ---------------- + + function At_Comment return Boolean is + begin + -- The interator is over a comment when the index is positioned over + -- the start of a comment header. + -- + -- unit (spec) -- comment + -- ^ + -- Index + + return + Within_Order (High_Offset => Comment_Offset) + and then Order (Index .. Index + Comment_Offset) = Comment_Header; + end At_Comment; + + ------------------- + -- At_Terminator -- + ------------------- + + function At_Terminator return Boolean is + begin + return Within_Order and then Is_Terminator (Order (Index)); + end At_Terminator; + + ------------------- + -- At_Whitespace -- + ------------------- + + function At_Whitespace return Boolean is + begin + return Within_Order and then Is_Whitespace (Order (Index)); + end At_Whitespace; + + ------------------- + -- Is_Terminator -- + ------------------- + + function Is_Terminator (C : Character) return Boolean is + begin + -- Carriage return is treated intentionally as whitespace since it + -- appears only on certain targets, while line feed is consistent on + -- all of them. + + return C = ASCII.LF; + end Is_Terminator; + + ------------------- + -- Is_Whitespace -- + ------------------- + + function Is_Whitespace (C : Character) return Boolean is + begin + return + C = ' ' + or else C = ASCII.CR -- carriage return + or else C = ASCII.FF -- form feed + or else C = ASCII.HT -- horizontal tab + or else C = ASCII.VT; -- vertical tab + end Is_Whitespace; + + --------------------- + -- Parse_Unit_Name -- + --------------------- + + procedure Parse_Unit_Name is + pragma Assert (not At_Comment); + pragma Assert (not At_Terminator); + pragma Assert (not At_Whitespace); + pragma Assert (Within_Order); + + procedure Find_End_Index_Of_Unit_Name; + pragma Inline (Find_End_Index_Of_Unit_Name); + -- Position the index of iterator Iter at the last character of the + -- first available unit name. + + --------------------------------- + -- Find_End_Index_Of_Unit_Name -- + --------------------------------- + + procedure Find_End_Index_Of_Unit_Name is + begin + -- At this point the index points at the start of a unit name. The + -- unit name may be legal, in which case it appears as: + -- + -- unit (body) + -- + -- However, it may also be illegal: + -- + -- unit without suffix + -- unit with multiple prefixes (spec) + -- + -- In order to handle both forms, find the construct following the + -- unit name. This is either a comment, a terminator, or the end + -- of the order: + -- + -- unit (body) -- comment + -- unit without suffix <terminator> + -- unit with multiple prefixes (spec)<end of order> + -- + -- Once the construct is found, truncate the unit name by skipping + -- all white space between the construct and the end of the unit + -- name. + + -- Find the construct that follows the unit name + + while Within_Order loop + if At_Comment then + exit; + + elsif At_Terminator then + exit; + end if; + + Index := Index + 1; + end loop; + + -- Position the index prior to the construct that follows the unit + -- name. + + Index := Index - 1; + + -- Truncate towards the end of the unit name + + while Within_Order loop + if At_Whitespace then + Index := Index - 1; + else + exit; + end if; + end loop; + end Find_End_Index_Of_Unit_Name; + + -- Local variables + + Start_Index : constant Positive := Index; + + End_Index : Positive; + Is_Body : Boolean := False; + Is_Spec : Boolean := False; + + -- Start of processing for Parse_Unit_Name + + begin + Find_End_Index_Of_Unit_Name; + End_Index := Index; + + pragma Assert (Start_Index <= End_Index); + + -- At this point the indices are positioned as follows: + -- + -- End_Index + -- Index + -- v + -- unit (spec) -- comment + -- ^ + -- Start_Index + + -- Rewind the index, skipping over the legal suffixes + -- + -- Index End_Index + -- v v + -- unit (spec) -- comment + -- ^ + -- Start_Index + + if Within_Order (Low_Offset => Body_Offset) + and then Order (Index - Body_Offset .. Index) = Body_Suffix + then + Is_Body := True; + Index := Index - Body_Length; + + elsif Within_Order (Low_Offset => Spec_Offset) + and then Order (Index - Spec_Offset .. Index) = Spec_Suffix + then + Is_Spec := True; + Index := Index - Spec_Length; + end if; + + -- Capture the line where the unit name is defined + + Iter.Unit_Line := Line; + + -- Transform the unit name to match the format recognized by the + -- name table. + + if Is_Body then + Iter.Unit_Name := + Name_Find (Order (Start_Index .. Index) & Body_Type); + + elsif Is_Spec then + Iter.Unit_Name := + Name_Find (Order (Start_Index .. Index) & Spec_Type); + + -- Otherwise the unit name is illegal, so leave it as is + + else + Iter.Unit_Name := Name_Find (Order (Start_Index .. Index)); + end if; + + -- Advance the index past the unit name + -- + -- End_IndexIndex + -- vv + -- unit (spec) -- comment + -- ^ + -- Start_Index + + Index := End_Index + 1; + end Parse_Unit_Name; + + ------------------ + -- Skip_Comment -- + ------------------ + + procedure Skip_Comment is + begin + pragma Assert (At_Comment); + + while Within_Order loop + if At_Terminator then + exit; + end if; + + Index := Index + 1; + end loop; + end Skip_Comment; + + --------------------- + -- Skip_Terminator -- + --------------------- + + procedure Skip_Terminator is + begin + pragma Assert (At_Terminator); + + Index := Index + 1; + Line := Line + 1; + end Skip_Terminator; + + --------------------- + -- Skip_Whitespace -- + --------------------- + + procedure Skip_Whitespace is + begin + while Within_Order loop + if At_Whitespace then + Index := Index + 1; + else + exit; + end if; + end loop; + end Skip_Whitespace; + + ------------------ + -- Within_Order -- + ------------------ + + function Within_Order + (Low_Offset : Natural := 0; + High_Offset : Natural := 0) return Boolean + is + begin + return + Order /= null + and then Index - Low_Offset >= Order'First + and then Index + High_Offset <= Order'Last; + end Within_Order; + + -- Start of processing for Parse_Next_Unit_Name + + begin + -- A line in the forced-elaboration-order file has the following + -- grammar: + -- + -- LINE ::= + -- [WHITESPACE] UNIT_NAME [WHITESPACE] [COMMENT] TERMINATOR + -- + -- WHITESPACE ::= + -- <any whitespace character> + -- | <carriage return> + -- + -- UNIT_NAME ::= + -- UNIT_PREFIX [WHITESPACE] UNIT_SUFFIX + -- + -- UNIT_PREFIX ::= + -- <any string> + -- + -- UNIT_SUFFIX ::= + -- (body) + -- | (spec) + -- + -- COMMENT ::= + -- -- <any string> + -- + -- TERMINATOR ::= + -- <line feed> + -- <end of file> + -- + -- Items in <> brackets are semantic notions + + -- Assume that the order has no remaining units + + Iter.Unit_Line := No_Line_Number; + Iter.Unit_Name := No_Unit_Name; + + -- Try to find the first available unit name from the current position + -- of iteration. + + while Within_Order loop + Skip_Whitespace; + + if At_Comment then + Skip_Comment; + + elsif not Within_Order then + exit; + + elsif At_Terminator then + Skip_Terminator; + + else + Parse_Unit_Name; + exit; + end if; + end loop; + end Parse_Next_Unit_Name; + + --------------------------------- + -- Read_Forced_Elab_Order_File -- + --------------------------------- + + function Read_Forced_Elab_Order_File return String_Ptr is + procedure Free is new Unchecked_Deallocation (String, String_Ptr); + + Descr : File_Descriptor; + Len : Natural; + Len_Read : Natural; + Result : String_Ptr; + Success : Boolean; + + begin + if Force_Elab_Order_File = null then + return null; + end if; + + -- Obtain and sanitize a descriptor to the elaboration-order file + + Descr := Open_Read (Force_Elab_Order_File.all, Binary); + + if Descr = Invalid_FD then + return null; + end if; + + -- Determine the size of the file, allocate a result large enough to + -- house its contents, and read it. + + Len := Natural (File_Length (Descr)); + + if Len = 0 then + return null; + end if; + + Result := new String (1 .. Len); + Len_Read := Read (Descr, Result (1)'Address, Len); + + -- The read failed to acquire the whole content of the file + + if Len_Read /= Len then + Free (Result); + return null; + end if; + + Close (Descr, Success); + + -- The file failed to close + + if not Success then + Free (Result); + return null; + end if; + + return Result; + end Read_Forced_Elab_Order_File; + ---------------- -- Uname_Less -- ---------------- diff --git a/gcc/ada/butil.ads b/gcc/ada/butil.ads index 80eb2a5..3ce2f1e 100644 --- a/gcc/ada/butil.ads +++ b/gcc/ada/butil.ads @@ -23,12 +23,13 @@ -- -- ------------------------------------------------------------------------------ +-- This package contains utility routines for the binder + with Namet; use Namet; +with Types; use Types; package Butil is --- This package contains utility routines for the binder - function Is_Predefined_Unit return Boolean; -- Given a unit name stored in Name_Buffer with length in Name_Len, -- returns True if this is the name of a predefined unit or a child of @@ -51,4 +52,52 @@ package Butil is -- Output unit name with (body) or (spec) after as required. On return -- Name_Len is set to the number of characters which were output. + --------------- + -- Iterators -- + --------------- + + -- The following type represents an iterator over all units that are + -- specified in the forced-elaboration-order file supplied by the binder + -- via switch -f. + + type Forced_Units_Iterator is private; + + function Has_Next (Iter : Forced_Units_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more units to examine + + function Iterate_Forced_Units return Forced_Units_Iterator; + pragma Inline (Iterate_Forced_Units); + -- Obtain an iterator over all units in the forced-elaboration-order file + + procedure Next + (Iter : in out Forced_Units_Iterator; + Unit_Name : out Unit_Name_Type; + Unit_Line : out Logical_Line_Number); + pragma Inline (Next); + -- Return the current unit referenced by iterator Iter along with the + -- line number it appears on, and advance to the next available unit. + +private + First_Line_Number : constant Logical_Line_Number := No_Line_Number + 1; + + type Forced_Units_Iterator is record + Order : String_Ptr := null; + -- A reference to the contents of the forced-elaboration-order file, + -- read in as a string. + + Order_Index : Positive := 1; + -- Index into the order string + + Order_Line : Logical_Line_Number := First_Line_Number; + -- Logical line number within the order string + + Unit_Line : Logical_Line_Number := No_Line_Number; + -- The logical line number of the current unit name within the order + -- string. + + Unit_Name : Unit_Name_Type := No_Unit_Name; + -- The current unit name parsed from the order string + end record; + end Butil; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index fcfaec7..33fb27e 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7429,6 +7429,19 @@ package body Checks is return; end if; + -- Entities declared in Lock_free protected types must be treated as + -- volatile, and we must inhibit validity checks to prevent improper + -- constant folding. + + if Is_Entity_Name (Expr) + and then Is_Subprogram (Scope (Entity (Expr))) + and then Present (Protected_Subprogram (Scope (Entity (Expr)))) + and then Uses_Lock_Free + (Scope (Protected_Subprogram (Scope (Entity (Expr))))) + then + return; + end if; + -- If we have a checked conversion, then validity check applies to -- the expression inside the conversion, not the result, since if -- the expression inside is valid, then so is the conversion result. diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index e43174c..d76d93d 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -177,8 +177,8 @@ package body Debug is -- d_C -- d_D -- d_E - -- d_F - -- d_G + -- d_F Encode full invocation paths in ALI files + -- d_G Encode invocation graph in ALI files -- d_H -- d_I -- d_J @@ -191,7 +191,7 @@ package body Debug is -- d_Q -- d_R -- d_S - -- d_T + -- d_T Output trace information on invocation path recording -- d_U -- d_V -- d_W @@ -258,6 +258,160 @@ package body Debug is -- dy -- dz + -- dA + -- dB + -- dC + -- dD + -- dE + -- dF + -- dG + -- dH + -- dI + -- dJ + -- dK + -- dL + -- dM + -- dN + -- dO + -- dP + -- dQ + -- dR + -- dS + -- dT + -- dU + -- dV + -- dW + -- dX + -- dY + -- dZ + + -- d.a + -- d.b + -- d.c + -- d.d + -- d.e + -- d.f + -- d.g + -- d.h + -- d.i + -- d.j + -- d.k + -- d.l + -- d.m + -- d.n + -- d.o + -- d.p + -- d.q + -- d.r + -- d.s + -- d.t + -- d.u + -- d.v + -- d.w + -- d.x + -- d.y + -- d.z + + -- d.A + -- d.B + -- d.C + -- d.D + -- d.E + -- d.F + -- d.G + -- d.H + -- d.I + -- d.J + -- d.K + -- d.L + -- d.M + -- d.N + -- d.O + -- d.P + -- d.Q + -- d.R + -- d.S + -- d.T + -- d.U + -- d.V + -- d.W + -- d.X + -- d.Y + -- d.Z + + -- d.1 + -- d.2 + -- d.3 + -- d.4 + -- d.5 + -- d.6 + -- d.7 + -- d.8 + -- d.9 + + -- d_a + -- d_b + -- d_c + -- d_d + -- d_e + -- d_f + -- d_g + -- d_h + -- d_i + -- d_j + -- d_k + -- d_l + -- d_m + -- d_n + -- d_o + -- d_p + -- d_q + -- d_r + -- d_s + -- d_t + -- d_u + -- d_v + -- d_w + -- d_x + -- d_y + -- d_z + + -- d_A Output ALI invocation tables + -- d_B + -- d_C + -- d_D + -- d_F + -- d_G + -- d_H + -- d_I Output invocation graph + -- d_J + -- d_K + -- d_L Output library graph + -- d_M + -- d_N New bindo order + -- d_O Output elaboration order + -- d_P + -- d_Q + -- d_R + -- d_S + -- d_T Output elaboration order trace information + -- d_U + -- d_V Validate bindo graphs and order + -- d_W + -- d_X + -- d_Y + -- d_Z + + -- d_1 + -- d_2 + -- d_3 + -- d_4 + -- d_5 + -- d_6 + -- d_7 + -- d_8 + -- d_9 + -- Debug flags used in package Make and its clients (e.g. GNATMAKE) -- da @@ -850,11 +1004,21 @@ package body Debug is -- d_A Do not generate ALI files by setting Opt.Disable_ALI_File. + -- d_F The compiler encodes the full path from an invocation construct to + -- an external target, offering additional information to GNATBIND for + -- purposes of error diagnostics. + + -- d_G The compiler encodes the invocation graph of a unit in its ALI + -- file. + -- d_L Output trace information on elaboration checking. This debug switch -- causes output to be generated showing each call or instantiation as -- it is checked, and the progress of the recursive trace through -- elaboration calls at compile time. + -- d_T The compiler outputs trance information to standard output whenever + -- an invocation path is recorded. + -- d1 Error messages have node numbers where possible. Normally error -- messages have only source locations. This option is useful when -- debugging errors caused by expanded code, where the source location @@ -954,11 +1118,10 @@ package body Debug is -- dependencies) except that internal units are included in the -- listing. - -- di Normally gnatbind calls Read_Ali with Ignore_Errors set to - -- False, since the binder really needs correct version ALI - -- files to do its job. This debug flag causes Ignore_Errors - -- mode to be set for the binder (and is particularly useful - -- for testing ignore errors mode). + -- di Normally GNATBIND calls Read_Ali with Ignore_Errors set to False, + -- since the binder really needs correct version ALI files to do its + -- job. This debug flag causes Ignore_Errors mode to be set for the + -- binder (and is particularly useful for testing ignore errors mode). -- dn List details of manipulation of Num_Pred values during execution of -- the algorithm used to determine a correct order of elaboration. This @@ -985,6 +1148,25 @@ package body Debug is -- dx Force the binder to read (and then ignore) the xref information -- in ali files (used to check that read circuit is working OK). + -- d_A GNATBIND output the contents of all ALI invocation-related tables + -- in textual format to standard output. + -- + -- d_I GNATBIND outputs the contents of the invocation graph in textual + -- format to standard output. + -- + -- d_L GNATBIND outputs the contents of the library graph in textual + -- format to standard output. + -- + -- d_N GNATBIND utilizes the elaboration order provided by bindo + -- + -- d_O GNATBIND outputs the elaboration order of units to standard output + -- + -- d_T GNATBIND outputs trace information of elaboration order activities + -- to standard output. + -- + -- d_V GNATBIND validates the invocation graph, library graph, SCC graph + -- and elaboration order. + -------------------------------------------- -- Documentation for gnatmake Debug Flags -- -------------------------------------------- diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 6074cd4..955a137 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -3766,18 +3766,19 @@ Syntax: pragma Machine_Attribute ( [Entity =>] LOCAL_NAME, [Attribute_Name =>] static_string_EXPRESSION - [, [Info =>] static_EXPRESSION] ); + [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] ); Machine-dependent attributes can be specified for types and/or declarations. This pragma is semantically equivalent to :samp:`__attribute__(({attribute_name}))` (if ``info`` is not specified) or :samp:`__attribute__(({attribute_name(info})))` -in GNU C, where *attribute_name* is recognized by the -compiler middle-end or the ``TARGET_ATTRIBUTE_TABLE`` machine -specific macro. A string literal for the optional parameter ``info`` -is transformed into an identifier, which may make this pragma unusable -for some attributes. +or :samp:`__attribute__(({attribute_name(info,...})))` in GNU C, +where *attribute_name* is recognized by the compiler middle-end +or the ``TARGET_ATTRIBUTE_TABLE`` machine specific macro. Note +that a string literal for the optional parameter ``info`` or the +following ones is transformed by default into an identifier, +which may make this pragma unusable for some attributes. For further information see :title:`GNU Compiler Collection (GCC) Internals`. Pragma Main diff --git a/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst b/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst index bb629f4..ad0be51 100644 --- a/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst +++ b/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst @@ -46,8 +46,10 @@ and C types: * Ada enumeration types map to C enumeration types directly if pragma - ``Convention C`` is specified, which causes them to have int - length. Without pragma ``Convention C``, Ada enumeration types map to + ``Convention C`` is specified, which causes them to have a length of + 32 bits, except for boolean types which map to C99 ``bool`` and for + which the length is 8 bits. + Without pragma ``Convention C``, Ada enumeration types map to 8, 16, or 32 bits (i.e., C types ``signed char``, ``short``, ``int``, respectively) depending on the number of values passed. This is the only case in which pragma ``Convention C`` affects the diff --git a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst index 5ad8e03..82dc97c 100644 --- a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst @@ -610,14 +610,23 @@ alignment of the type (this is true for all types). In some cases the end record; -On a typical 32-bit architecture, the X component will be four bytes, and -require four-byte alignment, and the Y component will be one byte. In this -case ``R'Value_Size`` will be 40 (bits) since this is the minimum size -required to store a value of this type, and for example, it is permissible -to have a component of type R in an outer array whose component size is -specified to be 48 bits. However, ``R'Object_Size`` will be 64 (bits), -since it must be rounded up so that this value is a multiple of the -alignment (4 bytes = 32 bits). +On a typical 32-bit architecture, the X component will occupy four bytes +and the Y component will occupy one byte, for a total of 5 bytes. As a +result ``R'Value_Size`` will be 40 (bits) since this is the minimum size +required to store a value of this type. For example, it is permissible +to have a component of type R in an array whose component size is +specified to be 40 bits. + +However, ``R'Object_Size`` will be 64 (bits). The difference is due to +the alignment requirement for objects of the record type. The X +component will require four-byte alignment because that is what type +Integer requires, whereas the Y component, a Character, will only +require 1-byte alignment. Since the alignment required for X is the +greatest of all the components' alignments, that is the alignment +required for the enclosing record type, i.e., 4 bytes or 32 bits. As +indicated above, the actual object size must be rounded up so that it is +a multiple of the alignment value. Therefore, 40 bits rounded up to the +next multiple of 32 yields 64 bits. For all other types, the ``Object_Size`` and ``Value_Size`` are the same (and equivalent to the RM attribute ``Size``). diff --git a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst index 0b9f6dc..7b599be 100644 --- a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst +++ b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst @@ -510,15 +510,14 @@ No_Multiple_Elaboration ----------------------- .. index:: No_Multiple_Elaboration -[GNAT] When this restriction is active, we are not requesting control-flow -preservation with -fpreserve-control-flow, and the static elaboration model is -used, the compiler is allowed to suppress the elaboration counter normally -associated with the unit, even if the unit has elaboration code. This counter -is typically used to check for access before elaboration and to control -multiple elaboration attempts. If the restriction is used, then the -situations in which multiple elaboration is possible, including non-Ada main -programs and Stand Alone libraries, are not permitted and will be diagnosed -by the binder. +[GNAT] When this restriction is active and the static elaboration model is +used, and -fpreserve-control-flow is not used, the compiler is allowed to +suppress the elaboration counter normally associated with the unit, even if +the unit has elaboration code. This counter is typically used to check for +access before elaboration and to control multiple elaboration attempts. If the +restriction is used, then the situations in which multiple elaboration is +possible, including non-Ada main programs and Stand Alone libraries, are not +permitted and will be diagnosed by the binder. No_Nested_Finalization ---------------------- 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 b5363da..57c3fe1 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 @@ -4045,8 +4045,8 @@ of the pragma in the :title:`GNAT_Reference_manual`). :switch:`-gnatw.z` *Activate warnings for size not a multiple of alignment.* - This switch activates warnings for cases of record types with - specified ``Size`` and ``Alignment`` attributes where the + This switch activates warnings for cases of array and record types + with specified ``Size`` and ``Alignment`` attributes where the size is not a multiple of the alignment, resulting in an object size that is greater than the specified size. The default is that such warnings are generated. @@ -4058,12 +4058,11 @@ of the pragma in the :title:`GNAT_Reference_manual`). :switch:`-gnatw.Z` *Suppress warnings for size not a multiple of alignment.* - This switch suppresses warnings for cases of record types with - specified ``Size`` and ``Alignment`` attributes where the + This switch suppresses warnings for cases of array and record types + with specified ``Size`` and ``Alignment`` attributes where the size is not a multiple of the alignment, resulting in an object - size that is greater than the specified size. - The warning can also be - suppressed by giving an explicit ``Object_Size`` value. + size that is greater than the specified size. The warning can also + be suppressed by giving an explicit ``Object_Size`` value. .. index:: -Wunused (gcc) @@ -4691,6 +4690,16 @@ checks to be performed. The following checks are defined: allowed). +.. index:: -gnatyD (gcc) + +:switch:`-gnatyD` + *Check declared identifiers in mixed case.* + + Declared identifiers must be in mixed case, as in + This_Is_An_Identifier. Use -gnatyr in addition to ensure + that references match declarations. + + .. index:: -gnatye (gcc) :switch:`-gnatye` @@ -5889,8 +5898,8 @@ Debugging Control compiler sources. If the switch is followed by an ``s`` (e.g., :switch:`-gnatR3s`), then - the output is to a file with the name :file:`file.rep` where file is - the name of the corresponding source file, except if `j`` is also + the output is to a file with the name :file:`file.rep` where ``file`` is + the name of the corresponding source file, except if ``j`` is also specified, in which case the file name is :file:`file.json`. Note that it is possible for record components to have zero size. In diff --git a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst index a4b8b7f..336555c 100644 --- a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst @@ -1056,17 +1056,17 @@ available. If the compilation was performed using a post-18.x version of GNAT, consider using the legacy elaboration model, in the following order: + - Use the relaxed static elaboration model, with compiler switch + :switch:`-gnatJ`. + + - Use the relaxed dynamic elaboration model, with compiler switches + :switch:`-gnatE` :switch:`-gnatJ`. + - Use the legacy static elaboration model, with compiler switch :switch:`-gnatH`. - Use the legacy dynamic elaboration model, with compiler switches - :switch:`-gnatH` :switch:`-gnatE`. - - - Use the relaxed legacy static elaboration model, with compiler switches - :switch:`-gnatH` :switch:`-gnatJ`. - - - Use the relaxed legacy dynamic elaboration model, with compiler switches - :switch:`-gnatH` :switch:`-gnatJ` :switch:`-gnatE`. + :switch:`-gnatE` :switch:`-gnatH`. * *Suppress all elaboration checks* diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst index 17ce45a..53904b1 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst @@ -3181,20 +3181,47 @@ Alternatively, you may run the script using the following command line: Do not place the keyword ``is`` on a separate line in a subprogram body in case if the spec occupies more than one line. + .. index:: --separate-loop (gnatpp) + + + :switch:`--separate-loop` + Place the keyword ``loop`` in FOR and WHILE loop statements + on a separate line. + + .. index:: --no-separate-then (gnatpp) + + + :switch:`--separate-then` + Place the keyword ``then`` in IF statements + on a separate line. + + .. index:: --no-separate-loop (gnatpp) + + + :switch:`--no-separate-loop` + Do not place the keyword ``loop`` in FOR and WHILE loop statements + on a separate line. This option is + incompatible with the :switch:`--separate-loop` option. + + .. index:: --no-separate-then (gnatpp) + + + :switch:`--no-separate-then` + Do not place the keyword ``then`` in IF statements + on a separate line. This option is + incompatible with the :switch:`--separate-then` option. + .. index:: --separate-loop-then (gnatpp) :switch:`--separate-loop-then` - Place the keyword ``loop`` in FOR and WHILE loop statements and the - keyword ``then`` in IF statements on a separate line. + Equivalent to :switch:`--separate-loop` :switch:`--separate-then`. .. index:: --no-separate-loop-then (gnatpp) :switch:`--no-separate-loop-then` - Do not place the keyword ``loop`` in FOR and WHILE loop statements and the - keyword ``then`` in IF statements on a separate line. This option is - incompatible with the :switch:`--separate-loop-then` option. + Equivalent to :switch:`--no-separate-loop` :switch:`--no-separate-then`. .. index:: --use-on-new-line (gnatpp) @@ -3458,6 +3485,8 @@ Alternatively, you may run the script using the following command line: * *unix* - UNIX style, lines end with LF character* * *lf* - the same as *unix* + The default is to use the same end-of-line convention as the input. + .. index:: --wide-character-encoding (gnatpp) :switch:`--wide-character-encoding={e}` diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 13f381d..b9a9a8d 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -8141,7 +8141,7 @@ package body Einfo is function Is_External_State (Id : E) return B is begin -- To qualify, the abstract state must appear with option "external" or - -- "synchronous" (SPARK RM 7.1.4(8) and (10)). + -- "synchronous" (SPARK RM 7.1.4(7) and (9)). return Ekind (Id) = E_Abstract_State @@ -8319,7 +8319,7 @@ package body Einfo is function Is_Synchronized_State (Id : E) return B is begin -- To qualify, the abstract state must appear with simple option - -- "synchronous" (SPARK RM 7.1.4(10)). + -- "synchronous" (SPARK RM 7.1.4(9)). return Ekind (Id) = E_Abstract_State diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 70d374b..9dc6cc2 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3779,7 +3779,7 @@ package Einfo is -- Optimize_Alignment_Space (Flag241) -- Defined in type, subtype, variable, and constant entities. This --- flag records that the type or object is to be layed out in a manner +-- flag records that the type or object is to be laid out in a manner -- consistent with Optimize_Alignment (Space) mode. The compiler and -- binder ensure a consistent view of any given type or object. If pragma -- Optimize_Alignment (Off) mode applies to the type/object, then neither @@ -3787,7 +3787,7 @@ package Einfo is -- Optimize_Alignment_Time (Flag242) -- Defined in type, subtype, variable, and constant entities. This --- flag records that the type or object is to be layed out in a manner +-- flag records that the type or object is to be laid out in a manner -- consistent with Optimize_Alignment (Time) mode. The compiler and -- binder ensure a consistent view of any given type or object. If pragma -- Optimize_Alignment (Off) mode applies to the type/object, then neither diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 57a169b..0c8ef5d 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -56,6 +56,12 @@ package body Erroutc is -- wild card chars (*). The entire pattern must match the entire string. -- Case is ignored in the comparison (so X matches x). + function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean; + -- Return whether Loc is in the range Start .. Stop, taking instantiation + -- locations of Loc into account. This is useful for suppressing warnings + -- from generic instantiations by using pragma Warnings around generic + -- instances, as needed in GNATprove. + --------------- -- Add_Class -- --------------- @@ -1588,6 +1594,24 @@ package body Erroutc is end if; end Set_Warnings_Mode_On; + ------------------- + -- Sloc_In_Range -- + ------------------- + + function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean is + Cur_Loc : Source_Ptr := Loc; + + begin + while Cur_Loc /= No_Location loop + if Start <= Cur_Loc and then Cur_Loc <= Stop then + return True; + end if; + Cur_Loc := Instantiation_Location (Cur_Loc); + end loop; + + return False; + end Sloc_In_Range; + -------------------------------- -- Validate_Specific_Warnings -- -------------------------------- @@ -1652,7 +1676,7 @@ package body Erroutc is -- location is in range of a specific non-configuration pragma. if SWE.Config - or else (SWE.Start <= Loc and then Loc <= SWE.Stop) + or else Sloc_In_Range (Loc, SWE.Start, SWE.Stop) then if Matches (Msg.all, SWE.Msg.all) or else Matches (Tag, SWE.Msg.all) @@ -1691,8 +1715,8 @@ package body Erroutc is -- Loop through table of ON/OFF warnings for J in Warnings.First .. Warnings.Last loop - if Warnings.Table (J).Start <= Loc - and then Loc <= Warnings.Table (J).Stop + if Sloc_In_Range (Loc, Warnings.Table (J).Start, + Warnings.Table (J).Stop) then return Warnings.Table (J).Reason; end if; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 22368a1..1e1b2f9 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -639,7 +639,7 @@ package body Exp_Attr is Stmts := No_List; - -- Validate componants + -- Validate components Validate_Component_List (Obj_Id => Obj_Id, @@ -1693,103 +1693,6 @@ package body Exp_Attr is -- generate conditionals in the code, so check the relevant restriction. Check_Restriction (No_Implicit_Conditionals, N); - - -- In Modify_Tree_For_C mode, we rewrite as an if expression - - if Modify_Tree_For_C then - declare - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (N); - Expr : constant Node_Id := First (Expressions (N)); - Left : constant Node_Id := Relocate_Node (Expr); - Right : constant Node_Id := Relocate_Node (Next (Expr)); - - function Make_Compare (Left, Right : Node_Id) return Node_Id; - -- Returns Left >= Right for Max, Left <= Right for Min - - ------------------ - -- Make_Compare -- - ------------------ - - function Make_Compare (Left, Right : Node_Id) return Node_Id is - begin - if Attribute_Name (N) = Name_Max then - return - Make_Op_Ge (Loc, - Left_Opnd => Left, - Right_Opnd => Right); - else - return - Make_Op_Le (Loc, - Left_Opnd => Left, - Right_Opnd => Right); - end if; - end Make_Compare; - - -- Start of processing for Min_Max - - begin - -- If both Left and Right are side effect free, then we can just - -- use Duplicate_Expr to duplicate the references and return - - -- (if Left >=|<= Right then Left else Right) - - if Side_Effect_Free (Left) and then Side_Effect_Free (Right) then - Rewrite (N, - Make_If_Expression (Loc, - Expressions => New_List ( - Make_Compare (Left, Right), - Duplicate_Subexpr_No_Checks (Left), - Duplicate_Subexpr_No_Checks (Right)))); - - -- Otherwise we generate declarations to capture the values. - - -- The translation is - - -- do - -- T1 : constant typ := Left; - -- T2 : constant typ := Right; - -- in - -- (if T1 >=|<= T2 then T1 else T2) - -- end; - - else - declare - T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left); - T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Right); - - begin - Rewrite (N, - Make_Expression_With_Actions (Loc, - Actions => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => T1, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Etype (Left), Loc), - Expression => Relocate_Node (Left)), - - Make_Object_Declaration (Loc, - Defining_Identifier => T2, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Etype (Right), Loc), - Expression => Relocate_Node (Right))), - - Expression => - Make_If_Expression (Loc, - Expressions => New_List ( - Make_Compare - (New_Occurrence_Of (T1, Loc), - New_Occurrence_Of (T2, Loc)), - New_Occurrence_Of (T1, Loc), - New_Occurrence_Of (T2, Loc))))); - end; - end if; - - Analyze_And_Resolve (N, Typ); - end; - end if; end Expand_Min_Max_Attribute; ---------------------------------- @@ -4242,6 +4145,11 @@ package body Exp_Attr is when Attribute_Invalid_Value => Rewrite (N, Get_Simple_Init_Val (Ptyp, N)); + -- The value produced may be a conversion of a literal, which must be + -- resolved to establish its proper type. + + Analyze_And_Resolve (N); + ---------- -- Last -- ---------- diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 96742e5..4209785 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -379,10 +379,6 @@ package body Exp_Ch7 is -- references within these nested subprograms (typically generated -- subprograms to handle finalization actions). - function Contains_Subprogram (Blk : Entity_Id) return Boolean; - -- Check recursively whether a loop or block contains a subprogram that - -- may need an activation record. - procedure Check_Visibly_Controlled (Prim : Final_Primitives; Typ : Entity_Id; @@ -400,6 +396,10 @@ package body Exp_Ch7 is -- and use it instead. This is one case that might be solved more cleanly -- once Overriding pragmas or declarations are in place. + function Contains_Subprogram (Blk : Entity_Id) return Boolean; + -- Check recursively whether a loop or block contains a subprogram that + -- may need an activation record. + function Convert_View (Proc : Entity_Id; Arg : Node_Id; @@ -5187,6 +5187,7 @@ 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)); end Expand_N_Package_Declaration; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 5ec9fb4..0f83d57 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8258,18 +8258,17 @@ package body Exp_Ch9 is Proc : Entity_Id; begin - -- Try to use System.Relative_Delays.Delay_For only if available. This - -- is the implementation used on restricted platforms when Ada.Calendar - -- is not available. + -- Try to use Ada.Calendar.Delays.Delay_For if available. - if RTE_Available (RO_RD_Delay_For) then - Proc := RTE (RO_RD_Delay_For); + if RTE_Available (RO_CA_Delay_For) then + Proc := RTE (RO_CA_Delay_For); - -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error - -- message if not available. + -- Otherwise, use System.Relative_Delays.Delay_For and emit an error + -- message if not available. This is the implementation used on + -- restricted platforms when Ada.Calendar is not available. else - Proc := RTE (RO_CA_Delay_For); + Proc := RTE (RO_RD_Delay_For); end if; Rewrite (N, @@ -8951,6 +8950,10 @@ package body Exp_Ch9 is Set_Is_Inlined (Protected_Body_Subprogram (Subp)); Set_Is_Inlined (Subp, False); end if; + + if Has_Pragma_No_Inline (Subp) then + Set_Has_Pragma_No_Inline (Protected_Body_Subprogram (Subp)); + end if; end Check_Inlining; --------------------------- diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 3d533ba..b81b1b9 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -254,8 +254,7 @@ package body Exp_Unst is Typ := Full_View (Typ); end if; - return Is_Array_Type (Typ) - and then not Is_Constrained (Typ); + return Is_Array_Type (Typ) and then not Is_Constrained (Typ); else return False; end if; @@ -464,7 +463,10 @@ package body Exp_Unst is Callee : Entity_Id; procedure Check_Static_Type - (T : Entity_Id; N : Node_Id; DT : in out Boolean); + (T : Entity_Id; + N : Node_Id; + DT : in out Boolean; + Check_Designated : Boolean := False); -- Given a type T, checks if it is a static type defined as a type -- with no dynamic bounds in sight. If so, the only action is to -- set Is_Static_Type True for T. If T is not a static type, then @@ -474,6 +476,9 @@ package body Exp_Unst is -- node that will need to be replaced. If not specified, it means -- we can't do a replacement because the bound is implicit. + -- If Check_Designated is True and T or its full view is an access + -- type, check whether the designated type has dynamic bounds. + procedure Note_Uplevel_Ref (E : Entity_Id; N : Node_Id; @@ -492,7 +497,10 @@ package body Exp_Unst is ----------------------- procedure Check_Static_Type - (T : Entity_Id; N : Node_Id; DT : in out Boolean) + (T : Entity_Id; + N : Node_Id; + DT : in out Boolean; + Check_Designated : Boolean := False) is procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id); -- N is the bound of a dynamic type. This procedure notes that @@ -602,7 +610,7 @@ package body Exp_Unst is begin -- If already marked static, immediate return - if Is_Static_Type (T) then + if Is_Static_Type (T) and then not Check_Designated then return; end if; @@ -685,13 +693,20 @@ package body Exp_Unst is -- For private type, examine whether full view is static - elsif Is_Private_Type (T) and then Present (Full_View (T)) then - Check_Static_Type (Full_View (T), N, DT); + elsif Is_Incomplete_Or_Private_Type (T) + and then Present (Full_View (T)) + then + Check_Static_Type (Full_View (T), N, DT, Check_Designated); if Is_Static_Type (Full_View (T)) then Set_Is_Static_Type (T); end if; + -- For access types, check designated type when required + + elsif Is_Access_Type (T) and then Check_Designated then + Check_Static_Type (Directly_Designated_Type (T), N, DT); + -- For now, ignore other types else @@ -936,7 +951,11 @@ package body Exp_Unst is declare DT : Boolean := False; begin - Check_Static_Type (Etype (Expression (N)), Empty, DT); + Check_Static_Type + (Etype (Expression (N)), + Empty, + DT, + Check_Designated => Nkind (N) = N_Free_Statement); end; end if; @@ -2188,8 +2207,7 @@ package body Exp_Unst is and then Present (Constant_Value (UPJ.Ent)) and then Is_Static_Expression (Constant_Value (UPJ.Ent)) then - Rewrite (UPJ.Ref, - New_Copy_Tree (Constant_Value (UPJ.Ent))); + Rewrite (UPJ.Ref, New_Copy_Tree (Constant_Value (UPJ.Ent))); goto Continue; end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b127f03..4206090 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4940,18 +4940,6 @@ package body Exp_Util is end if; end Evolve_Or_Else; - ------------------- - -- Exceptions_OK -- - ------------------- - - function Exceptions_OK return Boolean is - begin - return - not (Restriction_Active (No_Exception_Handlers) or else - Restriction_Active (No_Exception_Propagation) or else - Restriction_Active (No_Exceptions)); - end Exceptions_OK; - ----------------------------------------- -- Expand_Static_Predicates_In_Choices -- ----------------------------------------- @@ -8258,8 +8246,8 @@ package body Exp_Util is return False; end if; - -- Here we have a tagged type, see if it has any unlayed out fields - -- other than a possible tag and parent fields. If so, we return False. + -- Here we have a tagged type, see if it has any component (other than + -- tag and parent) with no component_clause. If so, we return False. Comp := First_Component (U); while Present (Comp) loop @@ -8273,7 +8261,7 @@ package body Exp_Util is end if; end loop; - -- All components are layed out + -- All components have clauses return True; end Is_Fully_Repped_Tagged_Type; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index aac4433..7cb9d2d 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -559,10 +559,6 @@ package Exp_Util is -- indicating that no checks were required). The Sloc field of the -- constructed N_Or_Else node is copied from Cond1. - function Exceptions_OK return Boolean; - -- Determine whether exceptions are allowed to be caught, propagated, or - -- raised. - procedure Expand_Static_Predicates_In_Choices (N : Node_Id); -- N is either a case alternative or a variant. The Discrete_Choices field -- of N points to a list of choices. If any of these choices is the name diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8e55fb8..5b843f2 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -5943,17 +5943,29 @@ package body Freeze is Inherit_Aspects_At_Freeze_Point (E); end if; - -- Check for incompatible size and alignment for record type + -- Case of array type + + if Is_Array_Type (E) then + Freeze_Array_Type (E); + end if; + + -- Check for incompatible size and alignment for array/record type if Warn_On_Size_Alignment - and then Is_Record_Type (E) - and then Has_Size_Clause (E) and then Has_Alignment_Clause (E) + and then (Is_Array_Type (E) or else Is_Record_Type (E)) + and then Has_Size_Clause (E) + and then Has_Alignment_Clause (E) -- If explicit Object_Size clause given assume that the programmer -- knows what he is doing, and expects the compiler behavior. and then not Has_Object_Size_Clause (E) + -- It does not really make sense to warn for the minimum alignment + -- since the programmer could not get rid of the warning. + + and then Alignment (E) > 1 + -- Check for size not a multiple of alignment and then RM_Size (E) mod (Alignment (E) * System_Storage_Unit) /= 0 @@ -5994,15 +6006,10 @@ package body Freeze is end; end if; - -- Array type - - if Is_Array_Type (E) then - Freeze_Array_Type (E); - -- For a class-wide type, the corresponding specific type is -- frozen as well (RM 13.14(15)) - elsif Is_Class_Wide_Type (E) then + if Is_Class_Wide_Type (E) then Freeze_And_Append (Root_Type (E), N, Result); -- If the base type of the class-wide type is still incomplete, @@ -7665,9 +7672,8 @@ package body Freeze is or else Ekind (Current_Scope) = E_Void then declare - N : constant Node_Id := Current_Scope; - Freeze_Nodes : List_Id := No_List; - Pos : Int := Scope_Stack.Last; + Freeze_Nodes : List_Id := No_List; + Pos : Int := Scope_Stack.Last; begin if Present (Desig_Typ) then @@ -7700,7 +7706,19 @@ package body Freeze is end if; if Is_Non_Empty_List (Freeze_Nodes) then - if No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then + + -- When the current scope is transient, insert the freeze nodes + -- prior to the expression that produced them. Transient scopes + -- may create additional declarations when finalizing objects + -- or managing the secondary stack. Inserting the freeze nodes + -- of those constructs prior to the scope would result in a + -- freeze-before-declaration, therefore the freeze node must + -- remain interleaved with their constructs. + + if Scope_Is_Transient then + Insert_Actions (N, Freeze_Nodes); + + elsif No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then Scope_Stack.Table (Pos).Pending_Freeze_Actions := Freeze_Nodes; else diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index de23b14..dd90c7b 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -317,10 +317,11 @@ GNAT_ADA_OBJS = \ ada/frontend.o \ ada/libgnat/g-byorma.o \ ada/libgnat/g-dynhta.o \ + ada/libgnat/g-graphs.o \ ada/libgnat/g-hesora.o \ ada/libgnat/g-htable.o \ - ada/libgnat/g-lists.o \ - ada/libgnat/g-sets.o \ + ada/libgnat/g-lists.o \ + ada/libgnat/g-sets.o \ ada/libgnat/g-spchge.o \ ada/libgnat/g-speche.o \ ada/libgnat/g-u3spch.o \ @@ -507,6 +508,15 @@ GNATBIND_OBJS = \ ada/binde.o \ ada/binderr.o \ ada/bindgen.o \ + ada/bindo.o \ + ada/bindo-augmentors.o \ + ada/bindo-builders.o \ + ada/bindo-diagnostics.o \ + ada/bindo-elaborators.o \ + ada/bindo-graphs.o \ + ada/bindo-units.o \ + ada/bindo-validators.o \ + ada/bindo-writers.o \ ada/bindusg.o \ ada/butil.o \ ada/casing.o \ @@ -526,8 +536,12 @@ GNATBIND_OBJS = \ ada/fname-uf.o \ ada/fname.o \ ada/libgnat/g-byorma.o \ + ada/libgnat/g-dynhta.o \ + ada/libgnat/g-graphs.o \ ada/libgnat/g-hesora.o \ ada/libgnat/g-htable.o \ + ada/libgnat/g-lists.o \ + ada/libgnat/g-sets.o \ ada/libgnat/gnat.o \ ada/gnatbind.o \ ada/gnatvsn.o \ diff --git a/gcc/ada/gcc-interface/ada-builtin-types.def b/gcc/ada/gcc-interface/ada-builtin-types.def new file mode 100644 index 0000000..f00845b --- /dev/null +++ b/gcc/ada/gcc-interface/ada-builtin-types.def @@ -0,0 +1,25 @@ +/* This file contains the type definitions for the builtins exclusively + used in the GNU Ada compiler. + + Copyright (C) 2019 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +/* See builtin-types.def for details. */ + +DEF_FUNCTION_TYPE_1 (BT_FN_BOOL_BOOL, BT_BOOL, BT_BOOL) +DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_BOOL_BOOL, BT_BOOL, BT_BOOL, BT_BOOL) diff --git a/gcc/ada/gcc-interface/ada-builtins.def b/gcc/ada/gcc-interface/ada-builtins.def new file mode 100644 index 0000000..dcdc4d9 --- /dev/null +++ b/gcc/ada/gcc-interface/ada-builtins.def @@ -0,0 +1,30 @@ +/* This file contains the definitions for the builtins exclusively used + in the GNU Ada compiler. + + Copyright (C) 2019 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +/* Before including this file, you should define a macro: + + DEF_ADA_BUILTIN (ENUM, NAME, TYPE, ATTRS) + + See builtins.def for details. */ + +DEF_ADA_BUILTIN (BUILT_IN_EXPECT, "expect", BT_FN_BOOL_BOOL_BOOL, ATTR_CONST_NOTHROW_LEAF_LIST) +DEF_ADA_BUILTIN (BUILT_IN_LIKELY, "likely", BT_FN_BOOL_BOOL, ATTR_CONST_NOTHROW_LEAF_LIST) +DEF_ADA_BUILTIN (BUILT_IN_UNLIKELY, "unlikely", BT_FN_BOOL_BOOL, ATTR_CONST_NOTHROW_LEAF_LIST) diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index ea2c945..2029b7c 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2018, Free Software Foundation, Inc. * + * Copyright (C) 1992-2019, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -582,3 +582,8 @@ do { \ #define EXIT_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 0) #define EXIT_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 1) + +/* Small kludge to be able to define Ada built-in functions locally. + We overload them on top of the HSAIL/BRIG builtin functions. */ +#define BUILT_IN_LIKELY BUILT_IN_HSAIL_WORKITEMABSID +#define BUILT_IN_UNLIKELY BUILT_IN_HSAIL_GRIDSIZE diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index ed015ba..81f621b 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -308,7 +308,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) tree gnu_size = NULL_TREE; /* Contains the GCC name to be used for the GCC node. */ tree gnu_entity_name; - /* True if we have already saved gnu_decl as a GNAT association. */ + /* True if we have already saved gnu_decl as a GNAT association. This can + also be used to purposely avoid making such an association but this use + case ought not to be applied to types because it can break the deferral + mechanism implemented for access types. */ bool saved = false; /* True if we incremented defer_incomplete_level. */ bool this_deferred = false; @@ -325,14 +328,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Since a use of an Itype is a definition, process it as such if it is in the main unit, except for E_Access_Subtype because it's actually a use - of its base type, and for E_Record_Subtype with cloned subtype because - it's actually a use of the cloned subtype, see below. */ + of its base type, see below. */ if (!definition && is_type && Is_Itype (gnat_entity) - && !(kind == E_Access_Subtype - || (kind == E_Record_Subtype - && Present (Cloned_Subtype (gnat_entity)))) + && Ekind (gnat_entity) != E_Access_Subtype && !present_gnu_tree (gnat_entity) && In_Extended_Main_Code_Unit (gnat_entity)) { @@ -375,7 +375,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } /* This abort means the Itype has an incorrect scope, i.e. that its - scope does not correspond to the subprogram it is declared in. */ + scope does not correspond to the subprogram it is first used in. */ gcc_unreachable (); } @@ -384,7 +384,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) In that case, we will abort below when we try to save a new GCC tree for this object. We also need to handle the case of getting a dummy type when a Full_View exists but be careful so as not to trigger its - premature elaboration. */ + premature elaboration. Likewise for a cloned subtype without its own + freeze node, which typically happens when a generic gets instantiated + on an incomplete or private type. */ if ((!definition || (is_type && imported_p)) && present_gnu_tree (gnat_entity)) { @@ -398,7 +400,23 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) || No (Freeze_Node (Full_View (gnat_entity))))) { gnu_decl - = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, false); + = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, + false); + save_gnu_tree (gnat_entity, NULL_TREE, false); + save_gnu_tree (gnat_entity, gnu_decl, false); + } + + if (TREE_CODE (gnu_decl) == TYPE_DECL + && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)) + && Ekind (gnat_entity) == E_Record_Subtype + && No (Freeze_Node (gnat_entity)) + && Present (Cloned_Subtype (gnat_entity)) + && (present_gnu_tree (Cloned_Subtype (gnat_entity)) + || No (Freeze_Node (Cloned_Subtype (gnat_entity))))) + { + gnu_decl + = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), NULL_TREE, + false); save_gnu_tree (gnat_entity, NULL_TREE, false); save_gnu_tree (gnat_entity, gnu_decl, false); } @@ -1855,7 +1873,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = Has_Biased_Representation (gnat_entity); /* Do the same processing for Character subtypes as for types. */ - if (TYPE_STRING_FLAG (TREE_TYPE (gnu_type))) + if (TREE_CODE (TREE_TYPE (gnu_type)) == INTEGER_TYPE + && TYPE_STRING_FLAG (TREE_TYPE (gnu_type))) { TYPE_NAME (gnu_type) = gnu_entity_name; TYPE_STRING_FLAG (gnu_type) = 1; @@ -3003,9 +3022,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) { SET_TYPE_ALIGN (gnu_type, 0); - /* If a type needs strict alignment, the minimum size will be the - type size instead of the RM size (see validate_size). Cap the - alignment lest it causes this type size to become too large. */ + /* If a type needs strict alignment, then its type size will also + be the RM size (see below). Cap the alignment if needed, lest + it may cause this type size to become too large. */ if (Strict_Alignment (gnat_entity) && Known_RM_Size (gnat_entity)) { unsigned int max_size = UI_To_Int (RM_Size (gnat_entity)); @@ -3282,6 +3301,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) compute_record_mode (gnu_type); } + /* If the type needs strict alignment, then no object of the type + may have a size smaller than the natural size, which means that + the RM size of the type is equal to the type size. */ + if (Strict_Alignment (gnat_entity)) + SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type)); + /* If there are entities in the chain corresponding to components that we did not elaborate, ensure we elaborate their types if they are Itypes. */ @@ -3331,14 +3356,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) case E_Record_Subtype: /* If Cloned_Subtype is Present it means this record subtype has identical layout to that type or subtype and we should use - that GCC type for this one. The front end guarantees that + that GCC type for this one. The front-end guarantees that the component list is shared. */ if (Present (Cloned_Subtype (gnat_entity))) { gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), NULL_TREE, false); gnat_annotate_type = Cloned_Subtype (gnat_entity); - saved = true; + maybe_present = true; break; } @@ -3373,7 +3398,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) Unchecked_Union (it must be an Itype), just return the type. */ if (Has_Discriminants (gnat_entity) && Stored_Constraint (gnat_entity) != No_Elist - && !Is_For_Access_Subtype (gnat_entity) && Is_Record_Type (gnat_base_type) && !Is_Unchecked_Union (gnat_base_type)) { @@ -3752,8 +3776,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) case E_Access_Subtype: /* We treat this as identical to its base type; any constraint is meaningful only to the front-end. */ - gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, false); - saved = true; + gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false); + maybe_present = true; /* The designated subtype must be elaborated as well, if it does not have its own freeze node. But designated subtypes created @@ -4187,7 +4211,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) already defined so we cannot pass true for IN_PLACE here. */ process_attributes (&gnu_type, &attr_list, false, gnat_entity); - /* ??? Don't set the size for a String_Literal since it is either + /* See if a size was specified, by means of either an Object_Size or + a regular Size clause, and validate it if so. + + ??? Don't set the size for a String_Literal since it is either confirming or we don't handle it properly (if the low bound is non-constant). */ if (!gnu_size && kind != E_String_Literal_Subtype) @@ -4309,49 +4336,44 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If we are just annotating types and the type is tagged, the tag and the parent components are not generated by the front-end so - alignment and sizes must be adjusted if there is no rep clause. */ - if (type_annotate_only - && Is_Tagged_Type (gnat_entity) - && Unknown_RM_Size (gnat_entity) - && !VOID_TYPE_P (gnu_type) - && (!TYPE_FIELDS (gnu_type) - || integer_zerop (bit_position (TYPE_FIELDS (gnu_type))))) + alignment and sizes must be adjusted. */ + if (type_annotate_only && Is_Tagged_Type (gnat_entity)) { - tree offset; - - if (Is_Derived_Type (gnat_entity)) - { - Entity_Id gnat_parent = Etype (Base_Type (gnat_entity)); - offset = UI_To_gnu (Esize (gnat_parent), bitsizetype); - Set_Alignment (gnat_entity, Alignment (gnat_parent)); - } - else + const bool derived_p = Is_Derived_Type (gnat_entity); + const Entity_Id gnat_parent + = derived_p ? Etype (Base_Type (gnat_entity)) : Empty; + const unsigned int inherited_align + = derived_p + ? UI_To_Int (Alignment (gnat_parent)) * BITS_PER_UNIT + : POINTER_SIZE; + const unsigned int align + = MAX (TYPE_ALIGN (gnu_type), inherited_align); + + Set_Alignment (gnat_entity, UI_From_Int (align / BITS_PER_UNIT)); + + /* If there is neither size clause nor representation clause, the + sizes need to be adjusted. */ + if (Unknown_RM_Size (gnat_entity) + && !VOID_TYPE_P (gnu_type) + && (!TYPE_FIELDS (gnu_type) + || integer_zerop (bit_position (TYPE_FIELDS (gnu_type))))) { - unsigned int align - = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT; - offset = bitsize_int (POINTER_SIZE); - Set_Alignment (gnat_entity, UI_From_Int (align)); + tree offset + = derived_p + ? UI_To_gnu (Esize (gnat_parent), bitsizetype) + : bitsize_int (POINTER_SIZE); + if (TYPE_FIELDS (gnu_type)) + offset + = round_up (offset, DECL_ALIGN (TYPE_FIELDS (gnu_type))); + gnu_size = size_binop (PLUS_EXPR, gnu_size, offset); } - if (TYPE_FIELDS (gnu_type)) - offset - = round_up (offset, DECL_ALIGN (TYPE_FIELDS (gnu_type))); - - gnu_size = size_binop (PLUS_EXPR, gnu_size, offset); - gnu_size = round_up (gnu_size, POINTER_SIZE); - Uint uint_size = annotate_value (gnu_size); - Set_RM_Size (gnat_entity, uint_size); - Set_Esize (gnat_entity, uint_size); - } - - /* If there is a rep clause, only adjust alignment and Esize. */ - else if (type_annotate_only && Is_Tagged_Type (gnat_entity)) - { - unsigned int align - = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT; - Set_Alignment (gnat_entity, UI_From_Int (align)); - gnu_size = round_up (gnu_size, POINTER_SIZE); + gnu_size = round_up (gnu_size, align); Set_Esize (gnat_entity, annotate_value (gnu_size)); + + /* Tagged types are Strict_Alignment so RM_Size = Esize. */ + if (Unknown_RM_Size (gnat_entity)) + Set_RM_Size (gnat_entity, Esize (gnat_entity)); } /* Otherwise no adjustment is needed. */ @@ -4481,6 +4503,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } } + /* Now check if the type allows atomic access. */ if (Is_Atomic_Or_VFA (gnat_entity)) check_ok_for_atomic_type (gnu_type, gnat_entity, false); @@ -4978,6 +5001,10 @@ Gigi_Equivalent_Type (Entity_Id gnat_entity) gnat_equiv = Equivalent_Type (gnat_entity); break; + case E_Access_Subtype: + gnat_equiv = Etype (gnat_entity); + break; + case E_Class_Wide_Type: gnat_equiv = Root_Type (gnat_entity); break; @@ -5100,6 +5127,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, } } + /* Now check if the type of the component allows atomic access. */ if (Has_Atomic_Components (gnat_array) || Is_Atomic_Or_VFA (gnat_type)) check_ok_for_atomic_type (gnu_type, gnat_array, true); @@ -6148,7 +6176,8 @@ static void set_nonaliased_component_on_array_type (tree type) { TYPE_NONALIASED_COMPONENT (type) = 1; - TYPE_NONALIASED_COMPONENT (TYPE_CANONICAL (type)) = 1; + if (TYPE_CANONICAL (type)) + TYPE_NONALIASED_COMPONENT (TYPE_CANONICAL (type)) = 1; } /* Set TYPE_REVERSE_STORAGE_ORDER on an array type built by means of @@ -6158,7 +6187,8 @@ static void set_reverse_storage_order_on_array_type (tree type) { TYPE_REVERSE_STORAGE_ORDER (type) = 1; - TYPE_REVERSE_STORAGE_ORDER (TYPE_CANONICAL (type)) = 1; + if (TYPE_CANONICAL (type)) + TYPE_REVERSE_STORAGE_ORDER (TYPE_CANONICAL (type)) = 1; } /* Return true if DISCR1 and DISCR2 represent the same discriminant. */ @@ -6459,25 +6489,18 @@ prepend_one_attribute (struct attrib **attr_list, static void prepend_one_attribute_pragma (struct attrib **attr_list, Node_Id gnat_pragma) { - const Node_Id gnat_arg = Pragma_Argument_Associations (gnat_pragma); - tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE; + const Node_Id gnat_arg = First (Pragma_Argument_Associations (gnat_pragma)); + Node_Id gnat_next_arg = Next (gnat_arg); + tree gnu_arg1 = NULL_TREE, gnu_arg_list = NULL_TREE; enum attrib_type etype; /* Map the pragma at hand. Skip if this isn't one we know how to handle. */ switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_pragma)))) { - case Pragma_Machine_Attribute: - etype = ATTR_MACHINE_ATTRIBUTE; - break; - case Pragma_Linker_Alias: etype = ATTR_LINK_ALIAS; break; - case Pragma_Linker_Section: - etype = ATTR_LINK_SECTION; - break; - case Pragma_Linker_Constructor: etype = ATTR_LINK_CONSTRUCTOR; break; @@ -6486,58 +6509,58 @@ prepend_one_attribute_pragma (struct attrib **attr_list, Node_Id gnat_pragma) etype = ATTR_LINK_DESTRUCTOR; break; - case Pragma_Weak_External: - etype = ATTR_WEAK_EXTERNAL; + case Pragma_Linker_Section: + etype = ATTR_LINK_SECTION; + break; + + case Pragma_Machine_Attribute: + etype = ATTR_MACHINE_ATTRIBUTE; break; case Pragma_Thread_Local_Storage: etype = ATTR_THREAD_LOCAL_STORAGE; break; + case Pragma_Weak_External: + etype = ATTR_WEAK_EXTERNAL; + break; + default: return; } /* See what arguments we have and turn them into GCC trees for attribute - handlers. These expect identifier for strings. We handle at most two - arguments and static expressions only. */ - if (Present (gnat_arg) && Present (First (gnat_arg))) + handlers. The first one is always expected to be a string meant to be + turned into an identifier. The next ones are all static expressions, + among which strings meant to be turned into an identifier, except for + a couple of specific attributes that require raw strings. */ + if (Present (gnat_next_arg)) { - Node_Id gnat_arg0 = Next (First (gnat_arg)); - Node_Id gnat_arg1 = Empty; - - if (Present (gnat_arg0) - && Is_OK_Static_Expression (Expression (gnat_arg0))) + gnu_arg1 = gnat_to_gnu (Expression (gnat_next_arg)); + gcc_assert (TREE_CODE (gnu_arg1) == STRING_CST); + + const char *const p = TREE_STRING_POINTER (gnu_arg1); + const bool string_args + = strcmp (p, "target") == 0 || strcmp (p, "target_clones") == 0; + gnu_arg1 = get_identifier (p); + if (IDENTIFIER_LENGTH (gnu_arg1) == 0) + return; + gnat_next_arg = Next (gnat_next_arg); + + while (Present (gnat_next_arg)) { - gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0)); - - if (TREE_CODE (gnu_arg0) == STRING_CST) - { - gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0)); - if (IDENTIFIER_LENGTH (gnu_arg0) == 0) - return; - } - - gnat_arg1 = Next (gnat_arg0); - } - - if (Present (gnat_arg1) - && Is_OK_Static_Expression (Expression (gnat_arg1))) - { - gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1)); - - if (TREE_CODE (gnu_arg1) == STRING_CST) - gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1)); + tree gnu_arg = gnat_to_gnu (Expression (gnat_next_arg)); + if (TREE_CODE (gnu_arg) == STRING_CST && !string_args) + gnu_arg = get_identifier (TREE_STRING_POINTER (gnu_arg)); + gnu_arg_list + = chainon (gnu_arg_list, build_tree_list (NULL_TREE, gnu_arg)); + gnat_next_arg = Next (gnat_next_arg); } } - /* Prepend to the list. Make a list of the argument we might have, as GCC - expects it. */ - prepend_one_attribute (attr_list, etype, gnu_arg0, - gnu_arg1 - ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE, - Present (Next (First (gnat_arg))) - ? Expression (Next (First (gnat_arg))) : gnat_pragma); + prepend_one_attribute (attr_list, etype, gnu_arg1, gnu_arg_list, + Present (Next (gnat_arg)) + ? Expression (Next (gnat_arg)) : gnat_pragma); } /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */ @@ -6908,6 +6931,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, boundaries, but that should be guaranteed by the GCC memory model. */ const bool needs_strict_alignment = (is_atomic || is_aliased || is_independent || is_strict_alignment); + bool is_bitfield; tree gnu_field_type = gnat_to_gnu_type (gnat_field_type); tree gnu_field_id = get_entity_name (gnat_field); tree gnu_field, gnu_size, gnu_pos; @@ -6922,7 +6946,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, /* If a size is specified, use it. Otherwise, if the record type is packed, use the official RM size. See "Handling of Type'Size Values" in Einfo for further details. */ - if (Known_Esize (gnat_field) || Present (gnat_clause)) + if (Present (gnat_clause) || Known_Esize (gnat_field)) gnu_size = validate_size (Esize (gnat_field), gnu_field_type, gnat_field, FIELD_DECL, false, true); else if (packed == 1) @@ -6934,12 +6958,36 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, else gnu_size = NULL_TREE; - /* If we have a specified size that is smaller than that of the field's type, - or a position is specified, and the field's type is a record that doesn't - require strict alignment, see if we can get either an integral mode form - of the type or a smaller form. If we can, show a size was specified for - the field if there wasn't one already, so we know to make this a bitfield - and avoid making things wider. + /* Likewise for the position. */ + if (Present (gnat_clause)) + { + gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype); + is_bitfield = !value_factor_p (gnu_pos, BITS_PER_UNIT); + } + + /* If the record has rep clauses and this is the tag field, make a rep + clause for it as well. */ + else if (Has_Specified_Layout (gnat_record_type) + && Chars (gnat_field) == Name_uTag) + { + gnu_pos = bitsize_zero_node; + gnu_size = TYPE_SIZE (gnu_field_type); + is_bitfield = false; + } + + else + { + gnu_pos = NULL_TREE; + is_bitfield = false; + } + + /* If the field's type is a fixed-size record that does not require strict + alignment, and the record is packed or we have a position specified for + the field that makes it a bitfield or we have a specified size that is + smaller than that of the field's type, then see if we can get either an + integral mode form of the field's type or a smaller form. If we can, + consider that a size was specified for the field if there wasn't one + already, so we know to make it a bitfield and avoid making things wider. Changing to an integral mode form is useful when the record is packed as we can then place the field at a non-byte-aligned position and so achieve @@ -6961,14 +7009,12 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, && !TYPE_FAT_POINTER_P (gnu_field_type) && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type)) && (packed == 1 + || is_bitfield || (gnu_size - && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type)) - || (Present (gnat_clause) - && !(UI_To_Int (Component_Bit_Offset (gnat_field)) - % BITS_PER_UNIT == 0 - && value_factor_p (gnu_size, BITS_PER_UNIT))))))) + && tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))))) { - tree gnu_packable_type = make_packable_type (gnu_field_type, true); + tree gnu_packable_type + = make_packable_type (gnu_field_type, true, is_bitfield ? 1 : 0); if (gnu_packable_type != gnu_field_type) { gnu_field_type = gnu_packable_type; @@ -6977,6 +7023,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, } } + /* Now check if the type of the field allows atomic access. */ if (Is_Atomic_Or_VFA (gnat_field)) { const unsigned int align @@ -6988,12 +7035,11 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, check_ok_for_atomic_type (gnu_field_type, gnat_field, false); } - if (Present (gnat_clause)) + /* If a position is specified, check that it is valid. */ + if (gnu_pos) { Entity_Id gnat_parent = Parent_Subtype (gnat_record_type); - gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype); - /* Ensure the position does not overlap with the parent subtype, if there is one. This test is omitted if the parent of the tagged type has a full rep clause since, in this case, component clauses are allowed to @@ -7006,7 +7052,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent))) post_error_ne_tree - ("offset of& must be beyond parent{, minimum allowed is ^}", + ("position for& must be beyond parent{, minimum allowed is ^}", Position (gnat_clause), gnat_field, TYPE_SIZE_UNIT (gnu_parent)); } @@ -7020,98 +7066,90 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, && !(type_annotate_only && Is_Tagged_Type (gnat_field_type))) { const unsigned int type_align = TYPE_ALIGN (gnu_field_type); + const char *field_s; if (TYPE_ALIGN (gnu_record_type) && TYPE_ALIGN (gnu_record_type) < type_align) SET_TYPE_ALIGN (gnu_record_type, type_align); - /* If the position is not a multiple of the alignment of the type, - then error out and reset the position. */ + if (is_atomic) + field_s = "atomic &"; + else if (is_aliased) + field_s = "aliased &"; + else if (is_independent) + field_s = "independent &"; + else if (is_strict_alignment) + field_s = "& with aliased or tagged part"; + else + gcc_unreachable (); + + /* If the position is not a multiple of the storage unit, then error + out and reset the position. */ if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos, - bitsize_int (type_align)))) + bitsize_unit_node))) { - const char *s; - - if (is_atomic) - s = "position of atomic field& must be multiple of ^ bits"; - else if (is_aliased) - s = "position of aliased field& must be multiple of ^ bits"; - else if (is_independent) - s = "position of independent field& must be multiple of ^ bits"; - else if (is_strict_alignment) - s = "position of & with aliased or tagged part must be" - " multiple of ^ bits"; - else - gcc_unreachable (); + char s[128]; + snprintf (s, sizeof (s), "position for %s must be " + "multiple of Storage_Unit", field_s); + post_error_ne (s, First_Bit (gnat_clause), gnat_field); + gnu_pos = NULL_TREE; + } + /* If the position is not a multiple of the alignment of the type, + then error out and reset the position. */ + else if (type_align > BITS_PER_UNIT + && !integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos, + bitsize_int (type_align)))) + { + char s[128]; + snprintf (s, sizeof (s), "position for %s must be multiple of ^", + field_s); post_error_ne_num (s, First_Bit (gnat_clause), gnat_field, - type_align); + type_align / BITS_PER_UNIT); + post_error_ne_num ("\\because alignment of its type& is ^", + First_Bit (gnat_clause), Etype (gnat_field), + type_align / BITS_PER_UNIT); gnu_pos = NULL_TREE; } if (gnu_size) { - tree gnu_type_size = TYPE_SIZE (gnu_field_type); - const int cmp = tree_int_cst_compare (gnu_size, gnu_type_size); + tree type_size = TYPE_SIZE (gnu_field_type); + int cmp; - /* If the size is lower than that of the type, or greater for - atomic and aliased, then error out and reset the size. */ - if (cmp < 0 || (cmp > 0 && (is_atomic || is_aliased))) + /* If the size is not a multiple of the storage unit, then error + out and reset the size. */ + if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_size, + bitsize_unit_node))) { - const char *s; - - if (is_atomic) - s = "size of atomic field& must be ^ bits"; - else if (is_aliased) - s = "size of aliased field& must be ^ bits"; - else if (is_independent) - s = "size of independent field& must be at least ^ bits"; - else if (is_strict_alignment) - s = "size of & with aliased or tagged part must be" - " at least ^ bits"; - else - gcc_unreachable (); - - post_error_ne_tree (s, Last_Bit (gnat_clause), gnat_field, - gnu_type_size); + char s[128]; + snprintf (s, sizeof (s), "size for %s must be " + "multiple of Storage_Unit", field_s); + post_error_ne (s, Last_Bit (gnat_clause), gnat_field); gnu_size = NULL_TREE; } - /* Likewise if the size is not a multiple of a byte, */ - else if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_size, - bitsize_unit_node))) + /* If the size is lower than that of the type, or greater for + atomic and aliased, then error out and reset the size. */ + else if ((cmp = tree_int_cst_compare (gnu_size, type_size)) < 0 + || (cmp > 0 && (is_atomic || is_aliased))) { - const char *s; - - if (is_independent) - s = "size of independent field& must be multiple of" - " Storage_Unit"; - else if (is_strict_alignment) - s = "size of & with aliased or tagged part must be" - " multiple of Storage_Unit"; + char s[128]; + if (is_atomic || is_aliased) + snprintf (s, sizeof (s), "size for %s must be ^", field_s); else - gcc_unreachable (); - - post_error_ne (s, Last_Bit (gnat_clause), gnat_field); + snprintf (s, sizeof (s), "size for %s must be at least ^", + field_s); + post_error_ne_tree (s, Last_Bit (gnat_clause), gnat_field, + type_size); gnu_size = NULL_TREE; } } } } - /* If the record has rep clauses and this is the tag field, make a rep - clause for it as well. */ - else if (Has_Specified_Layout (gnat_record_type) - && Chars (gnat_field) == Name_uTag) - { - gnu_pos = bitsize_zero_node; - gnu_size = TYPE_SIZE (gnu_field_type); - } - else { - gnu_pos = NULL_TREE; - /* If we are packing the record and the field is BLKmode, round the size up to a byte boundary. */ if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size) @@ -8162,6 +8200,8 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type, gnu_field_list = gnu_rep_list; else { + TYPE_NAME (gnu_rep_type) + = create_concat_name (gnat_record_type, "REP"); TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type) = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type); finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info); @@ -8718,7 +8758,7 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object, enum tree_code kind, bool component_p, bool zero_ok) { Node_Id gnat_error_node; - tree type_size, size; + tree old_size, size; /* Return 0 if no size was specified. */ if (uint_size == No_Uint) @@ -8783,17 +8823,11 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object, && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size); - if (kind == VAR_DECL - /* If a type needs strict alignment, a component of this type in - a packed record cannot be packed and thus uses the type size. */ - || (kind == TYPE_DECL && Strict_Alignment (gnat_object))) - type_size = TYPE_SIZE (gnu_type); - else - type_size = rm_size (gnu_type); + old_size = (kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type)); - /* Modify the size of a discriminated type to be the maximum size. */ - if (type_size && CONTAINS_PLACEHOLDER_P (type_size)) - type_size = max_size (type_size, true); + /* If the old size is self-referential, get the maximum size. */ + if (CONTAINS_PLACEHOLDER_P (old_size)) + old_size = max_size (old_size, true); /* If this is an access type or a fat pointer, the minimum size is that given by the smallest integral mode that's valid for pointers. */ @@ -8802,23 +8836,23 @@ validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object, scalar_int_mode p_mode = NARROWEST_INT_MODE; while (!targetm.valid_pointer_mode (p_mode)) p_mode = GET_MODE_WIDER_MODE (p_mode).require (); - type_size = bitsize_int (GET_MODE_BITSIZE (p_mode)); + old_size = bitsize_int (GET_MODE_BITSIZE (p_mode)); } /* Issue an error either if the default size of the object isn't a constant or if the new size is smaller than it. */ - if (TREE_CODE (type_size) != INTEGER_CST - || TREE_OVERFLOW (type_size) - || tree_int_cst_lt (size, type_size)) + if (TREE_CODE (old_size) != INTEGER_CST + || TREE_OVERFLOW (old_size) + || tree_int_cst_lt (size, old_size)) { if (component_p) post_error_ne_tree ("component size for& too small{, minimum allowed is ^}", - gnat_error_node, gnat_object, type_size); + gnat_error_node, gnat_object, old_size); else post_error_ne_tree ("size for& too small{, minimum allowed is ^}", - gnat_error_node, gnat_object, type_size); + gnat_error_node, gnat_object, old_size); return NULL_TREE; } @@ -9174,9 +9208,9 @@ intrin_arglists_compatible_p (intrin_binding_t * inb) if (!ada_type && !btin_type) break; - /* If one list is shorter than the other, they fail to match. */ - if (!ada_type || !btin_type) - return false; + /* If the internal builtin uses a variable list, accept anything. */ + if (!btin_type) + break; /* If we're done with the Ada args and not with the internal builtin args, or the other way around, complain. */ @@ -9686,7 +9720,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, if (RECORD_OR_UNION_TYPE_P (gnu_field_type) && !TYPE_FAT_POINTER_P (gnu_field_type) && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type))) - gnu_field_type = make_packable_type (gnu_field_type, true); + gnu_field_type = make_packable_type (gnu_field_type, true, 0); } else diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 191a017..f7415c7 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -126,7 +126,7 @@ extern tree make_aligning_type (tree type, unsigned int align, tree size, MAX_ALIGN alignment if the value is non-zero. If so, return the new type; if not, return the original type. */ extern tree make_packable_type (tree type, bool in_record, - unsigned int max_align = 0); + unsigned int max_align); /* Given a type TYPE, return a new type whose size is appropriate for SIZE. If TYPE is the best type, return it. Otherwise, make a new type. We @@ -837,7 +837,7 @@ extern unsigned int known_alignment (tree exp); /* Return true if VALUE is a multiple of FACTOR. FACTOR must be a power of 2. */ -extern bool value_factor_p (tree value, HOST_WIDE_INT factor); +extern bool value_factor_p (tree value, unsigned HOST_WIDE_INT factor); /* Build an atomic load for the underlying atomic object in SRC. SYNC is true if the load requires synchronization. */ @@ -1138,7 +1138,9 @@ gnat_signed_type_for (tree type_node) static inline tree maybe_character_type (tree type) { - if (TYPE_STRING_FLAG (type) && !TYPE_UNSIGNED (type)) + if (TREE_CODE (type) == INTEGER_TYPE + && TYPE_STRING_FLAG (type) + && !TYPE_UNSIGNED (type)) type = gnat_unsigned_type_for (type); return type; @@ -1151,7 +1153,9 @@ maybe_character_value (tree expr) { tree type = TREE_TYPE (expr); - if (TYPE_STRING_FLAG (type) && !TYPE_UNSIGNED (type)) + if (TREE_CODE (type) == INTEGER_TYPE + && TYPE_STRING_FLAG (type) + && !TYPE_UNSIGNED (type)) { type = gnat_unsigned_type_for (type); expr = convert (type, expr); diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 155cb4b..32dd132 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -778,6 +778,7 @@ lvalue_required_for_attribute_p (Node_Id gnat_node) case Attr_Range_Length: case Attr_Length: case Attr_Object_Size: + case Attr_Size: case Attr_Value_Size: case Attr_Component_Size: case Attr_Descriptor_Size: @@ -797,7 +798,6 @@ lvalue_required_for_attribute_p (Node_Id gnat_node) case Attr_Unrestricted_Access: case Attr_Code_Address: case Attr_Pool_Address: - case Attr_Size: case Attr_Alignment: case Attr_Bit_Position: case Attr_Position: @@ -1021,6 +1021,42 @@ fold_constant_decl_in_expr (tree exp) gcc_unreachable (); } +/* Return true if TYPE and DEF_TYPE are compatible GNAT types for Gigi. */ + +static bool +Gigi_Types_Compatible (Entity_Id type, Entity_Id def_type) +{ + /* The trivial case. */ + if (type == def_type) + return true; + + /* A class-wide type is equivalent to a subtype of itself. */ + if (Is_Class_Wide_Type (type)) + return true; + + /* A packed array type is compatible with its implementation type. */ + if (Is_Packed (def_type) && type == Packed_Array_Impl_Type (def_type)) + return true; + + /* If both types are Itypes, one may be a copy of the other. */ + if (Is_Itype (def_type) && Is_Itype (type)) + return true; + + /* If the type is incomplete and comes from a limited context, then also + consider its non-limited view. */ + if (Is_Incomplete_Type (def_type) + && From_Limited_With (def_type) + && Present (Non_Limited_View (def_type))) + return Gigi_Types_Compatible (type, Non_Limited_View (def_type)); + + /* If the type is incomplete/private, then also consider its full view. */ + if (Is_Incomplete_Or_Private_Type (def_type) + && Present (Full_View (def_type))) + return Gigi_Types_Compatible (type, Full_View (def_type)); + + return false; +} + /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier, to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where we should place the result type. */ @@ -1028,55 +1064,31 @@ fold_constant_decl_in_expr (tree exp) static tree Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) { - Node_Id gnat_temp, gnat_temp_type; - tree gnu_result, gnu_result_type; - - /* Whether we should require an lvalue for GNAT_NODE. Needed in - specific circumstances only, so evaluated lazily. < 0 means - unknown, > 0 means known true, 0 means known false. */ - int require_lvalue = -1; - + /* The entity of GNAT_NODE and its type. */ + Node_Id gnat_entity = (Nkind (gnat_node) == N_Defining_Identifier + || Nkind (gnat_node) == N_Defining_Operator_Symbol) + ? gnat_node : Entity (gnat_node); + Node_Id gnat_entity_type = Etype (gnat_entity); /* If GNAT_NODE is a constant, whether we should use the initialization value instead of the constant entity, typically for scalars with an address clause when the parent doesn't require an lvalue. */ bool use_constant_initializer = false; + /* Whether we should require an lvalue for GNAT_NODE. Needed in + specific circumstances only, so evaluated lazily. < 0 means + unknown, > 0 means known true, 0 means known false. */ + int require_lvalue = -1; + Node_Id gnat_result_type; + tree gnu_result, gnu_result_type; /* If the Etype of this node is not the same as that of the Entity, then something went wrong, probably in generic instantiation. However, this does not apply to types. Since we sometime have strange Ekind's, just - do this test for objects. Moreover, if the Etype of the Entity is private - or incomplete coming from a limited context, the Etype of the N_Identifier - is allowed to be the full/non-limited view and we also consider a packed - array type to be the same as the original type. Similarly, a CW type is - equivalent to a subtype of itself. Finally, if the types are Itypes, one - may be a copy of the other, which is also legal. */ - gnat_temp = ((Nkind (gnat_node) == N_Defining_Identifier - || Nkind (gnat_node) == N_Defining_Operator_Symbol) - ? gnat_node : Entity (gnat_node)); - gnat_temp_type = Etype (gnat_temp); - - gcc_assert (Etype (gnat_node) == gnat_temp_type - || (Is_Packed (gnat_temp_type) - && (Etype (gnat_node) - == Packed_Array_Impl_Type (gnat_temp_type))) - || (Is_Class_Wide_Type (Etype (gnat_node))) - || (Is_Incomplete_Or_Private_Type (gnat_temp_type) - && Present (Full_View (gnat_temp_type)) - && ((Etype (gnat_node) == Full_View (gnat_temp_type)) - || (Is_Packed (Full_View (gnat_temp_type)) - && (Etype (gnat_node) - == Packed_Array_Impl_Type - (Full_View (gnat_temp_type)))))) - || (Is_Incomplete_Type (gnat_temp_type) - && From_Limited_With (gnat_temp_type) - && Present (Non_Limited_View (gnat_temp_type)) - && Etype (gnat_node) == Non_Limited_View (gnat_temp_type)) - || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type)) - || !(Ekind (gnat_temp) == E_Variable - || Ekind (gnat_temp) == E_Component - || Ekind (gnat_temp) == E_Constant - || Ekind (gnat_temp) == E_Loop_Parameter - || Is_Formal (gnat_temp))); + do this test for objects, except for discriminants because their type + may have been changed to a subtype by Exp_Ch3.Adjust_Discriminants. */ + gcc_assert (!Is_Object (gnat_entity) + || Ekind (gnat_entity) == E_Discriminant + || Etype (gnat_node) == gnat_entity_type + || Gigi_Types_Compatible (Etype (gnat_node), gnat_entity_type)); /* If this is a reference to a deferred constant whose partial view is an unconstrained private type, the proper type is on the full view of the @@ -1086,36 +1098,40 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) attribute Position, generated for dispatching code (see Make_DT in exp_disp,adb). In that case we need the type itself, not is parent, in particular if it is a derived type */ - if (Ekind (gnat_temp) == E_Constant - && Is_Private_Type (gnat_temp_type) - && (Has_Unknown_Discriminants (gnat_temp_type) - || (Present (Full_View (gnat_temp_type)) - && Has_Discriminants (Full_View (gnat_temp_type)))) - && Present (Full_View (gnat_temp))) + if (Ekind (gnat_entity) == E_Constant + && Is_Private_Type (gnat_entity_type) + && (Has_Unknown_Discriminants (gnat_entity_type) + || (Present (Full_View (gnat_entity_type)) + && Has_Discriminants (Full_View (gnat_entity_type)))) + && Present (Full_View (gnat_entity))) { - gnat_temp = Full_View (gnat_temp); - gnat_temp_type = Etype (gnat_temp); + gnat_entity = Full_View (gnat_entity); + gnat_result_type = Etype (gnat_entity); } else { - /* We want to use the Actual_Subtype if it has already been elaborated, - otherwise the Etype. Avoid using Actual_Subtype for packed arrays to - simplify things. */ - if ((Ekind (gnat_temp) == E_Constant - || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp)) - && !(Is_Array_Type (Etype (gnat_temp)) - && Present (Packed_Array_Impl_Type (Etype (gnat_temp)))) - && Present (Actual_Subtype (gnat_temp)) - && present_gnu_tree (Actual_Subtype (gnat_temp))) - gnat_temp_type = Actual_Subtype (gnat_temp); + /* We use the Actual_Subtype only if it has already been elaborated, + as we may be invoked precisely during its elaboration, otherwise + the Etype. Avoid using it for packed arrays to simplify things, + except in a return statement because we need the actual size and + the front-end does not make it explicit in this case. */ + if ((Ekind (gnat_entity) == E_Constant + || Ekind (gnat_entity) == E_Variable + || Is_Formal (gnat_entity)) + && !(Is_Array_Type (Etype (gnat_entity)) + && Present (Packed_Array_Impl_Type (Etype (gnat_entity))) + && Nkind (Parent (gnat_node)) != N_Simple_Return_Statement) + && Present (Actual_Subtype (gnat_entity)) + && present_gnu_tree (Actual_Subtype (gnat_entity))) + gnat_result_type = Actual_Subtype (gnat_entity); else - gnat_temp_type = Etype (gnat_node); + gnat_result_type = Etype (gnat_node); } /* Expand the type of this identifier first, in case it is an enumeral literal, which only get made when the type is expanded. There is no order-of-elaboration issue here. */ - gnu_result_type = get_unpadded_type (gnat_temp_type); + gnu_result_type = get_unpadded_type (gnat_result_type); /* If this is a non-imported elementary constant with an address clause, retrieve the value instead of a pointer to be dereferenced unless @@ -1125,10 +1141,10 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) statement alternative or a record discriminant. There is no possible volatile-ness short-circuit here since Volatile constants must be imported per C.6. */ - if (Ekind (gnat_temp) == E_Constant - && Is_Elementary_Type (gnat_temp_type) - && !Is_Imported (gnat_temp) - && Present (Address_Clause (gnat_temp))) + if (Ekind (gnat_entity) == E_Constant + && Is_Elementary_Type (gnat_result_type) + && !Is_Imported (gnat_entity) + && Present (Address_Clause (gnat_entity))) { require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true, false); @@ -1139,13 +1155,13 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) { /* If this is a deferred constant, the initializer is attached to the full view. */ - if (Present (Full_View (gnat_temp))) - gnat_temp = Full_View (gnat_temp); + if (Present (Full_View (gnat_entity))) + gnat_entity = Full_View (gnat_entity); - gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp))); + gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); } else - gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, false); + gnu_result = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false); /* Some objects (such as parameters passed by reference, globals of variable size, and renamed objects) actually represent the address @@ -1184,7 +1200,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) if ((TREE_CODE (gnu_result) == INDIRECT_REF || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF) - && No (Address_Clause (gnat_temp))) + && No (Address_Clause (gnat_entity))) TREE_THIS_NOTRAP (gnu_result) = 1; if (read_only) @@ -1218,9 +1234,9 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) /* But for a constant renaming we couldn't do that incrementally for its definition because of the need to return an lvalue so, if the present context doesn't itself require an lvalue, we try again here. */ - else if (Ekind (gnat_temp) == E_Constant - && Is_Elementary_Type (gnat_temp_type) - && Present (Renamed_Object (gnat_temp))) + else if (Ekind (gnat_entity) == E_Constant + && Is_Elementary_Type (gnat_result_type) + && Present (Renamed_Object (gnat_entity))) { if (require_lvalue < 0) require_lvalue @@ -1236,10 +1252,10 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) avoid problematic conversions to the nominal subtype. But remove any padding from the resulting type. */ if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_result)) - || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type) - || (Ekind (gnat_temp) == E_Constant - && Present (Full_View (gnat_temp)) - && Has_Discriminants (gnat_temp_type) + || Is_Constr_Subt_For_UN_Aliased (gnat_result_type) + || (Ekind (gnat_entity) == E_Constant + && Present (Full_View (gnat_entity)) + && Has_Discriminants (gnat_result_type) && TREE_CODE (gnu_result) == CONSTRUCTOR)) { gnu_result_type = TREE_TYPE (gnu_result); @@ -2024,12 +2040,13 @@ check_inlining_for_nested_subprog (tree fndecl) if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (parent_decl))) { - error_at (loc1, "subprogram %q+F not marked Inline_Always", fndecl); + error_at (loc1, "subprogram %q+F not marked %<Inline_Always%>", + fndecl); error_at (loc2, "parent subprogram cannot be inlined"); } else { - warning_at (loc1, OPT_Winline, "subprogram %q+F not marked Inline", + warning_at (loc1, OPT_Winline, "subprogram %q+F not marked %<Inline%>", fndecl); warning_at (loc2, OPT_Winline, "parent subprogram cannot be inlined"); } @@ -2300,21 +2317,24 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) case Attr_Object_Size: case Attr_Value_Size: case Attr_Max_Size_In_Storage_Elements: - gnu_expr = gnu_prefix; - - /* Remove NOPs and conversions between original and packable version - from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR - to see if a COMPONENT_REF was involved. */ - while (TREE_CODE (gnu_expr) == NOP_EXPR - || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR - && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE - && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) + /* Strip NOPs, conversions between original and packable versions, and + unpadding from GNU_PREFIX. Note that we cannot simply strip every + VIEW_CONVERT_EXPR because some of them may give the actual size, e.g. + for nominally unconstrained packed array. We use GNU_EXPR to see + if a COMPONENT_REF was involved. */ + while (CONVERT_EXPR_P (gnu_prefix) + || TREE_CODE (gnu_prefix) == NON_LVALUE_EXPR + || (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR + && TREE_CODE (TREE_TYPE (gnu_prefix)) == RECORD_TYPE + && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) == RECORD_TYPE - && TYPE_NAME (TREE_TYPE (gnu_expr)) - == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))) - gnu_expr = TREE_OPERAND (gnu_expr, 0); - - gnu_prefix = remove_conversions (gnu_prefix, true); + && TYPE_NAME (TREE_TYPE (gnu_prefix)) + == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) + gnu_prefix = TREE_OPERAND (gnu_prefix, 0); + gnu_expr = gnu_prefix; + if (TREE_CODE (gnu_prefix) == COMPONENT_REF + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))) + gnu_prefix = TREE_OPERAND (gnu_prefix, 0); prefix_unused = true; gnu_type = TREE_TYPE (gnu_prefix); @@ -2377,7 +2397,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) /* Deal with a self-referential size by qualifying the size with the object or returning the maximum size for a type. */ if (TREE_CODE (gnu_prefix) != TYPE_DECL) - gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_expr); + gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); else if (CONTAINS_PLACEHOLDER_P (gnu_result)) gnu_result = max_size (gnu_result, true); @@ -3293,7 +3313,7 @@ independent_iterations_p (tree stmt_list) { tree_stmt_iterator tsi; bitmap params = BITMAP_GGC_ALLOC(); - auto_vec<tree> rhs; + auto_vec<tree, 16> rhs; tree iter; int i; @@ -4266,6 +4286,20 @@ finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data) return NULL_TREE; } +/* Apply FUNC to all the sub-trees of nested functions in NODE. FUNC is called + with the DATA and the address of each sub-tree. If FUNC returns a non-NULL + value, the traversal is stopped. */ + +static void +walk_nesting_tree (struct cgraph_node *node, walk_tree_fn func, void *data) +{ + for (node = node->nested; node; node = node->next_nested) + { + walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), func, data); + walk_nesting_tree (node, func, data); + } +} + /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap contains the candidates for Named Return Value and OTHER is a list of the other return values. GNAT_RET is a representative return node. */ @@ -4273,7 +4307,6 @@ finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data) static void finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret) { - struct cgraph_node *node; struct nrv_data data; walk_tree_fn func; unsigned int i; @@ -4294,10 +4327,7 @@ finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret return; /* Prune also the candidates that are referenced by nested functions. */ - node = cgraph_node::get_create (fndecl); - for (node = node->nested; node; node = node->next_nested) - walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r, - &data); + walk_nesting_tree (cgraph_node::get_create (fndecl), prune_nrv_r, &data); if (bitmap_empty_p (nrv)) return; @@ -5015,8 +5045,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, tree gnu_subprog_type = TREE_TYPE (gnu_subprog); /* The return type of the FUNCTION_TYPE. */ tree gnu_result_type = TREE_TYPE (gnu_subprog_type); - tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog); - vec<tree, va_gc> *gnu_actual_vec = NULL; + const bool frontend_builtin + = (TREE_CODE (gnu_subprog) == FUNCTION_DECL + && DECL_BUILT_IN_CLASS (gnu_subprog) == BUILT_IN_FRONTEND); + auto_vec<tree, 16> gnu_actual_vec; tree gnu_name_list = NULL_TREE; tree gnu_stmt_list = NULL_TREE; tree gnu_after_list = NULL_TREE; @@ -5297,13 +5329,23 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, /* Create an explicit temporary holding the copy. */ if (atomic_p) gnu_name = build_atomic_load (gnu_name, sync); - gnu_temp - = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual); - /* But initialize it on the fly like for an implicit temporary as - we aren't necessarily having a statement list. */ - gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt, - gnu_temp); + /* Do not initialize it for the _Init parameter of an initialization + procedure since no data is meant to be passed in. */ + if (Ekind (gnat_formal) == E_Out_Parameter + && Is_Entity_Name (Name (gnat_node)) + && Is_Init_Proc (Entity (Name (gnat_node)))) + gnu_name = gnu_temp = create_temporary ("A", TREE_TYPE (gnu_name)); + + /* Initialize it on the fly like for an implicit temporary in the + other cases, as we don't necessarily have a statement list. */ + else + { + gnu_temp = create_init_temporary ("A", gnu_name, &gnu_stmt, + gnat_actual); + gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt, + gnu_temp); + } /* Set up to move the copy back to the original if needed. */ if (!in_param) @@ -5354,7 +5396,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, since the parent is a procedure call, so put it back here. Note that we might have a dummy type here if the actual is the dereference of a pointer to it, but that's OK if the formal is passed by reference. */ - tree gnu_actual_type = gnat_to_gnu_type (Etype (gnat_actual)); + tree gnu_actual_type = get_unpadded_type (Etype (gnat_actual)); if (TYPE_IS_DUMMY_P (gnu_actual_type)) gcc_assert (is_true_formal_parm && DECL_BY_REF_P (gnu_formal)); else if (suppress_type_conversion @@ -5473,16 +5515,56 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, build_int_cst (type_for_size, 0), false); } - else + + /* If this is a front-end built-in function, there is no need to + convert to the type used to pass the argument. */ + else if (!frontend_builtin) gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual); } - vec_safe_push (gnu_actual_vec, gnu_actual); + gnu_actual_vec.safe_push (gnu_actual); + } + + if (frontend_builtin) + { + tree pred_cst = build_int_cst (integer_type_node, PRED_BUILTIN_EXPECT); + enum internal_fn icode = IFN_BUILTIN_EXPECT; + + switch (DECL_FUNCTION_CODE (gnu_subprog)) + { + case BUILT_IN_EXPECT: + break; + case BUILT_IN_LIKELY: + gnu_actual_vec.safe_push (boolean_true_node); + break; + case BUILT_IN_UNLIKELY: + gnu_actual_vec.safe_push (boolean_false_node); + break; + default: + gcc_unreachable (); + } + + gnu_actual_vec.safe_push (pred_cst); + + gnu_call + = build_call_expr_internal_loc_array (UNKNOWN_LOCATION, + icode, + gnu_result_type, + gnu_actual_vec.length (), + gnu_actual_vec.begin ()); + } + else + { + gnu_call + = build_call_array_loc (UNKNOWN_LOCATION, + gnu_result_type, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_subprog), + gnu_actual_vec.length (), + gnu_actual_vec.begin ()); + CALL_EXPR_BY_DESCRIPTOR (gnu_call) = by_descriptor; } - gnu_call - = build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec); - CALL_EXPR_BY_DESCRIPTOR (gnu_call) = by_descriptor; set_expr_location_from_node (gnu_call, gnat_node); /* If we have created a temporary for the return value, initialize it. */ @@ -6306,24 +6388,17 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) The compiler will automatically predict the last edge leading to a call to a noreturn function as very unlikely taken. This function makes it - possible to expand the prediction to predecessors in case the condition + possible to extend the prediction to predecessors in case the condition is made up of several short-circuit operators. */ static tree build_noreturn_cond (tree cond) { - tree fn = builtin_decl_explicit (BUILT_IN_EXPECT); - tree arg_types = TYPE_ARG_TYPES (TREE_TYPE (fn)); - tree pred_type = TREE_VALUE (arg_types); - tree expected_type = TREE_VALUE (TREE_CHAIN (arg_types)); - - tree t = build_call_expr (fn, 3, - fold_convert (pred_type, cond), - build_int_cst (expected_type, 0), - build_int_cst (integer_type_node, - PRED_NORETURN)); - - return build1 (NOP_EXPR, boolean_type_node, t); + tree pred_cst = build_int_cst (integer_type_node, PRED_NORETURN); + return + build_call_expr_internal_loc (UNKNOWN_LOCATION, IFN_BUILTIN_EXPECT, + boolean_type_node, 3, cond, + boolean_false_node, pred_cst); } /* Subroutine of gnat_to_gnu to translate GNAT_RANGE, a node representing a @@ -7421,7 +7496,7 @@ gnat_to_gnu (Node_Id gnat_node) enum tree_code code = gnu_codes[kind]; bool ignore_lhs_overflow = false; location_t saved_location = input_location; - tree gnu_type; + tree gnu_type, gnu_max_shift = NULL_TREE; /* Fix operations set up for boolean types in GNU_CODES above. */ if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node)))) @@ -7444,6 +7519,17 @@ gnat_to_gnu (Node_Id gnat_node) gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node)); + /* If this is a shift, take the count as unsigned since that is what + most machines do and will generate simpler adjustments below. */ + if (IN (kind, N_Op_Shift)) + { + tree gnu_count_type + = gnat_unsigned_type_for (get_base_type (TREE_TYPE (gnu_rhs))); + gnu_rhs = convert (gnu_count_type, gnu_rhs); + gnu_max_shift + = convert (TREE_TYPE (gnu_rhs), TYPE_SIZE (gnu_type)); + } + /* Pending generic support for efficient vector logical operations in GCC, convert vectors to their representative array type view and fallthrough. */ @@ -7467,25 +7553,20 @@ gnat_to_gnu (Node_Id gnat_node) /* If this is a shift whose count is not guaranteed to be correct, we need to adjust the shift count. */ - if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node)) - { - tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs)); - tree gnu_max_shift - = convert (gnu_count_type, TYPE_SIZE (gnu_type)); - - if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right) - gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type, - gnu_rhs, gnu_max_shift); - else if (kind == N_Op_Shift_Right_Arithmetic) - gnu_rhs - = build_binary_op - (MIN_EXPR, gnu_count_type, - build_binary_op (MINUS_EXPR, - gnu_count_type, - gnu_max_shift, - build_int_cst (gnu_count_type, 1)), - gnu_rhs); - } + if ((kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right) + && !Shift_Count_OK (gnat_node)) + gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, TREE_TYPE (gnu_rhs), + gnu_rhs, gnu_max_shift); + else if (kind == N_Op_Shift_Right_Arithmetic + && !Shift_Count_OK (gnat_node)) + gnu_rhs + = build_binary_op (MIN_EXPR, TREE_TYPE (gnu_rhs), + build_binary_op (MINUS_EXPR, + TREE_TYPE (gnu_rhs), + gnu_max_shift, + build_int_cst + (TREE_TYPE (gnu_rhs), 1)), + gnu_rhs); /* For right shifts, the type says what kind of shift to do, so we may need to choose a different type. In this case, @@ -7512,16 +7593,15 @@ gnat_to_gnu (Node_Id gnat_node) gnu_rhs = convert (gnu_type, gnu_rhs); } - /* Instead of expanding overflow checks for addition, subtraction - and multiplication itself, the front end will leave this to - the back end when Backend_Overflow_Checks_On_Target is set. */ + /* For signed integer addition, subtraction and multiplication, do an + overflow check if required. */ if (Do_Overflow_Check (gnat_node) - && Backend_Overflow_Checks_On_Target && (code == PLUS_EXPR || code == MINUS_EXPR || code == MULT_EXPR) && !TYPE_UNSIGNED (gnu_type) && !FLOAT_TYPE_P (gnu_type)) - gnu_result = build_binary_op_trapv (code, gnu_type, - gnu_lhs, gnu_rhs, gnat_node); + gnu_result + = build_binary_op_trapv (code, gnu_type, gnu_lhs, gnu_rhs, + gnat_node); else { /* Some operations, e.g. comparisons of arrays, generate complex @@ -7532,18 +7612,15 @@ gnat_to_gnu (Node_Id gnat_node) /* If this is a logical shift with the shift count not verified, we must return zero if it is too large. We cannot compensate - above in this case. */ + beforehand in this case. */ if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right) && !Shift_Count_OK (gnat_node)) gnu_result - = build_cond_expr - (gnu_type, - build_binary_op (GE_EXPR, boolean_type_node, - gnu_rhs, - convert (TREE_TYPE (gnu_rhs), - TYPE_SIZE (gnu_type))), - build_int_cst (gnu_type, 0), - gnu_result); + = build_cond_expr (gnu_type, + build_binary_op (GE_EXPR, boolean_type_node, + gnu_rhs, gnu_max_shift), + build_int_cst (gnu_type, 0), + gnu_result); } break; @@ -7585,19 +7662,17 @@ gnat_to_gnu (Node_Id gnat_node) gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node)); gnu_result_type = get_unpadded_type (Etype (gnat_node)); - /* Instead of expanding overflow checks for negation and absolute - value itself, the front end will leave this to the back end - when Backend_Overflow_Checks_On_Target is set. */ + /* For signed integer negation and absolute value, do an overflow check + if required. */ if (Do_Overflow_Check (gnat_node) - && Backend_Overflow_Checks_On_Target && !TYPE_UNSIGNED (gnu_result_type) && !FLOAT_TYPE_P (gnu_result_type)) gnu_result - = build_unary_op_trapv (gnu_codes[kind], - gnu_result_type, gnu_expr, gnat_node); + = build_unary_op_trapv (gnu_codes[kind], gnu_result_type, gnu_expr, + gnat_node); else - gnu_result = build_unary_op (gnu_codes[kind], - gnu_result_type, gnu_expr); + gnu_result + = build_unary_op (gnu_codes[kind], gnu_result_type, gnu_expr); break; case N_Allocator: @@ -8669,7 +8744,11 @@ gnat_to_gnu (Node_Id gnat_node) declaration, return the result unmodified because we want to use the return slot optimization in this case. - 5. Finally, if the type of the result is already correct. */ + 5. If this is a reference to an unconstrained array which is used as the + prefix of an attribute reference that requires an lvalue, return the + result unmodified because we want return the original bounds. + + 6. Finally, if the type of the result is already correct. */ if (Present (Parent (gnat_node)) && (lhs_or_actual_p (gnat_node) @@ -8718,13 +8797,19 @@ gnat_to_gnu (Node_Id gnat_node) else if (gnu_result == error_mark_node || gnu_result_type == void_type_node) gnu_result = error_mark_node; - else if (Present (Parent (gnat_node)) + else if (TREE_CODE (gnu_result) == CALL_EXPR + && Present (Parent (gnat_node)) && (Nkind (Parent (gnat_node)) == N_Object_Declaration || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration) - && TREE_CODE (gnu_result) == CALL_EXPR && return_type_with_variable_size_p (TREE_TYPE (gnu_result))) ; + else if (TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF + && Present (Parent (gnat_node)) + && Nkind (Parent (gnat_node)) == N_Attribute_Reference + && lvalue_required_for_attribute_p (Parent (gnat_node))) + ; + else if (TREE_TYPE (gnu_result) != gnu_result_type) gnu_result = convert (gnu_result_type, gnu_result); @@ -8957,8 +9042,9 @@ mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) else if (!TYPE_IS_DUMMY_P (t)) TREE_VISITED (t) = 1; + /* The test in gimplify_type_sizes is on the main variant. */ if (TYPE_P (t)) - TYPE_SIZES_GIMPLIFIED (t) = 1; + TYPE_SIZES_GIMPLIFIED (TYPE_MAIN_VARIANT (t)) = 1; return NULL_TREE; } diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index da4e100..c6942fe 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -90,15 +90,31 @@ static tree handle_novops_attribute (tree *, tree, tree, int, bool *); static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *); static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *); static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *); +static tree handle_stack_protect_attribute (tree *, tree, tree, int, bool *); static tree handle_noinline_attribute (tree *, tree, tree, int, bool *); static tree handle_noclone_attribute (tree *, tree, tree, int, bool *); +static tree handle_noicf_attribute (tree *, tree, tree, int, bool *); +static tree handle_noipa_attribute (tree *, tree, tree, int, bool *); static tree handle_leaf_attribute (tree *, tree, tree, int, bool *); static tree handle_always_inline_attribute (tree *, tree, tree, int, bool *); static tree handle_malloc_attribute (tree *, tree, tree, int, bool *); static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *); +static tree handle_flatten_attribute (tree *, tree, tree, int, bool *); +static tree handle_used_attribute (tree *, tree, tree, int, bool *); +static tree handle_cold_attribute (tree *, tree, tree, int, bool *); +static tree handle_hot_attribute (tree *, tree, tree, int, bool *); +static tree handle_target_attribute (tree *, tree, tree, int, bool *); +static tree handle_target_clones_attribute (tree *, tree, tree, int, bool *); static tree handle_vector_size_attribute (tree *, tree, tree, int, bool *); static tree handle_vector_type_attribute (tree *, tree, tree, int, bool *); +static const struct attribute_spec::exclusions attr_cold_hot_exclusions[] = +{ + { "cold", true, true, true }, + { "hot" , true, true, true }, + { NULL , false, false, false } +}; + /* Fake handler for attributes we don't properly support, typically because they'd require dragging a lot of the common-c front-end circuitry. */ static tree fake_attribute_handler (tree *, tree, tree, int, bool *); @@ -123,34 +139,55 @@ const struct attribute_spec gnat_internal_attribute_table[] = handle_sentinel_attribute, NULL }, { "noreturn", 0, 0, true, false, false, false, handle_noreturn_attribute, NULL }, + { "stack_protect",0, 0, true, false, false, false, + handle_stack_protect_attribute, NULL }, { "noinline", 0, 0, true, false, false, false, handle_noinline_attribute, NULL }, { "noclone", 0, 0, true, false, false, false, handle_noclone_attribute, NULL }, + { "no_icf", 0, 0, true, false, false, false, + handle_noicf_attribute, NULL }, + { "noipa", 0, 0, true, false, false, false, + handle_noipa_attribute, NULL }, { "leaf", 0, 0, true, false, false, false, handle_leaf_attribute, NULL }, { "always_inline",0, 0, true, false, false, false, handle_always_inline_attribute, NULL }, { "malloc", 0, 0, true, false, false, false, handle_malloc_attribute, NULL }, - { "type generic", 0, 0, false, true, true, false, + { "type generic", 0, 0, false, true, true, false, handle_type_generic_attribute, NULL }, - { "vector_size", 1, 1, false, true, false, false, + { "flatten", 0, 0, true, false, false, false, + handle_flatten_attribute, NULL }, + { "used", 0, 0, true, false, false, false, + handle_used_attribute, NULL }, + { "cold", 0, 0, true, false, false, false, + handle_cold_attribute, attr_cold_hot_exclusions }, + { "hot", 0, 0, true, false, false, false, + handle_hot_attribute, attr_cold_hot_exclusions }, + { "target", 1, -1, true, false, false, false, + handle_target_attribute, NULL }, + { "target_clones",1, -1, true, false, false, false, + handle_target_clones_attribute, NULL }, + + { "vector_size", 1, 1, false, true, false, false, handle_vector_size_attribute, NULL }, - { "vector_type", 0, 0, false, true, false, false, + { "vector_type", 0, 0, false, true, false, false, handle_vector_type_attribute, NULL }, - { "may_alias", 0, 0, false, true, false, false, NULL, NULL }, + { "may_alias", 0, 0, false, true, false, false, + NULL, NULL }, /* ??? format and format_arg are heavy and not supported, which actually prevents support for stdio builtins, which we however declare as part of the common builtins.def contents. */ - { "format", 3, 3, false, true, true, false, fake_attribute_handler, - NULL }, - { "format_arg", 1, 1, false, true, true, false, fake_attribute_handler, - NULL }, + { "format", 3, 3, false, true, true, false, + fake_attribute_handler, NULL }, + { "format_arg", 1, 1, false, true, true, false, + fake_attribute_handler, NULL }, - { NULL, 0, 0, false, false, false, false, NULL, NULL } + { NULL, 0, 0, false, false, false, false, + NULL, NULL } }; /* Associates a GNAT tree node to a GCC tree node. It is used in @@ -947,10 +984,45 @@ make_aligning_type (tree type, unsigned int align, tree size, return record_type; } +/* TYPE is an ARRAY_TYPE that is being used as the type of a field in a packed + record. See if we can rewrite it as a type that has non-BLKmode, which we + can pack tighter in the packed record. If so, return the new type; if not, + return the original type. */ + +static tree +make_packable_array_type (tree type) +{ + const unsigned HOST_WIDE_INT size = tree_to_uhwi (TYPE_SIZE (type)); + unsigned HOST_WIDE_INT new_size; + unsigned int new_align; + + /* No point in doing anything if the size is either zero or too large for an + integral mode, or if the type already has non-BLKmode. */ + if (size == 0 || size > MAX_FIXED_MODE_SIZE || TYPE_MODE (type) != BLKmode) + return type; + + /* Punt if the component type is an aggregate type for now. */ + if (AGGREGATE_TYPE_P (TREE_TYPE (type))) + return type; + + tree new_type = copy_type (type); + + new_size = ceil_pow2 (size); + new_align = MIN (new_size, BIGGEST_ALIGNMENT); + SET_TYPE_ALIGN (new_type, new_align); + + TYPE_SIZE (new_type) = bitsize_int (new_size); + TYPE_SIZE_UNIT (new_type) = size_int (new_size / BITS_PER_UNIT); + + SET_TYPE_MODE (new_type, mode_for_size (new_size, MODE_INT, 1).else_blk ()); + + return new_type; +} + /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used - as the field type of a packed record if IN_RECORD is true, or as the - component type of a packed array if IN_RECORD is false. See if we can - rewrite it either as a type that has non-BLKmode, which we can pack + as the type of a field in a packed record if IN_RECORD is true, or as + the component type of a packed array if IN_RECORD is false. See if we + can rewrite it either as a type that has non-BLKmode, which we can pack tighter in the packed record case, or as a smaller type with at most MAX_ALIGN alignment if the value is non-zero. If so, return the new type; if not, return the original type. */ @@ -958,9 +1030,9 @@ make_aligning_type (tree type, unsigned int align, tree size, tree make_packable_type (tree type, bool in_record, unsigned int max_align) { - unsigned HOST_WIDE_INT size = tree_to_uhwi (TYPE_SIZE (type)); + const unsigned HOST_WIDE_INT size = tree_to_uhwi (TYPE_SIZE (type)); + const unsigned int align = TYPE_ALIGN (type); unsigned HOST_WIDE_INT new_size; - unsigned int align = TYPE_ALIGN (type); unsigned int new_align; /* No point in doing anything if the size is zero. */ @@ -1021,10 +1093,19 @@ make_packable_type (tree type, bool in_record, unsigned int max_align) tree new_field_type = TREE_TYPE (field); tree new_field, new_field_size; - if (RECORD_OR_UNION_TYPE_P (new_field_type) - && !TYPE_FAT_POINTER_P (new_field_type) + if (AGGREGATE_TYPE_P (new_field_type) && tree_fits_uhwi_p (TYPE_SIZE (new_field_type))) - new_field_type = make_packable_type (new_field_type, true, max_align); + { + if (RECORD_OR_UNION_TYPE_P (new_field_type) + && !TYPE_FAT_POINTER_P (new_field_type)) + new_field_type + = make_packable_type (new_field_type, true, max_align); + else if (in_record + && max_align > 0 + && max_align < BITS_PER_UNIT + && TREE_CODE (new_field_type) == ARRAY_TYPE) + new_field_type = make_packable_array_type (new_field_type); + } /* However, for the last field in a not already packed record type that is of an aggregate type, we need to use the RM size in the @@ -1374,7 +1455,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, different modes, a VIEW_CONVERT_EXPR will be required for converting between them and it might be hard to overcome afterwards, including at the RTL level when the stand-alone object is accessed as a whole. */ - if (align != 0 + if (align > 0 && RECORD_OR_UNION_TYPE_P (type) && TYPE_MODE (type) == BLKmode && !TYPE_BY_REFERENCE_P (type) @@ -1385,7 +1466,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, || (TREE_CODE (size) == INTEGER_CST && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0))) { - tree packable_type = make_packable_type (type, true); + tree packable_type = make_packable_type (type, true, align); if (TYPE_MODE (packable_type) != BLKmode && align >= TYPE_ALIGN (packable_type)) type = packable_type; @@ -1530,14 +1611,14 @@ built: generated for some other corresponding source entity. */ if (Comes_From_Source (gnat_entity)) { - if (Present (gnat_error_node)) - post_error_ne_tree ("{^ }bits of & unused?", - gnat_error_node, gnat_entity, - size_diffop (size, orig_size)); - else if (is_component_type) + if (is_component_type) post_error_ne_tree ("component of& padded{ by ^ bits}?", gnat_entity, gnat_entity, size_diffop (size, orig_size)); + else if (Present (gnat_error_node)) + post_error_ne_tree ("{^ }bits of & unused?", + gnat_error_node, gnat_entity, + size_diffop (size, orig_size)); } } @@ -1778,13 +1859,18 @@ void finish_record_type (tree record_type, tree field_list, int rep_level, bool debug_info_p) { - enum tree_code code = TREE_CODE (record_type); + const enum tree_code orig_code = TREE_CODE (record_type); + const bool had_size = TYPE_SIZE (record_type) != NULL_TREE; + const bool had_size_unit = TYPE_SIZE_UNIT (record_type) != NULL_TREE; + const bool had_align = TYPE_ALIGN (record_type) > 0; + /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE + out just like a UNION_TYPE, since the size will be fixed. */ + const enum tree_code code + = (orig_code == QUAL_UNION_TYPE && rep_level > 0 && had_size + ? UNION_TYPE : orig_code); tree name = TYPE_IDENTIFIER (record_type); tree ada_size = bitsize_zero_node; tree size = bitsize_zero_node; - bool had_size = TYPE_SIZE (record_type) != 0; - bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0; - bool had_align = TYPE_ALIGN (record_type) != 0; tree field; TYPE_FIELDS (record_type) = field_list; @@ -1797,26 +1883,21 @@ finish_record_type (tree record_type, tree field_list, int rep_level, that just means some initializations; otherwise, layout the record. */ if (rep_level > 0) { - SET_TYPE_ALIGN (record_type, MAX (BITS_PER_UNIT, - TYPE_ALIGN (record_type))); - - if (!had_size_unit) - TYPE_SIZE_UNIT (record_type) = size_zero_node; + if (TYPE_ALIGN (record_type) < BITS_PER_UNIT) + SET_TYPE_ALIGN (record_type, BITS_PER_UNIT); if (!had_size) TYPE_SIZE (record_type) = bitsize_zero_node; - /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE - out just like a UNION_TYPE, since the size will be fixed. */ - else if (code == QUAL_UNION_TYPE) - code = UNION_TYPE; + if (!had_size_unit) + TYPE_SIZE_UNIT (record_type) = size_zero_node; } else { /* Ensure there isn't a size already set. There can be in an error case where there is a rep clause but all fields have errors and no longer have a position. */ - TYPE_SIZE (record_type) = 0; + TYPE_SIZE (record_type) = NULL_TREE; /* Ensure we use the traditional GCC layout for bitfields when we need to pack the record type or have a representation clause. The other @@ -1860,6 +1941,9 @@ finish_record_type (tree record_type, tree field_list, int rep_level, else this_ada_size = this_size; + const bool variant_part = (TREE_CODE (type) == QUAL_UNION_TYPE); + const bool variant_part_at_zero = variant_part && integer_zerop (pos); + /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */ if (DECL_BIT_FIELD (field) && operand_equal_p (this_size, TYPE_SIZE (type), 0)) @@ -1901,9 +1985,7 @@ finish_record_type (tree record_type, tree field_list, int rep_level, /* Clear DECL_BIT_FIELD_TYPE for a variant part at offset 0, it's simply not supported by the DECL_BIT_FIELD_REPRESENTATIVE machinery because the variant part is always the last field in the list. */ - if (DECL_INTERNAL_P (field) - && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE - && integer_zerop (pos)) + if (variant_part_at_zero) DECL_BIT_FIELD_TYPE (field) = NULL_TREE; /* If we still have DECL_BIT_FIELD set at this point, we know that the @@ -1938,18 +2020,18 @@ finish_record_type (tree record_type, tree field_list, int rep_level, case RECORD_TYPE: /* Since we know here that all fields are sorted in order of increasing bit position, the size of the record is one - higher than the ending bit of the last field processed - unless we have a rep clause, since in that case we might - have a field outside a QUAL_UNION_TYPE that has a higher ending - position. So use a MAX in that case. Also, if this field is a - QUAL_UNION_TYPE, we need to take into account the previous size in - the case of empty variants. */ + higher than the ending bit of the last field processed, + unless we have a variant part at offset 0, since in this + case we might have a field outside the variant part that + has a higher ending position; so use a MAX in this case. + Also, if this field is a QUAL_UNION_TYPE, we need to take + into account the previous size in the case of empty variants. */ ada_size - = merge_sizes (ada_size, pos, this_ada_size, - TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0); + = merge_sizes (ada_size, pos, this_ada_size, variant_part, + variant_part_at_zero); size - = merge_sizes (size, pos, this_size, - TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0); + = merge_sizes (size, pos, this_size, variant_part, + variant_part_at_zero); break; default: @@ -2230,13 +2312,12 @@ rest_of_record_type_compilation (tree record_type) /* Utility function of above to merge LAST_SIZE, the previous size of a record with FIRST_BIT and SIZE that describe a field. SPECIAL is true if this represents a QUAL_UNION_TYPE in which case we must look for COND_EXPRs and - replace a value of zero with the old size. If HAS_REP is true, we take the + replace a value of zero with the old size. If MAX is true, we take the MAX of the end position of this field with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE. Return an expression for the size. */ static tree -merge_sizes (tree last_size, tree first_bit, tree size, bool special, - bool has_rep) +merge_sizes (tree last_size, tree first_bit, tree size, bool special, bool max) { tree type = TREE_TYPE (last_size); tree new_size; @@ -2244,7 +2325,7 @@ merge_sizes (tree last_size, tree first_bit, tree size, bool special, if (!special || TREE_CODE (size) != COND_EXPR) { new_size = size_binop (PLUS_EXPR, first_bit, size); - if (has_rep) + if (max) new_size = size_binop (MAX_EXPR, last_size, new_size); } @@ -2253,11 +2334,11 @@ merge_sizes (tree last_size, tree first_bit, tree size, bool special, integer_zerop (TREE_OPERAND (size, 1)) ? last_size : merge_sizes (last_size, first_bit, TREE_OPERAND (size, 1), - 1, has_rep), + 1, max), integer_zerop (TREE_OPERAND (size, 2)) ? last_size : merge_sizes (last_size, first_bit, TREE_OPERAND (size, 2), - 1, has_rep)); + 1, max)); /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially when fed through SUBSTITUTE_IN_EXPR) into thinking that a constant @@ -2753,10 +2834,9 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos, size = round_up (size, BITS_PER_UNIT); } - /* If we may, according to ADDRESSABLE, make a bitfield when the size is - specified for two reasons: first if the size differs from the natural - size; second, if the alignment is insufficient. There are a number of - ways the latter can be true. + /* If we may, according to ADDRESSABLE, then make a bitfield when the size + is specified for two reasons: first, when it differs from the natural + size; second, when the alignment is insufficient. We never make a bitfield if the type of the field has a nonconstant size, because no such entity requiring bitfield operations should reach here. @@ -2772,17 +2852,17 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos, && size && TREE_CODE (size) == INTEGER_CST && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST - && (!tree_int_cst_equal (size, TYPE_SIZE (type)) + && (packed + || !tree_int_cst_equal (size, TYPE_SIZE (type)) || (pos && !value_factor_p (pos, TYPE_ALIGN (type))) - || packed - || (TYPE_ALIGN (record_type) != 0 + || (TYPE_ALIGN (record_type) && TYPE_ALIGN (record_type) < TYPE_ALIGN (type)))) { DECL_BIT_FIELD (field_decl) = 1; DECL_SIZE (field_decl) = size; if (!packed && !pos) { - if (TYPE_ALIGN (record_type) != 0 + if (TYPE_ALIGN (record_type) && TYPE_ALIGN (record_type) < TYPE_ALIGN (type)) SET_DECL_ALIGN (field_decl, TYPE_ALIGN (record_type)); else @@ -2964,10 +3044,12 @@ process_attributes (tree *node, struct attrib **attr_list, bool in_place, a power of 2. */ bool -value_factor_p (tree value, HOST_WIDE_INT factor) +value_factor_p (tree value, unsigned HOST_WIDE_INT factor) { + gcc_checking_assert (pow2p_hwi (factor)); + if (tree_fits_uhwi_p (value)) - return tree_to_uhwi (value) % factor == 0; + return (tree_to_uhwi (value) & (factor - 1)) == 0; if (TREE_CODE (value) == MULT_EXPR) return (value_factor_p (TREE_OPERAND (value, 0), factor) @@ -3394,8 +3476,6 @@ begin_subprog_body (tree subprog_decl) for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl; param_decl = DECL_CHAIN (param_decl)) DECL_CONTEXT (param_decl) = subprog_decl; - - make_decl_rtl (subprog_decl); } /* Finish translating the current subprogram and set its BODY. */ @@ -5185,8 +5265,8 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) if (etype == type) return expr; - /* If both types are integral just do a normal conversion. - Likewise for a conversion to an unconstrained array. */ + /* If both types are integral or regular pointer, then just do a normal + conversion. Likewise for a conversion to an unconstrained array. */ if (((INTEGRAL_TYPE_P (type) || (POINTER_TYPE_P (type) && !TYPE_IS_THIN_POINTER_P (type)) || (code == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type))) @@ -5317,14 +5397,16 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) we need to pad to have the same size on both sides. ??? We cannot do it unconditionally because unchecked conversions are - used liberally by the front-end to implement polymorphism, e.g. in: + used liberally by the front-end to implement interface thunks: + type ada__tags__addr_ptr is access system.address; S191s : constant ada__tags__addr_ptr := ada__tags__addr_ptr!(S190s); return p___size__4 (p__object!(S191s.all)); - so we skip all expressions that are references. */ - else if (!REFERENCE_CLASS_P (expr) + so we need to skip dereferences. */ + else if (!INDIRECT_REF_P (expr) && !AGGREGATE_TYPE_P (etype) + && ecode != UNCONSTRAINED_ARRAY_TYPE && TREE_CONSTANT (TYPE_SIZE (type)) && (c = tree_int_cst_compare (TYPE_SIZE (etype), TYPE_SIZE (type)))) { @@ -5344,6 +5426,31 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) } } + /* Likewise if we are converting from a scalar type to a type with self- + referential size. We use the max size to do the padding in this case. */ + else if (!INDIRECT_REF_P (expr) + && !AGGREGATE_TYPE_P (etype) + && ecode != UNCONSTRAINED_ARRAY_TYPE + && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (type))) + { + tree new_size = max_size (TYPE_SIZE (type), true); + c = tree_int_cst_compare (TYPE_SIZE (etype), new_size); + if (c < 0) + { + expr = convert (maybe_pad_type (etype, new_size, 0, Empty, + false, false, false, true), + expr); + expr = unchecked_convert (type, expr, notrunc_p); + } + else + { + tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty, + false, false, false, true); + expr = unchecked_convert (rec_type, expr, notrunc_p); + expr = build_component_ref (expr, TYPE_FIELDS (rec_type), false); + } + } + /* We have a special case when we are converting between two unconstrained array types. In that case, take the address, convert the fat pointer types, and dereference. */ @@ -5877,6 +5984,7 @@ enum c_builtin_type ARG6, ARG7) NAME, #define DEF_POINTER_TYPE(NAME, TYPE) NAME, #include "builtin-types.def" +#include "ada-builtin-types.def" #undef DEF_PRIMITIVE_TYPE #undef DEF_FUNCTION_TYPE_0 #undef DEF_FUNCTION_TYPE_1 @@ -6025,6 +6133,7 @@ install_builtin_function_types (void) builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]); #include "builtin-types.def" +#include "ada-builtin-types.def" #undef DEF_PRIMITIVE_TYPE #undef DEF_FUNCTION_TYPE_0 @@ -6197,7 +6306,8 @@ handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name), && (!TYPE_ATTRIBUTES (type) || !lookup_attribute ("type generic", TYPE_ATTRIBUTES (type)))) { - error ("nonnull attribute without arguments on a non-prototype"); + error ("%qs attribute without arguments on a non-prototype", + "nonnull"); *no_add_attrs = true; } return NULL_TREE; @@ -6211,8 +6321,8 @@ handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name), if (!get_nonnull_operand (TREE_VALUE (args), &arg_num)) { - error ("nonnull argument has invalid operand number (argument %lu)", - (unsigned long) attr_arg_num); + error ("%qs argument has invalid operand number (argument %lu)", + "nonnull", (unsigned long) attr_arg_num); *no_add_attrs = true; return NULL_TREE; } @@ -6233,8 +6343,8 @@ handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name), if (!argument || TREE_CODE (argument) == VOID_TYPE) { - error ("nonnull argument with out-of-range operand number " - "(argument %lu, operand %lu)", + error ("%qs argument with out-of-range operand number " + "(argument %lu, operand %lu)", "nonnull", (unsigned long) attr_arg_num, (unsigned long) arg_num); *no_add_attrs = true; return NULL_TREE; @@ -6242,8 +6352,8 @@ handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name), if (TREE_CODE (argument) != POINTER_TYPE) { - error ("nonnull argument references non-pointer operand " - "(argument %lu, operand %lu)", + error ("%qs argument references non-pointer operand " + "(argument %lu, operand %lu)", "nonnull", (unsigned long) attr_arg_num, (unsigned long) arg_num); *no_add_attrs = true; return NULL_TREE; @@ -6327,6 +6437,22 @@ handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args), return NULL_TREE; } +/* Handle a "stack_protect" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_stack_protect_attribute (tree *node, tree name, tree, int, + bool *no_add_attrs) +{ + if (TREE_CODE (*node) != FUNCTION_DECL) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + /* Handle a "noinline" attribute; arguments as in struct attribute_spec.handler. */ @@ -6372,6 +6498,38 @@ handle_noclone_attribute (tree *node, tree name, return NULL_TREE; } +/* Handle a "no_icf" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_noicf_attribute (tree *node, tree name, + tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) != FUNCTION_DECL) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "noipa" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_noipa_attribute (tree *node, tree name, tree, int, bool *no_add_attrs) +{ + if (TREE_CODE (*node) != FUNCTION_DECL) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + /* Handle a "leaf" attribute; arguments as in struct attribute_spec.handler. */ @@ -6462,6 +6620,166 @@ handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name), return NULL_TREE; } +/* Handle a "flatten" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_flatten_attribute (tree *node, tree name, + tree args ATTRIBUTE_UNUSED, + int flags ATTRIBUTE_UNUSED, bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + /* Do nothing else, just set the attribute. We'll get at + it later with lookup_attribute. */ + ; + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "used" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_used_attribute (tree *pnode, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + tree node = *pnode; + + if (TREE_CODE (node) == FUNCTION_DECL + || (VAR_P (node) && TREE_STATIC (node)) + || (TREE_CODE (node) == TYPE_DECL)) + { + TREE_USED (node) = 1; + DECL_PRESERVE_P (node) = 1; + if (VAR_P (node)) + DECL_READ_P (node) = 1; + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "cold" and attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_cold_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL + || TREE_CODE (*node) == LABEL_DECL) + { + /* Attribute cold processing is done later with lookup_attribute. */ + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "hot" and attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_hot_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL + || TREE_CODE (*node) == LABEL_DECL) + { + /* Attribute hot processing is done later with lookup_attribute. */ + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + +/* Handle a "target" attribute. */ + +static tree +handle_target_attribute (tree *node, tree name, tree args, int flags, + bool *no_add_attrs) +{ + /* Ensure we have a function type. */ + if (TREE_CODE (*node) != FUNCTION_DECL) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + else if (lookup_attribute ("target_clones", DECL_ATTRIBUTES (*node))) + { + warning (OPT_Wattributes, "%qE attribute ignored due to conflict " + "with %qs attribute", name, "target_clones"); + *no_add_attrs = true; + } + else if (!targetm.target_option.valid_attribute_p (*node, name, args, flags)) + *no_add_attrs = true; + + /* Check that there's no empty string in values of the attribute. */ + for (tree t = args; t != NULL_TREE; t = TREE_CHAIN (t)) + { + tree value = TREE_VALUE (t); + if (TREE_CODE (value) == STRING_CST + && TREE_STRING_LENGTH (value) == 1 + && TREE_STRING_POINTER (value)[0] == '\0') + { + warning (OPT_Wattributes, "empty string in attribute %<target%>"); + *no_add_attrs = true; + } + } + + return NULL_TREE; +} + +/* Handle a "target_clones" attribute. */ + +static tree +handle_target_clones_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + /* Ensure we have a function type. */ + if (TREE_CODE (*node) == FUNCTION_DECL) + { + if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (*node))) + { + warning (OPT_Wattributes, "%qE attribute ignored due to conflict " + "with %qs attribute", name, "always_inline"); + *no_add_attrs = true; + } + else if (lookup_attribute ("target", DECL_ATTRIBUTES (*node))) + { + warning (OPT_Wattributes, "%qE attribute ignored due to conflict " + "with %qs attribute", name, "target"); + *no_add_attrs = true; + } + else + /* Do not inline functions with multiple clone targets. */ + DECL_UNINLINABLE (*node) = 1; + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + return NULL_TREE; +} + /* Handle a "vector_size" attribute; arguments as in struct attribute_spec.handler. */ @@ -6574,7 +6892,10 @@ static int flag_isoc94 = 0; static int flag_isoc99 = 0; static int flag_isoc11 = 0; -/* Install what the common builtins.def offers. */ +/* Install what the common builtins.def offers plus our local additions. + + Note that ada-builtins.def is included first so that locally redefined + built-in functions take precedence over the commonly defined ones. */ static void install_builtin_functions (void) @@ -6587,6 +6908,10 @@ install_builtin_functions (void) builtin_types[(int) LIBTYPE], \ BOTH_P, FALLBACK_P, NONANSI_P, \ built_in_attributes[(int) ATTRS], IMPLICIT); +#define DEF_ADA_BUILTIN(ENUM, NAME, TYPE, ATTRS) \ + DEF_BUILTIN (ENUM, "__builtin_" NAME, BUILT_IN_FRONTEND, TYPE, BT_LAST, \ + false, false, false, ATTRS, true, true) +#include "ada-builtins.def" #include "builtins.def" } diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index cd4518f..1f5817a 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -1453,9 +1453,13 @@ begin -- Generate ALI file if specially requested, or for missing subunits, -- subunits or predefined generic. For ignored ghost code, the object - -- file IS generated, so Object should be True. + -- file IS generated, so Object should be True, and since the object + -- file is generated, we need to generate the ALI file. We never want + -- an object file without an ALI file. - if Opt.Force_ALI_Tree_File then + if Is_Ignored_Ghost_Unit (Main_Unit_Node) + or else Opt.Force_ALI_Tree_File + then Write_ALI (Object => Is_Ignored_Ghost_Unit (Main_Unit_Node)); end if; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 85bc144..39a24ab 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , Sep 24, 2018 +GNAT Reference Manual , Jun 21, 2019 AdaCore @@ -5220,18 +5220,19 @@ Syntax: pragma Machine_Attribute ( [Entity =>] LOCAL_NAME, [Attribute_Name =>] static_string_EXPRESSION - [, [Info =>] static_EXPRESSION] ); + [, [Info =>] static_EXPRESSION @{, static_EXPRESSION@}] ); @end example Machine-dependent attributes can be specified for types and/or declarations. This pragma is semantically equivalent to @code{__attribute__((@emph{attribute_name}))} (if @code{info} is not specified) or @code{__attribute__((@emph{attribute_name(info})))} -in GNU C, where @emph{attribute_name} is recognized by the -compiler middle-end or the @code{TARGET_ATTRIBUTE_TABLE} machine -specific macro. A string literal for the optional parameter @code{info} -is transformed into an identifier, which may make this pragma unusable -for some attributes. +or @code{__attribute__((@emph{attribute_name(info,...})))} in GNU C, +where @emph{attribute_name} is recognized by the compiler middle-end +or the @code{TARGET_ATTRIBUTE_TABLE} machine specific macro. Note +that a string literal for the optional parameter @code{info} or the +following ones is transformed by default into an identifier, +which may make this pragma unusable for some attributes. For further information see @cite{GNU Compiler Collection (GCC) Internals}. @node Pragma Main,Pragma Main_Storage,Pragma Machine_Attribute,Implementation Defined Pragmas @@ -12673,15 +12674,14 @@ Long_Integer'Size. @geindex No_Multiple_Elaboration -[GNAT] When this restriction is active, we are not requesting control-flow -preservation with -fpreserve-control-flow, and the static elaboration model is -used, the compiler is allowed to suppress the elaboration counter normally -associated with the unit, even if the unit has elaboration code. This counter -is typically used to check for access before elaboration and to control -multiple elaboration attempts. If the restriction is used, then the -situations in which multiple elaboration is possible, including non-Ada main -programs and Stand Alone libraries, are not permitted and will be diagnosed -by the binder. +[GNAT] When this restriction is active and the static elaboration model is +used, and -fpreserve-control-flow is not used, the compiler is allowed to +suppress the elaboration counter normally associated with the unit, even if +the unit has elaboration code. This counter is typically used to check for +access before elaboration and to control multiple elaboration attempts. If the +restriction is used, then the situations in which multiple elaboration is +possible, including non-Ada main programs and Stand Alone libraries, are not +permitted and will be diagnosed by the binder. @node No_Nested_Finalization,No_Protected_Type_Allocators,No_Multiple_Elaboration,Partition-Wide Restrictions @anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1e1} @@ -18982,14 +18982,23 @@ type R is record end record; @end example -On a typical 32-bit architecture, the X component will be four bytes, and -require four-byte alignment, and the Y component will be one byte. In this -case @code{R'Value_Size} will be 40 (bits) since this is the minimum size -required to store a value of this type, and for example, it is permissible -to have a component of type R in an outer array whose component size is -specified to be 48 bits. However, @code{R'Object_Size} will be 64 (bits), -since it must be rounded up so that this value is a multiple of the -alignment (4 bytes = 32 bits). +On a typical 32-bit architecture, the X component will occupy four bytes +and the Y component will occupy one byte, for a total of 5 bytes. As a +result @code{R'Value_Size} will be 40 (bits) since this is the minimum size +required to store a value of this type. For example, it is permissible +to have a component of type R in an array whose component size is +specified to be 40 bits. + +However, @code{R'Object_Size} will be 64 (bits). The difference is due to +the alignment requirement for objects of the record type. The X +component will require four-byte alignment because that is what type +Integer requires, whereas the Y component, a Character, will only +require 1-byte alignment. Since the alignment required for X is the +greatest of all the components' alignments, that is the alignment +required for the enclosing record type, i.e., 4 bytes or 32 bits. As +indicated above, the actual object size must be rounded up so that it is +a multiple of the alignment value. Therefore, 40 bits rounded up to the +next multiple of 32 yields 64 bits. For all other types, the @code{Object_Size} and @code{Value_Size} are the same (and equivalent to the RM attribute @code{Size}). @@ -25531,8 +25540,10 @@ and C types: @item Ada enumeration types map to C enumeration types directly if pragma -@code{Convention C} is specified, which causes them to have int -length. Without pragma @code{Convention C}, Ada enumeration types map to +@code{Convention C} is specified, which causes them to have a length of +32 bits, except for boolean types which map to C99 @code{bool} and for +which the length is 8 bits. +Without pragma @code{Convention C}, Ada enumeration types map to 8, 16, or 32 bits (i.e., C types @code{signed char}, @code{short}, @code{int}, respectively) depending on the number of values passed. This is the only case in which pragma @code{Convention C} affects the diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index faf01c6..7371a76 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 , Dec 05, 2018 +GNAT User's Guide for Native Platforms , Jun 21, 2019 AdaCore @@ -12683,8 +12683,8 @@ sizes or conventions. @emph{Activate warnings for size not a multiple of alignment.} -This switch activates warnings for cases of record types with -specified @code{Size} and @code{Alignment} attributes where the +This switch activates warnings for cases of array and record types +with specified @code{Size} and @code{Alignment} attributes where the size is not a multiple of the alignment, resulting in an object size that is greater than the specified size. The default is that such warnings are generated. @@ -12701,12 +12701,11 @@ is that such warnings are generated. @emph{Suppress warnings for size not a multiple of alignment.} -This switch suppresses warnings for cases of record types with -specified @code{Size} and @code{Alignment} attributes where the +This switch suppresses warnings for cases of array and record types +with specified @code{Size} and @code{Alignment} attributes where the size is not a multiple of the alignment, resulting in an object -size that is greater than the specified size. -The warning can also be -suppressed by giving an explicit @code{Object_Size} value. +size that is greater than the specified size. The warning can also +be suppressed by giving an explicit @code{Object_Size} value. @end table @geindex -Wunused (gcc) @@ -13516,6 +13515,20 @@ character (in particular the DOS line terminator sequence CR/LF is not allowed). @end table +@geindex -gnatyD (gcc) + + +@table @asis + +@item @code{-gnatyD} + +@emph{Check declared identifiers in mixed case.} + +Declared identifiers must be in mixed case, as in +This_Is_An_Identifier. Use -gnatyr in addition to ensure +that references match declarations. +@end table + @geindex -gnatye (gcc) @@ -15143,8 +15156,8 @@ available in the specification of the Repinfo unit present in the compiler sources. If the switch is followed by an @code{s} (e.g., @code{-gnatR3s}), then -the output is to a file with the name @code{file.rep} where file is -the name of the corresponding source file, except if @cite{j`} is also +the output is to a file with the name @code{file.rep} where @code{file} is +the name of the corresponding source file, except if @code{j} is also specified, in which case the file name is @code{file.json}. Note that it is possible for record components to have zero size. In @@ -23556,15 +23569,15 @@ the set of handlers Most programs should experience a substantial speed improvement by being compiled with a ZCX run-time. This is especially true for -tasking applications or applications with many exception handlers.@} +tasking applications or applications with many exception handlers. +Note however that the ZCX run-time does not support asynchronous abort +of tasks (@code{abort} and @code{select-then-abort} constructs) and will instead +implement abort by polling points in the runtime. You can also add additional +polling points explicitly if needed in your application via @code{pragma +Abort_Defer}. This section summarizes which combinations of threads and exception support are supplied on various GNAT platforms. -It then shows how to select a particular library either -permanently or temporarily, -explains the properties of (and tradeoffs among) the various threads -libraries, and provides some additional -information about several specific platforms. @menu * Summary of Run-Time Configurations:: @@ -28348,20 +28361,20 @@ using the legacy elaboration model, in the following order: @itemize - @item -Use the legacy static elaboration model, with compiler switch -@code{-gnatH}. +Use the relaxed static elaboration model, with compiler switch +@code{-gnatJ}. @item -Use the legacy dynamic elaboration model, with compiler switches -@code{-gnatH} @code{-gnatE}. +Use the relaxed dynamic elaboration model, with compiler switches +@code{-gnatE} @code{-gnatJ}. @item -Use the relaxed legacy static elaboration model, with compiler switches -@code{-gnatH} @code{-gnatJ}. +Use the legacy static elaboration model, with compiler switch +@code{-gnatH}. @item -Use the relaxed legacy dynamic elaboration model, with compiler switches -@code{-gnatH} @code{-gnatJ} @code{-gnatE}. +Use the legacy dynamic elaboration model, with compiler switches +@code{-gnatE} @code{-gnatH}. @end itemize @item diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index be703a9..41541c3 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -29,6 +29,7 @@ with Bcheck; use Bcheck; with Binde; use Binde; with Binderr; use Binderr; with Bindgen; use Bindgen; +with Bindo; use Bindo; with Bindusg; with Casing; use Casing; with Csets; @@ -878,11 +879,18 @@ begin if Errors_Detected = 0 then declare - Elab_Order : Unit_Id_Table; use Unit_Id_Tables; + Elab_Order : Unit_Id_Table; begin - Find_Elab_Order (Elab_Order, First_Main_Lib_File); + -- Use the invocation and library graph-based elaboration order + -- when switch -d_N (new bindo order) is in effect. + + if Debug_Flag_Underscore_NN then + Find_Elaboration_Order (Elab_Order, First_Main_Lib_File); + else + Find_Elab_Order (Elab_Order, First_Main_Lib_File); + end if; if Errors_Detected = 0 and then not Check_Only then Gen_Output_File @@ -892,12 +900,12 @@ begin end; end if; - Total_Errors := Total_Errors + Errors_Detected; + Total_Errors := Total_Errors + Errors_Detected; Total_Warnings := Total_Warnings + Warnings_Detected; exception when Unrecoverable_Error => - Total_Errors := Total_Errors + Errors_Detected; + Total_Errors := Total_Errors + Errors_Detected; Total_Warnings := Total_Warnings + Warnings_Detected; end; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index e8a1b92..5e5ede0 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -1884,6 +1884,7 @@ begin Clean_Link_Option_Set : declare J : Natural; Shared_Libgcc_Seen : Boolean := False; + Static_Libgcc_Seen : Boolean := False; begin J := Linker_Options.First; @@ -1905,7 +1906,7 @@ begin end if; end if; - -- Remove duplicate -shared-libgcc switch + -- Remove duplicate -shared-libgcc switches if Linker_Options.Table (J).all = Shared_Libgcc_String then if Shared_Libgcc_Seen then @@ -1919,6 +1920,20 @@ begin end if; end if; + -- Remove duplicate -static-libgcc switches + + if Linker_Options.Table (J).all = Static_Libgcc_String then + if Static_Libgcc_Seen then + Linker_Options.Table (J .. Linker_Options.Last - 1) := + Linker_Options.Table (J + 1 .. Linker_Options.Last); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 1; + + else + Static_Libgcc_Seen := True; + end if; + end if; + -- Here we just check for a canonical form that matches the -- pragma Linker_Options set in the NT runtime. @@ -1950,14 +1965,27 @@ begin -- libgcc, if gcc is not called with -shared-libgcc, call it -- with -static-libgcc, as there are some platforms where one -- of these two switches is compulsory to link. + -- Don't push extra switches if we already saw one. if Shared_Libgcc_Default = 'T' and then not Shared_Libgcc_Seen + and then not Static_Libgcc_Seen then Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last) := Static_Libgcc; Num_Args := Num_Args + 1; end if; + + -- Likewise, the reverse. + + if Shared_Libgcc_Default = 'H' + and then not Static_Libgcc_Seen + and then not Shared_Libgcc_Seen + then + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := Shared_Libgcc; + Num_Args := Num_Args + 1; + end if; end if; end Clean_Link_Option_Set; diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h index 200edaba..1821b1b 100644 --- a/gcc/ada/gsocket.h +++ b/gcc/ada/gsocket.h @@ -185,6 +185,7 @@ #include <limits.h> #include <errno.h> +#include <stddef.h> #if defined (__vxworks) && ! defined (__RTP__) #include <sys/times.h> @@ -252,12 +253,7 @@ # endif #endif -#if defined (__FreeBSD__) || defined (__vxworks) || defined(__rtems__) \ - || defined (__DragonFly__) || defined (__NetBSD__) || defined (__OpenBSD__) -# define Has_Sockaddr_Len 1 -#else -# define Has_Sockaddr_Len 0 -#endif +# define Has_Sockaddr_Len (offsetof(struct sockaddr_in, sin_family) != 0) #if !(defined (_WIN32) || defined (__hpux__) || defined (VMS)) # define HAVE_INET_PTON diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 4ee99e6..80857b3 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -275,6 +275,7 @@ package body Impunit is ("g-exptty", F), -- GNAT.Expect.TTY ("g-flocon", F), -- GNAT.Float_Control ("g-forstr", F), -- GNAT.Formatted_String + ("g-graphs", F), -- GNAT.Graphs ("g-heasor", F), -- GNAT.Heap_Sort ("g-hesora", F), -- GNAT.Heap_Sort_A ("g-hesorg", F), -- GNAT.Heap_Sort_G diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 709513d..b2038a6 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1706,11 +1706,29 @@ package body Inline is -- Use generic machinery to build an unexpanded body for the subprogram. -- This body is subsequently used for inline expansions at call sites. + procedure Build_Return_Object_Formal + (Loc : Source_Ptr; + Obj_Decl : Node_Id; + Formals : List_Id); + -- Create a formal parameter for return object declaration Obj_Decl of + -- an extended return statement and add it to list Formals. + function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean; -- Return true if we generate code for the function body N, the function -- body N has no local declarations and its unique statement is a single -- extended return statement with a handled statements sequence. + procedure Copy_Formals + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Formals : List_Id); + -- Create new formal parameters from the formal parameters of subprogram + -- Subp_Id and add them to list Formals. + + function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id; + -- Create a copy of return object declaration Obj_Decl of an extended + -- return statement. + procedure Split_Unconstrained_Function (N : Node_Id; Spec_Id : Entity_Id); @@ -1757,6 +1775,9 @@ package body Inline is Body_To_Inline := Copy_Generic_Node (N, Empty, Instantiating => True); else + -- ??? Shouldn't this use New_Copy_Tree? What about global + -- references captured in the body to inline? + Body_To_Inline := Copy_Separate_Tree (N); end if; @@ -1845,30 +1866,70 @@ package body Inline is Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id)); end Build_Body_To_Inline; + -------------------------------- + -- Build_Return_Object_Formal -- + -------------------------------- + + procedure Build_Return_Object_Formal + (Loc : Source_Ptr; + Obj_Decl : Node_Id; + Formals : List_Id) + is + Obj_Def : constant Node_Id := Object_Definition (Obj_Decl); + Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); + Typ_Def : Node_Id; + + begin + -- Build the type definition of the formal parameter. The use of + -- New_Copy_Tree ensures that global references preserved in the + -- case of generics. + + if Is_Entity_Name (Obj_Def) then + Typ_Def := New_Copy_Tree (Obj_Def); + else + Typ_Def := New_Copy_Tree (Subtype_Mark (Obj_Def)); + end if; + + -- Generate: + -- + -- Obj_Id : [out] Typ_Def + + -- Mode OUT should not be used when the return object is declared as + -- a constant. Check the definition of the object declaration because + -- the object has not been analyzed yet. + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Obj_Id)), + In_Present => False, + Out_Present => not Constant_Present (Obj_Decl), + Null_Exclusion_Present => False, + Parameter_Type => Typ_Def)); + end Build_Return_Object_Formal; + -------------------------------------- -- Can_Split_Unconstrained_Function -- -------------------------------------- function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is - Ret_Node : constant Node_Id := - First (Statements (Handled_Statement_Sequence (N))); - D : Node_Id; + Stmt : constant Node_Id := + First (Statements (Handled_Statement_Sequence (N))); + Decl : Node_Id; begin -- No user defined declarations allowed in the function except inside -- the unique return statement; implicit labels are the only allowed -- declarations. - if not Is_Empty_List (Declarations (N)) then - D := First (Declarations (N)); - while Present (D) loop - if Nkind (D) /= N_Implicit_Label_Declaration then - return False; - end if; + Decl := First (Declarations (N)); + while Present (Decl) loop + if Nkind (Decl) /= N_Implicit_Label_Declaration then + return False; + end if; - Next (D); - end loop; - end if; + Next (Decl); + end loop; -- We only split the inlined function when we are generating the code -- of its body; otherwise we leave duplicated split subprograms in @@ -1876,12 +1937,71 @@ package body Inline is -- time. return In_Extended_Main_Code_Unit (N) - and then Present (Ret_Node) - and then Nkind (Ret_Node) = N_Extended_Return_Statement - and then No (Next (Ret_Node)) - and then Present (Handled_Statement_Sequence (Ret_Node)); + and then Present (Stmt) + and then Nkind (Stmt) = N_Extended_Return_Statement + and then No (Next (Stmt)) + and then Present (Handled_Statement_Sequence (Stmt)); end Can_Split_Unconstrained_Function; + ------------------ + -- Copy_Formals -- + ------------------ + + procedure Copy_Formals + (Loc : Source_Ptr; + Subp_Id : Entity_Id; + Formals : List_Id) + is + Formal : Entity_Id; + Spec : Node_Id; + + begin + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + Spec := Parent (Formal); + + -- Create an exact copy of the formal parameter. The use of + -- New_Copy_Tree ensures that global references are preserved + -- in case of generics. + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), + In_Present => In_Present (Spec), + Out_Present => Out_Present (Spec), + Null_Exclusion_Present => Null_Exclusion_Present (Spec), + Parameter_Type => + New_Copy_Tree (Parameter_Type (Spec)), + Expression => New_Copy_Tree (Expression (Spec)))); + + Next_Formal (Formal); + end loop; + end Copy_Formals; + + ------------------------ + -- Copy_Return_Object -- + ------------------------ + + function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id is + Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); + + begin + -- The use of New_Copy_Tree ensures that global references are + -- preserved in case of generics. + + return + Make_Object_Declaration (Sloc (Obj_Decl), + Defining_Identifier => + Make_Defining_Identifier (Sloc (Obj_Id), Chars (Obj_Id)), + Aliased_Present => Aliased_Present (Obj_Decl), + Constant_Present => Constant_Present (Obj_Decl), + Null_Exclusion_Present => Null_Exclusion_Present (Obj_Decl), + Object_Definition => + New_Copy_Tree (Object_Definition (Obj_Decl)), + Expression => New_Copy_Tree (Expression (Obj_Decl))); + end Copy_Return_Object; + ---------------------------------- -- Split_Unconstrained_Function -- ---------------------------------- @@ -1891,10 +2011,10 @@ package body Inline is Spec_Id : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); - Ret_Node : constant Node_Id := + Ret_Stmt : constant Node_Id := First (Statements (Handled_Statement_Sequence (N))); Ret_Obj : constant Node_Id := - First (Return_Object_Declarations (Ret_Node)); + First (Return_Object_Declarations (Ret_Stmt)); procedure Build_Procedure (Proc_Id : out Entity_Id; @@ -1910,63 +2030,35 @@ package body Inline is (Proc_Id : out Entity_Id; Decl_List : out List_Id) is - Formal : Entity_Id; - Formal_List : constant List_Id := New_List; - Proc_Spec : Node_Id; - Proc_Body : Node_Id; - Subp_Name : constant Name_Id := New_Internal_Name ('F'); - Body_Decl_List : List_Id := No_List; - Param_Type : Node_Id; - - begin - if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then - Param_Type := - New_Copy (Object_Definition (Ret_Obj)); - else - Param_Type := - New_Copy (Subtype_Mark (Object_Definition (Ret_Obj))); - end if; - - Append_To (Formal_List, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (Ret_Obj))), - In_Present => False, - Out_Present => True, - Null_Exclusion_Present => False, - Parameter_Type => Param_Type)); + Formals : constant List_Id := New_List; + Subp_Name : constant Name_Id := New_Internal_Name ('F'); - Formal := First_Formal (Spec_Id); + Body_Decls : List_Id := No_List; + Decl : Node_Id; + Proc_Body : Node_Id; + Proc_Spec : Node_Id; - -- Note that we copy the parameter type rather than creating - -- a reference to it, because it may be a class-wide entity - -- that will not be retrieved by name. + begin + -- Create formal parameters for the return object and all formals + -- of the unconstrained function in order to pass their values to + -- the procedure. - while Present (Formal) loop - Append_To (Formal_List, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Sloc (Formal), - Chars => Chars (Formal)), - In_Present => In_Present (Parent (Formal)), - Out_Present => Out_Present (Parent (Formal)), - Null_Exclusion_Present => - Null_Exclusion_Present (Parent (Formal)), - Parameter_Type => - New_Copy_Tree (Parameter_Type (Parent (Formal))), - Expression => - Copy_Separate_Tree (Expression (Parent (Formal))))); + Build_Return_Object_Formal + (Loc => Loc, + Obj_Decl => Ret_Obj, + Formals => Formals); - Next_Formal (Formal); - end loop; + Copy_Formals + (Loc => Loc, + Subp_Id => Spec_Id, + Formals => Formals); Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name); Proc_Spec := Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc_Id, - Parameter_Specifications => Formal_List); + Parameter_Specifications => Formals); Decl_List := New_List; @@ -1978,37 +2070,30 @@ package body Inline is -- Copy these declarations to the built procedure. if Present (Declarations (N)) then - Body_Decl_List := New_List; + Body_Decls := New_List; - declare - D : Node_Id; - New_D : Node_Id; + Decl := First (Declarations (N)); + while Present (Decl) loop + pragma Assert (Nkind (Decl) = N_Implicit_Label_Declaration); - begin - D := First (Declarations (N)); - while Present (D) loop - pragma Assert (Nkind (D) = N_Implicit_Label_Declaration); - - New_D := - Make_Implicit_Label_Declaration (Loc, - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (D))), - Label_Construct => Empty); - Append_To (Body_Decl_List, New_D); - - Next (D); - end loop; - end; + Append_To (Body_Decls, + Make_Implicit_Label_Declaration (Loc, + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Decl))), + Label_Construct => Empty)); + + Next (Decl); + end loop; end if; - pragma Assert (Present (Handled_Statement_Sequence (Ret_Node))); + pragma Assert (Present (Handled_Statement_Sequence (Ret_Stmt))); Proc_Body := Make_Subprogram_Body (Loc, - Specification => Copy_Separate_Tree (Proc_Spec), - Declarations => Body_Decl_List, + Specification => Copy_Subprogram_Spec (Proc_Spec), + Declarations => Body_Decls, Handled_Statement_Sequence => - Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node))); + New_Copy_Tree (Handled_Statement_Sequence (Ret_Stmt))); Set_Defining_Unit_Name (Specification (Proc_Body), Make_Defining_Identifier (Loc, Subp_Name)); @@ -2018,10 +2103,10 @@ package body Inline is -- Local variables - New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj); + New_Obj : constant Node_Id := Copy_Return_Object (Ret_Obj); Blk_Stmt : Node_Id; - Proc_Id : Entity_Id; Proc_Call : Node_Id; + Proc_Id : Entity_Id; -- Start of processing for Split_Unconstrained_Function @@ -2089,7 +2174,7 @@ package body Inline is New_Occurrence_Of (Defining_Identifier (New_Obj), Loc))))); - Rewrite (Ret_Node, Blk_Stmt); + Rewrite (Ret_Stmt, Blk_Stmt); end Split_Unconstrained_Function; -- Local variables @@ -2386,11 +2471,23 @@ package body Inline is -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit -- declaration). Does nothing if Exit_Lab already set. + procedure Make_Loop_Labels_Unique (HSS : Node_Id); + -- When compiling for CCG and performing front-end inlining, replace + -- loop names and references to them so that they do not conflict with + -- homographs in the current subprogram. + function Process_Formals (N : Node_Id) return Traverse_Result; -- Replace occurrence of a formal with the corresponding actual, or the -- thunk generated for it. Replace a return statement with an assignment -- to the target of the call, with appropriate conversions if needed. + function Process_Formals_In_Aspects (N : Node_Id) + return Traverse_Result; + -- Because aspects are linked indirectly to the rest of the tree, + -- replacement of formals appearing in aspect specifications must + -- be performed in a separate pass, using an instantiation of the + -- previous subprogram over aspect specifications reachable from N. + function Process_Sloc (Nod : Node_Id) return Traverse_Result; -- If the call being expanded is that of an internal subprogram, set the -- sloc of the generated block to that of the call itself, so that the @@ -2474,6 +2571,61 @@ package body Inline is end if; end Make_Exit_Label; + ----------------------------- + -- Make_Loop_Labels_Unique -- + ----------------------------- + + procedure Make_Loop_Labels_Unique (HSS : Node_Id) is + function Process_Loop (N : Node_Id) return Traverse_Result; + + ------------------ + -- Process_Loop -- + ------------------ + + function Process_Loop (N : Node_Id) return Traverse_Result is + Id : Entity_Id; + + begin + if Nkind (N) = N_Loop_Statement + and then Present (Identifier (N)) + then + -- Create new external name for loop and update the + -- corresponding entity. + + Id := Entity (Identifier (N)); + Set_Chars (Id, New_External_Name (Chars (Id), 'L', -1)); + Set_Chars (Identifier (N), Chars (Id)); + + elsif Nkind (N) = N_Exit_Statement + and then Present (Name (N)) + then + -- The exit statement must name an enclosing loop, whose name + -- has already been updated. + + Set_Chars (Name (N), Chars (Entity (Name (N)))); + end if; + + return OK; + end Process_Loop; + + procedure Update_Loop_Names is new Traverse_Proc (Process_Loop); + + -- Local variables + + Stmt : Node_Id; + + -- Start of processing for Make_Loop_Labels_Unique + + begin + if Modify_Tree_For_C then + Stmt := First (Statements (HSS)); + while Present (Stmt) loop + Update_Loop_Names (Stmt); + Next (Stmt); + end loop; + end if; + end Make_Loop_Labels_Unique; + --------------------- -- Process_Formals -- --------------------- @@ -2676,6 +2828,29 @@ package body Inline is procedure Replace_Formals is new Traverse_Proc (Process_Formals); + -------------------------------- + -- Process_Formals_In_Aspects -- + -------------------------------- + + function Process_Formals_In_Aspects (N : Node_Id) + return Traverse_Result + is + A : Node_Id; + begin + if Has_Aspects (N) then + A := First (Aspect_Specifications (N)); + while Present (A) loop + Replace_Formals (Expression (A)); + + Next (A); + end loop; + end if; + return OK; + end Process_Formals_In_Aspects; + + procedure Replace_Formals_In_Aspects is + new Traverse_Proc (Process_Formals_In_Aspects); + ------------------ -- Process_Sloc -- ------------------ @@ -2742,6 +2917,8 @@ package body Inline is Fst : constant Node_Id := First (Statements (HSS)); begin + Make_Loop_Labels_Unique (HSS); + -- Optimize simple case: function body is a single return statement, -- which has been expanded into an assignment. @@ -2829,6 +3006,8 @@ package body Inline is HSS : constant Node_Id := Handled_Statement_Sequence (Blk); begin + Make_Loop_Labels_Unique (HSS); + -- If there is a transient scope for N, this will be the scope of the -- actions for N, and the statements in Blk need to be within this -- scope. For example, they need to have visibility on the constant @@ -3484,6 +3663,7 @@ package body Inline is -- Attach block to tree before analysis and rewriting. Replace_Formals (Blk); + Replace_Formals_In_Aspects (Blk); Set_Parent (Blk, N); if GNATprove_Mode then diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index f5f6aa8..f8e9099 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -443,9 +443,12 @@ package body Layout is Set_RM_Size (E, Esize (E)); end if; - -- For array base types, set component size if object size of the + -- For array base types, set the component size if object size of the -- component type is known and is a small power of 2 (8, 16, 32, 64), - -- since this is what will always be used. + -- since this is what will always be used, except if a very large + -- alignment was specified and so Adjust_Esize_For_Alignment gave up + -- because, in this case, the object size is not a multiple of the + -- alignment and, therefore, cannot be the component size. if Ekind (E) = E_Array_Type and then Unknown_Component_Size (E) then declare @@ -458,6 +461,9 @@ package body Layout is if Present (CT) and then Is_Scalar_Type (CT) and then Known_Static_Esize (CT) + and then not (Known_Alignment (CT) + and then Alignment_In_Bits (CT) > + Standard_Long_Long_Integer_Size) then declare S : constant Uint := Esize (CT); diff --git a/gcc/ada/layout.ads b/gcc/ada/layout.ads index c38d529..81162c1 100644 --- a/gcc/ada/layout.ads +++ b/gcc/ada/layout.ads @@ -34,7 +34,7 @@ package Layout is -- The following procedures are called from Freeze, so all entities -- for types and objects that get frozen (which should be all such - -- entities which are seen by the back end) will get layed out by one + -- entities which are seen by the back end) will get laid out by one -- of these two procedures. procedure Layout_Type (E : Entity_Id); diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 319557e..ffd6a90 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -62,6 +62,63 @@ package body Lib.Writ is -- Local Subprograms -- ----------------------- + function Column (IS_Id : Invocation_Signature_Id) return Nat; + pragma Inline (Column); + -- Obtain attribute Column of an invocation signature with id IS_Id + + function Extra (IR_Id : Invocation_Relation_Id) return Name_Id; + pragma Inline (Extra); + -- Obtain attribute Extra of an invocation relation with id IR_Id + + function Invoker + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id; + pragma Inline (Invoker); + -- Obtain attribute Invoker of an invocation relation with id IR_Id + + function Kind + (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind; + pragma Inline (Kind); + -- Obtain attribute Kind of an invocation construct with id IC_Id + + function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind; + pragma Inline (Kind); + -- Obtain attribute Kind of an invocation relation with id IR_Id + + function Line (IS_Id : Invocation_Signature_Id) return Nat; + pragma Inline (Line); + -- Obtain attribute Line of an invocation signature with id IS_Id + + function Locations (IS_Id : Invocation_Signature_Id) return Name_Id; + pragma Inline (Locations); + -- Obtain attribute Locations of an invocation signature with id IS_Id + + function Name (IS_Id : Invocation_Signature_Id) return Name_Id; + pragma Inline (Name); + -- Obtain attribute Name of an invocation signature with id IS_Id + + function Placement + (IC_Id : Invocation_Construct_Id) return Body_Placement_Kind; + pragma Inline (Placement); + -- Obtain attribute Placement of an invocation construct with id IC_Id + + function Present (N_Id : Name_Id) return Boolean; + pragma Inline (Present); + -- Determine whether a name with id N_Id exists + + function Scope (IS_Id : Invocation_Signature_Id) return Name_Id; + pragma Inline (Scope); + -- Obtain attribute Scope of an invocation signature with id IS_Id + + function Signature + (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id; + pragma Inline (Signature); + -- Obtain attribute Signature of an invocation construct with id IC_Id + + function Target + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id; + pragma Inline (Target); + -- Obtain attribute Target of an invocation relation with id IR_Id + procedure Write_Unit_Name (N : Node_Id); -- Used to write out the unit name for R (pragma Restriction) lines -- for uses of Restriction (No_Dependence => unit-name). @@ -104,6 +161,16 @@ package body Lib.Writ is OA_Setting => 'O'); end Add_Preprocessing_Dependency; + ------------ + -- Column -- + ------------ + + function Column (IS_Id : Invocation_Signature_Id) return Nat is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Column; + end Column; + ------------------------------ -- Ensure_System_Dependency -- ------------------------------ @@ -185,6 +252,135 @@ package body Lib.Writ is end; end Ensure_System_Dependency; + ----------- + -- Extra -- + ----------- + + function Extra (IR_Id : Invocation_Relation_Id) return Name_Id is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Extra; + end Extra; + + ------------- + -- Invoker -- + ------------- + + function Invoker + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id + is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Invoker; + end Invoker; + + ---------- + -- Kind -- + ---------- + + function Kind + (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind + is + begin + pragma Assert (Present (IC_Id)); + return Invocation_Constructs.Table (IC_Id).Kind; + end Kind; + + ---------- + -- Kind -- + ---------- + + function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Kind; + end Kind; + + ---------- + -- Line -- + ---------- + + function Line (IS_Id : Invocation_Signature_Id) return Nat is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Line; + end Line; + + --------------- + -- Locations -- + --------------- + + function Locations (IS_Id : Invocation_Signature_Id) return Name_Id is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Locations; + end Locations; + + ---------- + -- Name -- + ---------- + + function Name (IS_Id : Invocation_Signature_Id) return Name_Id is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Name; + end Name; + + --------------- + -- Placement -- + --------------- + + function Placement + (IC_Id : Invocation_Construct_Id) return Body_Placement_Kind + is + begin + pragma Assert (Present (IC_Id)); + return Invocation_Constructs.Table (IC_Id).Placement; + end Placement; + + ------------- + -- Present -- + ------------- + + function Present (N_Id : Name_Id) return Boolean is + begin + return N_Id /= No_Name; + end Present; + + ----------- + -- Scope -- + ----------- + + function Scope (IS_Id : Invocation_Signature_Id) return Name_Id is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Scope; + end Scope; + + --------------- + -- Signature -- + --------------- + + function Signature + (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id + is + begin + pragma Assert (Present (IC_Id)); + return Invocation_Constructs.Table (IC_Id).Signature; + end Signature; + + ------------ + -- Target -- + ------------ + + function Target + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id + is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Target; + end Target; + --------------- -- Write_ALI -- --------------- @@ -245,6 +441,9 @@ package body Lib.Writ is -- this file (using Scan_ALI) and returns True. If no file exists, -- or the file is not up to date, then False is returned. + procedure Write_Invocation_Graph; + -- Write out the invocation graph + procedure Write_Unit_Information (Unit_Num : Unit_Number_Type); -- Write out the library information for one unit for which code is -- generated (includes unit line and with lines). @@ -434,6 +633,175 @@ package body Lib.Writ is end Update_Tables_From_ALI_File; ---------------------------- + -- Write_Invocation_Graph -- + ---------------------------- + + procedure Write_Invocation_Graph is + procedure Write_Invocation_Construct + (IC_Id : Invocation_Construct_Id); + pragma Inline (Write_Invocation_Construct); + -- Write invocation construct IC_Id to the ALI file + + procedure Write_Invocation_Relation (IR_Id : Invocation_Relation_Id); + pragma Inline (Write_Invocation_Relation); + -- Write invocation relation IR_Id to the ALI file + + procedure Write_Invocation_Signature + (IS_Id : Invocation_Signature_Id); + pragma Inline (Write_Invocation_Signature); + -- Write invocation signature IS_Id to the ALI file + + -------------------------------- + -- Write_Invocation_Construct -- + -------------------------------- + + procedure Write_Invocation_Construct + (IC_Id : Invocation_Construct_Id) + is + begin + -- G header + + Write_Info_Initiate ('G'); + Write_Info_Char (' '); + + -- line-kind + + Write_Info_Char + (Invocation_Graph_Line_Kind_To_Code (Invocation_Construct_Line)); + Write_Info_Char (' '); + + -- construct-kind + + Write_Info_Char (Invocation_Construct_Kind_To_Code (Kind (IC_Id))); + Write_Info_Char (' '); + + -- construct-body-placement + + Write_Info_Char (Body_Placement_Kind_To_Code (Placement (IC_Id))); + Write_Info_Char (' '); + + -- construct-signature + + Write_Invocation_Signature (Signature (IC_Id)); + Write_Info_EOL; + end Write_Invocation_Construct; + + ------------------------------- + -- Write_Invocation_Relation -- + ------------------------------- + + procedure Write_Invocation_Relation + (IR_Id : Invocation_Relation_Id) + is + begin + -- G header + + Write_Info_Initiate ('G'); + Write_Info_Char (' '); + + -- line-kind + + Write_Info_Char + (Invocation_Graph_Line_Kind_To_Code (Invocation_Relation_Line)); + Write_Info_Char (' '); + + -- relation-kind + + Write_Info_Char (Invocation_Kind_To_Code (Kind (IR_Id))); + Write_Info_Char (' '); + + -- (extra-name | "none") + + if Present (Extra (IR_Id)) then + Write_Info_Name (Extra (IR_Id)); + else + Write_Info_Str ("none"); + end if; + + Write_Info_Char (' '); + + -- invoker-signature + + Write_Invocation_Signature (Invoker (IR_Id)); + Write_Info_Char (' '); + + -- target-signature + + Write_Invocation_Signature (Target (IR_Id)); + + Write_Info_EOL; + end Write_Invocation_Relation; + + -------------------------------- + -- Write_Invocation_Signature -- + -------------------------------- + + procedure Write_Invocation_Signature + (IS_Id : Invocation_Signature_Id) + is + begin + -- [ + + Write_Info_Char ('['); + + -- name + + Write_Info_Name (Name (IS_Id)); + Write_Info_Char (' '); + + -- scope + + Write_Info_Name (Scope (IS_Id)); + Write_Info_Char (' '); + + -- line + + Write_Info_Nat (Line (IS_Id)); + Write_Info_Char (' '); + + -- column + + Write_Info_Nat (Column (IS_Id)); + Write_Info_Char (' '); + + -- (locations | "none") + + if Present (Locations (IS_Id)) then + Write_Info_Name (Locations (IS_Id)); + else + Write_Info_Str ("none"); + end if; + + -- ] + + Write_Info_Char (']'); + end Write_Invocation_Signature; + + -- Start of processing for Write_Invocation_Graph + + begin + -- First write out all invocation constructs declared within the + -- current unit. This ensures that when this invocation is read, + -- the invocation constructs are materialized before they are + -- referenced by invocation relations. + + for IC_Id in Invocation_Constructs.First .. + Invocation_Constructs.Last + loop + Write_Invocation_Construct (IC_Id); + end loop; + + -- Write out all invocation relations that originate from invocation + -- constructs delared in the current unit. + + for IR_Id in Invocation_Relations.First .. + Invocation_Relations.Last + loop + Write_Invocation_Relation (IR_Id); + end loop; + end Write_Invocation_Graph; + + ---------------------------- -- Write_Unit_Information -- ---------------------------- @@ -1618,6 +1986,10 @@ package body Lib.Writ is end loop; end; + -- Output the invocation graph + + Write_Invocation_Graph; + -- Output cross-references if Opt.Xref_Active then diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 34e2480..c17233a 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -846,6 +846,94 @@ package Lib.Writ is -- dependency checking, but must be present for proper interpretation -- of the cross-reference data. + -- ------------------------- + -- -- G Invocation Graph -- + -- ------------------------- + + -- An invocation graph line has the following format: + -- + -- G line-kind line-attributes + -- + -- Attribute line-kind is a Character which denotes the nature of the + -- line. Table ALI.Invocation_Graph_Line_Codes lists all legal values. + -- + -- Attribute line-attributes depends on the value of line-kind, and is + -- contents are described further below. + -- + -- An invocation signature uniquely identifies an invocation construct in + -- the ALI file namespace, and has the following format: + -- + -- [ name scope line column (locations | "none") ] + -- + -- Attribute name is a String which denotes the name of the construct + -- + -- Attribute scope is a String which denotes the qualified name of the + -- scope where the construct is declared. + -- + -- Attribute line is a Positive which denotes the line number where the + -- initial declaration of the construct appears. + -- + -- Attribute column is a Positive which denotes the column number where + -- the initial declaration of the construct appears. + -- + -- Attribute locations is a String which denotes the line and column + -- locations of all instances where the initial declaration of the + -- construct appears. + -- + -- When the line-kind denotes an invocation construct, line-attributes are + -- set as follows: + -- + -- construct-kind construct-body-placement construct-signature + -- + -- Attribute construct-kind is a Character which denotes the nature of + -- the construct. Table ALI.Invocation_Construct_Codes lists all legal + -- values. + -- + -- Attribute construct-body-placement is a Character which denotes the + -- placement of the construct's body within the unit. All legal values + -- are listed in table ALI.Body_Placement_Codes. + -- + -- Attribute construct-signature is the invocation signature of the + -- construct. + -- + -- When the line-kind denotes an invocation relation, line-attributes are + -- set as follows: + -- + -- relation-kind (extra-name | "none") invoker-signature + -- target-signature + -- + -- Attribute relation-kind is a Character which denotes the nature of + -- the relation. All legal values are listed in ALI.Invocation_Codes. + -- + -- Attribute extra-name is a String which denotes the name of an extra + -- entity used for error diagnostics. The value of extra-name depends + -- on the relation-kind as follows: + -- + -- Accept_Alternative - related entry + -- Access_Taken - related subprogram + -- Call - not present + -- Controlled_Adjustment - related controlled type + -- Controlled_Finalization - related controlled type + -- Controlled_Initialization - related controlled type + -- Default_Initial_Condition_Verification - related private type + -- Initial_Condition_Verification - not present + -- Instantiation - not present + -- Internal_Controlled_Adjustment - related controlled type + -- Internal_Controlled_Finalization - related controlled type + -- Internal_Controlled_Initialization - related controlled type + -- Invariant_Verification - related private type + -- Postcondition_Verification - related routine + -- Protected_Entry_Call - not present + -- Protected_Subprogram_Call - not present + -- Task_Activation - related task object + -- Task_Entry_Call - not present + -- Type_Initialization - related type + -- + -- Attribute invoker-signature is the invocation signature of the + -- invoker. + -- + -- Attribute target-signature is the invocation signature of the target + -------------------------- -- Cross-Reference Data -- -------------------------- diff --git a/gcc/ada/libgnat/a-calend.ads b/gcc/ada/libgnat/a-calend.ads index 139c5fc..1b782f0 100644 --- a/gcc/ada/libgnat/a-calend.ads +++ b/gcc/ada/libgnat/a-calend.ads @@ -61,19 +61,20 @@ is -- the result will contain all elapsed leap seconds since the start of -- Ada time until now. - function Year (Date : Time) return Year_Number with Global => null; - function Month (Date : Time) return Month_Number with Global => null; - function Day (Date : Time) return Day_Number with Global => null; - function Seconds (Date : Time) return Day_Duration with Global => null; + function Year (Date : Time) return Year_Number; + function Month (Date : Time) return Month_Number; + function Day (Date : Time) return Day_Number; + function Seconds (Date : Time) return Day_Duration; + -- SPARK Note: These routines, just like Split and Time_Of below, might use + -- the OS-specific timezone database that is typically stored in a file. + -- This side effect needs to be modeled, so there is no Global => null. procedure Split (Date : Time; Year : out Year_Number; Month : out Month_Number; Day : out Day_Number; - Seconds : out Day_Duration) - with - Global => null; + Seconds : out Day_Duration); -- Break down a time value into its date components set in the current -- time zone. If Split is called on a time value created using Ada 2005 -- Time_Of in some arbitrary time zone, the input value will always be @@ -83,9 +84,7 @@ is (Year : Year_Number; Month : Month_Number; Day : Day_Number; - Seconds : Day_Duration := 0.0) return Time - with - Global => null; + Seconds : Day_Duration := 0.0) return Time; -- GNAT Note: Normally when procedure Split is called on a Time value -- result of a call to function Time_Of, the out parameters of procedure -- Split are identical to the in parameters of function Time_Of. However, diff --git a/gcc/ada/libgnat/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb index c47f6ff..84dcc30 100644 --- a/gcc/ada/libgnat/g-dynhta.adb +++ b/gcc/ada/libgnat/g-dynhta.adb @@ -34,6 +34,34 @@ with Ada.Unchecked_Deallocation; package body GNAT.Dynamic_HTables is ------------------- + -- Hash_Two_Keys -- + ------------------- + + function Hash_Two_Keys + (Left : Bucket_Range_Type; + Right : Bucket_Range_Type) return Bucket_Range_Type + is + Half : constant := 2 ** (Bucket_Range_Type'Size / 2); + Mask : constant := Half - 1; + + begin + -- The hash is obtained in the following manner: + -- + -- 1) The low bits of Left are obtained, then shifted over to the high + -- bits position. + -- + -- 2) The low bits of Right are obtained + -- + -- The results from 1) and 2) are or-ed to produce a value within the + -- range of Bucket_Range_Type. + + return + ((Left and Mask) * Half) + or + (Right and Mask); + end Hash_Two_Keys; + + ------------------- -- Static_HTable -- ------------------- @@ -364,11 +392,11 @@ package body GNAT.Dynamic_HTables is end Set_Next; end Simple_HTable; - -------------------- - -- Dynamic_HTable -- - -------------------- + ------------------------- + -- Dynamic_Hash_Tables -- + ------------------------- - package body Dynamic_HTable is + package body Dynamic_Hash_Tables is Minimum_Size : constant Bucket_Range_Type := 8; -- Minimum size of the buckets @@ -382,6 +410,12 @@ package body GNAT.Dynamic_HTables is -- Maximum safe size for hash table expansion. Beyond this size, an -- expansion will overflow the buckets. + procedure Delete_Node + (T : Dynamic_Hash_Table; + Nod : Node_Ptr); + pragma Inline (Delete_Node); + -- Detach and delete node Nod from table T + procedure Destroy_Buckets (Bkts : Bucket_Table_Ptr); pragma Inline (Destroy_Buckets); -- Destroy all nodes within buckets Bkts @@ -394,12 +428,12 @@ package body GNAT.Dynamic_HTables is pragma Inline (Ensure_Circular); -- Ensure that dummy head Head is circular with respect to itself - procedure Ensure_Created (T : Instance); + procedure Ensure_Created (T : Dynamic_Hash_Table); pragma Inline (Ensure_Created); -- Verify that hash table T is created. Raise Not_Created if this is not -- the case. - procedure Ensure_Unlocked (T : Instance); + procedure Ensure_Unlocked (T : Dynamic_Hash_Table); pragma Inline (Ensure_Unlocked); -- Verify that hash table T is unlocked. Raise Iterated if this is not -- the case. @@ -418,7 +452,7 @@ package body GNAT.Dynamic_HTables is -- otherwise return null. procedure First_Valid_Node - (T : Instance; + (T : Dynamic_Hash_Table; Low_Bkt : Bucket_Range_Type; High_Bkt : Bucket_Range_Type; Idx : out Bucket_Range_Type; @@ -433,7 +467,8 @@ package body GNAT.Dynamic_HTables is new Ada.Unchecked_Deallocation (Bucket_Table, Bucket_Table_Ptr); procedure Free is - new Ada.Unchecked_Deallocation (Hash_Table, Instance); + new Ada.Unchecked_Deallocation + (Dynamic_Hash_Table_Attributes, Dynamic_Hash_Table); procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr); @@ -447,15 +482,17 @@ package body GNAT.Dynamic_HTables is -- Determine whether node Nod is non-null and does not refer to dummy -- head Head, thus making it valid. - function Load_Factor (T : Instance) return Threshold_Type; + function Load_Factor (T : Dynamic_Hash_Table) return Threshold_Type; pragma Inline (Load_Factor); -- Calculate the load factor of hash table T - procedure Lock (T : Instance); + procedure Lock (T : Dynamic_Hash_Table); pragma Inline (Lock); -- Lock all mutation functionality of hash table T - procedure Mutate_And_Rehash (T : Instance; Size : Bucket_Range_Type); + procedure Mutate_And_Rehash + (T : Dynamic_Hash_Table; + Size : Bucket_Range_Type); pragma Inline (Mutate_And_Rehash); -- Replace the buckets of hash table T with a new set of buckets of size -- Size. Rehash all key-value pairs from the old to the new buckets. @@ -464,21 +501,55 @@ package body GNAT.Dynamic_HTables is pragma Inline (Prepend); -- Insert node Nod immediately after dummy head Head - procedure Unlock (T : Instance); + function Present (Bkts : Bucket_Table_Ptr) return Boolean; + pragma Inline (Present); + -- Determine whether buckets Bkts exist + + function Present (Nod : Node_Ptr) return Boolean; + pragma Inline (Present); + -- Determine whether node Nod exists + + procedure Unlock (T : Dynamic_Hash_Table); pragma Inline (Unlock); -- Unlock all mutation functionality of hash table T + -------------- + -- Contains -- + -------------- + + function Contains + (T : Dynamic_Hash_Table; + Key : Key_Type) return Boolean + is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (T); + + -- Obtain the dummy head of the bucket which should house the + -- key-value pair. + + Head := Find_Bucket (T.Buckets, Key); + + -- Try to find a node in the bucket which matches the key + + Nod := Find_Node (Head, Key); + + return Is_Valid (Nod, Head); + end Contains; + ------------ -- Create -- ------------ - function Create (Initial_Size : Positive) return Instance is + function Create (Initial_Size : Positive) return Dynamic_Hash_Table is Size : constant Bucket_Range_Type := Bucket_Range_Type'Max (Bucket_Range_Type (Initial_Size), Minimum_Size); -- Ensure that the buckets meet a minimum size - T : constant Instance := new Hash_Table; + T : constant Dynamic_Hash_Table := new Dynamic_Hash_Table_Attributes; begin T.Buckets := new Bucket_Table (0 .. Size - 1); @@ -491,7 +562,41 @@ package body GNAT.Dynamic_HTables is -- Delete -- ------------ - procedure Delete (T : Instance; Key : Key_Type) is + procedure Delete + (T : Dynamic_Hash_Table; + Key : Key_Type) + is + Head : Node_Ptr; + Nod : Node_Ptr; + + begin + Ensure_Created (T); + Ensure_Unlocked (T); + + -- Obtain the dummy head of the bucket which should house the + -- key-value pair. + + Head := Find_Bucket (T.Buckets, Key); + + -- Try to find a node in the bucket which matches the key + + Nod := Find_Node (Head, Key); + + -- If such a node exists, remove it from the bucket and deallocate it + + if Is_Valid (Nod, Head) then + Delete_Node (T, Nod); + end if; + end Delete; + + ----------------- + -- Delete_Node -- + ----------------- + + procedure Delete_Node + (T : Dynamic_Hash_Table; + Nod : Node_Ptr) + is procedure Compress; pragma Inline (Compress); -- Determine whether hash table T requires compression, and if so, @@ -502,8 +607,8 @@ package body GNAT.Dynamic_HTables is -------------- procedure Compress is - pragma Assert (T /= null); - pragma Assert (T.Buckets /= null); + pragma Assert (Present (T)); + pragma Assert (Present (T.Buckets)); Old_Size : constant Bucket_Range_Type := T.Buckets'Length; @@ -520,47 +625,33 @@ package body GNAT.Dynamic_HTables is -- Local variables - Head : Node_Ptr; - Nod : Node_Ptr; + Ref : Node_Ptr := Nod; - -- Start of processing for Delete + -- Start of processing for Delete_Node begin - Ensure_Created (T); - Ensure_Unlocked (T); - - -- Obtain the dummy head of the bucket which should house the - -- key-value pair. - - Head := Find_Bucket (T.Buckets, Key); - - -- Try to find a node in the bucket which matches the key + pragma Assert (Present (Ref)); + pragma Assert (Present (T)); - Nod := Find_Node (Head, Key); - - -- If such a node exists, remove it from the bucket and deallocate it + Detach (Ref); + Free (Ref); - if Is_Valid (Nod, Head) then - Detach (Nod); - Free (Nod); + -- The number of key-value pairs is updated when the hash table + -- contains a valid node which represents the pair. - -- The number of key-value pairs is updated when the hash table - -- contains a valid node which represents the pair. + T.Pairs := T.Pairs - 1; - T.Pairs := T.Pairs - 1; + -- Compress the hash table if the load factor drops below the value + -- of Compression_Threshold. - -- Compress the hash table if the load factor drops below - -- Compression_Threshold. - - Compress; - end if; - end Delete; + Compress; + end Delete_Node; ------------- -- Destroy -- ------------- - procedure Destroy (T : in out Instance) is + procedure Destroy (T : in out Dynamic_Hash_Table) is begin Ensure_Created (T); Ensure_Unlocked (T); @@ -594,6 +685,10 @@ package body GNAT.Dynamic_HTables is while Is_Valid (Head.Next, Head) loop Nod := Head.Next; + -- Invoke the value destructor before deallocating the node + + Destroy_Value (Nod.Value); + Detach (Nod); Free (Nod); end loop; @@ -602,7 +697,7 @@ package body GNAT.Dynamic_HTables is -- Start of processing for Destroy_Buckets begin - pragma Assert (Bkts /= null); + pragma Assert (Present (Bkts)); for Scan_Idx in Bkts'Range loop Destroy_Bucket (Bkts (Scan_Idx)'Access); @@ -614,17 +709,17 @@ package body GNAT.Dynamic_HTables is ------------ procedure Detach (Nod : Node_Ptr) is - pragma Assert (Nod /= null); + pragma Assert (Present (Nod)); Next : constant Node_Ptr := Nod.Next; Prev : constant Node_Ptr := Nod.Prev; begin - pragma Assert (Next /= null); - pragma Assert (Prev /= null); + pragma Assert (Present (Next)); + pragma Assert (Present (Prev)); - Prev.Next := Next; - Next.Prev := Prev; + Prev.Next := Next; -- Prev ---> Next + Next.Prev := Prev; -- Prev <--> Next Nod.Next := null; Nod.Prev := null; @@ -635,10 +730,10 @@ package body GNAT.Dynamic_HTables is --------------------- procedure Ensure_Circular (Head : Node_Ptr) is - pragma Assert (Head /= null); + pragma Assert (Present (Head)); begin - if Head.Next = null and then Head.Prev = null then + if not Present (Head.Next) and then not Present (Head.Prev) then Head.Next := Head; Head.Prev := Head; end if; @@ -648,9 +743,9 @@ package body GNAT.Dynamic_HTables is -- Ensure_Created -- -------------------- - procedure Ensure_Created (T : Instance) is + procedure Ensure_Created (T : Dynamic_Hash_Table) is begin - if T = null then + if not Present (T) then raise Not_Created; end if; end Ensure_Created; @@ -659,9 +754,9 @@ package body GNAT.Dynamic_HTables is -- Ensure_Unlocked -- --------------------- - procedure Ensure_Unlocked (T : Instance) is + procedure Ensure_Unlocked (T : Dynamic_Hash_Table) is begin - pragma Assert (T /= null); + pragma Assert (Present (T)); -- The hash table has at least one outstanding iterator @@ -678,7 +773,7 @@ package body GNAT.Dynamic_HTables is (Bkts : Bucket_Table_Ptr; Key : Key_Type) return Node_Ptr is - pragma Assert (Bkts /= null); + pragma Assert (Present (Bkts)); Idx : constant Bucket_Range_Type := Hash (Key) mod Bkts'Length; @@ -691,7 +786,7 @@ package body GNAT.Dynamic_HTables is --------------- function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr is - pragma Assert (Head /= null); + pragma Assert (Present (Head)); Nod : Node_Ptr; @@ -716,7 +811,7 @@ package body GNAT.Dynamic_HTables is ---------------------- procedure First_Valid_Node - (T : Instance; + (T : Dynamic_Hash_Table; Low_Bkt : Bucket_Range_Type; High_Bkt : Bucket_Range_Type; Idx : out Bucket_Range_Type; @@ -725,8 +820,8 @@ package body GNAT.Dynamic_HTables is Head : Node_Ptr; begin - pragma Assert (T /= null); - pragma Assert (T.Buckets /= null); + pragma Assert (Present (T)); + pragma Assert (Present (T.Buckets)); -- Assume that no valid node exists @@ -754,7 +849,10 @@ package body GNAT.Dynamic_HTables is -- Get -- --------- - function Get (T : Instance; Key : Key_Type) return Value_Type is + function Get + (T : Dynamic_Hash_Table; + Key : Key_Type) return Value_Type + is Head : Node_Ptr; Nod : Node_Ptr; @@ -784,11 +882,11 @@ package body GNAT.Dynamic_HTables is -------------- function Has_Next (Iter : Iterator) return Boolean is - Is_OK : constant Boolean := Is_Valid (Iter); - T : constant Instance := Iter.Table; + Is_OK : constant Boolean := Is_Valid (Iter); + T : constant Dynamic_Hash_Table := Iter.Table; begin - pragma Assert (T /= null); + pragma Assert (Present (T)); -- The iterator is no longer valid which indicates that it has been -- exhausted. Unlock all mutation functionality of the hash table @@ -805,7 +903,7 @@ package body GNAT.Dynamic_HTables is -- Is_Empty -- -------------- - function Is_Empty (T : Instance) return Boolean is + function Is_Empty (T : Dynamic_Hash_Table) return Boolean is begin Ensure_Created (T); @@ -821,7 +919,7 @@ package body GNAT.Dynamic_HTables is -- The invariant of Iterate and Next ensures that the iterator always -- refers to a valid node if there exists one. - return Iter.Nod /= null; + return Present (Iter.Curr_Nod); end Is_Valid; -------------- @@ -833,19 +931,19 @@ package body GNAT.Dynamic_HTables is -- A node is valid if it is non-null, and does not refer to the dummy -- head of some bucket. - return Nod /= null and then Nod /= Head; + return Present (Nod) and then Nod /= Head; end Is_Valid; ------------- -- Iterate -- ------------- - function Iterate (T : Instance) return Iterator is + function Iterate (T : Dynamic_Hash_Table) return Iterator is Iter : Iterator; begin Ensure_Created (T); - pragma Assert (T.Buckets /= null); + pragma Assert (Present (T.Buckets)); -- Initialize the iterator to reference the first valid node in -- the full range of hash table buckets. If no such node exists, @@ -856,8 +954,8 @@ package body GNAT.Dynamic_HTables is (T => T, Low_Bkt => T.Buckets'First, High_Bkt => T.Buckets'Last, - Idx => Iter.Idx, - Nod => Iter.Nod); + Idx => Iter.Curr_Idx, + Nod => Iter.Curr_Nod); -- Associate the iterator with the hash table to allow for future -- mutation functionality unlocking. @@ -876,9 +974,9 @@ package body GNAT.Dynamic_HTables is -- Load_Factor -- ----------------- - function Load_Factor (T : Instance) return Threshold_Type is - pragma Assert (T /= null); - pragma Assert (T.Buckets /= null); + function Load_Factor (T : Dynamic_Hash_Table) return Threshold_Type is + pragma Assert (Present (T)); + pragma Assert (Present (T.Buckets)); begin -- The load factor is the ratio of key-value pairs to buckets @@ -890,7 +988,7 @@ package body GNAT.Dynamic_HTables is -- Lock -- ---------- - procedure Lock (T : Instance) is + procedure Lock (T : Dynamic_Hash_Table) is begin -- The hash table may be locked multiple times if multiple iterators -- are operating over it. @@ -902,7 +1000,10 @@ package body GNAT.Dynamic_HTables is -- Mutate_And_Rehash -- ----------------------- - procedure Mutate_And_Rehash (T : Instance; Size : Bucket_Range_Type) is + procedure Mutate_And_Rehash + (T : Dynamic_Hash_Table; + Size : Bucket_Range_Type) + is procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr); pragma Inline (Rehash); -- Remove all nodes from buckets From and rehash them into buckets To @@ -922,8 +1023,8 @@ package body GNAT.Dynamic_HTables is procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr) is begin - pragma Assert (From /= null); - pragma Assert (To /= null); + pragma Assert (Present (From)); + pragma Assert (Present (To)); for Scan_Idx in From'Range loop Rehash_Bucket (From (Scan_Idx)'Access, To); @@ -935,7 +1036,7 @@ package body GNAT.Dynamic_HTables is ------------------- procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr) is - pragma Assert (Head /= null); + pragma Assert (Present (Head)); Nod : Node_Ptr; @@ -955,7 +1056,7 @@ package body GNAT.Dynamic_HTables is ----------------- procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr) is - pragma Assert (Nod /= null); + pragma Assert (Present (Nod)); Head : Node_Ptr; @@ -982,7 +1083,7 @@ package body GNAT.Dynamic_HTables is -- Start of processing for Mutate_And_Rehash begin - pragma Assert (T /= null); + pragma Assert (Present (T)); Old_Bkts := T.Buckets; T.Buckets := new Bucket_Table (0 .. Size - 1); @@ -1000,13 +1101,13 @@ package body GNAT.Dynamic_HTables is procedure Next (Iter : in out Iterator; Key : out Key_Type) is Is_OK : constant Boolean := Is_Valid (Iter); - Saved : constant Node_Ptr := Iter.Nod; - T : constant Instance := Iter.Table; + Saved : constant Node_Ptr := Iter.Curr_Nod; + T : constant Dynamic_Hash_Table := Iter.Table; Head : Node_Ptr; begin - pragma Assert (T /= null); - pragma Assert (T.Buckets /= null); + pragma Assert (Present (T)); + pragma Assert (Present (T.Buckets)); -- The iterator is no longer valid which indicates that it has been -- exhausted. Unlock all mutation functionality of the hash table as @@ -1019,21 +1120,21 @@ package body GNAT.Dynamic_HTables is -- Advance to the next node along the same bucket - Iter.Nod := Iter.Nod.Next; - Head := T.Buckets (Iter.Idx)'Access; + Iter.Curr_Nod := Iter.Curr_Nod.Next; + Head := T.Buckets (Iter.Curr_Idx)'Access; -- If the new node is no longer valid, then this indicates that the -- current bucket has been exhausted. Advance to the next valid node -- within the remaining range of buckets. If no such node exists, the -- iterator is left in a state which does not allow it to advance. - if not Is_Valid (Iter.Nod, Head) then + if not Is_Valid (Iter.Curr_Nod, Head) then First_Valid_Node - (T => T, - Low_Bkt => Iter.Idx + 1, + (T => T, + Low_Bkt => Iter.Curr_Idx + 1, High_Bkt => T.Buckets'Last, - Idx => Iter.Idx, - Nod => Iter.Nod); + Idx => Iter.Curr_Idx, + Nod => Iter.Curr_Nod); end if; Key := Saved.Key; @@ -1044,8 +1145,8 @@ package body GNAT.Dynamic_HTables is ------------- procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr) is - pragma Assert (Nod /= null); - pragma Assert (Head /= null); + pragma Assert (Present (Nod)); + pragma Assert (Present (Head)); Next : constant Node_Ptr := Head.Next; @@ -1057,11 +1158,42 @@ package body GNAT.Dynamic_HTables is Nod.Prev := Head; end Prepend; + ------------- + -- Present -- + ------------- + + function Present (Bkts : Bucket_Table_Ptr) return Boolean is + begin + return Bkts /= null; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (Nod : Node_Ptr) return Boolean is + begin + return Nod /= null; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (T : Dynamic_Hash_Table) return Boolean is + begin + return T /= Nil; + end Present; + --------- -- Put -- --------- - procedure Put (T : Instance; Key : Key_Type; Value : Value_Type) is + procedure Put + (T : Dynamic_Hash_Table; + Key : Key_Type; + Value : Value_Type) + is procedure Expand; pragma Inline (Expand); -- Determine whether hash table T requires expansion, and if so, @@ -1078,8 +1210,8 @@ package body GNAT.Dynamic_HTables is ------------ procedure Expand is - pragma Assert (T /= null); - pragma Assert (T.Buckets /= null); + pragma Assert (Present (T)); + pragma Assert (Present (T.Buckets)); Old_Size : constant Bucket_Range_Type := T.Buckets'Length; @@ -1099,7 +1231,7 @@ package body GNAT.Dynamic_HTables is ------------------------ procedure Prepend_Or_Replace (Head : Node_Ptr) is - pragma Assert (Head /= null); + pragma Assert (Present (Head)); Nod : Node_Ptr; @@ -1166,7 +1298,7 @@ package body GNAT.Dynamic_HTables is -- Reset -- ----------- - procedure Reset (T : Instance) is + procedure Reset (T : Dynamic_Hash_Table) is begin Ensure_Created (T); Ensure_Unlocked (T); @@ -1186,7 +1318,7 @@ package body GNAT.Dynamic_HTables is -- Size -- ---------- - function Size (T : Instance) return Natural is + function Size (T : Dynamic_Hash_Table) return Natural is begin Ensure_Created (T); @@ -1197,13 +1329,13 @@ package body GNAT.Dynamic_HTables is -- Unlock -- ------------ - procedure Unlock (T : Instance) is + procedure Unlock (T : Dynamic_Hash_Table) is begin -- The hash table may be locked multiple times if multiple iterators -- are operating over it. T.Iterators := T.Iterators - 1; end Unlock; - end Dynamic_HTable; + end Dynamic_Hash_Tables; end GNAT.Dynamic_HTables; diff --git a/gcc/ada/libgnat/g-dynhta.ads b/gcc/ada/libgnat/g-dynhta.ads index 0f81d72..107c4c0 100644 --- a/gcc/ada/libgnat/g-dynhta.ads +++ b/gcc/ada/libgnat/g-dynhta.ads @@ -50,6 +50,12 @@ pragma Compiler_Unit_Warning; package GNAT.Dynamic_HTables is + function Hash_Two_Keys + (Left : Bucket_Range_Type; + Right : Bucket_Range_Type) return Bucket_Range_Type; + pragma Inline (Hash_Two_Keys); + -- Obtain the hash value of keys Left and Right + ------------------- -- Static_HTable -- ------------------- @@ -258,16 +264,16 @@ package GNAT.Dynamic_HTables is Nil : constant Instance := Instance (Tab.Nil); end Simple_HTable; - -------------------- - -- Dynamic_HTable -- - -------------------- + ------------------------- + -- Dynamic_Hash_Tables -- + ------------------------- -- The following package offers a hash table abstraction with the following -- characteristics: -- - -- * Dynamic resizing based on load factor. - -- * Creation of multiple instances, of different sizes. - -- * Iterable keys. + -- * Dynamic resizing based on load factor + -- * Creation of multiple instances, of different sizes + -- * Iterable keys -- -- This type of hash table is best used in scenarios where the size of the -- key set is not known. The dynamic resizing aspect allows for performance @@ -275,7 +281,7 @@ package GNAT.Dynamic_HTables is -- -- The following use pattern must be employed when operating this table: -- - -- Table : Instance := Create (<some size>); + -- Table : Dynamic_Hash_Table := Create (<some size>); -- -- <various operations> -- @@ -327,10 +333,13 @@ package GNAT.Dynamic_HTables is (Left : Key_Type; Right : Key_Type) return Boolean; + with procedure Destroy_Value (Val : in out Value_Type); + -- Value destructor + with function Hash (Key : Key_Type) return Bucket_Range_Type; -- Map an arbitrary key into the range of buckets - package Dynamic_HTable is + package Dynamic_Hash_Tables is ---------------------- -- Table operations -- @@ -339,34 +348,49 @@ package GNAT.Dynamic_HTables is -- The following type denotes a hash table handle. Each instance must be -- created using routine Create. - type Instance is private; - Nil : constant Instance; + type Dynamic_Hash_Table is private; + Nil : constant Dynamic_Hash_Table; - function Create (Initial_Size : Positive) return Instance; + function Contains + (T : Dynamic_Hash_Table; + Key : Key_Type) return Boolean; + -- Determine whether key Key exists in hash table T + + function Create (Initial_Size : Positive) return Dynamic_Hash_Table; -- Create a new table with bucket capacity Initial_Size. This routine -- must be called at the start of a hash table's lifetime. - procedure Delete (T : Instance; Key : Key_Type); + procedure Delete + (T : Dynamic_Hash_Table; + Key : Key_Type); -- Delete the value which corresponds to key Key from hash table T. The -- routine has no effect if the value is not present in the hash table. -- This action will raise Iterated if the hash table has outstanding -- iterators. If the load factor drops below Compression_Threshold, the -- size of the buckets is decreased by Copression_Factor. - procedure Destroy (T : in out Instance); + procedure Destroy (T : in out Dynamic_Hash_Table); -- Destroy the contents of hash table T, rendering it unusable. This -- routine must be called at the end of a hash table's lifetime. This -- action will raise Iterated if the hash table has outstanding -- iterators. - function Get (T : Instance; Key : Key_Type) return Value_Type; + function Get + (T : Dynamic_Hash_Table; + Key : Key_Type) return Value_Type; -- Obtain the value which corresponds to key Key from hash table T. If -- the value does not exist, return No_Value. - function Is_Empty (T : Instance) return Boolean; + function Is_Empty (T : Dynamic_Hash_Table) return Boolean; -- Determine whether hash table T is empty - procedure Put (T : Instance; Key : Key_Type; Value : Value_Type); + function Present (T : Dynamic_Hash_Table) return Boolean; + -- Determine whether hash table T exists + + procedure Put + (T : Dynamic_Hash_Table; + Key : Key_Type; + Value : Value_Type); -- Associate value Value with key Key in hash table T. If the table -- already contains a mapping of the same key to a previous value, the -- previous value is overwritten. This action will raise Iterated if @@ -374,12 +398,12 @@ package GNAT.Dynamic_HTables is -- over Expansion_Threshold, the size of the buckets is increased by -- Expansion_Factor. - procedure Reset (T : Instance); + procedure Reset (T : Dynamic_Hash_Table); -- Destroy the contents of hash table T, and reset it to its initial -- created state. This action will raise Iterated if the hash table -- has outstanding iterators. - function Size (T : Instance) return Natural; + function Size (T : Dynamic_Hash_Table) return Natural; -- Obtain the number of key-value pairs in hash table T ------------------------- @@ -401,15 +425,15 @@ package GNAT.Dynamic_HTables is type Iterator is private; - function Iterate (T : Instance) return Iterator; - -- Obtain an iterator over the keys of hash table T. This action locks - -- all mutation functionality of the associated hash table. - function Has_Next (Iter : Iterator) return Boolean; -- Determine whether iterator Iter has more keys to examine. If the -- iterator has been exhausted, restore all mutation functionality of -- the associated hash table. + function Iterate (T : Dynamic_Hash_Table) return Iterator; + -- Obtain an iterator over the keys of hash table T. This action locks + -- all mutation functionality of the associated hash table. + procedure Next (Iter : in out Iterator; Key : out Key_Type); -- Return the current key referenced by iterator Iter and advance to -- the next available key. If the iterator has been exhausted and @@ -455,7 +479,7 @@ package GNAT.Dynamic_HTables is -- The following type represents a hash table - type Hash_Table is record + type Dynamic_Hash_Table_Attributes is record Buckets : Bucket_Table_Ptr := null; -- Reference to the compressing / expanding buckets @@ -469,25 +493,25 @@ package GNAT.Dynamic_HTables is -- Number of key-value pairs in the buckets end record; - type Instance is access Hash_Table; - Nil : constant Instance := null; + type Dynamic_Hash_Table is access Dynamic_Hash_Table_Attributes; + Nil : constant Dynamic_Hash_Table := null; -- The following type represents a key iterator type Iterator is record - Idx : Bucket_Range_Type := 0; + Curr_Idx : Bucket_Range_Type := 0; -- Index of the current bucket being examined. This index is always -- kept within the range of the buckets. - Nod : Node_Ptr := null; + Curr_Nod : Node_Ptr := null; -- Reference to the current node being examined within the current -- bucket. The invariant of the iterator requires that this field -- always point to a valid node. A value of null indicates that the -- iterator is exhausted. - Table : Instance := null; + Table : Dynamic_Hash_Table := null; -- Reference to the associated hash table end record; - end Dynamic_HTable; + end Dynamic_Hash_Tables; end GNAT.Dynamic_HTables; diff --git a/gcc/ada/libgnat/g-graphs.adb b/gcc/ada/libgnat/g-graphs.adb new file mode 100644 index 0000000..1049641 --- /dev/null +++ b/gcc/ada/libgnat/g-graphs.adb @@ -0,0 +1,1491 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . G R A P H S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018-2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body GNAT.Graphs is + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Sequence_Next_Component return Component_Id; + -- Produce the next handle for a component. The handle is guaranteed to be + -- unique across all graphs. + + -------------------- + -- Directed_Graph -- + -------------------- + + package body Directed_Graphs is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Add_Component + (G : Directed_Graph; + Comp : Component_Id; + Vertices : Vertex_List.Doubly_Linked_List); + pragma Inline (Add_Component); + -- Add component Comp which houses vertices Vertices to graph G + + procedure Ensure_Created (G : Directed_Graph); + pragma Inline (Ensure_Created); + -- Verify that graph G is created. Raise Not_Created if this is not the + -- case. + + procedure Ensure_Not_Present + (G : Directed_Graph; + E : Edge_Id); + pragma Inline (Ensure_Not_Present); + -- Verify that graph G lacks edge E. Raise Duplicate_Edge if this is not + -- the case. + + procedure Ensure_Not_Present + (G : Directed_Graph; + V : Vertex_Id); + pragma Inline (Ensure_Not_Present); + -- Verify that graph G lacks vertex V. Raise Duplicate_Vertex if this is + -- not the case. + + procedure Ensure_Present + (G : Directed_Graph; + Comp : Component_Id); + pragma Inline (Ensure_Present); + -- Verify that component Comp exists in graph G. Raise Missing_Component + -- if this is not the case. + + procedure Ensure_Present + (G : Directed_Graph; + E : Edge_Id); + pragma Inline (Ensure_Present); + -- Verify that edge E is present in graph G. Raise Missing_Edge if this + -- is not the case. + + procedure Ensure_Present + (G : Directed_Graph; + V : Vertex_Id); + pragma Inline (Ensure_Present); + -- Verify that vertex V is present in graph G. Raise Missing_Vertex if + -- this is not the case. + + procedure Free is + new Ada.Unchecked_Deallocation + (Directed_Graph_Attributes, Directed_Graph); + + function Get_Component_Attributes + (G : Directed_Graph; + Comp : Component_Id) return Component_Attributes; + pragma Inline (Get_Component_Attributes); + -- Obtain the attributes of component Comp of graph G + + function Get_Edge_Attributes + (G : Directed_Graph; + E : Edge_Id) return Edge_Attributes; + pragma Inline (Get_Edge_Attributes); + -- Obtain the attributes of edge E of graph G + + function Get_Vertex_Attributes + (G : Directed_Graph; + V : Vertex_Id) return Vertex_Attributes; + pragma Inline (Get_Vertex_Attributes); + -- Obtain the attributes of vertex V of graph G + + function Get_Outgoing_Edges + (G : Directed_Graph; + V : Vertex_Id) return Edge_Set.Membership_Set; + pragma Inline (Get_Outgoing_Edges); + -- Obtain the Outgoing_Edges attribute of vertex V of graph G + + function Get_Vertices + (G : Directed_Graph; + Comp : Component_Id) return Vertex_List.Doubly_Linked_List; + pragma Inline (Get_Vertices); + -- Obtain the Vertices attribute of component Comp of graph G + + procedure Set_Component + (G : Directed_Graph; + V : Vertex_Id; + Val : Component_Id); + pragma Inline (Set_Component); + -- Set attribute Component of vertex V of graph G to value Val + + procedure Set_Outgoing_Edges + (G : Directed_Graph; + V : Vertex_Id; + Val : Edge_Set.Membership_Set); + pragma Inline (Set_Outgoing_Edges); + -- Set attribute Outgoing_Edges of vertex V of graph G to value Val + + procedure Set_Vertex_Attributes + (G : Directed_Graph; + V : Vertex_Id; + Val : Vertex_Attributes); + pragma Inline (Set_Vertex_Attributes); + -- Set the attributes of vertex V of graph G to value Val + + ------------------- + -- Add_Component -- + ------------------- + + procedure Add_Component + (G : Directed_Graph; + Comp : Component_Id; + Vertices : Vertex_List.Doubly_Linked_List) + is + begin + pragma Assert (Present (G)); + + -- Add the component to the set of all components in the graph + + Component_Map.Put + (T => G.Components, + Key => Comp, + Value => (Vertices => Vertices)); + end Add_Component; + + -------------- + -- Add_Edge -- + -------------- + + procedure Add_Edge + (G : Directed_Graph; + E : Edge_Id; + Source : Vertex_Id; + Destination : Vertex_Id) + is + begin + Ensure_Created (G); + Ensure_Not_Present (G, E); + Ensure_Present (G, Source); + Ensure_Present (G, Destination); + + -- Add the edge to the set of all edges in the graph + + Edge_Map.Put + (T => G.All_Edges, + Key => E, + Value => + (Destination => Destination, + Source => Source)); + + -- Associate the edge with its source vertex which effectively "owns" + -- the edge. + + Edge_Set.Insert + (S => Get_Outgoing_Edges (G, Source), + Elem => E); + end Add_Edge; + + ---------------- + -- Add_Vertex -- + ---------------- + + procedure Add_Vertex + (G : Directed_Graph; + V : Vertex_Id) + is + begin + Ensure_Created (G); + Ensure_Not_Present (G, V); + + -- Add the vertex to the set of all vertices in the graph + + Vertex_Map.Put + (T => G.All_Vertices, + Key => V, + Value => + (Component => No_Component, + Outgoing_Edges => Edge_Set.Nil)); + + -- It is assumed that the vertex will have at least one outgoing + -- edge. It is important not to create the set of edges above as + -- the call to Put may fail in case the vertices are iterated. + -- This would lead to a memory leak because the set would not be + -- reclaimed. + + Set_Outgoing_Edges (G, V, Edge_Set.Create (1)); + end Add_Vertex; + + --------------- + -- Component -- + --------------- + + function Component + (G : Directed_Graph; + V : Vertex_Id) return Component_Id + is + begin + Ensure_Created (G); + Ensure_Present (G, V); + + return Get_Vertex_Attributes (G, V).Component; + end Component; + + ------------------------ + -- Contains_Component -- + ------------------------ + + function Contains_Component + (G : Directed_Graph; + Comp : Component_Id) return Boolean + is + begin + Ensure_Created (G); + + return Component_Map.Contains (G.Components, Comp); + end Contains_Component; + + ------------------- + -- Contains_Edge -- + ------------------- + + function Contains_Edge + (G : Directed_Graph; + E : Edge_Id) return Boolean + is + begin + Ensure_Created (G); + + return Edge_Map.Contains (G.All_Edges, E); + end Contains_Edge; + + --------------------- + -- Contains_Vertex -- + --------------------- + + function Contains_Vertex + (G : Directed_Graph; + V : Vertex_Id) return Boolean + is + begin + Ensure_Created (G); + + return Vertex_Map.Contains (G.All_Vertices, V); + end Contains_Vertex; + + ------------ + -- Create -- + ------------ + + function Create + (Initial_Vertices : Positive; + Initial_Edges : Positive) return Directed_Graph + is + G : constant Directed_Graph := new Directed_Graph_Attributes; + + begin + G.All_Edges := Edge_Map.Create (Initial_Edges); + G.All_Vertices := Vertex_Map.Create (Initial_Vertices); + G.Components := Component_Map.Create (Initial_Vertices); + + return G; + end Create; + + ----------------- + -- Delete_Edge -- + ----------------- + + procedure Delete_Edge + (G : Directed_Graph; + E : Edge_Id) + is + Source : Vertex_Id; + + begin + Ensure_Created (G); + Ensure_Present (G, E); + + Source := Source_Vertex (G, E); + Ensure_Present (G, Source); + + -- Delete the edge from its source vertex which effectively "owns" + -- the edge. + + Edge_Set.Delete (Get_Outgoing_Edges (G, Source), E); + + -- Delete the edge from the set of all edges + + Edge_Map.Delete (G.All_Edges, E); + end Delete_Edge; + + ------------------------ + -- Destination_Vertex -- + ------------------------ + + function Destination_Vertex + (G : Directed_Graph; + E : Edge_Id) return Vertex_Id + is + begin + Ensure_Created (G); + Ensure_Present (G, E); + + return Get_Edge_Attributes (G, E).Destination; + end Destination_Vertex; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (G : in out Directed_Graph) is + begin + Ensure_Created (G); + + Edge_Map.Destroy (G.All_Edges); + Vertex_Map.Destroy (G.All_Vertices); + Component_Map.Destroy (G.Components); + + Free (G); + end Destroy; + + ---------------------------------- + -- Destroy_Component_Attributes -- + ---------------------------------- + + procedure Destroy_Component_Attributes + (Attrs : in out Component_Attributes) + is + begin + Vertex_List.Destroy (Attrs.Vertices); + end Destroy_Component_Attributes; + + ----------------------------- + -- Destroy_Edge_Attributes -- + ----------------------------- + + procedure Destroy_Edge_Attributes (Attrs : in out Edge_Attributes) is + pragma Unreferenced (Attrs); + begin + null; + end Destroy_Edge_Attributes; + + -------------------- + -- Destroy_Vertex -- + -------------------- + + procedure Destroy_Vertex (V : in out Vertex_Id) is + pragma Unreferenced (V); + begin + null; + end Destroy_Vertex; + + ------------------------------- + -- Destroy_Vertex_Attributes -- + ------------------------------- + + procedure Destroy_Vertex_Attributes (Attrs : in out Vertex_Attributes) is + begin + Edge_Set.Destroy (Attrs.Outgoing_Edges); + end Destroy_Vertex_Attributes; + + -------------------- + -- Ensure_Created -- + -------------------- + + procedure Ensure_Created (G : Directed_Graph) is + begin + if not Present (G) then + raise Not_Created; + end if; + end Ensure_Created; + + ------------------------ + -- Ensure_Not_Present -- + ------------------------ + + procedure Ensure_Not_Present + (G : Directed_Graph; + E : Edge_Id) + is + begin + if Contains_Edge (G, E) then + raise Duplicate_Edge; + end if; + end Ensure_Not_Present; + + ------------------------ + -- Ensure_Not_Present -- + ------------------------ + + procedure Ensure_Not_Present + (G : Directed_Graph; + V : Vertex_Id) + is + begin + if Contains_Vertex (G, V) then + raise Duplicate_Vertex; + end if; + end Ensure_Not_Present; + + -------------------- + -- Ensure_Present -- + -------------------- + + procedure Ensure_Present + (G : Directed_Graph; + Comp : Component_Id) + is + begin + if not Contains_Component (G, Comp) then + raise Missing_Component; + end if; + end Ensure_Present; + + -------------------- + -- Ensure_Present -- + -------------------- + + procedure Ensure_Present + (G : Directed_Graph; + E : Edge_Id) + is + begin + if not Contains_Edge (G, E) then + raise Missing_Edge; + end if; + end Ensure_Present; + + -------------------- + -- Ensure_Present -- + -------------------- + + procedure Ensure_Present + (G : Directed_Graph; + V : Vertex_Id) + is + begin + if not Contains_Vertex (G, V) then + raise Missing_Vertex; + end if; + end Ensure_Present; + + --------------------- + -- Find_Components -- + --------------------- + + procedure Find_Components (G : Directed_Graph) is + + -- The components of graph G are discovered using Tarjan's strongly + -- connected component algorithm. Do not modify this code unless you + -- intimately understand the algorithm. + + ---------------- + -- Tarjan_Map -- + ---------------- + + type Visitation_Number is new Natural; + No_Visitation_Number : constant Visitation_Number := + Visitation_Number'First; + First_Visitation_Number : constant Visitation_Number := + No_Visitation_Number + 1; + + type Tarjan_Attributes is record + Index : Visitation_Number := No_Visitation_Number; + -- Visitation number + + Low_Link : Visitation_Number := No_Visitation_Number; + -- Lowest visitation number + + On_Stack : Boolean := False; + -- Set when the corresponding vertex appears on the Stack + end record; + + No_Tarjan_Attributes : constant Tarjan_Attributes := + (Index => No_Visitation_Number, + Low_Link => No_Visitation_Number, + On_Stack => False); + + procedure Destroy_Tarjan_Attributes + (Attrs : in out Tarjan_Attributes); + -- Destroy the contents of attributes Attrs + + package Tarjan_Map is new Dynamic_Hash_Tables + (Key_Type => Vertex_Id, + Value_Type => Tarjan_Attributes, + No_Value => No_Tarjan_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => Same_Vertex, + Destroy_Value => Destroy_Tarjan_Attributes, + Hash => Hash_Vertex); + + ------------------ + -- Tarjan_Stack -- + ------------------ + + package Tarjan_Stack is new Doubly_Linked_Lists + (Element_Type => Vertex_Id, + "=" => Same_Vertex, + Destroy_Element => Destroy_Vertex); + + ----------------- + -- Global data -- + ----------------- + + Attrs : Tarjan_Map.Dynamic_Hash_Table := Tarjan_Map.Nil; + Stack : Tarjan_Stack.Doubly_Linked_List := Tarjan_Stack.Nil; + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Associate_All_Vertices; + pragma Inline (Associate_All_Vertices); + -- Associate all vertices in the graph with the corresponding + -- components that house them. + + procedure Associate_Vertices (Comp : Component_Id); + pragma Inline (Associate_Vertices); + -- Associate all vertices of component Comp with the component + + procedure Create_Component (V : Vertex_Id); + pragma Inline (Create_Component); + -- Create a new component with root vertex V + + function Get_Tarjan_Attributes + (V : Vertex_Id) return Tarjan_Attributes; + pragma Inline (Get_Tarjan_Attributes); + -- Obtain the Tarjan attributes of vertex V + + function Index (V : Vertex_Id) return Visitation_Number; + pragma Inline (Index); + -- Obtain the Index attribute of vertex V + + procedure Initialize_Components; + pragma Inline (Initialize_Components); + -- Initialize or reinitialize the components of the graph + + function Is_Visited (V : Vertex_Id) return Boolean; + pragma Inline (Is_Visited); + -- Determine whether vertex V has been visited + + function Low_Link (V : Vertex_Id) return Visitation_Number; + pragma Inline (Low_Link); + -- Obtain the Low_Link attribute of vertex V + + function On_Stack (V : Vertex_Id) return Boolean; + pragma Inline (On_Stack); + -- Obtain the On_Stack attribute of vertex V + + function Pop return Vertex_Id; + pragma Inline (Pop); + -- Pop a vertex off Stack + + procedure Push (V : Vertex_Id); + pragma Inline (Push); + -- Push vertex V on Stack + + procedure Record_Visit (V : Vertex_Id); + pragma Inline (Record_Visit); + -- Save the visitation of vertex V by setting relevant attributes + + function Sequence_Next_Index return Visitation_Number; + pragma Inline (Sequence_Next_Index); + -- Procedure the next visitation number of the DFS traversal + + procedure Set_Index + (V : Vertex_Id; + Val : Visitation_Number); + pragma Inline (Set_Index); + -- Set attribute Index of vertex V to value Val + + procedure Set_Low_Link + (V : Vertex_Id; + Val : Visitation_Number); + pragma Inline (Set_Low_Link); + -- Set attribute Low_Link of vertex V to value Val + + procedure Set_On_Stack + (V : Vertex_Id; + Val : Boolean); + pragma Inline (Set_On_Stack); + -- Set attribute On_Stack of vertex V to value Val + + procedure Set_Tarjan_Attributes + (V : Vertex_Id; + Val : Tarjan_Attributes); + pragma Inline (Set_Tarjan_Attributes); + -- Set the attributes of vertex V to value Val + + procedure Visit_Successors (V : Vertex_Id); + pragma Inline (Visit_Successors); + -- Visit the successors of vertex V + + procedure Visit_Vertex (V : Vertex_Id); + pragma Inline (Visit_Vertex); + -- Visit single vertex V + + procedure Visit_Vertices; + pragma Inline (Visit_Vertices); + -- Visit all vertices in the graph + + ---------------------------- + -- Associate_All_Vertices -- + ---------------------------- + + procedure Associate_All_Vertices is + Comp : Component_Id; + Iter : Component_Iterator; + + begin + Iter := Iterate_Components (G); + while Has_Next (Iter) loop + Next (Iter, Comp); + + Associate_Vertices (Comp); + end loop; + end Associate_All_Vertices; + + ------------------------ + -- Associate_Vertices -- + ------------------------ + + procedure Associate_Vertices (Comp : Component_Id) is + Iter : Component_Vertex_Iterator; + V : Vertex_Id; + + begin + Iter := Iterate_Component_Vertices (G, Comp); + while Has_Next (Iter) loop + Next (Iter, V); + + Set_Component (G, V, Comp); + end loop; + end Associate_Vertices; + + ---------------------- + -- Create_Component -- + ---------------------- + + procedure Create_Component (V : Vertex_Id) is + Curr_V : Vertex_Id; + Vertices : Vertex_List.Doubly_Linked_List; + + begin + Vertices := Vertex_List.Create; + + -- Collect all vertices that comprise the current component by + -- popping the stack until reaching the root vertex V. + + loop + Curr_V := Pop; + Vertex_List.Append (Vertices, Curr_V); + + exit when Same_Vertex (Curr_V, V); + end loop; + + Add_Component + (G => G, + Comp => Sequence_Next_Component, + Vertices => Vertices); + end Create_Component; + + ------------------------------- + -- Destroy_Tarjan_Attributes -- + ------------------------------- + + procedure Destroy_Tarjan_Attributes + (Attrs : in out Tarjan_Attributes) + is + pragma Unreferenced (Attrs); + begin + null; + end Destroy_Tarjan_Attributes; + + --------------------------- + -- Get_Tarjan_Attributes -- + --------------------------- + + function Get_Tarjan_Attributes + (V : Vertex_Id) return Tarjan_Attributes + is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + return Tarjan_Map.Get (Attrs, V); + end Get_Tarjan_Attributes; + + ----------- + -- Index -- + ----------- + + function Index (V : Vertex_Id) return Visitation_Number is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + return Get_Tarjan_Attributes (V).Index; + end Index; + + --------------------------- + -- Initialize_Components -- + --------------------------- + + procedure Initialize_Components is + begin + pragma Assert (Present (G)); + + -- The graph already contains a set of components. Reinitialize + -- them in order to accommodate the new set of components about to + -- be computed. + + if Number_Of_Components (G) > 0 then + Component_Map.Destroy (G.Components); + G.Components := Component_Map.Create (Number_Of_Vertices (G)); + end if; + end Initialize_Components; + + ---------------- + -- Is_Visited -- + ---------------- + + function Is_Visited (V : Vertex_Id) return Boolean is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + return Index (V) /= No_Visitation_Number; + end Is_Visited; + + -------------- + -- Low_Link -- + -------------- + + function Low_Link (V : Vertex_Id) return Visitation_Number is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + return Get_Tarjan_Attributes (V).Low_Link; + end Low_Link; + + -------------- + -- On_Stack -- + -------------- + + function On_Stack (V : Vertex_Id) return Boolean is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + return Get_Tarjan_Attributes (V).On_Stack; + end On_Stack; + + --------- + -- Pop -- + --------- + + function Pop return Vertex_Id is + V : Vertex_Id; + + begin + V := Tarjan_Stack.Last (Stack); + Tarjan_Stack.Delete_Last (Stack); + Set_On_Stack (V, False); + + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + return V; + end Pop; + + ---------- + -- Push -- + ---------- + + procedure Push (V : Vertex_Id) is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + Tarjan_Stack.Append (Stack, V); + Set_On_Stack (V, True); + end Push; + + ------------------ + -- Record_Visit -- + ------------------ + + procedure Record_Visit (V : Vertex_Id) is + Index : constant Visitation_Number := Sequence_Next_Index; + + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + Set_Index (V, Index); + Set_Low_Link (V, Index); + end Record_Visit; + + ------------------------- + -- Sequence_Next_Index -- + ------------------------- + + Index_Sequencer : Visitation_Number := First_Visitation_Number; + -- The counter for visitation numbers. Do not directly manipulate its + -- value because this will destroy the Index and Low_Link invariants + -- of the algorithm. + + function Sequence_Next_Index return Visitation_Number is + Index : constant Visitation_Number := Index_Sequencer; + + begin + Index_Sequencer := Index_Sequencer + 1; + return Index; + end Sequence_Next_Index; + + --------------- + -- Set_Index -- + --------------- + + procedure Set_Index + (V : Vertex_Id; + Val : Visitation_Number) + is + TA : Tarjan_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + TA := Get_Tarjan_Attributes (V); + TA.Index := Val; + Set_Tarjan_Attributes (V, TA); + end Set_Index; + + ------------------ + -- Set_Low_Link -- + ------------------ + + procedure Set_Low_Link + (V : Vertex_Id; + Val : Visitation_Number) + is + TA : Tarjan_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + TA := Get_Tarjan_Attributes (V); + TA.Low_Link := Val; + Set_Tarjan_Attributes (V, TA); + end Set_Low_Link; + + ------------------ + -- Set_On_Stack -- + ------------------ + + procedure Set_On_Stack + (V : Vertex_Id; + Val : Boolean) + is + TA : Tarjan_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + TA := Get_Tarjan_Attributes (V); + TA.On_Stack := Val; + Set_Tarjan_Attributes (V, TA); + end Set_On_Stack; + + --------------------------- + -- Set_Tarjan_Attributes -- + --------------------------- + + procedure Set_Tarjan_Attributes + (V : Vertex_Id; + Val : Tarjan_Attributes) + is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + Tarjan_Map.Put (Attrs, V, Val); + end Set_Tarjan_Attributes; + + ---------------------- + -- Visit_Successors -- + ---------------------- + + procedure Visit_Successors (V : Vertex_Id) is + E : Edge_Id; + Iter : Outgoing_Edge_Iterator; + Succ : Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + Iter := Iterate_Outgoing_Edges (G, V); + while Has_Next (Iter) loop + Next (Iter, E); + + Succ := Destination_Vertex (G, E); + pragma Assert (Contains_Vertex (G, Succ)); + + -- The current successor has not been visited yet. Extend the + -- DFS traversal into it. + + if not Is_Visited (Succ) then + Visit_Vertex (Succ); + + Set_Low_Link (V, + Visitation_Number'Min (Low_Link (V), Low_Link (Succ))); + + -- The current successor has been visited, and still remains on + -- the stack which indicates that it does not participate in a + -- component yet. + + elsif On_Stack (Succ) then + Set_Low_Link (V, + Visitation_Number'Min (Low_Link (V), Index (Succ))); + end if; + end loop; + end Visit_Successors; + + ------------------ + -- Visit_Vertex -- + ------------------ + + procedure Visit_Vertex (V : Vertex_Id) is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + if not Is_Visited (V) then + Record_Visit (V); + Push (V); + Visit_Successors (V); + + -- The current vertex is the root of a component + + if Low_Link (V) = Index (V) then + Create_Component (V); + end if; + end if; + end Visit_Vertex; + + -------------------- + -- Visit_Vertices -- + -------------------- + + procedure Visit_Vertices is + Iter : All_Vertex_Iterator; + V : Vertex_Id; + + begin + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, V); + + Visit_Vertex (V); + end loop; + end Visit_Vertices; + + -- Start of processing for Find_Components + + begin + -- Initialize or reinitialize the components of the graph + + Initialize_Components; + + -- Prepare the extra attributes needed for each vertex, global + -- visitation number, and the stack where examined vertices are + -- placed. + + Attrs := Tarjan_Map.Create (Number_Of_Vertices (G)); + Stack := Tarjan_Stack.Create; + + -- Start the DFS traversal of Tarjan's SCC algorithm + + Visit_Vertices; + + Tarjan_Map.Destroy (Attrs); + Tarjan_Stack.Destroy (Stack); + + -- Associate each vertex with the component it belongs to + + Associate_All_Vertices; + end Find_Components; + + ------------------------------ + -- Get_Component_Attributes -- + ------------------------------ + + function Get_Component_Attributes + (G : Directed_Graph; + Comp : Component_Id) return Component_Attributes + is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Component (G, Comp)); + + return Component_Map.Get (G.Components, Comp); + end Get_Component_Attributes; + + ------------------------- + -- Get_Edge_Attributes -- + ------------------------- + + function Get_Edge_Attributes + (G : Directed_Graph; + E : Edge_Id) return Edge_Attributes + is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Edge (G, E)); + + return Edge_Map.Get (G.All_Edges, E); + end Get_Edge_Attributes; + + --------------------------- + -- Get_Vertex_Attributes -- + --------------------------- + + function Get_Vertex_Attributes + (G : Directed_Graph; + V : Vertex_Id) return Vertex_Attributes + is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + return Vertex_Map.Get (G.All_Vertices, V); + end Get_Vertex_Attributes; + + ------------------------ + -- Get_Outgoing_Edges -- + ------------------------ + + function Get_Outgoing_Edges + (G : Directed_Graph; + V : Vertex_Id) return Edge_Set.Membership_Set + is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + return Get_Vertex_Attributes (G, V).Outgoing_Edges; + end Get_Outgoing_Edges; + + ------------------ + -- Get_Vertices -- + ------------------ + + function Get_Vertices + (G : Directed_Graph; + Comp : Component_Id) return Vertex_List.Doubly_Linked_List + is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Component (G, Comp)); + + return Get_Component_Attributes (G, Comp).Vertices; + end Get_Vertices; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : All_Edge_Iterator) return Boolean is + begin + return Edge_Map.Has_Next (Edge_Map.Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : All_Vertex_Iterator) return Boolean is + begin + return Vertex_Map.Has_Next (Vertex_Map.Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Component_Iterator) return Boolean is + begin + return Component_Map.Has_Next (Component_Map.Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Component_Vertex_Iterator) return Boolean is + begin + return Vertex_List.Has_Next (Vertex_List.Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Outgoing_Edge_Iterator) return Boolean is + begin + return Edge_Set.Has_Next (Edge_Set.Iterator (Iter)); + end Has_Next; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (G : Directed_Graph) return Boolean is + begin + Ensure_Created (G); + + return + Edge_Map.Is_Empty (G.All_Edges) + and then Vertex_Map.Is_Empty (G.All_Vertices); + end Is_Empty; + + ----------------------- + -- Iterate_All_Edges -- + ----------------------- + + function Iterate_All_Edges + (G : Directed_Graph) return All_Edge_Iterator + is + begin + Ensure_Created (G); + + return All_Edge_Iterator (Edge_Map.Iterate (G.All_Edges)); + end Iterate_All_Edges; + + -------------------------- + -- Iterate_All_Vertices -- + -------------------------- + + function Iterate_All_Vertices + (G : Directed_Graph) return All_Vertex_Iterator + is + begin + Ensure_Created (G); + + return All_Vertex_Iterator (Vertex_Map.Iterate (G.All_Vertices)); + end Iterate_All_Vertices; + + ------------------------ + -- Iterate_Components -- + ------------------------ + + function Iterate_Components + (G : Directed_Graph) return Component_Iterator + is + begin + Ensure_Created (G); + + return Component_Iterator (Component_Map.Iterate (G.Components)); + end Iterate_Components; + + -------------------------------- + -- Iterate_Component_Vertices -- + -------------------------------- + + function Iterate_Component_Vertices + (G : Directed_Graph; + Comp : Component_Id) return Component_Vertex_Iterator + is + begin + Ensure_Created (G); + Ensure_Present (G, Comp); + + return + Component_Vertex_Iterator + (Vertex_List.Iterate (Get_Vertices (G, Comp))); + end Iterate_Component_Vertices; + + ---------------------------- + -- Iterate_Outgoing_Edges -- + ---------------------------- + + function Iterate_Outgoing_Edges + (G : Directed_Graph; + V : Vertex_Id) return Outgoing_Edge_Iterator + is + begin + Ensure_Created (G); + Ensure_Present (G, V); + + return + Outgoing_Edge_Iterator + (Edge_Set.Iterate (Get_Outgoing_Edges (G, V))); + end Iterate_Outgoing_Edges; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out All_Edge_Iterator; + E : out Edge_Id) + is + begin + Edge_Map.Next (Edge_Map.Iterator (Iter), E); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out All_Vertex_Iterator; + V : out Vertex_Id) + is + begin + Vertex_Map.Next (Vertex_Map.Iterator (Iter), V); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Component_Iterator; + Comp : out Component_Id) + is + begin + Component_Map.Next (Component_Map.Iterator (Iter), Comp); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Component_Vertex_Iterator; + V : out Vertex_Id) + is + begin + Vertex_List.Next (Vertex_List.Iterator (Iter), V); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Outgoing_Edge_Iterator; + E : out Edge_Id) + is + begin + Edge_Set.Next (Edge_Set.Iterator (Iter), E); + end Next; + + ---------------------------------- + -- Number_Of_Component_Vertices -- + ---------------------------------- + + function Number_Of_Component_Vertices + (G : Directed_Graph; + Comp : Component_Id) return Natural + is + begin + Ensure_Created (G); + Ensure_Present (G, Comp); + + return Vertex_List.Size (Get_Vertices (G, Comp)); + end Number_Of_Component_Vertices; + + -------------------------- + -- Number_Of_Components -- + -------------------------- + + function Number_Of_Components (G : Directed_Graph) return Natural is + begin + Ensure_Created (G); + + return Component_Map.Size (G.Components); + end Number_Of_Components; + + --------------------- + -- Number_Of_Edges -- + --------------------- + + function Number_Of_Edges (G : Directed_Graph) return Natural is + begin + Ensure_Created (G); + + return Edge_Map.Size (G.All_Edges); + end Number_Of_Edges; + + ------------------------------ + -- Number_Of_Outgoing_Edges -- + ------------------------------ + + function Number_Of_Outgoing_Edges + (G : Directed_Graph; + V : Vertex_Id) return Natural + is + begin + Ensure_Created (G); + Ensure_Present (G, V); + + return Edge_Set.Size (Get_Outgoing_Edges (G, V)); + end Number_Of_Outgoing_Edges; + + ------------------------ + -- Number_Of_Vertices -- + ------------------------ + + function Number_Of_Vertices (G : Directed_Graph) return Natural is + begin + Ensure_Created (G); + + return Vertex_Map.Size (G.All_Vertices); + end Number_Of_Vertices; + + ------------- + -- Present -- + ------------- + + function Present (G : Directed_Graph) return Boolean is + begin + return G /= Nil; + end Present; + + ------------------- + -- Set_Component -- + ------------------- + + procedure Set_Component + (G : Directed_Graph; + V : Vertex_Id; + Val : Component_Id) + is + VA : Vertex_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + VA := Get_Vertex_Attributes (G, V); + VA.Component := Val; + Set_Vertex_Attributes (G, V, VA); + end Set_Component; + + ------------------------ + -- Set_Outgoing_Edges -- + ------------------------ + + procedure Set_Outgoing_Edges + (G : Directed_Graph; + V : Vertex_Id; + Val : Edge_Set.Membership_Set) + is + VA : Vertex_Attributes; + + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + VA := Get_Vertex_Attributes (G, V); + VA.Outgoing_Edges := Val; + Set_Vertex_Attributes (G, V, VA); + end Set_Outgoing_Edges; + + --------------------------- + -- Set_Vertex_Attributes -- + --------------------------- + + procedure Set_Vertex_Attributes + (G : Directed_Graph; + V : Vertex_Id; + Val : Vertex_Attributes) + is + begin + pragma Assert (Present (G)); + pragma Assert (Contains_Vertex (G, V)); + + Vertex_Map.Put (G.All_Vertices, V, Val); + end Set_Vertex_Attributes; + + ------------------- + -- Source_Vertex -- + ------------------- + + function Source_Vertex + (G : Directed_Graph; + E : Edge_Id) return Vertex_Id + is + begin + Ensure_Created (G); + Ensure_Present (G, E); + + return Get_Edge_Attributes (G, E).Source; + end Source_Vertex; + end Directed_Graphs; + + -------------------- + -- Hash_Component -- + -------------------- + + function Hash_Component (Comp : Component_Id) return Bucket_Range_Type is + begin + return Bucket_Range_Type (Comp); + end Hash_Component; + + ------------- + -- Present -- + ------------- + + function Present (Comp : Component_Id) return Boolean is + begin + return Comp /= No_Component; + end Present; + + ----------------------------- + -- Sequence_Next_Component -- + ----------------------------- + + Component_Sequencer : Component_Id := First_Component; + -- The counter for component handles. Do not directly manipulate its value + -- because this will destroy the invariant of the handles. + + function Sequence_Next_Component return Component_Id is + Component : constant Component_Id := Component_Sequencer; + + begin + Component_Sequencer := Component_Sequencer + 1; + return Component; + end Sequence_Next_Component; + +end GNAT.Graphs; diff --git a/gcc/ada/libgnat/g-graphs.ads b/gcc/ada/libgnat/g-graphs.ads new file mode 100644 index 0000000..3b65522 --- /dev/null +++ b/gcc/ada/libgnat/g-graphs.ads @@ -0,0 +1,536 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . G R A P H S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018-2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; +with GNAT.Lists; use GNAT.Lists; +with GNAT.Sets; use GNAT.Sets; + +package GNAT.Graphs is + + --------------- + -- Component -- + --------------- + + -- The following type denotes a strongly connected component handle + -- (referred to as simply "component") in a graph. + + type Component_Id is new Natural; + No_Component : constant Component_Id := Component_Id'First; + + function Hash_Component (Comp : Component_Id) return Bucket_Range_Type; + -- Map component Comp into the range of buckets + + function Present (Comp : Component_Id) return Boolean; + -- Determine whether component Comp exists + + --------------------- + -- Directed_Graphs -- + --------------------- + + -- The following package offers a directed graph abstraction with the + -- following characteristics: + -- + -- * Dynamic resizing based on number of vertices and edges + -- * Creation of multiple instances, of different sizes + -- * Discovery of strongly connected components + -- * Iterable attributes + -- + -- The following use pattern must be employed when operating this graph: + -- + -- Graph : Directed_Graph := Create (<some size>, <some size>); + -- + -- <various operations> + -- + -- Destroy (Graph); + -- + -- The destruction of the graph reclaims all storage occupied by it. + + generic + + -------------- + -- Vertices -- + -------------- + + type Vertex_Id is private; + -- The handle of a vertex + + No_Vertex : Vertex_Id; + -- An indicator for a nonexistent vertex + + with function Hash_Vertex (V : Vertex_Id) return Bucket_Range_Type; + -- Map vertex V into the range of buckets + + with function Same_Vertex + (Left : Vertex_Id; + Right : Vertex_Id) return Boolean; + -- Compare vertex Left to vertex Right for identity + + ----------- + -- Edges -- + ----------- + + type Edge_Id is private; + -- The handle of an edge + + No_Edge : Edge_Id; + -- An indicator for a nonexistent edge + + with function Hash_Edge (E : Edge_Id) return Bucket_Range_Type; + -- Map edge E into the range of buckets + + with function Same_Edge + (Left : Edge_Id; + Right : Edge_Id) return Boolean; + -- Compare edge Left to edge Right for identity + + package Directed_Graphs is + + -- The following exceptions are raised when an attempt is made to add + -- the same edge or vertex in a graph. + + Duplicate_Edge : exception; + Duplicate_Vertex : exception; + + -- The following exceptions are raised when an attempt is made to delete + -- or reference a nonexistent component, edge, or vertex in a graph. + + Missing_Component : exception; + Missing_Edge : exception; + Missing_Vertex : exception; + + ---------------------- + -- Graph operations -- + ---------------------- + + -- The following type denotes a graph handle. Each instance must be + -- created using routine Create. + + type Directed_Graph is private; + Nil : constant Directed_Graph; + + procedure Add_Edge + (G : Directed_Graph; + E : Edge_Id; + Source : Vertex_Id; + Destination : Vertex_Id); + -- Add edge E to graph G which links vertex source Source and desination + -- vertex Destination. The edge is "owned" by vertex Source. This action + -- raises the following exceptions: + -- + -- * Duplicate_Edge, when the edge is already present in the graph + -- + -- * Iterated, when the graph has an outstanding edge iterator + -- + -- * Missing_Vertex, when either the source or desination are not + -- present in the graph. + + procedure Add_Vertex + (G : Directed_Graph; + V : Vertex_Id); + -- Add vertex V to graph G. This action raises the following exceptions: + -- + -- * Duplicate_Vertex, when the vertex is already present in the graph + -- + -- * Iterated, when the graph has an outstanding vertex iterator + + function Component + (G : Directed_Graph; + V : Vertex_Id) return Component_Id; + -- Obtain the component where vertex V of graph G resides. This action + -- raises the following exceptions: + -- + -- * Missing_Vertex, when the vertex is not present in the graph + + function Contains_Component + (G : Directed_Graph; + Comp : Component_Id) return Boolean; + -- Determine whether graph G contains component Comp + + function Contains_Edge + (G : Directed_Graph; + E : Edge_Id) return Boolean; + -- Determine whether graph G contains edge E + + function Contains_Vertex + (G : Directed_Graph; + V : Vertex_Id) return Boolean; + -- Determine whether graph G contains vertex V + + function Create + (Initial_Vertices : Positive; + Initial_Edges : Positive) return Directed_Graph; + -- Create a new graph with vertex capacity Initial_Vertices and edge + -- capacity Initial_Edges. This routine must be called at the start of + -- a graph's lifetime. + + procedure Delete_Edge + (G : Directed_Graph; + E : Edge_Id); + -- Delete edge E from graph G. This action raises these exceptions: + -- + -- * Iterated, when the graph has an outstanding edge iterator + -- + -- * Missing_Edge, when the edge is not present in the graph + -- + -- * Missing_Vertex, when the source vertex that "owns" the edge is + -- not present in the graph. + + function Destination_Vertex + (G : Directed_Graph; + E : Edge_Id) return Vertex_Id; + -- Obtain the destination vertex of edge E of graph G. This action + -- raises the following exceptions: + -- + -- * Missing_Edge, when the edge is not present in the graph + + procedure Destroy (G : in out Directed_Graph); + -- Destroy the contents of graph G, rendering it unusable. This routine + -- must be called at the end of a graph's lifetime. This action raises + -- the following exceptions: + -- + -- * Iterated, if the graph has any outstanding iterator + + procedure Find_Components (G : Directed_Graph); + -- Find all components of graph G. This action raises the following + -- exceptions: + -- + -- * Iterated, when the components or vertices of the graph have an + -- outstanding iterator. + + function Is_Empty (G : Directed_Graph) return Boolean; + -- Determine whether graph G is empty + + function Number_Of_Component_Vertices + (G : Directed_Graph; + Comp : Component_Id) return Natural; + -- Obtain the total number of vertices of component Comp of graph G + + function Number_Of_Components (G : Directed_Graph) return Natural; + -- Obtain the total number of components of graph G + + function Number_Of_Edges (G : Directed_Graph) return Natural; + -- Obtain the total number of edges of graph G + + function Number_Of_Outgoing_Edges + (G : Directed_Graph; + V : Vertex_Id) return Natural; + -- Obtain the total number of outgoing edges of vertex V of graph G + + function Number_Of_Vertices (G : Directed_Graph) return Natural; + -- Obtain the total number of vertices of graph G + + function Present (G : Directed_Graph) return Boolean; + -- Determine whether graph G exists + + function Source_Vertex + (G : Directed_Graph; + E : Edge_Id) return Vertex_Id; + -- Obtain the source vertex that "owns" edge E of graph G. This action + -- raises the following exceptions: + -- + -- * Missing_Edge, when the edge is not present in the graph + + ------------------------- + -- Iterator operations -- + ------------------------- + + -- The following types represent iterators over various attributes of a + -- graph. Each iterator locks all mutation operations of its associated + -- attribute, and unlocks them once it is exhausted. The iterators must + -- be used with the following pattern: + -- + -- Iter : Iterate_XXX (Graph); + -- while Has_Next (Iter) loop + -- Next (Iter, Element); + -- end loop; + -- + -- It is possible to advance the iterators by using Next only, however + -- this risks raising Iterator_Exhausted. + + -- The following type represents an iterator over all edges of a graph + + type All_Edge_Iterator is private; + + function Has_Next (Iter : All_Edge_Iterator) return Boolean; + -- Determine whether iterator Iter has more edges to examine + + function Iterate_All_Edges (G : Directed_Graph) return All_Edge_Iterator; + -- Obtain an iterator over all edges of graph G + + procedure Next + (Iter : in out All_Edge_Iterator; + E : out Edge_Id); + -- Return the current edge referenced by iterator Iter and advance to + -- the next available edge. This action raises the following exceptions: + -- + -- * Iterator_Exhausted, when the iterator has been exhausted and + -- further attempts are made to advance it. + + -- The following type represents an iterator over all vertices of a + -- graph. + + type All_Vertex_Iterator is private; + + function Has_Next (Iter : All_Vertex_Iterator) return Boolean; + -- Determine whether iterator Iter has more vertices to examine + + function Iterate_All_Vertices + (G : Directed_Graph) return All_Vertex_Iterator; + -- Obtain an iterator over all vertices of graph G + + procedure Next + (Iter : in out All_Vertex_Iterator; + V : out Vertex_Id); + -- Return the current vertex referenced by iterator Iter and advance + -- to the next available vertex. This action raises the following + -- exceptions: + -- + -- * Iterator_Exhausted, when the iterator has been exhausted and + -- further attempts are made to advance it. + + -- The following type represents an iterator over all components of a + -- graph. + + type Component_Iterator is private; + + function Has_Next (Iter : Component_Iterator) return Boolean; + -- Determine whether iterator Iter has more components to examine + + function Iterate_Components + (G : Directed_Graph) return Component_Iterator; + -- Obtain an iterator over all components of graph G + + procedure Next + (Iter : in out Component_Iterator; + Comp : out Component_Id); + -- Return the current component referenced by iterator Iter and advance + -- to the next component. This action raises the following exceptions: + -- + -- * Iterator_Exhausted, when the iterator has been exhausted and + -- further attempts are made to advance it. + + -- The following type prepresents an iterator over all vertices of a + -- component. + + type Component_Vertex_Iterator is private; + + function Has_Next (Iter : Component_Vertex_Iterator) return Boolean; + -- Determine whether iterator Iter has more vertices to examine + + function Iterate_Component_Vertices + (G : Directed_Graph; + Comp : Component_Id) return Component_Vertex_Iterator; + -- Obtain an iterator over all vertices that comprise component Comp of + -- graph G. + + procedure Next + (Iter : in out Component_Vertex_Iterator; + V : out Vertex_Id); + -- Return the current vertex referenced by iterator Iter and advance to + -- the next vertex. This action raises the following exceptions: + -- + -- * Iterator_Exhausted, when the iterator has been exhausted and + -- further attempts are made to advance it. + + -- The following type represents an iterator over all outgoing edges of + -- a vertex. + + type Outgoing_Edge_Iterator is private; + + function Has_Next (Iter : Outgoing_Edge_Iterator) return Boolean; + -- Determine whether iterator Iter has more outgoing edges to examine + + function Iterate_Outgoing_Edges + (G : Directed_Graph; + V : Vertex_Id) return Outgoing_Edge_Iterator; + -- Obtain an iterator over all the outgoing edges "owned" by vertex V of + -- graph G. + + procedure Next + (Iter : in out Outgoing_Edge_Iterator; + E : out Edge_Id); + -- Return the current outgoing edge referenced by iterator Iter and + -- advance to the next available outgoing edge. This action raises the + -- following exceptions: + -- + -- * Iterator_Exhausted, when the iterator has been exhausted and + -- further attempts are made to advance it. + + private + pragma Unreferenced (No_Edge); + + -------------- + -- Edge_Map -- + -------------- + + type Edge_Attributes is record + Destination : Vertex_Id := No_Vertex; + -- The target of a directed edge + + Source : Vertex_Id := No_Vertex; + -- The origin of a directed edge. The source vertex "owns" the edge. + end record; + + No_Edge_Attributes : constant Edge_Attributes := + (Destination => No_Vertex, + Source => No_Vertex); + + procedure Destroy_Edge_Attributes (Attrs : in out Edge_Attributes); + -- Destroy the contents of attributes Attrs + + package Edge_Map is new Dynamic_Hash_Tables + (Key_Type => Edge_Id, + Value_Type => Edge_Attributes, + No_Value => No_Edge_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => Same_Edge, + Destroy_Value => Destroy_Edge_Attributes, + Hash => Hash_Edge); + + -------------- + -- Edge_Set -- + -------------- + + package Edge_Set is new Membership_Sets + (Element_Type => Edge_Id, + "=" => "=", + Hash => Hash_Edge); + + ----------------- + -- Vertex_List -- + ----------------- + + procedure Destroy_Vertex (V : in out Vertex_Id); + -- Destroy the contents of a vertex + + package Vertex_List is new Doubly_Linked_Lists + (Element_Type => Vertex_Id, + "=" => Same_Vertex, + Destroy_Element => Destroy_Vertex); + + ---------------- + -- Vertex_Map -- + ---------------- + + type Vertex_Attributes is record + Component : Component_Id := No_Component; + -- The component where a vertex lives + + Outgoing_Edges : Edge_Set.Membership_Set := Edge_Set.Nil; + -- The set of edges that extend out from a vertex + end record; + + No_Vertex_Attributes : constant Vertex_Attributes := + (Component => No_Component, + Outgoing_Edges => Edge_Set.Nil); + + procedure Destroy_Vertex_Attributes (Attrs : in out Vertex_Attributes); + -- Destroy the contents of attributes Attrs + + package Vertex_Map is new Dynamic_Hash_Tables + (Key_Type => Vertex_Id, + Value_Type => Vertex_Attributes, + No_Value => No_Vertex_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => Same_Vertex, + Destroy_Value => Destroy_Vertex_Attributes, + Hash => Hash_Vertex); + + ------------------- + -- Component_Map -- + ------------------- + + type Component_Attributes is record + Vertices : Vertex_List.Doubly_Linked_List := Vertex_List.Nil; + end record; + + No_Component_Attributes : constant Component_Attributes := + (Vertices => Vertex_List.Nil); + + procedure Destroy_Component_Attributes + (Attrs : in out Component_Attributes); + -- Destroy the contents of attributes Attrs + + package Component_Map is new Dynamic_Hash_Tables + (Key_Type => Component_Id, + Value_Type => Component_Attributes, + No_Value => No_Component_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Component_Attributes, + Hash => Hash_Component); + + ----------- + -- Graph -- + ----------- + + type Directed_Graph_Attributes is record + All_Edges : Edge_Map.Dynamic_Hash_Table := Edge_Map.Nil; + -- The map of edge -> edge attributes for all edges in the graph + + All_Vertices : Vertex_Map.Dynamic_Hash_Table := Vertex_Map.Nil; + -- The map of vertex -> vertex attributes for all vertices in the + -- graph. + + Components : Component_Map.Dynamic_Hash_Table := Component_Map.Nil; + -- The map of component -> component attributes for all components + -- in the graph. + end record; + + type Directed_Graph is access Directed_Graph_Attributes; + Nil : constant Directed_Graph := null; + + --------------- + -- Iterators -- + --------------- + + type All_Edge_Iterator is new Edge_Map.Iterator; + type All_Vertex_Iterator is new Vertex_Map.Iterator; + type Component_Iterator is new Component_Map.Iterator; + type Component_Vertex_Iterator is new Vertex_List.Iterator; + type Outgoing_Edge_Iterator is new Edge_Set.Iterator; + end Directed_Graphs; + +private + First_Component : constant Component_Id := No_Component + 1; + +end GNAT.Graphs; diff --git a/gcc/ada/libgnat/g-lists.adb b/gcc/ada/libgnat/g-lists.adb index 7cf7aa6..f7447a5 100644 --- a/gcc/ada/libgnat/g-lists.adb +++ b/gcc/ada/libgnat/g-lists.adb @@ -33,8 +33,10 @@ with Ada.Unchecked_Deallocation; package body GNAT.Lists is - package body Doubly_Linked_List is - procedure Delete_Node (L : Instance; Nod : Node_Ptr); + package body Doubly_Linked_Lists is + procedure Delete_Node + (L : Doubly_Linked_List; + Nod : Node_Ptr); pragma Inline (Delete_Node); -- Detach and delete node Nod from list L @@ -42,17 +44,17 @@ package body GNAT.Lists is pragma Inline (Ensure_Circular); -- Ensure that dummy head Head is circular with respect to itself - procedure Ensure_Created (L : Instance); + procedure Ensure_Created (L : Doubly_Linked_List); pragma Inline (Ensure_Created); -- Verify that list L is created. Raise Not_Created if this is not the -- case. - procedure Ensure_Full (L : Instance); + procedure Ensure_Full (L : Doubly_Linked_List); pragma Inline (Ensure_Full); -- Verify that list L contains at least one element. Raise List_Empty if -- this is not the case. - procedure Ensure_Unlocked (L : Instance); + procedure Ensure_Unlocked (L : Doubly_Linked_List); pragma Inline (Ensure_Unlocked); -- Verify that list L is unlocked. Raise Iterated if this is not the -- case. @@ -65,12 +67,14 @@ package body GNAT.Lists is -- exists a node with element Elem. If such a node exists, return it, -- otherwise return null; - procedure Free is new Ada.Unchecked_Deallocation (Linked_List, Instance); + procedure Free is + new Ada.Unchecked_Deallocation + (Doubly_Linked_List_Attributes, Doubly_Linked_List); procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr); procedure Insert_Between - (L : Instance; + (L : Doubly_Linked_List; Elem : Element_Type; Left : Node_Ptr; Right : Node_Ptr); @@ -81,16 +85,22 @@ package body GNAT.Lists is pragma Inline (Is_Valid); -- Determine whether iterator Iter refers to a valid element - function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean; + function Is_Valid + (Nod : Node_Ptr; + Head : Node_Ptr) return Boolean; pragma Inline (Is_Valid); -- Determine whether node Nod is non-null and does not refer to dummy -- head Head, thus making it valid. - procedure Lock (L : Instance); + procedure Lock (L : Doubly_Linked_List); pragma Inline (Lock); -- Lock all mutation functionality of list L - procedure Unlock (L : Instance); + function Present (Nod : Node_Ptr) return Boolean; + pragma Inline (Present); + -- Determine whether node Nod exists + + procedure Unlock (L : Doubly_Linked_List); pragma Inline (Unlock); -- Unlock all mutation functionality of list L @@ -98,7 +108,10 @@ package body GNAT.Lists is -- Append -- ------------ - procedure Append (L : Instance; Elem : Element_Type) is + procedure Append + (L : Doubly_Linked_List; + Elem : Element_Type) + is Head : Node_Ptr; begin @@ -125,16 +138,19 @@ package body GNAT.Lists is -- Create -- ------------ - function Create return Instance is + function Create return Doubly_Linked_List is begin - return new Linked_List; + return new Doubly_Linked_List_Attributes; end Create; -------------- -- Contains -- -------------- - function Contains (L : Instance; Elem : Element_Type) return Boolean is + function Contains + (L : Doubly_Linked_List; + Elem : Element_Type) return Boolean + is Head : Node_Ptr; Nod : Node_Ptr; @@ -151,7 +167,10 @@ package body GNAT.Lists is -- Delete -- ------------ - procedure Delete (L : Instance; Elem : Element_Type) is + procedure Delete + (L : Doubly_Linked_List; + Elem : Element_Type) + is Head : Node_Ptr; Nod : Node_Ptr; @@ -172,7 +191,7 @@ package body GNAT.Lists is -- Delete_First -- ------------------ - procedure Delete_First (L : Instance) is + procedure Delete_First (L : Doubly_Linked_List) is Head : Node_Ptr; Nod : Node_Ptr; @@ -193,7 +212,7 @@ package body GNAT.Lists is -- Delete_Last -- ----------------- - procedure Delete_Last (L : Instance) is + procedure Delete_Last (L : Doubly_Linked_List) is Head : Node_Ptr; Nod : Node_Ptr; @@ -214,18 +233,21 @@ package body GNAT.Lists is -- Delete_Node -- ----------------- - procedure Delete_Node (L : Instance; Nod : Node_Ptr) is + procedure Delete_Node + (L : Doubly_Linked_List; + Nod : Node_Ptr) + is Ref : Node_Ptr := Nod; - pragma Assert (Ref /= null); + pragma Assert (Present (Ref)); Next : constant Node_Ptr := Ref.Next; Prev : constant Node_Ptr := Ref.Prev; begin - pragma Assert (L /= null); - pragma Assert (Next /= null); - pragma Assert (Prev /= null); + pragma Assert (Present (L)); + pragma Assert (Present (Next)); + pragma Assert (Present (Prev)); Prev.Next := Next; -- Prev ---> Next Next.Prev := Prev; -- Prev <--> Next @@ -235,6 +257,10 @@ package body GNAT.Lists is L.Elements := L.Elements - 1; + -- Invoke the element destructor before deallocating the node + + Destroy_Element (Nod.Elem); + Free (Ref); end Delete_Node; @@ -242,7 +268,7 @@ package body GNAT.Lists is -- Destroy -- ------------- - procedure Destroy (L : in out Instance) is + procedure Destroy (L : in out Doubly_Linked_List) is Head : Node_Ptr; begin @@ -263,10 +289,10 @@ package body GNAT.Lists is --------------------- procedure Ensure_Circular (Head : Node_Ptr) is - pragma Assert (Head /= null); + pragma Assert (Present (Head)); begin - if Head.Next = null and then Head.Prev = null then + if not Present (Head.Next) and then not Present (Head.Prev) then Head.Next := Head; Head.Prev := Head; end if; @@ -276,9 +302,9 @@ package body GNAT.Lists is -- Ensure_Created -- -------------------- - procedure Ensure_Created (L : Instance) is + procedure Ensure_Created (L : Doubly_Linked_List) is begin - if L = null then + if not Present (L) then raise Not_Created; end if; end Ensure_Created; @@ -287,9 +313,9 @@ package body GNAT.Lists is -- Ensure_Full -- ----------------- - procedure Ensure_Full (L : Instance) is + procedure Ensure_Full (L : Doubly_Linked_List) is begin - pragma Assert (L /= null); + pragma Assert (Present (L)); if L.Elements = 0 then raise List_Empty; @@ -300,9 +326,9 @@ package body GNAT.Lists is -- Ensure_Unlocked -- --------------------- - procedure Ensure_Unlocked (L : Instance) is + procedure Ensure_Unlocked (L : Doubly_Linked_List) is begin - pragma Assert (L /= null); + pragma Assert (Present (L)); -- The list has at least one outstanding iterator @@ -319,7 +345,7 @@ package body GNAT.Lists is (Head : Node_Ptr; Elem : Element_Type) return Node_Ptr is - pragma Assert (Head /= null); + pragma Assert (Present (Head)); Nod : Node_Ptr; @@ -342,7 +368,7 @@ package body GNAT.Lists is -- First -- ----------- - function First (L : Instance) return Element_Type is + function First (L : Doubly_Linked_List) return Element_Type is begin Ensure_Created (L); Ensure_Full (L); @@ -374,7 +400,7 @@ package body GNAT.Lists is ------------------ procedure Insert_After - (L : Instance; + (L : Doubly_Linked_List; After : Element_Type; Elem : Element_Type) is @@ -402,7 +428,7 @@ package body GNAT.Lists is ------------------- procedure Insert_Before - (L : Instance; + (L : Doubly_Linked_List; Before : Element_Type; Elem : Element_Type) is @@ -430,14 +456,14 @@ package body GNAT.Lists is -------------------- procedure Insert_Between - (L : Instance; + (L : Doubly_Linked_List; Elem : Element_Type; Left : Node_Ptr; Right : Node_Ptr) is - pragma Assert (L /= null); - pragma Assert (Left /= null); - pragma Assert (Right /= null); + pragma Assert (Present (L)); + pragma Assert (Present (Left)); + pragma Assert (Present (Right)); Nod : constant Node_Ptr := new Node'(Elem => Elem, @@ -455,7 +481,7 @@ package body GNAT.Lists is -- Is_Empty -- -------------- - function Is_Empty (L : Instance) return Boolean is + function Is_Empty (L : Doubly_Linked_List) return Boolean is begin Ensure_Created (L); @@ -471,26 +497,29 @@ package body GNAT.Lists is -- The invariant of Iterate and Next ensures that the iterator always -- refers to a valid node if there exists one. - return Is_Valid (Iter.Nod, Iter.List.Nodes'Access); + return Is_Valid (Iter.Curr_Nod, Iter.List.Nodes'Access); end Is_Valid; -------------- -- Is_Valid -- -------------- - function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean is + function Is_Valid + (Nod : Node_Ptr; + Head : Node_Ptr) return Boolean + is begin -- A node is valid if it is non-null, and does not refer to the dummy -- head of some list. - return Nod /= null and then Nod /= Head; + return Present (Nod) and then Nod /= Head; end Is_Valid; ------------- -- Iterate -- ------------- - function Iterate (L : Instance) return Iterator is + function Iterate (L : Doubly_Linked_List) return Iterator is begin Ensure_Created (L); @@ -499,14 +528,14 @@ package body GNAT.Lists is Lock (L); - return (List => L, Nod => L.Nodes.Next); + return (List => L, Curr_Nod => L.Nodes.Next); end Iterate; ---------- -- Last -- ---------- - function Last (L : Instance) return Element_Type is + function Last (L : Doubly_Linked_List) return Element_Type is begin Ensure_Created (L); Ensure_Full (L); @@ -518,9 +547,9 @@ package body GNAT.Lists is -- Lock -- ---------- - procedure Lock (L : Instance) is + procedure Lock (L : Doubly_Linked_List) is begin - pragma Assert (L /= null); + pragma Assert (Present (L)); -- The list may be locked multiple times if multiple iterators are -- operating over it. @@ -532,9 +561,12 @@ package body GNAT.Lists is -- Next -- ---------- - procedure Next (Iter : in out Iterator; Elem : out Element_Type) is + procedure Next + (Iter : in out Iterator; + Elem : out Element_Type) + is Is_OK : constant Boolean := Is_Valid (Iter); - Saved : constant Node_Ptr := Iter.Nod; + Saved : constant Node_Ptr := Iter.Curr_Nod; begin -- The iterator is no linger valid which indicates that it has been @@ -548,15 +580,19 @@ package body GNAT.Lists is -- Advance to the next node along the list - Iter.Nod := Iter.Nod.Next; - Elem := Saved.Elem; + Iter.Curr_Nod := Iter.Curr_Nod.Next; + + Elem := Saved.Elem; end Next; ------------- -- Prepend -- ------------- - procedure Prepend (L : Instance; Elem : Element_Type) is + procedure Prepend + (L : Doubly_Linked_List; + Elem : Element_Type) + is Head : Node_Ptr; begin @@ -580,11 +616,29 @@ package body GNAT.Lists is end Prepend; ------------- + -- Present -- + ------------- + + function Present (L : Doubly_Linked_List) return Boolean is + begin + return L /= Nil; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (Nod : Node_Ptr) return Boolean is + begin + return Nod /= null; + end Present; + + ------------- -- Replace -- ------------- procedure Replace - (L : Instance; + (L : Doubly_Linked_List; Old_Elem : Element_Type; New_Elem : Element_Type) is @@ -607,7 +661,7 @@ package body GNAT.Lists is -- Size -- ---------- - function Size (L : Instance) return Natural is + function Size (L : Doubly_Linked_List) return Natural is begin Ensure_Created (L); @@ -618,15 +672,15 @@ package body GNAT.Lists is -- Unlock -- ------------ - procedure Unlock (L : Instance) is + procedure Unlock (L : Doubly_Linked_List) is begin - pragma Assert (L /= null); + pragma Assert (Present (L)); -- The list may be locked multiple times if multiple iterators are -- operating over it. L.Iterators := L.Iterators - 1; end Unlock; - end Doubly_Linked_List; + end Doubly_Linked_Lists; end GNAT.Lists; diff --git a/gcc/ada/libgnat/g-lists.ads b/gcc/ada/libgnat/g-lists.ads index 75dfeb5..b64ef08 100644 --- a/gcc/ada/libgnat/g-lists.ads +++ b/gcc/ada/libgnat/g-lists.ads @@ -40,12 +40,12 @@ package GNAT.Lists is -- The following package offers a doubly linked list abstraction with the -- following characteristics: -- - -- * Creation of multiple instances, of different sizes. - -- * Iterable elements. + -- * Creation of multiple instances, of different sizes + -- * Iterable elements -- -- The following use pattern must be employed with this list: -- - -- List : Instance := Create; + -- List : Doubly_Linked_List := Create; -- -- <various operations> -- @@ -60,60 +60,69 @@ package GNAT.Lists is (Left : Element_Type; Right : Element_Type) return Boolean; - package Doubly_Linked_List is + with procedure Destroy_Element (Elem : in out Element_Type); + -- Element destructor + + package Doubly_Linked_Lists is --------------------- -- List operations -- --------------------- - type Instance is private; - Nil : constant Instance; + type Doubly_Linked_List is private; + Nil : constant Doubly_Linked_List; -- The following exception is raised when the list is empty, and an -- attempt is made to delete an element from it. List_Empty : exception; - procedure Append (L : Instance; Elem : Element_Type); + procedure Append + (L : Doubly_Linked_List; + Elem : Element_Type); -- Insert element Elem at the end of list L. This action will raise -- Iterated if the list has outstanding iterators. - function Contains (L : Instance; Elem : Element_Type) return Boolean; + function Contains + (L : Doubly_Linked_List; + Elem : Element_Type) return Boolean; -- Determine whether list L contains element Elem - function Create return Instance; + function Create return Doubly_Linked_List; -- Create a new list - procedure Delete (L : Instance; Elem : Element_Type); + procedure Delete + (L : Doubly_Linked_List; + Elem : Element_Type); -- Delete element Elem from list L. The routine has no effect if Elem is -- not present. This action will raise -- -- * List_Empty if the list is empty. -- * Iterated if the list has outstanding iterators. - procedure Delete_First (L : Instance); + procedure Delete_First (L : Doubly_Linked_List); -- Delete an element from the start of list L. This action will raise -- -- * List_Empty if the list is empty. -- * Iterated if the list has outstanding iterators. - procedure Delete_Last (L : Instance); + procedure Delete_Last (L : Doubly_Linked_List); -- Delete an element from the end of list L. This action will raise -- -- * List_Empty if the list is empty. -- * Iterated if the list has outstanding iterators. - procedure Destroy (L : in out Instance); + procedure Destroy (L : in out Doubly_Linked_List); -- Destroy the contents of list L. This routine must be called at the -- end of a list's lifetime. This action will raise Iterated if the -- list has outstanding iterators. - function First (L : Instance) return Element_Type; + function First (L : Doubly_Linked_List) return Element_Type; -- Obtain an element from the start of list L. This action will raise -- List_Empty if the list is empty. procedure Insert_After - (L : Instance; + (L : Doubly_Linked_List; After : Element_Type; Elem : Element_Type); -- Insert new element Elem after element After in list L. The routine @@ -121,33 +130,38 @@ package GNAT.Lists is -- Iterated if the list has outstanding iterators. procedure Insert_Before - (L : Instance; + (L : Doubly_Linked_List; Before : Element_Type; Elem : Element_Type); -- Insert new element Elem before element Before in list L. The routine -- has no effect if After is not present. This action will raise -- Iterated if the list has outstanding iterators. - function Is_Empty (L : Instance) return Boolean; + function Is_Empty (L : Doubly_Linked_List) return Boolean; -- Determine whether list L is empty - function Last (L : Instance) return Element_Type; + function Last (L : Doubly_Linked_List) return Element_Type; -- Obtain an element from the end of list L. This action will raise -- List_Empty if the list is empty. - procedure Prepend (L : Instance; Elem : Element_Type); + procedure Prepend + (L : Doubly_Linked_List; + Elem : Element_Type); -- Insert element Elem at the start of list L. This action will raise -- Iterated if the list has outstanding iterators. + function Present (L : Doubly_Linked_List) return Boolean; + -- Determine whether list L exists + procedure Replace - (L : Instance; + (L : Doubly_Linked_List; Old_Elem : Element_Type; New_Elem : Element_Type); -- Replace old element Old_Elem with new element New_Elem in list L. The -- routine has no effect if Old_Elem is not present. This action will -- raise Iterated if the list has outstanding iterators. - function Size (L : Instance) return Natural; + function Size (L : Doubly_Linked_List) return Natural; -- Obtain the number of elements in list L ------------------------- @@ -168,16 +182,18 @@ package GNAT.Lists is type Iterator is private; - function Iterate (L : Instance) return Iterator; - -- Obtain an iterator over the elements of list L. This action locks all - -- mutation functionality of the associated list. - function Has_Next (Iter : Iterator) return Boolean; -- Determine whether iterator Iter has more elements to examine. If the -- iterator has been exhausted, restore all mutation functionality of -- the associated list. - procedure Next (Iter : in out Iterator; Elem : out Element_Type); + function Iterate (L : Doubly_Linked_List) return Iterator; + -- Obtain an iterator over the elements of list L. This action locks all + -- mutation functionality of the associated list. + + procedure Next + (Iter : in out Iterator; + Elem : out Element_Type); -- Return the current element referenced by iterator Iter and advance -- to the next available element. If the iterator has been exhausted -- and further attempts are made to advance it, this routine restores @@ -198,7 +214,7 @@ package GNAT.Lists is -- The following type represents a list - type Linked_List is record + type Doubly_Linked_List_Attributes is record Elements : Natural := 0; -- The number of elements in the list @@ -209,20 +225,20 @@ package GNAT.Lists is -- The dummy head of the list end record; - type Instance is access all Linked_List; - Nil : constant Instance := null; + type Doubly_Linked_List is access all Doubly_Linked_List_Attributes; + Nil : constant Doubly_Linked_List := null; -- The following type represents an element iterator type Iterator is record - List : Instance := null; - -- Reference to the associated list - - Nod : Node_Ptr := null; + Curr_Nod : Node_Ptr := null; -- Reference to the current node being examined. The invariant of the -- iterator requires that this field always points to a valid node. A -- value of null indicates that the iterator is exhausted. + + List : Doubly_Linked_List := null; + -- Reference to the associated list end record; - end Doubly_Linked_List; + end Doubly_Linked_Lists; end GNAT.Lists; diff --git a/gcc/ada/libgnat/g-sets.adb b/gcc/ada/libgnat/g-sets.adb index bd367cb..b588880 100644 --- a/gcc/ada/libgnat/g-sets.adb +++ b/gcc/ada/libgnat/g-sets.adb @@ -31,46 +31,59 @@ package body GNAT.Sets is - -------------------- - -- Membership_Set -- - -------------------- + --------------------- + -- Membership_Sets -- + --------------------- - package body Membership_Set is + package body Membership_Sets is -------------- -- Contains -- -------------- - function Contains (S : Instance; Elem : Element_Type) return Boolean is + function Contains + (S : Membership_Set; + Elem : Element_Type) return Boolean + is begin - return Hashed_Set.Get (Hashed_Set.Instance (S), Elem); + return Hashed_Set.Contains (Hashed_Set.Dynamic_Hash_Table (S), Elem); end Contains; ------------ -- Create -- ------------ - function Create (Initial_Size : Positive) return Instance is + function Create (Initial_Size : Positive) return Membership_Set is begin - return Instance (Hashed_Set.Create (Initial_Size)); + return Membership_Set (Hashed_Set.Create (Initial_Size)); end Create; ------------ -- Delete -- ------------ - procedure Delete (S : Instance; Elem : Element_Type) is + procedure Delete (S : Membership_Set; Elem : Element_Type) is begin - Hashed_Set.Delete (Hashed_Set.Instance (S), Elem); + Hashed_Set.Delete (Hashed_Set.Dynamic_Hash_Table (S), Elem); end Delete; ------------- -- Destroy -- ------------- - procedure Destroy (S : in out Instance) is + procedure Destroy (B : in out Boolean) is + pragma Unreferenced (B); begin - Hashed_Set.Destroy (Hashed_Set.Instance (S)); + null; + end Destroy; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (S : in out Membership_Set) is + begin + Hashed_Set.Destroy (Hashed_Set.Dynamic_Hash_Table (S)); end Destroy; -------------- @@ -86,46 +99,71 @@ package body GNAT.Sets is -- Insert -- ------------ - procedure Insert (S : Instance; Elem : Element_Type) is + procedure Insert + (S : Membership_Set; + Elem : Element_Type) + is begin - Hashed_Set.Put (Hashed_Set.Instance (S), Elem, True); + Hashed_Set.Put (Hashed_Set.Dynamic_Hash_Table (S), Elem, True); end Insert; -------------- -- Is_Empty -- -------------- - function Is_Empty (S : Instance) return Boolean is + function Is_Empty (S : Membership_Set) return Boolean is begin - return Hashed_Set.Is_Empty (Hashed_Set.Instance (S)); + return Hashed_Set.Is_Empty (Hashed_Set.Dynamic_Hash_Table (S)); end Is_Empty; ------------- -- Iterate -- ------------- - function Iterate (S : Instance) return Iterator is + function Iterate (S : Membership_Set) return Iterator is begin - return Iterator (Hashed_Set.Iterate (Hashed_Set.Instance (S))); + return + Iterator (Hashed_Set.Iterate (Hashed_Set.Dynamic_Hash_Table (S))); end Iterate; ---------- -- Next -- ---------- - procedure Next (Iter : in out Iterator; Elem : out Element_Type) is + procedure Next + (Iter : in out Iterator; + Elem : out Element_Type) + is begin Hashed_Set.Next (Hashed_Set.Iterator (Iter), Elem); end Next; + ------------- + -- Present -- + ------------- + + function Present (S : Membership_Set) return Boolean is + begin + return Hashed_Set.Present (Hashed_Set.Dynamic_Hash_Table (S)); + end Present; + + ----------- + -- Reset -- + ----------- + + procedure Reset (S : Membership_Set) is + begin + Hashed_Set.Reset (Hashed_Set.Dynamic_Hash_Table (S)); + end Reset; + ---------- -- Size -- ---------- - function Size (S : Instance) return Natural is + function Size (S : Membership_Set) return Natural is begin - return Hashed_Set.Size (Hashed_Set.Instance (S)); + return Hashed_Set.Size (Hashed_Set.Dynamic_Hash_Table (S)); end Size; - end Membership_Set; + end Membership_Sets; end GNAT.Sets; diff --git a/gcc/ada/libgnat/g-sets.ads b/gcc/ada/libgnat/g-sets.ads index 27b1a65..1898e26 100644 --- a/gcc/ada/libgnat/g-sets.ads +++ b/gcc/ada/libgnat/g-sets.ads @@ -42,12 +42,12 @@ package GNAT.Sets is -- The following package offers a membership set abstraction with the -- following characteristics: -- - -- * Creation of multiple instances, of different sizes. - -- * Iterable elements. + -- * Creation of multiple instances, of different sizes + -- * Iterable elements -- -- The following use pattern must be employed with this set: -- - -- Set : Instance := Create (<some size>); + -- Set : Membership_Set := Create (<some size>); -- -- <various operations> -- @@ -65,7 +65,7 @@ package GNAT.Sets is with function Hash (Key : Element_Type) return Bucket_Range_Type; -- Map an arbitrary key into the range of buckets - package Membership_Set is + package Membership_Sets is -------------------- -- Set operations -- @@ -74,36 +74,50 @@ package GNAT.Sets is -- The following type denotes a membership set handle. Each instance -- must be created using routine Create. - type Instance is private; - Nil : constant Instance; + type Membership_Set is private; + Nil : constant Membership_Set; - function Contains (S : Instance; Elem : Element_Type) return Boolean; + function Contains + (S : Membership_Set; + Elem : Element_Type) return Boolean; -- Determine whether membership set S contains element Elem - function Create (Initial_Size : Positive) return Instance; + function Create (Initial_Size : Positive) return Membership_Set; -- Create a new membership set with bucket capacity Initial_Size. This -- routine must be called at the start of the membership set's lifetime. - procedure Delete (S : Instance; Elem : Element_Type); + procedure Delete + (S : Membership_Set; + Elem : Element_Type); -- Delete element Elem from membership set S. The routine has no effect -- if the element is not present in the membership set. This action will -- raise Iterated if the membership set has outstanding iterators. - procedure Destroy (S : in out Instance); + procedure Destroy (S : in out Membership_Set); -- Destroy the contents of membership set S, rendering it unusable. This -- routine must be called at the end of the membership set's lifetime. -- This action will raise Iterated if the hash table has outstanding -- iterators. - procedure Insert (S : Instance; Elem : Element_Type); + procedure Insert + (S : Membership_Set; + Elem : Element_Type); -- Insert element Elem in membership set S. The routine has no effect -- if the element is already present in the membership set. This action -- will raise Iterated if the membership set has outstanding iterators. - function Is_Empty (S : Instance) return Boolean; + function Is_Empty (S : Membership_Set) return Boolean; -- Determine whether set S is empty - function Size (S : Instance) return Natural; + function Present (S : Membership_Set) return Boolean; + -- Determine whether set S exists + + procedure Reset (S : Membership_Set); + -- Destroy the contents of membership set S, and reset it to its initial + -- created state. This action will raise Iterated if the membership set + -- has outstanding iterators. + + function Size (S : Membership_Set) return Natural; -- Obtain the number of elements in membership set S ------------------------- @@ -124,7 +138,7 @@ package GNAT.Sets is type Iterator is private; - function Iterate (S : Instance) return Iterator; + function Iterate (S : Membership_Set) return Iterator; -- Obtain an iterator over the elements of membership set S. This action -- locks all mutation functionality of the associated membership set. @@ -141,7 +155,10 @@ package GNAT.Sets is -- raises Iterator_Exhausted. private - package Hashed_Set is new Dynamic_HTable + procedure Destroy (B : in out Boolean); + -- Destroy boolean B + + package Hashed_Set is new Dynamic_Hash_Tables (Key_Type => Element_Type, Value_Type => Boolean, No_Value => False, @@ -150,12 +167,13 @@ package GNAT.Sets is Compression_Threshold => 0.3, Compression_Factor => 2, "=" => "=", + Destroy_Value => Destroy, Hash => Hash); - type Instance is new Hashed_Set.Instance; - Nil : constant Instance := Instance (Hashed_Set.Nil); + type Membership_Set is new Hashed_Set.Dynamic_Hash_Table; + Nil : constant Membership_Set := Membership_Set (Hashed_Set.Nil); type Iterator is new Hashed_Set.Iterator; - end Membership_Set; + end Membership_Sets; end GNAT.Sets; diff --git a/gcc/ada/libgnat/g-sothco.adb b/gcc/ada/libgnat/g-sothco.adb index df82d01..eb15ac2 100644 --- a/gcc/ada/libgnat/g-sothco.adb +++ b/gcc/ada/libgnat/g-sothco.adb @@ -59,14 +59,15 @@ package body GNAT.Sockets.Thin_Common is ----------------- function Get_Address (Sin : Sockaddr) return Sock_Addr_Type is + use type C.unsigned_short; Family : constant C.unsigned_short := (if SOSC.Has_Sockaddr_Len = 0 then Sin.Sin_Family.Short_Family else C.unsigned_short (Sin.Sin_Family.Char_Family)); + AF_INET6_Defined : constant Boolean := SOSC.AF_INET6 > 0; Result : Sock_Addr_Type - (case Family is - when SOSC.AF_INET6 => Family_Inet6, - when SOSC.AF_INET => Family_Inet, - when others => Family_Unspec); + (if AF_INET6_Defined and then SOSC.AF_INET6 = Family then Family_Inet6 + elsif SOSC.AF_INET = Family then Family_Inet + else Family_Unspec); begin Result.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); diff --git a/gcc/ada/libgnat/s-win32.ads b/gcc/ada/libgnat/s-win32.ads index e69c01e..d09c4b3 100644 --- a/gcc/ada/libgnat/s-win32.ads +++ b/gcc/ada/libgnat/s-win32.ads @@ -57,6 +57,7 @@ package System.Win32 is INVALID_HANDLE_VALUE : constant HANDLE := -1; INVALID_FILE_SIZE : constant := 16#FFFFFFFF#; + type ULONG is new Interfaces.C.unsigned_long; type DWORD is new Interfaces.C.unsigned_long; type WORD is new Interfaces.C.unsigned_short; type BYTE is new Interfaces.C.unsigned_char; @@ -157,18 +158,20 @@ package System.Win32 is GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS : constant := 16#00000004#; type OVERLAPPED is record - Internal : DWORD; - InternalHigh : DWORD; + Internal : access ULONG; + InternalHigh : access ULONG; Offset : DWORD; OffsetHigh : DWORD; hEvent : HANDLE; end record; + pragma Convention (C_Pass_By_Copy, OVERLAPPED); type SECURITY_ATTRIBUTES is record nLength : DWORD; pSecurityDescriptor : PVOID; bInheritHandle : BOOL; end record; + pragma Convention (C_Pass_By_Copy, SECURITY_ATTRIBUTES); function CreateFileA (lpFileName : Address; @@ -267,6 +270,7 @@ package System.Win32 is dwAllocationGranularity : DWORD; dwReserved : DWORD; end record; + pragma Convention (C_Pass_By_Copy, SYSTEM_INFO); procedure GetSystemInfo (SI : access SYSTEM_INFO); pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo"); @@ -285,6 +289,7 @@ package System.Win32 is wSecond : WORD; wMilliseconds : WORD; end record; + pragma Convention (C_Pass_By_Copy, SYSTEMTIME); procedure GetSystemTime (pSystemTime : access SYSTEMTIME); pragma Import (Stdcall, GetSystemTime, "GetSystemTime"); diff --git a/gcc/ada/libgnat/system-darwin-ppc.ads b/gcc/ada/libgnat/system-darwin-ppc.ads index d314b66..9adc2de 100644 --- a/gcc/ada/libgnat/system-darwin-ppc.ads +++ b/gcc/ada/libgnat/system-darwin-ppc.ads @@ -158,7 +158,7 @@ private Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; Support_Atomic_Primitives : constant Boolean := Word_Size = 64; diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 5f1ff90..c5454d4 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -1497,6 +1497,33 @@ package body Namet is return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2); end Name_Equals; + ------------- + -- Present -- + ------------- + + function Present (Nam : File_Name_Type) return Boolean is + begin + return Nam /= No_File; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (Nam : Name_Id) return Boolean is + begin + return Nam /= No_Name; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (Nam : Unit_Name_Type) return Boolean is + begin + return Nam /= No_Unit_Name; + end Present; + ------------------ -- Reinitialize -- ------------------ diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 58fbc08..a54735a 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -204,6 +204,10 @@ package Namet is subtype Valid_Name_Id is Name_Id range First_Name_Id .. Name_Id'Last; -- All but No_Name and Error_Name + function Present (Nam : Name_Id) return Boolean; + pragma Inline (Present); + -- Determine whether name Nam exists + ------------------------------ -- Name_Id Membership Tests -- ------------------------------ @@ -626,6 +630,10 @@ package Namet is -- Constant used to indicate no file is present (this is used for example -- when a search for a file indicates that no file of the name exists). + function Present (Nam : File_Name_Type) return Boolean; + pragma Inline (Present); + -- Determine whether file name Nam exists + Error_File_Name : constant File_Name_Type := File_Name_Type (Error_Name); -- The special File_Name_Type value Error_File_Name is used to indicate -- a unit name where some previous processing has found an error. @@ -650,6 +658,10 @@ package Namet is No_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (No_Name); -- Constant used to indicate no file name present + function Present (Nam : Unit_Name_Type) return Boolean; + pragma Inline (Present); + -- Determine whether unit name Nam exists + Error_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (Error_Name); -- The special Unit_Name_Type value Error_Unit_Name is used to indicate -- a unit name where some previous processing has found an error. diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 4ee5fdb..16b5cba 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -746,9 +746,9 @@ package Opt is -- file name with extension stripped. Generate_C_Code : Boolean := False; - -- GNAT + -- GNAT, GNATBIND -- If True, the Cprint circuitry to generate C code output is activated. - -- Set True by use of -gnateg or -gnatd.V. + -- Set True by use of -gnateg or -gnatd.V for GNAT, and -G for GNATBIND. Generate_CodePeer_Messages : Boolean := False; -- GNAT diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 40772c3..d9d72d0 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -1422,6 +1422,15 @@ package body Osint is return Name_Find; end Get_Directory; + ------------------------------ + -- Get_First_Main_File_Name -- + ------------------------------ + + function Get_First_Main_File_Name return String is + begin + return File_Names (1).all; + end Get_First_Main_File_Name; + -------------------------- -- Get_Next_Dir_In_Path -- -------------------------- diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 048225e..dda44e7 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -511,6 +511,9 @@ package Osint is procedure Dump_Command_Line_Source_File_Names; -- Prints out the names of all source files on the command-line + function Get_First_Main_File_Name return String; + -- Return the file name of the first main file + ------------------------------------------- -- Representation of Library Information -- ------------------------------------------- diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 75c17c3..aff14ed 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -228,8 +228,12 @@ package body Ch3 is raise Error_Resync; end if; + if Style_Check then + Style.Check_Defining_Identifier_Casing; + end if; + Ident_Node := Token_Node; - Scan; -- past the reserved identifier + Scan; -- past the identifier -- If we already have a defining identifier, clean it out and make -- a new clean identifier. This situation arises in some error cases diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index cd6e521..47ad874 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -3155,7 +3155,7 @@ package Rtsfind is -- immediately, since obviously Ent cannot be the entity in question if the -- corresponding unit has not been loaded. - function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean; + function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean; pragma Inline (Is_RTU); -- This function determines if the given entity corresponds to the entity -- for the unit referenced by U. If this unit has not been loaded, the diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e966bf1..bdc76c3 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3833,14 +3833,16 @@ package body Sem_Attr is Check_Discrete_Type; Resolve (E1, P_Base_Type); - -- X'Enum_Rep case. X must be an object or enumeration literal, and - -- it must be of a discrete type. + -- X'Enum_Rep case. X must be an object or enumeration literal + -- (including an attribute reference), and it must be of a + -- discrete type. elsif not ((Is_Object_Reference (P) or else (Is_Entity_Name (P) - and then Ekind (Entity (P)) = E_Enumeration_Literal)) + and then Ekind (Entity (P)) = E_Enumeration_Literal) + or else Nkind (P) = N_Attribute_Reference) and then Is_Discrete_Type (Etype (P))) then Error_Attr_P ("prefix of % attribute must be discrete object"); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index efbb6cc..42feab0 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3473,6 +3473,17 @@ package body Sem_Ch12 is begin Check_SPARK_05_Restriction ("generic is not allowed", N); + -- A generic may grant access to its private enclosing context depending + -- on the placement of its corresponding body. From elaboration point of + -- view, the flow of execution may enter this private context, and then + -- reach an external unit, thus producing a dependency on that external + -- unit. For such a path to be properly discovered and encoded in the + -- ALI file of the main unit, let the ABE mechanism process the body of + -- the main unit, and encode all relevant invocation constructs and the + -- relations between them. + + Mark_Save_Invocation_Graph_Of_Body; + -- We introduce a renaming of the enclosing package, to have a usable -- entity as the prefix of an expanded name for a local entity of the -- form Par.P.Q, where P is the generic package. This is because a local @@ -3668,6 +3679,17 @@ package body Sem_Ch12 is begin Check_SPARK_05_Restriction ("generic is not allowed", N); + -- A generic may grant access to its private enclosing context depending + -- on the placement of its corresponding body. From elaboration point of + -- view, the flow of execution may enter this private context, and then + -- reach an external unit, thus producing a dependency on that external + -- unit. For such a path to be properly discovered and encoded in the + -- ALI file of the main unit, let the ABE mechanism process the body of + -- the main unit, and encode all relevant invocation constructs and the + -- relations between them. + + Mark_Save_Invocation_Graph_Of_Body; + -- Create copy of generic unit, and save for instantiation. If the unit -- is a child unit, do not copy the specifications for the parent, which -- are not part of the generic tree. @@ -3899,8 +3921,8 @@ package body Sem_Ch12 is -- Local declarations Gen_Id : constant Node_Id := Name (N); - Is_Actual_Pack : constant Boolean := - Is_Internal (Defining_Entity (N)); + Inst_Id : constant Entity_Id := Defining_Entity (N); + Is_Actual_Pack : constant Boolean := Is_Internal (Inst_Id); Loc : constant Source_Ptr := Sloc (N); Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; @@ -4109,6 +4131,9 @@ package body Sem_Ch12 is goto Leave; else + Set_Ekind (Inst_Id, E_Package); + Set_Scope (Inst_Id, Current_Scope); + -- If the context of the instance is subject to SPARK_Mode "off" or -- the annotation is altogether missing, set the global flag which -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within @@ -5156,14 +5181,13 @@ package body Sem_Ch12 is (N : Node_Id; K : Entity_Kind) is - Loc : constant Source_Ptr := Sloc (N); - Gen_Id : constant Node_Id := Name (N); - Errs : constant Nat := Serious_Errors_Detected; - - Anon_Id : constant Entity_Id := - Make_Defining_Identifier (Sloc (Defining_Entity (N)), - Chars => New_External_Name - (Chars (Defining_Entity (N)), 'R')); + Errs : constant Nat := Serious_Errors_Detected; + Gen_Id : constant Node_Id := Name (N); + Inst_Id : constant Entity_Id := Defining_Entity (N); + Anon_Id : constant Entity_Id := + Make_Defining_Identifier (Sloc (Inst_Id), + Chars => New_External_Name (Chars (Inst_Id), 'R')); + Loc : constant Source_Ptr := Sloc (N); Act_Decl_Id : Entity_Id := Empty; -- init to avoid warning Act_Decl : Node_Id; @@ -5489,6 +5513,9 @@ package body Sem_Ch12 is Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); else + Set_Ekind (Inst_Id, K); + Set_Scope (Inst_Id, Current_Scope); + Set_Entity (Gen_Id, Gen_Unit); Set_Is_Instantiated (Gen_Unit); @@ -5654,6 +5681,16 @@ package body Sem_Ch12 is Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); + Set_Has_Pragma_Inline_Always + (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); + Set_Has_Pragma_Inline_Always + (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit)); + + Set_Has_Pragma_No_Inline + (Act_Decl_Id, Has_Pragma_No_Inline (Gen_Unit)); + Set_Has_Pragma_No_Inline + (Anon_Id, Has_Pragma_No_Inline (Gen_Unit)); + -- Propagate No_Return if pragma applied to generic unit. This must -- be done explicitly because pragma does not appear in generic -- declaration (unlike the aspect case). @@ -5663,11 +5700,6 @@ package body Sem_Ch12 is Set_No_Return (Anon_Id); end if; - Set_Has_Pragma_Inline_Always - (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); - Set_Has_Pragma_Inline_Always - (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit)); - -- Mark both the instance spec and the anonymous package in case the -- body is instantiated at a later pass. This preserves the original -- context in effect for the body. @@ -6190,6 +6222,12 @@ package body Sem_Ch12 is -- Common error routine for mismatch between the parameters of the -- actual instance and those of the formal package. + function Is_Defaulted (Param : Entity_Id) return Boolean; + -- If the formal package has partly box-initialized formals, skip + -- conformance check for these formals. Previously the code assumed + -- that box initialization for a formal package applied to all its + -- formal parameters. + function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean; -- The formal may come from a nested formal package, and the actual may -- have been constant-folded. To determine whether the two denote the @@ -6240,6 +6278,34 @@ package body Sem_Ch12 is end if; end Check_Mismatch; + ------------------ + -- Is_Defaulted -- + ------------------ + + function Is_Defaulted (Param : Entity_Id) return Boolean is + Assoc : Node_Id; + + begin + Assoc := + First (Generic_Associations (Parent + (Associated_Formal_Package (Actual_Pack)))); + + while Present (Assoc) loop + if Nkind (Assoc) = N_Others_Choice then + return True; + + elsif Nkind (Assoc) = N_Generic_Association + and then Chars (Selector_Name (Assoc)) = Chars (Param) + then + return Box_Present (Assoc); + end if; + + Next (Assoc); + end loop; + + return False; + end Is_Defaulted; + -------------------------------- -- Same_Instantiated_Constant -- -------------------------------- @@ -6409,6 +6475,9 @@ package body Sem_Ch12 is then goto Next_E; + elsif Is_Defaulted (E1) then + goto Next_E; + elsif Is_Type (E1) then -- Subtypes must statically match. E1, E2 are the local entities diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 7e6e5fc..2a4afb8 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4933,9 +4933,13 @@ package body Sem_Ch13 is elsif Is_Object (Ent) and then Present (Renamed_Object (Ent)) then - -- Case of renamed object from source, this is an error + -- In the case of a renamed object from source, this is an error + -- unless the object is an aggregate and the renaming is created + -- for an object declaration. - if Comes_From_Source (Renamed_Object (Ent)) then + if Comes_From_Source (Renamed_Object (Ent)) + and then Nkind (Renamed_Object (Ent)) /= N_Aggregate + then Get_Name_String (Chars (N)); Error_Msg_Strlen := Name_Len; Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); @@ -8197,6 +8201,13 @@ package body Sem_Ch13 is Set_Static_Discrete_Predicate (Typ, Plist); + -- Within a generic the predicate functions themselves need not + -- be constructed. + + if Inside_A_Generic then + return; + end if; + -- The processing for static predicates put the expression into -- canonical form as a series of ranges. It also eliminated -- duplicates and collapsed and combined ranges. We might as well @@ -8729,9 +8740,13 @@ package body Sem_Ch13 is -- Do not generate predicate bodies within a generic unit. The -- expressions have been analyzed already, and the bodies play - -- no role if not within an executable unit. + -- no role if not within an executable unit. However, if a statc + -- predicate is present it must be processed for legality checks + -- such as case coverage in an expression. - elsif Inside_A_Generic then + elsif Inside_A_Generic + and then not Has_Static_Predicate_Aspect (Typ) + then return; end if; @@ -9324,8 +9339,8 @@ package body Sem_Ch13 is Analyze (End_Decl_Expr); Set_Is_Frozen (Ent, True); - -- If the end of declarations comes before any other freeze - -- point, the Freeze_Expr is not analyzed: no check needed. + -- If the end of declarations comes before any other freeze point, + -- the Freeze_Expr is not analyzed: no check needed. if Analyzed (Freeze_Expr) and then not In_Instance then Check_Overloaded_Name; @@ -9336,6 +9351,13 @@ package body Sem_Ch13 is -- All other cases else + -- In a generic context freeze nodes are not always generated, so + -- analyze the expression now. + + if not Analyzed (Freeze_Expr) and then Inside_A_Generic then + Preanalyze (Freeze_Expr); + end if; + -- Indicate that the expression comes from an aspect specification, -- which is used in subsequent analysis even if expansion is off. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 8b06223..75a0099 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -924,15 +924,16 @@ package body Sem_Ch3 is Set_Has_Delayed_Freeze (Current_Scope); end if; - -- Ada 2005: If the designated type is an interface that may contain - -- tasks, create a Master entity for the declaration. This must be done - -- before expansion of the full declaration, because the declaration may - -- include an expression that is an allocator, whose expansion needs the - -- proper Master for the created tasks. + -- If the designated type is limited and class-wide, the object might + -- contain tasks, so we create a Master entity for the declaration. This + -- must be done before expansion of the full declaration, because the + -- declaration may include an expression that is an allocator, whose + -- expansion needs the proper Master for the created tasks. if Nkind (Related_Nod) = N_Object_Declaration and then Expander_Active then - if Is_Interface (Desig_Type) and then Is_Limited_Record (Desig_Type) + if Is_Limited_Record (Desig_Type) + and then Is_Class_Wide_Type (Desig_Type) then Build_Class_Wide_Master (Anon_Type); @@ -8582,6 +8583,16 @@ package body Sem_Ch3 is Parent_Base := Base_Type (Parent_Type); end if; + -- If the parent type is declared as a subtype of another private + -- type with inherited discriminants, its generated base type is + -- itself a record subtype. To further inherit the constraint we + -- need to use its own base to have an unconstrained type on which + -- to apply the inherited constraint. + + if Ekind (Parent_Base) = E_Record_Subtype then + Parent_Base := Base_Type (Parent_Base); + end if; + -- AI05-0115: if this is a derivation from a private type in some -- other scope that may lead to invisible components for the derived -- type, mark it accordingly. @@ -10376,10 +10387,9 @@ package body Sem_Ch3 is -- build-in-place library function, child unit or not. if (Nkind (Nod) in N_Entity and then Is_Compilation_Unit (Nod)) - or else - (Nkind_In (Nod, - N_Defining_Program_Unit_Name, N_Subprogram_Declaration) - and then Is_Compilation_Unit (Defining_Entity (Nod))) + or else (Nkind_In (Nod, N_Defining_Program_Unit_Name, + N_Subprogram_Declaration) + and then Is_Compilation_Unit (Defining_Entity (Nod))) then Add_Global_Declaration (IR); else diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 2c40011..3328f96 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7375,7 +7375,7 @@ package body Sem_Ch4 is Etype (Next_Formal (First_Formal (Op_Id)))) then Error_Msg_N - ("No legal interpretation for operator&", N); + ("no legal interpretation for operator&", N); Error_Msg_NE ("\use clause on& would make operation legal", N, Scope (Op_Id)); @@ -7393,6 +7393,26 @@ package body Sem_Ch4 is Error_Msg_NE ("\left operand has}!", N, Etype (L)); Error_Msg_NE ("\right operand has}!", N, Etype (R)); + -- For multiplication and division operators with + -- a fixed-point operand and an integer operand, + -- indicate that the integer operand should be of + -- type Integer. + + if Nkind_In (N, N_Op_Multiply, N_Op_Divide) + and then Is_Fixed_Point_Type (Etype (L)) + and then Is_Integer_Type (Etype (R)) + then + Error_Msg_N + ("\convert right operand to `Integer`", N); + + elsif Nkind (N) = N_Op_Multiply + and then Is_Fixed_Point_Type (Etype (R)) + and then Is_Integer_Type (Etype (L)) + then + Error_Msg_N + ("\convert left operand to `Integer`", N); + end if; + -- For concatenation operators it is more difficult to -- determine which is the wrong operand. It is worth -- flagging explicitly an access type, for those who diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 76d6bcb..88fd204 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -3359,8 +3359,6 @@ package body Sem_Ch5 is -- The following exception is raised by routine Prepare_Loop_Statement -- to avoid further analysis of a transformed loop. - Skip_Analysis : exception; - function Disable_Constant (N : Node_Id) return Traverse_Result; -- If N represents an E_Variable entity, set Is_True_Constant To False @@ -3368,11 +3366,12 @@ package body Sem_Ch5 is -- Helper for Analyze_Loop_Statement, to unset Is_True_Constant on -- variables referenced within an OpenACC construct. - procedure Prepare_Loop_Statement (Iter : Node_Id); + procedure Prepare_Loop_Statement + (Iter : Node_Id; + Stop_Processing : out Boolean); -- Determine whether loop statement N with iteration scheme Iter must be - -- transformed prior to analysis, and if so, perform it. The routine - -- raises Skip_Analysis to prevent further analysis of the transformed - -- loop. + -- transformed prior to analysis, and if so, perform it. + -- If Stop_Processing is set to True, should stop further processing. ---------------------- -- Disable_Constant -- @@ -3394,7 +3393,10 @@ package body Sem_Ch5 is -- Prepare_Loop_Statement -- ---------------------------- - procedure Prepare_Loop_Statement (Iter : Node_Id) is + procedure Prepare_Loop_Statement + (Iter : Node_Id; + Stop_Processing : out Boolean) + is function Has_Sec_Stack_Default_Iterator (Cont_Typ : Entity_Id) return Boolean; pragma Inline (Has_Sec_Stack_Default_Iterator); @@ -3414,21 +3416,27 @@ package body Sem_Ch5 is -- Determine whether arbitrary statement Stmt is the sole statement -- wrapped within some block, excluding pragmas. - procedure Prepare_Iterator_Loop (Iter_Spec : Node_Id); + procedure Prepare_Iterator_Loop + (Iter_Spec : Node_Id; + Stop_Processing : out Boolean); pragma Inline (Prepare_Iterator_Loop); -- Prepare an iterator loop with iteration specification Iter_Spec -- for transformation if needed. + -- If Stop_Processing is set to True, should stop further processing. - procedure Prepare_Param_Spec_Loop (Param_Spec : Node_Id); + procedure Prepare_Param_Spec_Loop + (Param_Spec : Node_Id; + Stop_Processing : out Boolean); pragma Inline (Prepare_Param_Spec_Loop); -- Prepare a discrete loop with parameter specification Param_Spec -- for transformation if needed. + -- If Stop_Processing is set to True, should stop further processing. procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean); - pragma Inline (Wrap_Loop_Statement); - pragma No_Return (Wrap_Loop_Statement); + pragma Inline (Wrap_Loop_Statement); -- Wrap loop statement N within a block. Flag Manage_Sec_Stack must -- be set when the block must mark and release the secondary stack. + -- Should stop further processing after calling this procedure. ------------------------------------ -- Has_Sec_Stack_Default_Iterator -- @@ -3504,12 +3512,17 @@ package body Sem_Ch5 is -- Prepare_Iterator_Loop -- --------------------------- - procedure Prepare_Iterator_Loop (Iter_Spec : Node_Id) is + procedure Prepare_Iterator_Loop + (Iter_Spec : Node_Id; + Stop_Processing : out Boolean) + is Cont_Typ : Entity_Id; Nam : Node_Id; Nam_Copy : Node_Id; begin + Stop_Processing := False; + -- The iterator specification has syntactic errors. Transform the -- loop into an infinite loop in order to safely perform at least -- some minor analysis. This check must come first. @@ -3517,8 +3530,7 @@ package body Sem_Ch5 is if Error_Posted (Iter_Spec) then Set_Iteration_Scheme (N, Empty); Analyze (N); - - raise Skip_Analysis; + Stop_Processing := True; -- Nothing to do when the loop is already wrapped in a block @@ -3578,6 +3590,7 @@ package body Sem_Ch5 is (Cont_Typ, Name_First) or else Is_Sec_Stack_Iteration_Primitive (Cont_Typ, Name_Next)); + Stop_Processing := True; end if; end if; end Prepare_Iterator_Loop; @@ -3586,7 +3599,10 @@ package body Sem_Ch5 is -- Prepare_Param_Spec_Loop -- ----------------------------- - procedure Prepare_Param_Spec_Loop (Param_Spec : Node_Id) is + procedure Prepare_Param_Spec_Loop + (Param_Spec : Node_Id; + Stop_Processing : out Boolean) + is High : Node_Id; Low : Node_Id; Rng : Node_Id; @@ -3594,6 +3610,7 @@ package body Sem_Ch5 is Rng_Typ : Entity_Id; begin + Stop_Processing := False; Rng := Discrete_Subtype_Definition (Param_Spec); -- Nothing to do when the loop is already wrapped in a block @@ -3622,11 +3639,10 @@ package body Sem_Ch5 is -- on the secondary stack. Note that the loop must be wrapped -- only when such a call exists. - if Has_Sec_Stack_Call (Low) - or else - Has_Sec_Stack_Call (High) + if Has_Sec_Stack_Call (Low) or else Has_Sec_Stack_Call (High) then Wrap_Loop_Statement (Manage_Sec_Stack => True); + Stop_Processing := True; end if; -- Otherwise the parameter specification appears in the form @@ -3663,6 +3679,7 @@ package body Sem_Ch5 is and then Needs_Finalization (Rng_Typ)) then Wrap_Loop_Statement (Manage_Sec_Stack => True); + Stop_Processing := True; end if; end if; end Prepare_Param_Spec_Loop; @@ -3690,8 +3707,6 @@ package body Sem_Ch5 is Rewrite (N, Blk); Analyze (N); - - raise Skip_Analysis; end Wrap_Loop_Statement; -- Local variables @@ -3702,11 +3717,13 @@ package body Sem_Ch5 is -- Start of processing for Prepare_Loop_Statement begin + Stop_Processing := False; + if Present (Iter_Spec) then - Prepare_Iterator_Loop (Iter_Spec); + Prepare_Iterator_Loop (Iter_Spec, Stop_Processing); elsif Present (Param_Spec) then - Prepare_Param_Spec_Loop (Param_Spec); + Prepare_Param_Spec_Loop (Param_Spec, Stop_Processing); end if; end Prepare_Loop_Statement; @@ -3805,7 +3822,15 @@ package body Sem_Ch5 is -- wrapped within a block in order to manage the secondary stack. if Present (Iter) then - Prepare_Loop_Statement (Iter); + declare + Stop_Processing : Boolean; + begin + Prepare_Loop_Statement (Iter, Stop_Processing); + + if Stop_Processing then + return; + end if; + end; end if; -- Kill current values on entry to loop, since statements in the body of @@ -3979,10 +4004,6 @@ package body Sem_Ch5 is if Is_OpenAcc_Environment (Stmt) then Disable_Constants (Stmt); end if; - - exception - when Skip_Analysis => - null; end Analyze_Loop_Statement; ---------------------------- diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d635543c..cf1b0e7 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5444,10 +5444,14 @@ package body Sem_Ch6 is and then Directly_Designated_Type (Old_Formal_Base) = Directly_Designated_Type (New_Formal_Base) and then ((Is_Itype (Old_Formal_Base) - and then Can_Never_Be_Null (Old_Formal_Base)) + and then (Can_Never_Be_Null (Old_Formal_Base) + or else Is_Access_Constant + (Old_Formal_Base))) or else (Is_Itype (New_Formal_Base) - and then Can_Never_Be_Null (New_Formal_Base))); + and then (Can_Never_Be_Null (New_Formal_Base) + or else Is_Access_Constant + (New_Formal_Base)))); -- Types must always match. In the visible part of an instance, -- usual overloading rules for dispatching operations apply, and diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index c6095ef..6f5126e 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -389,6 +389,8 @@ package body Sem_Ch7 is end if; -- An inlined subprogram body acts as a referencer + -- unless we generate C code since inlining is then + -- handled by the C compiler. -- Note that we test Has_Pragma_Inline here in addition -- to Is_Inlined. We are doing this for a client, since @@ -397,8 +399,9 @@ package body Sem_Ch7 is -- should occur, so we need to catch all cases where the -- subprogram may be inlined by the client. - if Is_Inlined (Decl_Id) - or else Has_Pragma_Inline (Decl_Id) + if not Generate_C_Code + and then (Is_Inlined (Decl_Id) + or else Has_Pragma_Inline (Decl_Id)) then Has_Referencer_Of_Non_Subprograms := True; @@ -415,9 +418,12 @@ package body Sem_Ch7 is Decl_Id := Defining_Entity (Decl); -- An inlined subprogram body acts as a referencer + -- unless we generate C code since inlining is then + -- handled by the C compiler. - if Is_Inlined (Decl_Id) - or else Has_Pragma_Inline (Decl_Id) + if not Generate_C_Code + and then (Is_Inlined (Decl_Id) + or else Has_Pragma_Inline (Decl_Id)) then Has_Referencer_Of_Non_Subprograms := True; @@ -3253,7 +3259,7 @@ package body Sem_Ch7 is -- A [generic] package that defines at least one non-null abstract state -- requires a completion only when at least one other construct requires - -- a completion in a body (SPARK RM 7.1.4(4) and (6)). This check is not + -- a completion in a body (SPARK RM 7.1.4(4) and (5)). This check is not -- performed if the caller requests this behavior. if Do_Abstract_States diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index a5e821d..b58ad64 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -784,9 +784,9 @@ package body Sem_Ch8 is begin if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference) - and then Is_Composite_Type (Etype (Nam)) - and then not Is_Constrained (Etype (Nam)) - and then not Has_Unknown_Discriminants (Etype (Nam)) + and then Is_Composite_Type (Typ) + and then not Is_Constrained (Typ) + and then not Has_Unknown_Discriminants (Typ) and then Expander_Active then -- If Actual_Subtype is already set, nothing to do @@ -1122,7 +1122,11 @@ package body Sem_Ch8 is Wrong_Type (Nam, T); end if; - T2 := Etype (Nam); + -- We must search for an actual subtype here so that the bounds of + -- objects of unconstrained types don't get dropped on the floor - such + -- as with renamings of formal parameters. + + T2 := Get_Actual_Subtype_If_Available (Nam); -- Ada 2005 (AI-326): Handle wrong use of incomplete type @@ -5489,8 +5493,10 @@ package body Sem_Ch8 is if Nkind (N) = N_Identifier then Mark_Elaboration_Attributes - (N_Id => N, - Modes => True); + (N_Id => N, + Checks => True, + Modes => True, + Warnings => True); end if; -- Here if Entity pointer was not set, we need full visibility analysis @@ -6514,8 +6520,10 @@ package body Sem_Ch8 is -- resolution, and expansion are over. Mark_Elaboration_Attributes - (N_Id => N, - Modes => True); + (N_Id => N, + Checks => True, + Modes => True, + Warnings => True); -- Set appropriate type @@ -7418,10 +7426,28 @@ package body Sem_Ch8 is -- It is not an error if the prefix is the current instance of -- type name, e.g. the expression of a type aspect, when it is - -- analyzed for ASIS use. + -- analyzed for ASIS use, or within a generic unit. We still + -- have to verify that a component of that name exists, and + -- decorate the node accordingly. elsif Is_Entity_Name (P) and then Is_Current_Instance (P) then - null; + declare + Comp : Entity_Id; + + begin + Comp := First_Entity (Entity (P)); + while Present (Comp) loop + if Chars (Comp) = Chars (Selector_Name (N)) then + Set_Entity (N, Comp); + Set_Etype (N, Etype (Comp)); + Set_Entity (Selector_Name (N), Comp); + Set_Etype (Selector_Name (N), Etype (Comp)); + return; + end if; + + Next_Entity (Comp); + end loop; + end; elsif Ekind (P_Name) = E_Void then Premature_Usage (P); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index b74f88d..f57b3b1 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with ALI; use ALI; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -59,7 +60,10 @@ with Tbuild; use Tbuild; with Uintp; use Uintp; with Uname; use Uname; -with GNAT.HTable; use GNAT.HTable; +with GNAT; use GNAT; +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; +with GNAT.Lists; use GNAT.Lists; +with GNAT.Sets; use GNAT.Sets; package body Sem_Elab is @@ -80,30 +84,41 @@ package body Sem_Elab is -- Due to control and data flow, the ABE mechanism cannot accurately -- determine whether a particular scenario will be elaborated or not. -- Conditional ABE checks are therefore used to verify the elaboration - -- status of a local and external target at run time. + -- status of local and external targets at run time. -- - -- * Supply elaboration dependencies for a unit to binde + -- * Supply implicit elaboration dependencies for a unit to binde -- - -- The ABE mechanism registers each outgoing elaboration edge for the - -- main unit in its ALI file. GNATbind and binde can then reconstruct - -- the full elaboration graph and determine the proper elaboration - -- order for all units in the compilation. + -- The ABE mechanism creates implicit dependencies in the form of with + -- clauses subject to pragma Elaborate[_All] when the elaboration graph + -- reaches into an external unit. The implicit dependencies are encoded + -- in the ALI file of the main unit. GNATbind and binde then use these + -- dependencies to augment the library item graph and determine the + -- elaboration order of all units in the compilation. + -- + -- * Supply pieces of the invocation graph for a unit to bindo + -- + -- The ABE mechanism captures paths starting from elaboration code or + -- top level constructs that reach into an external unit. The paths are + -- encoded in the ALI file of the main unit in the form of declarations + -- which represent nodes, and relations which represent edges. GNATbind + -- and bindo then build the full invocation graph in order to augment + -- the library item graph and determine the elaboration order of all + -- units in the compilation. -- -- The ABE mechanism supports three models of elaboration: -- -- * Dynamic model - This is the most permissive of the three models. - -- When the dynamic model is in effect, the mechanism performs very - -- little diagnostics and generates run-time checks to detect ABE - -- issues. The behaviour of this model is identical to that specified - -- by the Ada RM. This model is enabled with switch -gnatE. + -- When the dynamic model is in effect, the mechanism diagnoses and + -- installs run-time checks to detect ABE issues in the main unit. + -- The behaviour of this model is identical to that specified by the + -- Ada RM. This model is enabled with switch -gnatE. -- - -- * Static model - This is the middle ground of the three models. When + -- Static model - This is the middle ground of the three models. When -- the static model is in effect, the mechanism diagnoses and installs -- run-time checks to detect ABE issues in the main unit. In addition, - -- the mechanism generates implicit Elaborate or Elaborate_All pragmas - -- to ensure the prior elaboration of withed units. The model employs - -- textual order, with clause context, and elaboration-related source - -- pragmas. This is the default model. + -- the mechanism generates implicit dependencies between units in the + -- form of with clauses subject to pragma Elaborate[_All] to ensure + -- the prior elaboration of withed units. This is the default model. -- -- * SPARK model - This is the most conservative of the three models and -- impelements the semantics defined in SPARK RM 7.7. The SPARK model @@ -117,8 +132,8 @@ package body Sem_Elab is -- Terminology -- ----------------- - -- * ABE - An attempt to activate, call, or instantiate a scenario which - -- has not been fully elaborated. + -- * ABE - An attempt to invoke a scenario which has not been elaborated + -- yet. -- -- * Bridge target - A type of target. A bridge target is a link between -- scenarios. It is usually a byproduct of expansion and does not have @@ -129,9 +144,9 @@ package body Sem_Elab is -- call. N_Call_Marker nodes do not have static and run-time semantics. -- -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the - -- elaboration or invocation of a target by a scenario within the main - -- unit causes an ABE, but does not cause an ABE for another scenarios - -- within the main unit. + -- invocation of a target by a scenario within the main unit causes an + -- ABE, but does not cause an ABE for another scenarios within the main + -- unit. -- -- * Declaration level - A type of enclosing level. A scenario or target is -- at the declaration level when it appears within the declarations of a @@ -148,13 +163,26 @@ package body Sem_Elab is -- package library unit, ignoring enclosing packages. -- -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the - -- elaboration or invocation of a target by all scenarios within the - -- main unit causes an ABE. + -- invocation of a target by all scenarios within the main unit causes + -- an ABE. -- -- * Instantiation library level - A type of enclosing level. A scenario -- or target is at the instantiation library level if it appears in an -- instantiation library unit, ignoring enclosing packages. -- + -- * Invocation - The act of activating a task, calling a subprogram, or + -- instantiating a generic. + -- + -- * Invocation construct - An entry declaration, [single] protected type, + -- subprogram declaration, subprogram instantiation, or a [single] task + -- type declared in the visible, private, or body declarations of the + -- main unit. + -- + -- * Invocation relation - A flow link between two invocation constructs + -- + -- * Invocation signature - A set of attributes that uniquely identify an + -- invocation construct within the namespace of all ALI files. + -- -- * Library level - A type of enclosing level. A scenario or target is at -- the library level if it appears in a package library unit, ignoring -- enclosng packages. @@ -162,9 +190,9 @@ package body Sem_Elab is -- * Non-library-level encapsulator - A construct that cannot be elaborated -- on its own and requires elaboration by a top-level scenario. -- - -- * Scenario - A construct or context which may be elaborated or executed - -- by elaboration code. The scenarios recognized by the ABE mechanism are - -- as follows: + -- * Scenario - A construct or context which is invoked by elaboration code + -- or invocation construct. The scenarios recognized by the ABE mechanism + -- are as follows: -- -- - '[Unrestricted_]Access of entries, operators, and subprograms -- @@ -182,8 +210,8 @@ package body Sem_Elab is -- -- - Task activation -- - -- * Target - A construct referenced by a scenario. The targets recognized - -- by the ABE mechanism are as follows: + -- * Target - A construct invoked by a scenario. The targets recognized by + -- the ABE mechanism are as follows: -- -- - For '[Unrestricted_]Access of entries, operators, and subprograms, -- the target is the entry, operator, or subprogram. @@ -201,16 +229,84 @@ package body Sem_Elab is -- - For reads of variables, the target is the variable -- -- - For task activation, the target is the task body - -- - -- * Top-level scenario - A scenario which appears in a non-generic main - -- unit. Depending on the elaboration model is in effect, the following - -- addotional restrictions apply: - -- - -- - Dynamic model - No restrictions - -- - -- - SPARK model - Falls back to either the dynamic or static model - -- - -- - Static model - The scenario must be at the library level + + ------------------ + -- Architecture -- + ------------------ + + -- Analysis/Resolution + -- | + -- +- Build_Call_Marker + -- | + -- +- Build_Variable_Reference_Marker + -- | + -- +- | -------------------- Recording phase ---------------------------+ + -- | v | + -- | Record_Elaboration_Scenario | + -- | | | + -- | +--> Check_Preelaborated_Call | + -- | | | + -- | +--> Process_Guaranteed_ABE | + -- | | | | + -- | | +--> Process_Guaranteed_ABE_Activation | + -- | | +--> Process_Guaranteed_ABE_Call | + -- | | +--> Process_Guaranteed_ABE_Instantiation | + -- | | | + -- +- | ----------------------------------------------------------------+ + -- | + -- | + -- +--> Internal_Representation + -- | + -- +--> Scenario_Storage + -- | + -- End of Compilation + -- | + -- +- | --------------------- Processing phase -------------------------+ + -- | v | + -- | Check_Elaboration_Scenarios | + -- | | | + -- | +--> Check_Conditional_ABE_Scenarios | + -- | | | | + -- | | +--> Process_Conditional_ABE <----------------------+ | + -- | | | | | + -- | | +--> Process_Conditional_ABE_Activation | | + -- | | | | | | + -- | | | +-----------------------------+ | | + -- | | | | | | + -- | | +--> Process_Conditional_ABE_Call +---> Traverse_Body | + -- | | | | | | + -- | | | +-----------------------------+ | + -- | | | | + -- | | +--> Process_Conditional_ABE_Access_Taken | + -- | | +--> Process_Conditional_ABE_Instantiation | + -- | | +--> Process_Conditional_ABE_Variable_Assignment | + -- | | +--> Process_Conditional_ABE_Variable_Reference | + -- | | | + -- | +--> Check_SPARK_Scenario | + -- | | | | + -- | | +--> Process_SPARK_Scenario | + -- | | | | + -- | | +--> Process_SPARK_Derived_Type | + -- | | +--> Process_SPARK_Instantiation | + -- | | +--> Process_SPARK_Refined_State_Pragma | + -- | | | + -- | +--> Record_Invocation_Graph | + -- | | | + -- | +--> Process_Invocation_Body_Scenarios | + -- | +--> Process_Invocation_Spec_Scenarios | + -- | +--> Process_Main_Unit | + -- | | | + -- | +--> Process_Invocation_Scenario <-------------+ | + -- | | | | + -- | +--> Process_Invocation_Activation | | + -- | | | | | + -- | | +------------------------+ | | + -- | | | | | + -- | +--> Process_Invocation_Call +---> Traverse_Body | + -- | | | | + -- | +------------------------+ | + -- | | + -- +--------------------------------------------------------------------+ --------------------- -- Recording phase -- @@ -219,14 +315,14 @@ package body Sem_Elab is -- The Recording phase coincides with the analysis/resolution phase of the -- compiler. It has the following objectives: -- - -- * Record all top-level scenarios for examination by the Processing + -- * Record all suitable scenarios for examination by the Processing -- phase. -- -- Saving only a certain number of nodes improves the performance of -- the ABE mechanism. This eliminates the need to examine the whole -- tree in a separate pass. -- - -- * Record certain SPARK scenarios which are not necessarily executable + -- * Record certain SPARK scenarios which are not necessarily invoked -- during elaboration, but still require elaboration-related checks. -- -- Saving only a certain number of nodes improves the performance of @@ -240,8 +336,8 @@ package body Sem_Elab is -- does not need the heavy recursive traversal done by the Processing -- phase. -- - -- * Detect and diagnose guaranteed ABEs caused by instantiations, - -- calls, and task activation. + -- * Detect and diagnose guaranteed ABEs caused by instantiations, calls, + -- and task activation. -- -- The issues detected by the ABE mechanism are reported as warnings -- because they do not violate Ada semantics. Forward instantiations @@ -259,101 +355,34 @@ package body Sem_Elab is -- and/or inlining of bodies, but before the removal of Ghost code. It has -- the following objectives: -- - -- * Examine all top-level scenarios saved during the Recording phase + -- * Examine all scenarios saved during the Recording phase, and perform + -- the following actions: -- - -- The top-level scenarios act as roots for depth-first traversal of - -- the call/instantiation/task activation graph. The traversal stops - -- when an outgoing edge leaves the main unit. + -- - Dynamic model -- - -- * Examine all SPARK scenarios saved during the Recording phase + -- Diagnose conditional ABEs, and install run-time conditional ABE + -- checks for all scenarios. -- - -- * Depending on the elaboration model in effect, perform the following - -- actions: + -- - SPARK model -- - -- - Dynamic model - Install run-time conditional ABE checks. + -- Enforce the SPARK elaboration rules -- - -- - SPARK model - Enforce the SPARK elaboration rules + -- - Static model -- - -- - Static model - Diagnose conditional ABEs, install run-time - -- conditional ABE checks, and guarantee the elaboration of - -- external units. + -- Diagnose conditional ABEs, install run-time conditional ABE + -- checks only for scenarios are reachable from elaboration code, + -- and guarantee the elaboration of external units by creating + -- implicit with clauses subject to pragma Elaborate[_All]. -- - -- * Examine nested scenarios + -- * Examine library-level scenarios and invocation constructs, and + -- perform the following actions: -- - -- Nested scenarios discovered during the depth-first traversal are - -- in turn subjected to the same actions outlined above and examined - -- for the next level of nested scenarios. - - ------------------ - -- Architecture -- - ------------------ - - -- Analysis/Resolution - -- | - -- +- Build_Call_Marker - -- | - -- +- Build_Variable_Reference_Marker - -- | - -- +- | -------------------- Recording phase ---------------------------+ - -- | v | - -- | Record_Elaboration_Scenario | - -- | | | - -- | +--> Check_Preelaborated_Call | - -- | | | - -- | +--> Process_Guaranteed_ABE | - -- | | | | - -- | | +--> Process_Guaranteed_ABE_Activation | - -- | | | | - -- | | +--> Process_Guaranteed_ABE_Call | - -- | | | | - -- | | +--> Process_Guaranteed_ABE_Instantiation | - -- | | | - -- +- | ----------------------------------------------------------------+ - -- | - -- | - -- +--> SPARK_Scenarios - -- | +-----------+-----------+ .. +-----------+ - -- | | Scenario1 | Scenario2 | .. | ScenarioN | - -- | +-----------+-----------+ .. +-----------+ - -- | - -- +--> Top_Level_Scenarios - -- | +-----------+-----------+ .. +-----------+ - -- | | Scenario1 | Scenario2 | .. | ScenarioN | - -- | +-----------+-----------+ .. +-----------+ - -- | - -- End of Compilation - -- | - -- +- | --------------------- Processing phase -------------------------+ - -- | v | - -- | Check_Elaboration_Scenarios | - -- | | | - -- | +--> Check_SPARK_Scenario | - -- | | | | - -- | | +--> Check_SPARK_Derived_Type | - -- | | | | - -- | | +--> Check_SPARK_Instantiation | - -- | | | | - -- | | +--> Check_SPARK_Refined_State_Pragma | - -- | | | - -- | +--> Process_Conditional_ABE <---------------------------+ | - -- | | | | - -- | +--> Process_Conditional_ABE_Access Is_Suitable_Scenario | - -- | | ^ | - -- | +--> Process_Conditional_ABE_Activation | | - -- | | | | | - -- | | +-----------------------------+ | | - -- | | | | | - -- | +--> Process_Conditional_ABE_Call +--------> Traverse_Body | - -- | | | | | - -- | | +-----------------------------+ | - -- | | | - -- | +--> Process_Conditional_ABE_Instantiation | - -- | | | - -- | +--> Process_Conditional_ABE_Variable_Assignment | - -- | | | - -- | +--> Process_Conditional_ABE_Variable_Reference | - -- | | - -- +--------------------------------------------------------------------+ + -- - Determine whether the flow of execution reaches into an external + -- unit. If this is the case, encode the path in the ALI file of + -- the main unit. + -- + -- - Create declarations for invocation constructs in the ALI file of + -- the main unit. ---------------------- -- Important points -- @@ -364,11 +393,11 @@ package body Sem_Elab is -- available. The scope stack is empty, global flags such as In_Instance -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism -- must either save or recompute semantic information. - + -- -- Expansion heavily transforms calls and to some extent instantiations. To -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to -- capture the target and relevant attributes of the original call. - + -- -- The diagnostics of the ABE mechanism depend on accurate source locations -- to determine the spacial relation of nodes. @@ -453,6 +482,13 @@ package body Sem_Elab is -- The ABE mechanism considers scenarios which appear in internal -- units (Ada, GNAT, Interfaces, System). -- + -- -gnatd_F encode full invocation paths in ALI files + -- + -- The ABE mechanism encodes the full path from an elaboration + -- procedure or invocable construct to an external target. The + -- path contains all intermediate activations, instantiations, + -- and calls. + -- -- -gnatd.G ignore calls through generic formal parameters for elaboration -- -- The ABE mechanism does not generate N_Call_Marker nodes for @@ -460,6 +496,12 @@ package body Sem_Elab is -- actual subprograms through generic formal subprograms. As a -- result, the calls are not recorded or processed. -- + -- -gnatd_G encode invocation graph in ALI files + -- + -- The ABE mechanism encodes the invocation graph of the main + -- unit. This includes elaboration code, as well as invocation + -- constructs. + -- -- -gnatd_i ignore activations and calls to instances for elaboration -- -- The ABE mechanism ignores calls and task activations when they @@ -508,6 +550,11 @@ package body Sem_Elab is -- Ada.Synchronous_Barriers.Wait_For_Release -- Ada.Synchronous_Task_Control.Suspend_Until_True -- + -- -gnatd_T output trace information on invocation relation construction + -- + -- The ABE mechanism outputs text information concerning relation + -- construction to standard output. + -- -- -gnatd.U ignore indirect calls for static elaboration -- -- The ABE mechanism does not consider '[Unrestricted_]Access of @@ -589,66 +636,6 @@ package body Sem_Elab is -- -- The complementary switch for -gnatwl. - --------------------------- - -- Adding a new scenario -- - --------------------------- - - -- The following steps describe how to add a new elaboration scenario and - -- preserve the existing architecture. Note that not all of the steps may - -- need to be carried out. - -- - -- 1) Update predicate Is_Scenario - -- - -- 2) Add predicate Is_Suitable_xxx. Include a call to it in predicate - -- Is_Suitable_Scenario. - -- - -- 3) Update routine Record_Elaboration_Scenario - -- - -- 4) Add routine Process_Conditional_ABE_xxx. Include a call to it in - -- routine Process_Conditional_ABE. - -- - -- 5) Add routine Process_Guaranteed_ABE_xxx. Include a call to it in - -- routine Process_Guaranteed_ABE. - -- - -- 6) Add routine Check_SPARK_xxx. Include a call to it in routine - -- Check_SPARK_Scenario. - -- - -- 7) Add routine Info_xxx. Include a call to it in routine - -- Process_Conditional_ABE_xxx. - -- - -- 8) Add routine Output_xxx. Include a call to it in routine - -- Output_Active_Scenarios. - -- - -- 9) Add routine Extract_xxx_Attributes - -- - -- 10) Update routine Is_Potential_Scenario - - ------------------------- - -- Adding a new target -- - ------------------------- - - -- The following steps describe how to add a new elaboration target and - -- preserve the existing architecture. Note that not all of the steps may - -- need to be carried out. - -- - -- 1) Add predicate Is_xxx. - -- - -- 2) Update the following predicates - -- - -- Is_Ada_Semantic_Target - -- Is_Assertion_Pragma_Target - -- Is_Bridge_Target - -- Is_SPARK_Semantic_Target - -- - -- If necessary, create a new category. - -- - -- 3) Update the appropriate Info_xxx routine. - -- - -- 4) Update the appropriate Output_xxx routine. - -- - -- 5) Update routine Extract_Target_Attributes. If necessary, create a - -- new Extract_xxx routine. - -------------------------- -- Debugging ABE issues -- -------------------------- @@ -659,7 +646,7 @@ package body Sem_Elab is -- -- Build_Call_Marker -- Record_Elaboration_Scenario - + -- -- * If the issue involves an arbitrary scenario, ensure that the scenario -- is either recorded, or is successfully recognized while traversing a -- body. The routines of interest are @@ -668,7 +655,7 @@ package body Sem_Elab is -- Process_Conditional_ABE -- Process_Guaranteed_ABE -- Traverse_Body - + -- -- * If the issue involves a circularity in the elaboration order, examine -- the ALI files and look for the following encodings next to units: -- @@ -685,601 +672,1272 @@ package body Sem_Elab is -- -- Ensure_Prior_Elaboration - ---------------- - -- Attributes -- - ---------------- + ----------- + -- Kinds -- + ----------- - -- To minimize the amount of code within routines, the ABE mechanism relies - -- on "attribute" records to capture relevant information for a scenario or - -- a target. + -- The following type enumerates all subprogram body traversal modes - -- The following type captures relevant attributes which pertain to a call + type Body_Traversal_Kind is + (Deep_Traversal, + -- The traversal examines the internals of a subprogram - type Call_Attributes is record - Elab_Checks_OK : Boolean; - -- This flag is set when the call has elaboration checks enabled + No_Traversal); - Elab_Warnings_OK : Boolean; - -- This flag is set when the call has elaboration warnings elabled + -- The following type enumerates all operation modes - From_Source : Boolean; - -- This flag is set when the call comes from source + type Processing_Kind is + (Conditional_ABE_Processing, + -- The ABE mechanism detects and diagnoses conditional ABEs for library + -- and declaration-level scenarios. - Ghost_Mode_Ignore : Boolean; - -- This flag is set when the call appears in a region subject to pragma - -- Ghost with policy Ignore. + Dynamic_Model_Processing, + -- The ABE mechanism installs conditional ABE checks for all eligible + -- scenarios when the dynamic model is in effect. - In_Declarations : Boolean; - -- This flag is set when the call appears at the declaration level + Guaranteed_ABE_Processing, + -- The ABE mechanism detects and diagnoses guaranteed ABEs caused by + -- calls, instantiations, and task activations. - Is_Dispatching : Boolean; - -- This flag is set when the call is dispatching + Invocation_Construct_Processing, + -- The ABE mechanism locates all invocation constructs within the main + -- unit and utilizes them as roots of miltiple DFS traversals aimed at + -- detecting transitions from the main unit to an external unit. - SPARK_Mode_On : Boolean; - -- This flag is set when the call appears in a region subject to pragma - -- SPARK_Mode with value On. - end record; + Invocation_Body_Processing, + -- The ABE mechanism utilizes all library-level body scenarios as roots + -- of miltiple DFS traversals aimed at detecting transitions from the + -- main unit to an external unit. - -- The following type captures relevant attributes which pertain to the - -- prior elaboration of a unit. This type is coupled together with a unit - -- to form a key -> value relationship. - - type Elaboration_Attributes is record - Source_Pragma : Node_Id; - -- This attribute denotes a source Elaborate or Elaborate_All pragma - -- which guarantees the prior elaboration of some unit with respect - -- to the main unit. The pragma may come from the following contexts: - - -- * The main unit - -- * The spec of the main unit (if applicable) - -- * Any parent spec of the main unit (if applicable) - -- * Any parent subunit of the main unit (if applicable) - - -- The attribute remains Empty if no such pragma is available. Source - -- pragmas play a role in satisfying SPARK elaboration requirements. - - With_Clause : Node_Id; - -- This attribute denotes an internally generated or source with clause - -- for some unit withed by the main unit. With clauses carry flags which - -- represent implicit Elaborate or Elaborate_All pragmas. These clauses - -- play a role in supplying the elaboration dependencies to binde. - end record; + Invocation_Spec_Processing, + -- The ABE mechanism utilizes all library-level spec scenarios as roots + -- of miltiple DFS traversals aimed at detecting transitions from the + -- main unit to an external unit. - No_Elaboration_Attributes : constant Elaboration_Attributes := - (Source_Pragma => Empty, - With_Clause => Empty); + SPARK_Processing, + -- The ABE mechanism detects and diagnoses violations of the SPARK + -- elaboration rules for SPARK-specific scenarios. - -- The following type captures relevant attributes which pertain to an - -- instantiation. + No_Processing); - type Instantiation_Attributes is record - Elab_Checks_OK : Boolean; - -- This flag is set when the instantiation has elaboration checks - -- enabled. + -- The following type enumerates all possible scenario kinds - Elab_Warnings_OK : Boolean; - -- This flag is set when the instantiation has elaboration warnings - -- enabled. + type Scenario_Kind is + (Access_Taken_Scenario, + -- An attribute reference which takes 'Access or 'Unrestricted_Access of + -- an entry, operator, or subprogram. - Ghost_Mode_Ignore : Boolean; - -- This flag is set when the instantiation appears in a region subject - -- to pragma Ghost with policy ignore, or starts one such region. + Call_Scenario, + -- A call which invokes an entry, operator, or subprogram - In_Declarations : Boolean; - -- This flag is set when the instantiation appears at the declaration - -- level. + Derived_Type_Scenario, + -- A declaration of a derived type. This is a SPARK-specific scenario. - SPARK_Mode_On : Boolean; - -- This flag is set when the instantiation appears in a region subject - -- to pragma SPARK_Mode with value On, or starts one such region. - end record; + Instantiation_Scenario, + -- An instantiation which instantiates a generic package or subprogram. + -- This scenario is also subject to SPARK-specific rules. + + Refined_State_Pragma_Scenario, + -- A Refined_State pragma. This is a SPARK-specific scenario. + + Task_Activation_Scenario, + -- A call which activates objects of various task types + + Variable_Assignment_Scenario, + -- An assignment statement which modifies the value of some variable + + Variable_Reference_Scenario, + -- A reference to a variable. This is a SPARK-specific scenario. + + No_Scenario); + + -- The following type enumerates all possible consistency models of target + -- and scenario representations. + + type Representation_Kind is + (Inconsistent_Representation, + -- A representation is said to be "inconsistent" when it is created from + -- a partially analyzed tree. In such an environment, certain attributes + -- such as a completing body may not be available yet. + + Consistent_Representation, + -- A representation is said to be "consistent" when it is created from a + -- fully analyzed tree, where all attributes are available. + + No_Representation); + + -- The following type enumerates all possible target kinds + + type Target_Kind is + (Generic_Target, + -- A generic unit being instantiated + + Subprogram_Target, + -- An entry, operator, or subprogram being invoked, or aliased through + -- 'Access or 'Unrestricted_Access. + + Task_Target, + -- A task being activated by an activation call + + Variable_Target, + -- A variable being updated through an assignment statement, or read + -- through a variable reference. + + No_Target); + + ----------- + -- Types -- + ----------- + + procedure Destroy (NE : in out Node_Or_Entity_Id); + pragma Inline (Destroy); + -- Destroy node or entity NE + + function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type; + pragma Inline (Hash); + -- Obtain the hash value of key NE + + -- The following is a general purpose list for nodes and entities + + package NE_List is new Doubly_Linked_Lists + (Element_Type => Node_Or_Entity_Id, + "=" => "=", + Destroy_Element => Destroy); + + -- The following is a general purpose map which relates nodes and entities + -- to lists of nodes and entities. + + package NE_List_Map is new Dynamic_Hash_Tables + (Key_Type => Node_Or_Entity_Id, + Value_Type => NE_List.Doubly_Linked_List, + No_Value => NE_List.Nil, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => NE_List.Destroy, + Hash => Hash); + + -- The following is a general purpose membership set for nodes and entities + + package NE_Set is new Membership_Sets + (Element_Type => Node_Or_Entity_Id, + "=" => "=", + Hash => Hash); -- The following type captures relevant attributes which pertain to the - -- state of the Processing phase. + -- in state of the Processing phase. - type Processing_Attributes is record - Suppress_Implicit_Pragmas : Boolean; + type Processing_In_State is record + Processing : Processing_Kind := No_Processing; + -- Operation mode of the Processing phase. Once set, this value should + -- not be changed. + + Representation : Representation_Kind := No_Representation; + -- Required level of scenario and target representation. Once set, this + -- value should not be changed. + + Suppress_Checks : Boolean := False; + -- This flag is set when the Processing phase must not generate any ABE + -- checks. + + Suppress_Implicit_Pragmas : Boolean := False; -- This flag is set when the Processing phase must not generate any -- implicit Elaborate[_All] pragmas. - Suppress_Warnings : Boolean; + Suppress_Info_Messages : Boolean := False; + -- This flag is set when the Processing phase must not emit any info + -- messages. + + Suppress_Up_Level_Targets : Boolean := False; + -- This flag is set when the Processing phase must ignore up-level + -- targets. + + Suppress_Warnings : Boolean := False; -- This flag is set when the Processing phase must not emit any warnings -- on elaboration problems. - Within_Initial_Condition : Boolean; - -- This flag is set when the Processing phase is currently examining a - -- scenario which was reached from an initial condition procedure. + Traversal : Body_Traversal_Kind := No_Traversal; + -- The subprogram body traversal mode. Once set, this value should not + -- be changed. + + Within_Generic : Boolean := False; + -- This flag is set when the Processing phase is currently within a + -- generic unit. - Within_Instance : Boolean; + Within_Initial_Condition : Boolean := False; -- This flag is set when the Processing phase is currently examining a - -- scenario which was reached from a scenario defined in an instance. + -- scenario which was reached from an initial condition procedure. - Within_Partial_Finalization : Boolean; + Within_Partial_Finalization : Boolean := False; -- This flag is set when the Processing phase is currently examining a -- scenario which was reached from a partial finalization procedure. - Within_Task_Body : Boolean; + Within_Task_Body : Boolean := False; -- This flag is set when the Processing phase is currently examining a -- scenario which was reached from a task body. end record; - Initial_State : constant Processing_Attributes := - (Suppress_Implicit_Pragmas => False, - Suppress_Warnings => False, - Within_Initial_Condition => False, - Within_Instance => False, - Within_Partial_Finalization => False, - Within_Task_Body => False); + -- The following constants define the various operational states of the + -- Processing phase. - -- The following type captures relevant attributes which pertain to a - -- target. + -- The conditional ABE state is used when processing scenarios that appear + -- at the declaration, instantiation, and library levels to detect errors + -- and install conditional ABE checks. + + Conditional_ABE_State : constant Processing_In_State := + (Processing => Conditional_ABE_Processing, + Representation => Consistent_Representation, + Traversal => Deep_Traversal, + others => False); + + -- The dynamic model state is used to install conditional ABE checks when + -- switch -gnatE (dynamic elaboration checking mode enabled) is in effect. + + Dynamic_Model_State : constant Processing_In_State := + (Processing => Dynamic_Model_Processing, + Representation => Consistent_Representation, + Suppress_Implicit_Pragmas => True, + Suppress_Info_Messages => True, + Suppress_Up_Level_Targets => True, + Suppress_Warnings => True, + Traversal => No_Traversal, + others => False); + + -- The guaranteed ABE state is used when processing scenarios that appear + -- at the declaration, instantiation, and library levels to detect errors + -- and install guarateed ABE failures. + + Guaranteed_ABE_State : constant Processing_In_State := + (Processing => Guaranteed_ABE_Processing, + Representation => Inconsistent_Representation, + Suppress_Implicit_Pragmas => True, + Traversal => No_Traversal, + others => False); + + -- The invocation body state is used when processing scenarios that appear + -- at the body library level to encode paths that start from elaboration + -- code and ultimately reach into external units. + + Invocation_Body_State : constant Processing_In_State := + (Processing => Invocation_Body_Processing, + Representation => Consistent_Representation, + Suppress_Checks => True, + Suppress_Implicit_Pragmas => True, + Suppress_Info_Messages => True, + Suppress_Up_Level_Targets => True, + Suppress_Warnings => True, + Traversal => Deep_Traversal, + others => False); + + -- The invocation construct state is used when processing constructs that + -- appear within the spec and body of the main unit and eventually reach + -- into external units. + + Invocation_Construct_State : constant Processing_In_State := + (Processing => Invocation_Construct_Processing, + Representation => Consistent_Representation, + Suppress_Checks => True, + Suppress_Implicit_Pragmas => True, + Suppress_Info_Messages => True, + Suppress_Up_Level_Targets => True, + Suppress_Warnings => True, + Traversal => Deep_Traversal, + others => False); + + -- The invocation spec state is used when processing scenarios that appear + -- at the spec library level to encode paths that start from elaboration + -- code and ultimately reach into external units. + + Invocation_Spec_State : constant Processing_In_State := + (Processing => Invocation_Spec_Processing, + Representation => Consistent_Representation, + Suppress_Checks => True, + Suppress_Implicit_Pragmas => True, + Suppress_Info_Messages => True, + Suppress_Up_Level_Targets => True, + Suppress_Warnings => True, + Traversal => Deep_Traversal, + others => False); + + -- The SPARK state is used when verying SPARK-specific semantics of certain + -- scenarios. + + SPARK_State : constant Processing_In_State := + (Processing => SPARK_Processing, + Representation => Consistent_Representation, + Traversal => No_Traversal, + others => False); + + -- The following type identifies a scenario representation + + type Scenario_Rep_Id is new Natural; + + No_Scenario_Rep : constant Scenario_Rep_Id := Scenario_Rep_Id'First; + First_Scenario_Rep : constant Scenario_Rep_Id := No_Scenario_Rep + 1; + + -- The following type identifies a target representation + + type Target_Rep_Id is new Natural; + + No_Target_Rep : constant Target_Rep_Id := Target_Rep_Id'First; + First_Target_Rep : constant Target_Rep_Id := No_Target_Rep + 1; - type Target_Attributes is record - Elab_Checks_OK : Boolean; - -- This flag is set when the target has elaboration checks enabled + -------------- + -- Services -- + -------------- - Elab_Warnings_OK : Boolean; - -- This flag is set when the target has elaboration warnings enabled + -- The following package keeps track of all active scenarios during a DFS + -- traversal. - From_Source : Boolean; - -- This flag is set when the target comes from source + package Active_Scenarios is - Ghost_Mode_Ignore : Boolean; - -- This flag is set when the target appears in a region subject to - -- pragma Ghost with policy ignore, or starts one such region. + ----------- + -- Types -- + ----------- - SPARK_Mode_On : Boolean; - -- This flag is set when the target appears in a region subject to - -- pragma SPARK_Mode with value On, or starts one such region. + -- The following type defines the position within the active scenario + -- stack. - Spec_Decl : Node_Id; - -- This attribute denotes the declaration of Spec_Id + type Active_Scenario_Pos is new Natural; - Unit_Id : Entity_Id; - -- This attribute denotes the top unit where Spec_Id resides + --------------------- + -- Data structures -- + --------------------- - -- The semantics of the following attributes depend on the target + -- The following table stores all active scenarios in a DFS traversal. + -- This table must be maintained in a FIFO fashion. + + package Active_Scenario_Stack is new Table.Table + (Table_Index_Type => Active_Scenario_Pos, + Table_Component_Type => Node_Id, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Active_Scenario_Stack"); + + --------- + -- API -- + --------- + + procedure Output_Active_Scenarios + (Error_Nod : Node_Id; + In_State : Processing_In_State); + pragma Inline (Output_Active_Scenarios); + -- Output the contents of the active scenario stack from earliest to + -- latest to supplement an earlier error emitted for node Error_Nod. + -- In_State denotes the current state of the Processing phase. + + procedure Pop_Active_Scenario (N : Node_Id); + pragma Inline (Pop_Active_Scenario); + -- Pop the top of the scenario stack. A check is made to ensure that the + -- scenario being removed is the same as N. + + procedure Push_Active_Scenario (N : Node_Id); + pragma Inline (Push_Active_Scenario); + -- Push scenario N on top of the scenario stack + + function Root_Scenario return Node_Id; + pragma Inline (Root_Scenario); + -- Return the scenario which started a DFS traversal + + end Active_Scenarios; + use Active_Scenarios; + + -- The following package provides the main entry point for task activation + -- processing. - Body_Barf : Node_Id; - Body_Decl : Node_Id; - Spec_Id : Entity_Id; + package Activation_Processor is + + ----------- + -- Types -- + ----------- + + type Activation_Processor_Ptr is access procedure + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State); + -- Reference to a procedure that takes all attributes of an activation + -- and performs a desired action. Call is the activation call. Call_Rep + -- is the representation of the call. Obj_Id is the task object being + -- activated. Obj_Rep is the representation of the object. Task_Typ is + -- the task type whose body is being activated. Task_Rep denotes the + -- representation of the task type. In_State is the current state of + -- the Processing phase. + + --------- + -- API -- + --------- + + procedure Process_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Processor : Activation_Processor_Ptr; + In_State : Processing_In_State); + -- Find all task objects activated by activation call Call and invoke + -- Processor on them. Call_Rep denotes the representation of the call. + -- In_State is the current state of the Processing phase. + + end Activation_Processor; + use Activation_Processor; + + -- The following package profides functionality for traversing subprogram + -- bodies in DFS manner and processing of eligible scenarios within. + + package Body_Processor is + + ----------- + -- Types -- + ----------- + + type Scenario_Predicate_Ptr is access function + (N : Node_Id) return Boolean; + -- Reference to a function which determines whether arbitrary node N + -- denotes a suitable scenario for processing. + + type Scenario_Processor_Ptr is access procedure + (N : Node_Id; In_State : Processing_In_State); + -- Reference to a procedure which processes scenario N. In_State is the + -- current state of the Processing phase. + + --------- + -- API -- + --------- + + procedure Traverse_Body + (N : Node_Id; + Requires_Processing : Scenario_Predicate_Ptr; + Processor : Scenario_Processor_Ptr; + In_State : Processing_In_State); + pragma Inline (Traverse_Body); + -- Traverse the declarations and handled statements of subprogram body + -- N, looking for scenarios that satisfy predicate Requires_Processing. + -- Routine Processor is invoked for each such scenario. + + procedure Reset_Traversed_Bodies; + pragma Inline (Reset_Traversed_Bodies); + -- Reset the visited status of all subprogram bodies that have already + -- been processed by routine Traverse_Body. - -- The target is a generic package or a subprogram - -- - -- * Body_Barf - Empty - -- - -- * Body_Decl - This attribute denotes the generic or subprogram - -- body. - -- - -- * Spec_Id - This attribute denotes the entity of the generic - -- package or subprogram. + ----------------- + -- Maintenance -- + ----------------- - -- The target is a protected entry - -- - -- * Body_Barf - This attribute denotes the body of the barrier - -- function if expansion took place, otherwise it is Empty. - -- - -- * Body_Decl - This attribute denotes the body of the procedure - -- which emulates the entry if expansion took place, otherwise it - -- denotes the body of the protected entry. - -- - -- * Spec_Id - This attribute denotes the entity of the procedure - -- which emulates the entry if expansion took place, otherwise it - -- denotes the protected entry. + procedure Finalize_Body_Processor; + pragma Inline (Finalize_Body_Processor); + -- Finalize all internal data structures + + procedure Initialize_Body_Processor; + pragma Inline (Initialize_Body_Processor); + -- Initialize all internal data structures + + end Body_Processor; + use Body_Processor; + + -- The following package provides functionality for installing ABE-related + -- checks and failures. + + package Check_Installer is + + --------- + -- API -- + --------- + + function Check_Or_Failure_Generation_OK return Boolean; + pragma Inline (Check_Or_Failure_Generation_OK); + -- Determine whether a conditional ABE check or guaranteed ABE failure + -- can be generated. + + procedure Install_Dynamic_ABE_Checks; + pragma Inline (Install_Dynamic_ABE_Checks); + -- Install conditional ABE checks for all saved scenarios when the + -- dynamic model is in effect. + + procedure Install_Scenario_ABE_Check + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Scenario_Rep_Id); + pragma Inline (Install_Scenario_ABE_Check); + -- Install a conditional ABE check for scenario N to ensure that target + -- Targ_Id is properly elaborated. Targ_Rep is the representation of the + -- target. If the check is installed, disable the elaboration checks of + -- scenario Disable. + + procedure Install_Scenario_ABE_Check + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Target_Rep_Id); + pragma Inline (Install_Scenario_ABE_Check); + -- Install a conditional ABE check for scenario N to ensure that target + -- Targ_Id is properly elaborated. Targ_Rep is the representation of the + -- target. If the check is installed, disable the elaboration checks of + -- target Disable. + + procedure Install_Scenario_ABE_Failure + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Scenario_Rep_Id); + pragma Inline (Install_Scenario_ABE_Failure); + -- Install a guaranteed ABE failure for scenario N with target Targ_Id. + -- Targ_Rep denotes the representation of the target. If the failure is + -- installed, disable the elaboration checks of scenario Disable. + + procedure Install_Scenario_ABE_Failure + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Target_Rep_Id); + pragma Inline (Install_Scenario_ABE_Failure); + -- Install a guaranteed ABE failure for scenario N with target Targ_Id. + -- Targ_Rep denotes the representation of the target. If the failure is + -- installed, disable the elaboration checks of target Disable. + + procedure Install_Unit_ABE_Check + (N : Node_Id; + Unit_Id : Entity_Id; + Disable : Scenario_Rep_Id); + pragma Inline (Install_Unit_ABE_Check); + -- Install a conditional ABE check for scenario N to ensure that unit + -- Unit_Id is properly elaborated. If the check is installed, disable + -- the elaboration checks of scenario Disable. + + procedure Install_Unit_ABE_Check + (N : Node_Id; + Unit_Id : Entity_Id; + Disable : Target_Rep_Id); + pragma Inline (Install_Unit_ABE_Check); + -- Install a conditional ABE check for scenario N to ensure that unit + -- Unit_Id is properly elaborated. If the check is installed, disable + -- the elaboration checks of target Disable. + + end Check_Installer; + use Check_Installer; + + -- The following package provides the main entry point for conditional ABE + -- checks and diagnostics. + + package Conditional_ABE_Processor is + + --------- + -- API -- + --------- + + procedure Check_Conditional_ABE_Scenarios + (Iter : in out NE_Set.Iterator); + pragma Inline (Check_Conditional_ABE_Scenarios); + -- Perform conditional ABE checks and diagnostics for all scenarios + -- available through iterator Iter. + + procedure Process_Conditional_ABE + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE); + -- Perform conditional ABE checks and diagnostics for scenario N. + -- In_State denotes the current state of the Processing phase. + + end Conditional_ABE_Processor; + use Conditional_ABE_Processor; + + -- The following package provides functionality to emit errors, information + -- messages, and warnings. + + package Diagnostics is + + --------- + -- API -- + --------- + + procedure Elab_Msg_NE + (Msg : String; + N : Node_Id; + Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + pragma Inline (Elab_Msg_NE); + -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary + -- node N and entity. If flag Info_Msg is set, the routine emits an + -- information message, otherwise it emits an error. If flag In_SPARK + -- is set, then string " in SPARK" is added to the end of the message. + + procedure Info_Call + (Call : Node_Id; + Subp_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + pragma Inline (Info_Call); + -- Output information concerning call Call that invokes subprogram + -- Subp_Id. When flag Info_Msg is set, the routine emits an information + -- message, otherwise it emits an error. When flag In_SPARK is set, " in + -- SPARK" is added to the end of the message. + + procedure Info_Instantiation + (Inst : Node_Id; + Gen_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + pragma Inline (Info_Instantiation); + -- Output information concerning instantiation Inst which instantiates + -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an + -- information message, otherwise it emits an error. If flag In_SPARK + -- is set, then string " in SPARK" is added to the end of the message. + + procedure Info_Variable_Reference + (Ref : Node_Id; + Var_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + pragma Inline (Info_Variable_Reference); + -- Output information concerning reference Ref which mentions variable + -- Var_Id. If flag Info_Msg is set, the routine emits an information + -- message, otherwise it emits an error. If flag In_SPARK is set, then + -- string " in SPARK" is added to the end of the message. + + end Diagnostics; + use Diagnostics; + + -- The following package provides functionality to locate the early call + -- region of a subprogram body. + + package Early_Call_Region_Processor is + + --------- + -- API -- + --------- + + function Find_Early_Call_Region + (Body_Decl : Node_Id; + Assume_Elab_Body : Boolean := False; + Skip_Memoization : Boolean := False) return Node_Id; + pragma Inline (Find_Early_Call_Region); + -- Find the start of the early call region that belongs to subprogram + -- body Body_Decl as defined in SPARK RM 7.7. This routine finds the + -- early call region, memoizes it, and returns it, but this behavior + -- can be altered. Flag Assume_Elab_Body should be set when a package + -- spec may lack pragma Elaborate_Body, but the routine must still + -- examine that spec. Flag Skip_Memoization should be set when the + -- routine must avoid memoizing the region. + + ----------------- + -- Maintenance -- + ----------------- + + procedure Finalize_Early_Call_Region_Processor; + pragma Inline (Finalize_Early_Call_Region_Processor); + -- Finalize all internal data structures - -- The target is a protected subprogram + procedure Initialize_Early_Call_Region_Processor; + pragma Inline (Initialize_Early_Call_Region_Processor); + -- Initialize all internal data structures + + end Early_Call_Region_Processor; + use Early_Call_Region_Processor; + + -- The following package provides access to the elaboration statuses of all + -- units withed by the main unit. + + package Elaborated_Units is + + --------- + -- API -- + --------- + + procedure Collect_Elaborated_Units; + pragma Inline (Collect_Elaborated_Units); + -- Save the elaboration statuses of all units withed by the main unit + + procedure Ensure_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State); + pragma Inline (Ensure_Prior_Elaboration); + -- Guarantee the elaboration of unit Unit_Id with respect to the main + -- unit by either suggesting or installing an Elaborate[_All] pragma + -- denoted by Prag_Nam. N denotes the related scenario. In_State is the + -- current state of the Processing phase. + + function Has_Prior_Elaboration + (Unit_Id : Entity_Id; + Context_OK : Boolean := False; + Elab_Body_OK : Boolean := False; + Same_Unit_OK : Boolean := False) return Boolean; + pragma Inline (Has_Prior_Elaboration); + -- Determine whether unit Unit_Id is elaborated prior to the main unit. + -- If flag Context_OK is set, the routine considers the following case + -- as valid prior elaboration: -- - -- * Body_Barf - Empty + -- * Unit_Id is in the elaboration context of the main unit -- - -- * Body_Decl - This attribute denotes the body of the protected or - -- unprotected version of the protected subprogram if expansion took - -- place, otherwise it denotes the body of the protected subprogram. + -- If flag Elab_Body_OK is set, the routine considers the following case + -- as valid prior elaboration: -- - -- * Spec_Id - This attribute denotes the entity of the protected or - -- unprotected version of the protected subprogram if expansion took - -- place, otherwise it is the entity of the protected subprogram. - - -- The target is a task entry + -- * Unit_Id has pragma Elaborate_Body and is not the main unit -- - -- * Body_Barf - Empty + -- If flag Same_Unit_OK is set, the routine considers the following + -- cases as valid prior elaboration: -- - -- * Body_Decl - This attribute denotes the body of the procedure - -- which emulates the task body if expansion took place, otherwise - -- it denotes the body of the task type. + -- * Unit_Id is the main unit -- - -- * Spec_Id - This attribute denotes the entity of the procedure - -- which emulates the task body if expansion took place, otherwise - -- it denotes the entity of the task type. - end record; + -- * Unit_Id denotes the spec of the main unit body + + procedure Meet_Elaboration_Requirement + (N : Node_Id; + Targ_Id : Entity_Id; + Req_Nam : Name_Id; + In_State : Processing_In_State); + pragma Inline (Meet_Elaboration_Requirement); + -- Determine whether elaboration requirement Req_Nam for scenario N with + -- target Targ_Id is met by the context of the main unit using the SPARK + -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an + -- error if this is not the case. In_State denotes the current state of + -- the Processing phase. - -- The following type captures relevant attributes which pertain to a task - -- type. + ----------------- + -- Maintenance -- + ----------------- - type Task_Attributes is record - Body_Decl : Node_Id; - -- This attribute denotes the declaration of the procedure body which - -- emulates the behaviour of the task body. + procedure Finalize_Elaborated_Units; + pragma Inline (Finalize_Elaborated_Units); + -- Finalize all internal data structures - Elab_Checks_OK : Boolean; - -- This flag is set when the task type has elaboration checks enabled + procedure Initialize_Elaborated_Units; + pragma Inline (Initialize_Elaborated_Units); + -- Initialize all internal data structures - Elab_Warnings_OK : Boolean; - -- This flag is set when the task type has elaboration warnings enabled + end Elaborated_Units; + use Elaborated_Units; - Ghost_Mode_Ignore : Boolean; - -- This flag is set when the task type appears in a region subject to - -- pragma Ghost with policy ignore, or starts one such region. + -- The following package provides the main entry point for guaranteed ABE + -- checks and diagnostics. - SPARK_Mode_On : Boolean; - -- This flag is set when the task type appears in a region subject to - -- pragma SPARK_Mode with value On, or starts one such region. + package Guaranteed_ABE_Processor is - Spec_Id : Entity_Id; - -- This attribute denotes the entity of the initial declaration of the - -- procedure body which emulates the behaviour of the task body. + --------- + -- API -- + --------- - Task_Decl : Node_Id; - -- This attribute denotes the declaration of the task type + procedure Process_Guaranteed_ABE + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Guaranteed_ABE); + -- Perform guaranteed ABE checks and diagnostics for scenario N. + -- In_State is the current state of the Processing phase. - Unit_Id : Entity_Id; - -- This attribute denotes the entity of the compilation unit where the - -- task type resides. - end record; + end Guaranteed_ABE_Processor; + use Guaranteed_ABE_Processor; - -- The following type captures relevant attributes which pertain to a - -- variable. + -- The following package provides access to the internal representation of + -- scenarios and targets. - type Variable_Attributes is record - Unit_Id : Entity_Id; - -- This attribute denotes the entity of the compilation unit where the - -- variable resides. - end record; + package Internal_Representation is - --------------------- - -- Data structures -- - --------------------- + ----------- + -- Types -- + ----------- + + -- The following type enumerates all possible Ghost mode mode kinds + + type Extended_Ghost_Mode is + (Is_Ignored, + Is_Checked_Or_Not_Specified); + + -- The following type enumerates all possible SPARK mode kinds + + type Extended_SPARK_Mode is + (Is_On, + Is_Off_Or_Not_Specified); - -- The ABE mechanism employs lists and hash tables to store information - -- pertaining to scenarios and targets, as well as the Processing phase. - -- The need for data structures comes partly from the size limitation of - -- nodes. Note that the use of hash tables is conservative and operations - -- are carried out only when a particular hash table has at least one key - -- value pair (see xxx_In_Use flags). + -------------- + -- Builders -- + -------------- - -- The following table stores the early call regions of subprogram bodies + function Scenario_Representation_Of + (N : Node_Id; + In_State : Processing_In_State) return Scenario_Rep_Id; + pragma Inline (Scenario_Representation_Of); + -- Obtain the id of elaboration scenario N's representation. The routine + -- constructs the representation if it is not available. In_State is the + -- current state of the Processing phase. + + function Target_Representation_Of + (Id : Entity_Id; + In_State : Processing_In_State) return Target_Rep_Id; + pragma Inline (Target_Representation_Of); + -- Obtain the id of elaboration target Id's representation. The routine + -- constructs the representation if it is not available. In_State is the + -- current state of the Processing phase. - Early_Call_Regions_Max : constant := 101; + ------------------------- + -- Scenario attributes -- + ------------------------- - type Early_Call_Regions_Index is range 0 .. Early_Call_Regions_Max - 1; + function Activated_Task_Objects + (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List; + pragma Inline (Activated_Task_Objects); + -- For Task_Activation_Scenario S_Id, obtain the list of task objects + -- the scenario is activating. + + function Activated_Task_Type (S_Id : Scenario_Rep_Id) return Entity_Id; + pragma Inline (Activated_Task_Type); + -- For Task_Activation_Scenario S_Id, obtain the currently activated + -- task type. + + procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id); + pragma Inline (Disable_Elaboration_Checks); + -- Disable elaboration checks of scenario S_Id + + function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Elaboration_Checks_OK); + -- Determine whether scenario S_Id may be subjected to elaboration + -- checks. + + function Elaboration_Warnings_OK (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Elaboration_Warnings_OK); + -- Determine whether scenario S_Id may be subjected to elaboration + -- warnings. + + function Ghost_Mode_Of + (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode; + pragma Inline (Ghost_Mode_Of); + -- Obtain the Ghost mode of scenario S_Id + + function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Is_Dispatching_Call); + -- For Call_Scenario S_Id, determine whether the call is dispatching + + function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Is_Read_Reference); + -- For Variable_Reference_Scenario S_Id, determine whether the reference + -- is a read. + + function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind; + pragma Inline (Kind); + -- Obtain the nature of scenario S_Id + + function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind; + pragma Inline (Level); + -- Obtain the enclosing level of scenario S_Id + + procedure Set_Activated_Task_Objects + (S_Id : Scenario_Rep_Id; + Task_Objs : NE_List.Doubly_Linked_List); + pragma Inline (Set_Activated_Task_Objects); + -- For Task_Activation_Scenario S_Id, set the list of task objects + -- activated by the scenario to Task_Objs. + + procedure Set_Activated_Task_Type + (S_Id : Scenario_Rep_Id; + Task_Typ : Entity_Id); + pragma Inline (Set_Activated_Task_Type); + -- For Task_Activation_Scenario S_Id, set the currently activated task + -- type to Task_Typ. + + function SPARK_Mode_Of + (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode; + pragma Inline (SPARK_Mode_Of); + -- Obtain the SPARK mode of scenario S_Id + + function Target (S_Id : Scenario_Rep_Id) return Entity_Id; + pragma Inline (Target); + -- Obtain the target of scenario S_Id - function Early_Call_Regions_Hash - (Key : Entity_Id) return Early_Call_Regions_Index; - -- Obtain the hash value of entity Key + ----------------------- + -- Target attributes -- + ----------------------- - Early_Call_Regions_In_Use : Boolean := False; - -- This flag determines whether table Early_Call_Regions contains at least - -- least one key/value pair. + function Barrier_Body_Declaration (T_Id : Target_Rep_Id) return Node_Id; + pragma Inline (Barrier_Body_Declaration); + -- For Subprogram_Target T_Id, obtain the declaration of the barrier + -- function's body. - Early_Call_Regions_No_Element : constant Node_Id := Empty; + function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id; + pragma Inline (Body_Declaration); + -- Obtain the declaration of the body which belongs to target T_Id - package Early_Call_Regions is new Simple_HTable - (Header_Num => Early_Call_Regions_Index, - Element => Node_Id, - No_Element => Early_Call_Regions_No_Element, - Key => Entity_Id, - Hash => Early_Call_Regions_Hash, - Equal => "="); + procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id); + pragma Inline (Disable_Elaboration_Checks); + -- Disable elaboration checks of target T_Id - -- The following table stores the elaboration status of all units withed by - -- the main unit. + function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean; + pragma Inline (Elaboration_Checks_OK); + -- Determine whether target T_Id may be subjected to elaboration checks - Elaboration_Statuses_Max : constant := 1009; + function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean; + pragma Inline (Elaboration_Warnings_OK); + -- Determine whether target T_Id may be subjected to elaboration + -- warnings. - type Elaboration_Statuses_Index is range 0 .. Elaboration_Statuses_Max - 1; + function Ghost_Mode_Of (T_Id : Target_Rep_Id) return Extended_Ghost_Mode; + pragma Inline (Ghost_Mode_Of); + -- Obtain the Ghost mode of target T_Id - function Elaboration_Statuses_Hash - (Key : Entity_Id) return Elaboration_Statuses_Index; - -- Obtain the hash value of entity Key + function Kind (T_Id : Target_Rep_Id) return Target_Kind; + pragma Inline (Kind); + -- Obtain the nature of target T_Id - Elaboration_Statuses_In_Use : Boolean := False; - -- This flag flag determines whether table Elaboration_Statuses contains at - -- least one key/value pair. + function SPARK_Mode_Of (T_Id : Target_Rep_Id) return Extended_SPARK_Mode; + pragma Inline (SPARK_Mode_Of); + -- Obtain the SPARK mode of target T_Id - Elaboration_Statuses_No_Element : constant Elaboration_Attributes := - No_Elaboration_Attributes; + function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id; + pragma Inline (Spec_Declaration); + -- Obtain the declaration of the spec which belongs to target T_Id - package Elaboration_Statuses is new Simple_HTable - (Header_Num => Elaboration_Statuses_Index, - Element => Elaboration_Attributes, - No_Element => Elaboration_Statuses_No_Element, - Key => Entity_Id, - Hash => Elaboration_Statuses_Hash, - Equal => "="); + function Unit (T_Id : Target_Rep_Id) return Entity_Id; + pragma Inline (Unit); + -- Obtain the unit where the target is defined - -- The following table stores a status flag for each SPARK scenario saved - -- in table SPARK_Scenarios. + function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id; + pragma Inline (Variable_Declaration); + -- For Variable_Target T_Id, obtain the declaration of the variable - Recorded_SPARK_Scenarios_Max : constant := 127; + ----------------- + -- Maintenance -- + ----------------- - type Recorded_SPARK_Scenarios_Index is - range 0 .. Recorded_SPARK_Scenarios_Max - 1; + procedure Finalize_Internal_Representation; + pragma Inline (Finalize_Internal_Representation); + -- Finalize all internal data structures - function Recorded_SPARK_Scenarios_Hash - (Key : Node_Id) return Recorded_SPARK_Scenarios_Index; - -- Obtain the hash value of Key + procedure Initialize_Internal_Representation; + pragma Inline (Initialize_Internal_Representation); + -- Initialize all internal data structures - Recorded_SPARK_Scenarios_In_Use : Boolean := False; - -- This flag flag determines whether table Recorded_SPARK_Scenarios - -- contains at least one key/value pair. + end Internal_Representation; + use Internal_Representation; - Recorded_SPARK_Scenarios_No_Element : constant Boolean := False; + -- The following package provides functionality for recording pieces of the + -- invocation graph in the ALI file of the main unit. - package Recorded_SPARK_Scenarios is new Simple_HTable - (Header_Num => Recorded_SPARK_Scenarios_Index, - Element => Boolean, - No_Element => Recorded_SPARK_Scenarios_No_Element, - Key => Node_Id, - Hash => Recorded_SPARK_Scenarios_Hash, - Equal => "="); + package Invocation_Graph is - -- The following table stores a status flag for each top-level scenario - -- recorded in table Top_Level_Scenarios. + --------- + -- API -- + --------- - Recorded_Top_Level_Scenarios_Max : constant := 503; + procedure Record_Invocation_Graph; + pragma Inline (Record_Invocation_Graph); + -- Process all declaration, instantiation, and library level scenarios, + -- along with invocation construct within the spec and body of the main + -- unit to determine whether any of these reach into an external unit. + -- If such a path exists, encode in the ALI file of the main unit. - type Recorded_Top_Level_Scenarios_Index is - range 0 .. Recorded_Top_Level_Scenarios_Max - 1; + ----------------- + -- Maintenance -- + ----------------- - function Recorded_Top_Level_Scenarios_Hash - (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index; - -- Obtain the hash value of entity Key + procedure Finalize_Invocation_Graph; + pragma Inline (Finalize_Invocation_Graph); + -- Finalize all internal data structures - Recorded_Top_Level_Scenarios_In_Use : Boolean := False; - -- This flag flag determines whether table Recorded_Top_Level_Scenarios - -- contains at least one key/value pair. + procedure Initialize_Invocation_Graph; + pragma Inline (Initialize_Invocation_Graph); + -- Initialize all internal data structures - Recorded_Top_Level_Scenarios_No_Element : constant Boolean := False; + end Invocation_Graph; + use Invocation_Graph; - package Recorded_Top_Level_Scenarios is new Simple_HTable - (Header_Num => Recorded_Top_Level_Scenarios_Index, - Element => Boolean, - No_Element => Recorded_Top_Level_Scenarios_No_Element, - Key => Node_Id, - Hash => Recorded_Top_Level_Scenarios_Hash, - Equal => "="); + -- The following package stores scenarios - -- The following table stores all active scenarios in a recursive traversal - -- starting from a top-level scenario. This table must be maintained in a - -- FIFO fashion. + package Scenario_Storage is - package Scenario_Stack is new Table.Table - (Table_Component_Type => Node_Id, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 100, - Table_Name => "Scenario_Stack"); + --------- + -- API -- + --------- - -- The following table stores SPARK scenarios which are not necessarily - -- executable during elaboration, but still require elaboration-related - -- checks. + procedure Add_Declaration_Scenario (N : Node_Id); + pragma Inline (Add_Declaration_Scenario); + -- Save declaration level scenario N - package SPARK_Scenarios is new Table.Table - (Table_Component_Type => Node_Id, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 100, - Table_Name => "SPARK_Scenarios"); + procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id); + pragma Inline (Add_Dynamic_ABE_Check_Scenario); + -- Save scenario N for conditional ABE check installation purposes when + -- the dynamic model is in effect. - -- The following table stores all top-level scenario saved during the - -- Recording phase. The contents of this table act as traversal roots - -- later in the Processing phase. This table must be maintained in a - -- LIFO fashion. + procedure Add_Library_Body_Scenario (N : Node_Id); + pragma Inline (Add_Library_Body_Scenario); + -- Save library-level body scenario N - package Top_Level_Scenarios is new Table.Table - (Table_Component_Type => Node_Id, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 1000, - Table_Increment => 100, - Table_Name => "Top_Level_Scenarios"); + procedure Add_Library_Spec_Scenario (N : Node_Id); + pragma Inline (Add_Library_Spec_Scenario); + -- Save library-level spec scenario N + + procedure Add_SPARK_Scenario (N : Node_Id); + pragma Inline (Add_SPARK_Scenario); + -- Save SPARK scenario N + + procedure Delete_Scenario (N : Node_Id); + pragma Inline (Delete_Scenario); + -- Delete arbitrary scenario N + + function Iterate_Declaration_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Declaration_Scenarios); + -- Obtain an iterator over all declaration level scenarios + + function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Dynamic_ABE_Check_Scenarios); + -- Obtain an iterator over all scenarios that require a conditional ABE + -- check when the dynamic model is in effect. + + function Iterate_Library_Body_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Library_Body_Scenarios); + -- Obtain an iterator over all library level body scenarios + + function Iterate_Library_Spec_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Library_Spec_Scenarios); + -- Obtain an iterator over all library level spec scenarios + + function Iterate_SPARK_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_SPARK_Scenarios); + -- Obtain an iterator over all SPARK scenarios + + procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id); + pragma Inline (Replace_Scenario); + -- Replace scenario Old_N with scenario New_N + + ----------------- + -- Maintenance -- + ----------------- + + procedure Finalize_Scenario_Storage; + pragma Inline (Finalize_Scenario_Storage); + -- Finalize all internal data structures + + procedure Initialize_Scenario_Storage; + pragma Inline (Initialize_Scenario_Storage); + -- Initialize all internal data structures + + end Scenario_Storage; + use Scenario_Storage; + + -- The following package provides various semantic predicates + + package Semantics is + + --------- + -- API -- + --------- + + function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Accept_Alternative_Proc); + -- Determine whether arbitrary entity Id denotes an internally generated + -- procedure which encapsulates the statements of an accept alternative. + + function Is_Activation_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Activation_Proc); + -- Determine whether arbitrary entity Id denotes a runtime procedure in + -- charge with activating tasks. + + function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Ada_Semantic_Target); + -- Determine whether arbitrary entity Id denodes a source or internally + -- generated subprogram which emulates Ada semantics. - -- The following table stores the bodies of all eligible scenarios visited - -- during a traversal starting from a top-level scenario. The contents of - -- this table must be reset upon each new traversal. + function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Assertion_Pragma_Target); + -- Determine whether arbitrary entity Id denotes a procedure which + -- varifies the run-time semantics of an assertion pragma. - Visited_Bodies_Max : constant := 511; + function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; + pragma Inline (Is_Bodiless_Subprogram); + -- Determine whether subprogram Subp_Id will never have a body - type Visited_Bodies_Index is range 0 .. Visited_Bodies_Max - 1; + function Is_Bridge_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Bridge_Target); + -- Determine whether arbitrary entity Id denotes a bridge target - function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index; - -- Obtain the hash value of node Key + function Is_Controlled_Proc + (Subp_Id : Entity_Id; + Subp_Nam : Name_Id) return Boolean; + pragma Inline (Is_Controlled_Proc); + -- Determine whether subprogram Subp_Id denotes controlled type + -- primitives Adjust, Finalize, or Initialize as denoted by name + -- Subp_Nam. + + function Is_Default_Initial_Condition_Proc + (Id : Entity_Id) return Boolean; + pragma Inline (Is_Default_Initial_Condition_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine Default_Initial_Condition. + + function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Finalizer_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine _Finalizer. + + function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Initial_Condition_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine Initial_Condition. + + function Is_Initialized (Obj_Decl : Node_Id) return Boolean; + pragma Inline (Is_Initialized); + -- Determine whether object declaration Obj_Decl is initialized + + function Is_Invariant_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Invariant_Proc); + -- Determine whether arbitrary entity Id denotes an invariant procedure + + function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; + pragma Inline (Is_Non_Library_Level_Encapsulator); + -- Determine whether arbitrary node N is a non-library encapsulator + + function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Partial_Invariant_Proc); + -- Determine whether arbitrary entity Id denotes a partial invariant + -- procedure. - Visited_Bodies_In_Use : Boolean := False; - -- This flag determines whether table Visited_Bodies contains at least one - -- key/value pair. + function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Postconditions_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine _Postconditions. - Visited_Bodies_No_Element : constant Boolean := False; + function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; + pragma Inline (Is_Preelaborated_Unit); + -- Determine whether arbitrary entity Id denotes a unit which is subject + -- to one of the following pragmas: + -- + -- * Preelaborable + -- * Pure + -- * Remote_Call_Interface + -- * Remote_Types + -- * Shared_Passive + + function Is_Protected_Entry (Id : Entity_Id) return Boolean; + pragma Inline (Is_Protected_Entry); + -- Determine whether arbitrary entity Id denotes a protected entry + + function Is_Protected_Subp (Id : Entity_Id) return Boolean; + pragma Inline (Is_Protected_Subp); + -- Determine whether entity Id denotes a protected subprogram + + function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; + pragma Inline (Is_Protected_Body_Subp); + -- Determine whether entity Id denotes the protected or unprotected + -- version of a protected subprogram. + + function Is_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Scenario); + -- Determine whether attribute node N denotes a scenario. The scenario + -- may not necessarily be eligible for ABE processing. + + function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_SPARK_Semantic_Target); + -- Determine whether arbitrary entity Id nodes a source or internally + -- generated subprogram which emulates SPARK semantics. + + function Is_Subprogram_Inst (Id : Entity_Id) return Boolean; + pragma Inline (Is_Subprogram_Inst); + -- Determine whether arbitrary entity Id denotes a subprogram instance + + function Is_Suitable_Access_Taken (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Access_Taken); + -- Determine whether arbitrary node N denotes a suitable attribute for + -- ABE processing. + + function Is_Suitable_Call (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Call); + -- Determine whether arbitrary node N denotes a suitable call for ABE + -- processing. - package Visited_Bodies is new Simple_HTable - (Header_Num => Visited_Bodies_Index, - Element => Boolean, - No_Element => Visited_Bodies_No_Element, - Key => Node_Id, - Hash => Visited_Bodies_Hash, - Equal => "="); + function Is_Suitable_Instantiation (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Instantiation); + -- Determine whether arbitrary node N is a suitable instantiation for + -- ABE processing. + + function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_SPARK_Derived_Type); + -- Determine whether arbitrary node N denotes a suitable derived type + -- declaration for ABE processing using the SPARK rules. + + function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_SPARK_Instantiation); + -- Determine whether arbitrary node N denotes a suitable instantiation + -- for ABE processing using the SPARK rules. + + function Is_Suitable_SPARK_Refined_State_Pragma + (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); + -- Determine whether arbitrary node N denotes a suitable Refined_State + -- pragma for ABE processing using the SPARK rules. + + function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Variable_Assignment); + -- Determine whether arbitrary node N denotes a suitable assignment for + -- ABE processing. + + function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Variable_Reference); + -- Determine whether arbitrary node N is a suitable variable reference + -- for ABE processing. + + function Is_Task_Entry (Id : Entity_Id) return Boolean; + pragma Inline (Is_Task_Entry); + -- Determine whether arbitrary entity Id denotes a task entry + + function Is_Up_Level_Target + (Targ_Decl : Node_Id; + In_State : Processing_In_State) return Boolean; + pragma Inline (Is_Up_Level_Target); + -- Determine whether the current root resides at the declaration level. + -- If this is the case, determine whether a target with by declaration + -- Target_Decl is within a context which encloses the current root or is + -- in a different unit. In_State is the current state of the Processing + -- phase. + + end Semantics; + use Semantics; + + -- The following package provides the main entry point for SPARK-related + -- checks and diagnostics. + + package SPARK_Processor is + + --------- + -- API -- + --------- + + procedure Check_SPARK_Model_In_Effect; + pragma Inline (Check_SPARK_Model_In_Effect); + -- Determine whether a suitable elaboration model is currently in effect + -- for verifying SPARK rules. Emit a warning if this is not the case. + + procedure Check_SPARK_Scenarios; + pragma Inline (Check_SPARK_Scenarios); + -- Examine SPARK scenarios which are not necessarily executable during + -- elaboration, but still requires elaboration-related checks. + + end SPARK_Processor; + use SPARK_Processor; ----------------------- -- Local subprograms -- ----------------------- - -- Multiple local subprograms are utilized to lower the semantic complexity - -- of the Recording and Processing phase. - - procedure Check_Preelaborated_Call (Call : Node_Id); - pragma Inline (Check_Preelaborated_Call); - -- Verify that entry, operator, or subprogram call Call does not appear at - -- the library level of a preelaborated unit. - - procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id); - pragma Inline (Check_SPARK_Derived_Type); - -- Verify that the freeze node of a derived type denoted by declaration - -- Typ_Decl is within the early call region of each overriding primitive - -- body that belongs to the derived type (SPARK RM 7.7(8)). - - procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id); - pragma Inline (Check_SPARK_Instantiation); - -- Verify that expanded instance Exp_Inst does not precede the generic body - -- it instantiates (SPARK RM 7.7(6)). - - procedure Check_SPARK_Model_In_Effect (N : Node_Id); - pragma Inline (Check_SPARK_Model_In_Effect); - -- Determine whether a suitable elaboration model is currently in effect - -- for verifying the SPARK rules of scenario N. Emit a warning if this is - -- not the case. - - procedure Check_SPARK_Scenario (N : Node_Id); - pragma Inline (Check_SPARK_Scenario); - -- Top-level dispatcher for verifying SPARK scenarios which are not always - -- executable during elaboration but still need elaboration-related checks. - - procedure Check_SPARK_Refined_State_Pragma (N : Node_Id); - pragma Inline (Check_SPARK_Refined_State_Pragma); - -- Verify that each constituent of Refined_State pragma N which belongs to - -- an abstract state mentioned in pragma Initializes has prior elaboration - -- with respect to the main unit (SPARK RM 7.7.1(7)). + function Assignment_Target (Asmt : Node_Id) return Node_Id; + pragma Inline (Assignment_Target); + -- Obtain the target of assignment statement Asmt + + function Call_Name (Call : Node_Id) return Node_Id; + pragma Inline (Call_Name); + -- Obtain the name of an entry, operator, or subprogram call Call + + function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id; + pragma Inline (Canonical_Subprogram); + -- Obtain the uniform canonical entity of subprogram Subp_Id function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id; pragma Inline (Compilation_Unit); -- Return the N_Compilation_Unit node of unit Unit_Id - function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; - pragma Inline (Early_Call_Region); - -- Return the early call region associated with entry or subprogram body - -- Body_Id. IMPORTANT: This routine does not find the early call region. - -- To compute it, use routine Find_Early_Call_Region. - - procedure Elab_Msg_NE - (Msg : String; - N : Node_Id; - Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean); - pragma Inline (Elab_Msg_NE); - -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary node - -- N and entity. If flag Info_Msg is set, the routine emits an information - -- message, otherwise it emits an error. If flag In_SPARK is set, then - -- string " in SPARK" is added to the end of the message. - - function Elaboration_Status - (Unit_Id : Entity_Id) return Elaboration_Attributes; - pragma Inline (Elaboration_Status); - -- Return the set of elaboration attributes associated with unit Unit_Id - - procedure Ensure_Prior_Elaboration - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id; - State : Processing_Attributes); - -- Guarantee the elaboration of unit Unit_Id with respect to the main unit - -- by installing pragma Elaborate or Elaborate_All denoted by Prag_Nam. N - -- denotes the related scenario. State denotes the current state of the - -- Processing phase. - - procedure Ensure_Prior_Elaboration_Dynamic - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id); - -- Guarantee the elaboration of unit Unit_Id with respect to the main unit - -- by suggesting the use of Elaborate[_All] with name Prag_Nam. N denotes - -- the related scenario. - - procedure Ensure_Prior_Elaboration_Static - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id); - -- Guarantee the elaboration of unit Unit_Id with respect to the main unit - -- by installing an implicit Elaborate[_All] pragma with name Prag_Nam. N - -- denotes the related scenario. - - function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id; - pragma Inline (Extract_Assignment_Name); - -- Obtain the Name attribute of assignment statement Asmt - - procedure Extract_Call_Attributes - (Call : Node_Id; - Target_Id : out Entity_Id; - Attrs : out Call_Attributes); - pragma Inline (Extract_Call_Attributes); - -- Obtain attributes Attrs associated with call Call. Target_Id is the - -- entity of the call target. - - function Extract_Call_Name (Call : Node_Id) return Node_Id; - pragma Inline (Extract_Call_Name); - -- Obtain the Name attribute of entry or subprogram call Call - - procedure Extract_Instance_Attributes - (Exp_Inst : Node_Id; - Inst_Body : out Node_Id; - Inst_Decl : out Node_Id); - pragma Inline (Extract_Instance_Attributes); - -- Obtain body Inst_Body and spec Inst_Decl of expanded instance Exp_Inst - - procedure Extract_Instantiation_Attributes - (Exp_Inst : Node_Id; - Inst : out Node_Id; - Inst_Id : out Entity_Id; - Gen_Id : out Entity_Id; - Attrs : out Instantiation_Attributes); - pragma Inline (Extract_Instantiation_Attributes); - -- Obtain attributes Attrs associated with expanded instantiation Exp_Inst. - -- Inst is the instantiation. Inst_Id is the entity of the instance. Gen_Id - -- is the entity of the generic unit being instantiated. - - procedure Extract_Target_Attributes - (Target_Id : Entity_Id; - Attrs : out Target_Attributes); - -- Obtain attributes Attrs associated with an entry, package, or subprogram - -- denoted by Target_Id. - - procedure Extract_Task_Attributes - (Typ : Entity_Id; - Attrs : out Task_Attributes); - pragma Inline (Extract_Task_Attributes); - -- Obtain attributes Attrs associated with task type Typ - - procedure Extract_Variable_Reference_Attributes - (Ref : Node_Id; - Var_Id : out Entity_Id; - Attrs : out Variable_Attributes); - pragma Inline (Extract_Variable_Reference_Attributes); - -- Obtain attributes Attrs associated with reference Ref that mentions - -- variable Var_Id. - - function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id; - pragma Inline (Find_Code_Unit); - -- Return the code unit which contains arbitrary node or entity N. This - -- is the unit of the file which physically contains the related construct - -- denoted by N except when N is within an instantiation. In that case the - -- unit is that of the top-level instantiation. - - function Find_Early_Call_Region - (Body_Decl : Node_Id; - Assume_Elab_Body : Boolean := False; - Skip_Memoization : Boolean := False) return Node_Id; - -- Find the start of the early call region which belongs to subprogram body - -- Body_Decl as defined in SPARK RM 7.7. The behavior of the routine is to - -- find the early call region, memoize it, and return it, but this behavior - -- can be altered. Flag Assume_Elab_Body should be set when a package spec - -- may lack pragma Elaborate_Body, but the routine must still examine that - -- spec. Flag Skip_Memoization should be set when the routine must avoid - -- memoizing the region. - - procedure Find_Elaborated_Units; - -- Populate table Elaboration_Statuses with all units which have prior - -- elaboration with respect to the main unit. - function Find_Enclosing_Instance (N : Node_Id) return Node_Id; pragma Inline (Find_Enclosing_Instance); -- Find the declaration or body of the nearest expanded instance which @@ -1301,33 +1959,10 @@ package body Sem_Elab is -- subprogram lacks formal parameters, return Empty. function Has_Body (Pack_Decl : Node_Id) return Boolean; + pragma Inline (Has_Body); -- Determine whether package declaration Pack_Decl has a corresponding body -- or would eventually have one. - function Has_Prior_Elaboration - (Unit_Id : Entity_Id; - Context_OK : Boolean := False; - Elab_Body_OK : Boolean := False; - Same_Unit_OK : Boolean := False) return Boolean; - pragma Inline (Has_Prior_Elaboration); - -- Determine whether unit Unit_Id is elaborated prior to the main unit. - -- If flag Context_OK is set, the routine considers the following case - -- as valid prior elaboration: - -- - -- * Unit_Id is in the elaboration context of the main unit - -- - -- If flag Elab_Body_OK is set, the routine considers the following case - -- as valid prior elaboration: - -- - -- * Unit_Id has pragma Elaborate_Body and is not the main unit - -- - -- If flag Same_Unit_OK is set, the routine considers the following cases - -- as valid prior elaboration: - -- - -- * Unit_Id is the main unit - -- - -- * Unit_Id denotes the spec of the main unit body - function In_External_Instance (N : Node_Id; Target_Decl : Node_Id) return Boolean; @@ -1344,204 +1979,38 @@ package body Sem_Elab is (N1 : Node_Id; N2 : Node_Id; Nested_OK : Boolean := False) return Boolean; + pragma Inline (In_Same_Context); -- Determine whether two arbitrary nodes N1 and N2 appear within the same -- context ignoring enclosing library levels. Nested_OK should be set when -- the context of N1 can enclose that of N2. - function In_Task_Body (N : Node_Id) return Boolean; - pragma Inline (In_Task_Body); - -- Determine whether arbitrary node N appears within a task body - - procedure Info_Call - (Call : Node_Id; - Target_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean); - -- Output information concerning call Call which invokes target Target_Id. - -- If flag Info_Msg is set, the routine emits an information message, - -- otherwise it emits an error. If flag In_SPARK is set, then the string - -- " in SPARK" is added to the end of the message. - - procedure Info_Instantiation - (Inst : Node_Id; - Gen_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean); - pragma Inline (Info_Instantiation); - -- Output information concerning instantiation Inst which instantiates - -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an - -- information message, otherwise it emits an error. If flag In_SPARK - -- is set, then string " in SPARK" is added to the end of the message. - - procedure Info_Variable_Reference - (Ref : Node_Id; - Var_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean); - pragma Inline (Info_Variable_Reference); - -- Output information concerning reference Ref which mentions variable - -- Var_Id. If flag Info_Msg is set, the routine emits an information - -- message, otherwise it emits an error. If flag In_SPARK is set, then - -- string " in SPARK" is added to the end of the message. - - function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id; - pragma Inline (Insertion_Node); - -- Obtain the proper insertion node of an ABE check or failure for scenario - -- N and candidate insertion node Ins_Nod. - - procedure Install_ABE_Check - (N : Node_Id; - Id : Entity_Id; - Ins_Nod : Node_Id); - -- Insert a run-time ABE check for elaboration scenario N which verifies - -- whether arbitrary entity Id is elaborated. The check in inserted prior - -- to node Ins_Nod. - - procedure Install_ABE_Check - (N : Node_Id; - Target_Id : Entity_Id; - Target_Decl : Node_Id; - Target_Body : Node_Id; - Ins_Nod : Node_Id); - -- Insert a run-time ABE check for elaboration scenario N which verifies - -- whether target Target_Id with initial declaration Target_Decl and body - -- Target_Body is elaborated. The check is inserted prior to node Ins_Nod. - - procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id); - -- Insert a Program_Error concerning a guaranteed ABE for elaboration - -- scenario N. The failure is inserted prior to node Node_Id. - - function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Accept_Alternative_Proc); - -- Determine whether arbitrary entity Id denotes an internally generated - -- procedure which encapsulates the statements of an accept alternative. - - function Is_Activation_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Activation_Proc); - -- Determine whether arbitrary entity Id denotes a runtime procedure in - -- charge with activating tasks. - - function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; - pragma Inline (Is_Ada_Semantic_Target); - -- Determine whether arbitrary entity Id denodes a source or internally - -- generated subprogram which emulates Ada semantics. - - function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; - pragma Inline (Is_Assertion_Pragma_Target); - -- Determine whether arbitrary entity Id denotes a procedure which varifies - -- the run-time semantics of an assertion pragma. - - function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; - pragma Inline (Is_Bodiless_Subprogram); - -- Determine whether subprogram Subp_Id will never have a body - - function Is_Controlled_Proc - (Subp_Id : Entity_Id; - Subp_Nam : Name_Id) return Boolean; - pragma Inline (Is_Controlled_Proc); - -- Determine whether subprogram Subp_Id denotes controlled type primitives - -- Adjust, Finalize, or Initialize as denoted by name Subp_Nam. - - function Is_Default_Initial_Condition_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Default_Initial_Condition_Proc); - -- Determine whether arbitrary entity Id denotes internally generated - -- routine Default_Initial_Condition. - - function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Finalizer_Proc); - -- Determine whether arbitrary entity Id denotes internally generated - -- routine _Finalizer. - - function Is_Guaranteed_ABE - (N : Node_Id; - Target_Decl : Node_Id; - Target_Body : Node_Id) return Boolean; - pragma Inline (Is_Guaranteed_ABE); - -- Determine whether scenario N with a target described by its initial - -- declaration Target_Decl and body Target_Decl results in a guaranteed - -- ABE. - - function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Initial_Condition_Proc); - -- Determine whether arbitrary entity Id denotes internally generated - -- routine Initial_Condition. - - function Is_Initialized (Obj_Decl : Node_Id) return Boolean; - pragma Inline (Is_Initialized); - -- Determine whether object declaration Obj_Decl is initialized - - function Is_Invariant_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Invariant_Proc); - -- Determine whether arbitrary entity Id denotes an invariant procedure - - function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; - pragma Inline (Is_Non_Library_Level_Encapsulator); - -- Determine whether arbitrary node N is a non-library encapsulator - - function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Partial_Invariant_Proc); - -- Determine whether arbitrary entity Id denotes a partial invariant - -- procedure. - - function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Postconditions_Proc); - -- Determine whether arbitrary entity Id denotes internally generated - -- routine _Postconditions. - - function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; - pragma Inline (Is_Preelaborated_Unit); - -- Determine whether arbitrary entity Id denotes a unit which is subject to - -- one of the following pragmas: - -- - -- * Preelaborable - -- * Pure - -- * Remote_Call_Interface - -- * Remote_Types - -- * Shared_Passive - - function Is_Protected_Entry (Id : Entity_Id) return Boolean; - pragma Inline (Is_Protected_Entry); - -- Determine whether arbitrary entity Id denotes a protected entry - - function Is_Protected_Subp (Id : Entity_Id) return Boolean; - pragma Inline (Is_Protected_Subp); - -- Determine whether entity Id denotes a protected subprogram - - function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; - pragma Inline (Is_Protected_Body_Subp); - -- Determine whether entity Id denotes the protected or unprotected version - -- of a protected subprogram. - - function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean; - pragma Inline (Is_Recorded_SPARK_Scenario); - -- Determine whether arbitrary node N is a recorded SPARK scenario which - -- appears in table SPARK_Scenarios. - - function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean; - pragma Inline (Is_Recorded_Top_Level_Scenario); - -- Determine whether arbitrary node N is a recorded top-level scenario - -- which appears in table Top_Level_Scenarios. + function Instantiated_Generic (Inst : Node_Id) return Entity_Id; + pragma Inline (Instantiated_Generic); + -- Obtain the generic instantiated by instance Inst function Is_Safe_Activation - (Call : Node_Id; - Task_Decl : Node_Id) return Boolean; + (Call : Node_Id; + Task_Rep : Target_Rep_Id) return Boolean; pragma Inline (Is_Safe_Activation); - -- Determine whether call Call which activates a task object described by - -- declaration Task_Decl is always ABE-safe. + -- Determine whether activation call Call which activates an object of a + -- task type described by representation Task_Rep is always ABE-safe. function Is_Safe_Call - (Call : Node_Id; - Target_Attrs : Target_Attributes) return Boolean; + (Call : Node_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id) return Boolean; pragma Inline (Is_Safe_Call); - -- Determine whether call Call which invokes a target described by - -- attributes Target_Attrs is always ABE-safe. + -- Determine whether call Call which invokes entry, operator, or subprogram + -- Subp_Id is always ABE-safe. Subp_Rep is the representation of the entry, + -- operator, or subprogram. function Is_Safe_Instantiation - (Inst : Node_Id; - Gen_Attrs : Target_Attributes) return Boolean; + (Inst : Node_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id) return Boolean; pragma Inline (Is_Safe_Instantiation); - -- Determine whether instance Inst which instantiates a generic unit - -- described by attributes Gen_Attrs is always ABE-safe. + -- Determine whether instantiation Inst which instantiates generic Gen_Id + -- is always ABE-safe. Gen_Rep is the representation of the generic. function Is_Same_Unit (Unit_1 : Entity_Id; @@ -1549,332 +2018,1374 @@ package body Sem_Elab is pragma Inline (Is_Same_Unit); -- Determine whether entities Unit_1 and Unit_2 denote the same unit - function Is_Scenario (N : Node_Id) return Boolean; - pragma Inline (Is_Scenario); - -- Determine whether attribute node N denotes a scenario. The scenario may - -- not necessarily be eligible for ABE processing. + function Non_Private_View (Typ : Entity_Id) return Entity_Id; + pragma Inline (Non_Private_View); + -- Return the full view of private type Typ if available, otherwise return + -- type Typ. - function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; - pragma Inline (Is_SPARK_Semantic_Target); - -- Determine whether arbitrary entity Id nodes a source or internally - -- generated subprogram which emulates SPARK semantics. + function Scenario (N : Node_Id) return Node_Id; + pragma Inline (Scenario); + -- Return the appropriate scenario node for scenario N - function Is_Suitable_Access (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Access); - -- Determine whether arbitrary node N denotes a suitable attribute for ABE - -- processing. + procedure Spec_And_Body_From_Entity + (Id : Node_Id; + Spec_Decl : out Node_Id; + Body_Decl : out Node_Id); + pragma Inline (Spec_And_Body_From_Entity); + -- Given arbitrary entity Id representing a construct with a spec and body, + -- retrieve declaration of the spec in Spec_Decl and the declaration of the + -- body in Body_Decl. - function Is_Suitable_Call (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Call); - -- Determine whether arbitrary node N denotes a suitable call for ABE - -- processing. + procedure Spec_And_Body_From_Node + (N : Node_Id; + Spec_Decl : out Node_Id; + Body_Decl : out Node_Id); + pragma Inline (Spec_And_Body_From_Node); + -- Given arbitrary node N representing a construct with a spec and body, + -- retrieve declaration of the spec in Spec_Decl and the declaration of + -- the body in Body_Decl. - function Is_Suitable_Instantiation (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Instantiation); - -- Determine whether arbitrary node N is a suitable instantiation for ABE - -- processing. + function Static_Elaboration_Checks return Boolean; + pragma Inline (Static_Elaboration_Checks); + -- Determine whether the static model is in effect - function Is_Suitable_Scenario (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Scenario); - -- Determine whether arbitrary node N is a suitable scenario for ABE - -- processing. + function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; + pragma Inline (Unit_Entity); + -- Return the entity of the initial declaration for unit Unit_Id - function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_SPARK_Derived_Type); - -- Determine whether arbitrary node N denotes a suitable derived type - -- declaration for ABE processing using the SPARK rules. - - function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_SPARK_Instantiation); - -- Determine whether arbitrary node N denotes a suitable instantiation for - -- ABE processing using the SPARK rules. - - function Is_Suitable_SPARK_Refined_State_Pragma - (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); - -- Determine whether arbitrary node N denotes a suitable Refined_State - -- pragma for ABE processing using the SPARK rules. - - function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Variable_Assignment); - -- Determine whether arbitrary node N denotes a suitable assignment for ABE - -- processing. + procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); + pragma Inline (Update_Elaboration_Scenario); + -- Update all relevant internal data structures when scenario Old_N is + -- transformed into scenario New_N by Atree.Rewrite. - function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Variable_Reference); - -- Determine whether arbitrary node N is a suitable variable reference for - -- ABE processing. + ---------------------- + -- Active_Scenarios -- + ---------------------- - function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean; - pragma Inline (Is_Synchronous_Suspension_Call); - -- Determine whether arbitrary node N denotes a call to one the following - -- routines: - -- - -- Ada.Synchronous_Barriers.Wait_For_Release - -- Ada.Synchronous_Task_Control.Suspend_Until_True + package body Active_Scenarios is - function Is_Task_Entry (Id : Entity_Id) return Boolean; - pragma Inline (Is_Task_Entry); - -- Determine whether arbitrary entity Id denotes a task entry + ----------------------- + -- Local subprograms -- + ----------------------- - function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean; - pragma Inline (Is_Up_Level_Target); - -- Determine whether the current root resides at the declaration level. If - -- this is the case, determine whether a target described by declaration - -- Target_Decl is within a context which encloses the current root or is in - -- a different unit. + procedure Output_Access_Taken + (Attr : Node_Id; + Attr_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Access_Taken); + -- Emit a specific diagnostic message for 'Access attribute reference + -- Attr with representation Attr_Rep. The message is associated with + -- node Error_Nod. - function Is_Visited_Body (Body_Decl : Node_Id) return Boolean; - pragma Inline (Is_Visited_Body); - -- Determine whether subprogram body Body_Decl is already visited during a - -- recursive traversal started from a top-level scenario. + procedure Output_Active_Scenario + (N : Node_Id; + Error_Nod : Node_Id; + In_State : Processing_In_State); + pragma Inline (Output_Active_Scenario); + -- Top level dispatcher for outputting a scenario. Emit a specific + -- diagnostic message for scenario N. The message is associated with + -- node Error_Nod. In_State is the current state of the Processing + -- phase. + + procedure Output_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Call); + -- Emit a diagnostic message for call Call with representation Call_Rep. + -- The message is associated with node Error_Nod. + + procedure Output_Header (Error_Nod : Node_Id); + pragma Inline (Output_Header); + -- Emit a specific diagnostic message for the unit of the root scenario. + -- The message is associated with node Error_Nod. + + procedure Output_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Instantiation); + -- Emit a specific diagnostic message for instantiation Inst with + -- representation Inst_Rep. The message is associated with node + -- Error_Nod. + + procedure Output_Refined_State_Pragma + (Prag : Node_Id; + Prag_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Refined_State_Pragma); + -- Emit a specific diagnostic message for Refined_State pragma Prag + -- with representation Prag_Rep. The message is associated with node + -- Error_Nod. + + procedure Output_Task_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Task_Activation); + -- Emit a specific diagnostic message for activation call Call + -- with representation Call_Rep. The message is associated with + -- node Error_Nod. + + procedure Output_Variable_Assignment + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Variable_Assignment); + -- Emit a specific diagnostic message for assignment statement Asmt + -- with representation Asmt_Rep. The message is associated with node + -- Error_Nod. + + procedure Output_Variable_Reference + (Ref : Node_Id; + Ref_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Variable_Reference); + -- Emit a specific diagnostic message for read reference Ref with + -- representation Ref_Rep. The message is associated with node + -- Error_Nod. - procedure Meet_Elaboration_Requirement - (N : Node_Id; - Target_Id : Entity_Id; - Req_Nam : Name_Id); - -- Determine whether elaboration requirement Req_Nam for scenario N with - -- target Target_Id is met by the context of the main unit using the SPARK - -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an - -- error if this is not the case. + ------------------- + -- Output_Access -- + ------------------- - function Non_Private_View (Typ : Entity_Id) return Entity_Id; - pragma Inline (Non_Private_View); - -- Return the full view of private type Typ if available, otherwise return - -- type Typ. + procedure Output_Access_Taken + (Attr : Node_Id; + Attr_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + Subp_Id : constant Entity_Id := Target (Attr_Rep); - procedure Output_Active_Scenarios (Error_Nod : Node_Id); - -- Output the contents of the active scenario stack from earliest to latest - -- to supplement an earlier error emitted for node Error_Nod. - - procedure Pop_Active_Scenario (N : Node_Id); - pragma Inline (Pop_Active_Scenario); - -- Pop the top of the scenario stack. A check is made to ensure that the - -- scenario being removed is the same as N. - - generic - with procedure Process_Single_Activation - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for task activation call Call - -- which activates task Obj_Id. Call_Attrs are the attributes of the - -- activation call. Task_Attrs are the attributes of the task type. - -- State is the current state of the Processing phase. - - procedure Process_Activation_Generic - (Call : Node_Id; - Call_Attrs : Call_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for activation call Call by invoking - -- routine Process_Single_Activation on each task object being activated. - -- Call_Attrs are the attributes of the activation call. State is the - -- current state of the Processing phase. - - procedure Process_Conditional_ABE - (N : Node_Id; - State : Processing_Attributes := Initial_State); - -- Top-level dispatcher for processing of various elaboration scenarios. - -- Perform conditional ABE checks and diagnostics for scenario N. State - -- is the current state of the Processing phase. - - procedure Process_Conditional_ABE_Access - (Attr : Node_Id; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for 'Access to entry, operator, or - -- subprogram denoted by Attr. State is the current state of the Processing - -- phase. + begin + Error_Msg_Name_1 := Attribute_Name (Attr); + Error_Msg_Sloc := Sloc (Attr); + Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); + end Output_Access_Taken; - procedure Process_Conditional_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - State : Processing_Attributes); - -- Perform common conditional ABE checks and diagnostics for call Call - -- which activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs - -- are the attributes of the activation call. Task_Attrs are the attributes - -- of the task type. State is the current state of the Processing phase. - - procedure Process_Conditional_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - State : Processing_Attributes); - -- Top-level dispatcher for processing of calls. Perform ABE checks and - -- diagnostics for call Call which invokes target Target_Id. Call_Attrs - -- are the attributes of the call. State is the current state of the - -- Processing phase. + ---------------------------- + -- Output_Active_Scenario -- + ---------------------------- - procedure Process_Conditional_ABE_Call_Ada - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for call Call which invokes target - -- Target_Id using the Ada rules. Call_Attrs are the attributes of the - -- call. Target_Attrs are attributes of the target. State is the current - -- state of the Processing phase. - - procedure Process_Conditional_ABE_Call_SPARK - (Call : Node_Id; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for call Call which invokes target - -- Target_Id using the SPARK rules. Target_Attrs denotes the attributes of - -- the target. State is the current state of the Processing phase. - - procedure Process_Conditional_ABE_Instantiation - (Exp_Inst : Node_Id; - State : Processing_Attributes); - -- Top-level dispatcher for processing of instantiations. Perform ABE - -- checks and diagnostics for expanded instantiation Exp_Inst. State is - -- the current state of the Processing phase. - - procedure Process_Conditional_ABE_Instantiation_Ada - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst - -- of generic Gen_Id using the Ada rules. Inst is the instantiation node. - -- Inst_Attrs are the attributes of the instance. Gen_Attrs denotes the - -- attributes of the generic. State is the current state of the Processing - -- phase. + procedure Output_Active_Scenario + (N : Node_Id; + Error_Nod : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); + Scen_Rep : Scenario_Rep_Id; - procedure Process_Conditional_ABE_Instantiation_SPARK - (Inst : Node_Id; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for instantiation Inst of generic - -- Gen_Id using the SPARK rules. Gen_Attrs denotes the attributes of the - -- generic. State is the current state of the Processing phase. - - procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id); - -- Top-level dispatcher for processing of variable assignments. Perform ABE - -- checks and diagnostics for assignment statement Asmt. - - procedure Process_Conditional_ABE_Variable_Assignment_Ada - (Asmt : Node_Id; - Var_Id : Entity_Id); - -- Perform ABE checks and diagnostics for assignment statement Asmt that - -- updates the value of variable Var_Id using the Ada rules. - - procedure Process_Conditional_ABE_Variable_Assignment_SPARK - (Asmt : Node_Id; - Var_Id : Entity_Id); - -- Perform ABE checks and diagnostics for assignment statement Asmt that - -- updates the value of variable Var_Id using the SPARK rules. - - procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id); - -- Top-level dispatcher for processing of variable references. Perform ABE - -- checks and diagnostics for variable reference Ref. - - procedure Process_Conditional_ABE_Variable_Reference_Read - (Ref : Node_Id; - Var_Id : Entity_Id; - Attrs : Variable_Attributes); - -- Perform ABE checks and diagnostics for reference Ref described by its - -- attributes Attrs, that reads variable Var_Id. - - procedure Process_Guaranteed_ABE (N : Node_Id); - -- Top-level dispatcher for processing of scenarios which result in a - -- guaranteed ABE. - - procedure Process_Guaranteed_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - State : Processing_Attributes); - -- Perform common guaranteed ABE checks and diagnostics for call Call which - -- activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs are - -- the attributes of the activation call. Task_Attrs are the attributes of - -- the task type. State is provided for compatibility and is not used. - - procedure Process_Guaranteed_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id); - -- Perform common guaranteed ABE checks and diagnostics for call Call which - -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are - -- the attributes of the call. - - procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id); - -- Perform common guaranteed ABE checks and diagnostics for expanded - -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK - -- rules. - - procedure Push_Active_Scenario (N : Node_Id); - pragma Inline (Push_Active_Scenario); - -- Push scenario N on top of the scenario stack - - procedure Record_SPARK_Elaboration_Scenario (N : Node_Id); - pragma Inline (Record_SPARK_Elaboration_Scenario); - -- Save SPARK scenario N in table SPARK_Scenarios for later processing - - procedure Reset_Visited_Bodies; - pragma Inline (Reset_Visited_Bodies); - -- Clear the contents of table Visited_Bodies - - function Root_Scenario return Node_Id; - pragma Inline (Root_Scenario); - -- Return the top-level scenario which started a recursive search for other - -- scenarios. It is assumed that there is a valid top-level scenario on the - -- active scenario stack. - - procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); - pragma Inline (Set_Early_Call_Region); - -- Associate an early call region with begins at construct Start with entry - -- or subprogram body Body_Id. - - procedure Set_Elaboration_Status - (Unit_Id : Entity_Id; - Val : Elaboration_Attributes); - pragma Inline (Set_Elaboration_Status); - -- Associate an set of elaboration attributes with unit Unit_Id - - procedure Set_Is_Recorded_SPARK_Scenario - (N : Node_Id; - Val : Boolean := True); - pragma Inline (Set_Is_Recorded_SPARK_Scenario); - -- Mark scenario N as being recorded in table SPARK_Scenarios - - procedure Set_Is_Recorded_Top_Level_Scenario - (N : Node_Id; - Val : Boolean := True); - pragma Inline (Set_Is_Recorded_Top_Level_Scenario); - -- Mark scenario N as being recorded in table Top_Level_Scenarios - - procedure Set_Is_Visited_Body (Subp_Body : Node_Id); - pragma Inline (Set_Is_Visited_Body); - -- Mark subprogram body Subp_Body as being visited during a recursive - -- traversal started from a top-level scenario. + begin + -- 'Access - function Static_Elaboration_Checks return Boolean; - pragma Inline (Static_Elaboration_Checks); - -- Determine whether the static model is in effect + if Is_Suitable_Access_Taken (Scen) then + Output_Access_Taken + (Attr => Scen, + Attr_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); - procedure Traverse_Body (N : Node_Id; State : Processing_Attributes); - -- Inspect the declarative and statement lists of subprogram body N for - -- suitable elaboration scenarios and process them. State is the current - -- state of the Processing phase. + -- Call or task activation - function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; - pragma Inline (Unit_Entity); - -- Return the entity of the initial declaration for unit Unit_Id + elsif Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); - pragma Inline (Update_Elaboration_Scenario); - -- Update all relevant internal data structures when scenario Old_N is - -- transformed into scenario New_N by Atree.Rewrite. + if Kind (Scen_Rep) = Call_Scenario then + Output_Call + (Call => Scen, + Call_Rep => Scen_Rep, + Error_Nod => Error_Nod); + + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); + + Output_Task_Activation + (Call => Scen, + Call_Rep => Scen_Rep, + Error_Nod => Error_Nod); + end if; + + -- Instantiation + + elsif Is_Suitable_Instantiation (Scen) then + Output_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); + + -- Pragma Refined_State + + elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then + Output_Refined_State_Pragma + (Prag => Scen, + Prag_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); + + -- Variable assignment + + elsif Is_Suitable_Variable_Assignment (Scen) then + Output_Variable_Assignment + (Asmt => Scen, + Asmt_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); + + -- Variable reference + + elsif Is_Suitable_Variable_Reference (Scen) then + Output_Variable_Reference + (Ref => Scen, + Ref_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); + end if; + end Output_Active_Scenario; + + ----------------------------- + -- Output_Active_Scenarios -- + ----------------------------- + + procedure Output_Active_Scenarios + (Error_Nod : Node_Id; + In_State : Processing_In_State) + is + package Scenarios renames Active_Scenario_Stack; + + Header_Posted : Boolean := False; + + begin + -- Output the contents of the active scenario stack starting from the + -- bottom, or the least recent scenario. + + for Index in Scenarios.First .. Scenarios.Last loop + if not Header_Posted then + Output_Header (Error_Nod); + Header_Posted := True; + end if; + + Output_Active_Scenario + (N => Scenarios.Table (Index), + Error_Nod => Error_Nod, + In_State => In_State); + end loop; + end Output_Active_Scenarios; + + ----------------- + -- Output_Call -- + ----------------- + + procedure Output_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + procedure Output_Accept_Alternative (Alt_Id : Entity_Id); + pragma Inline (Output_Accept_Alternative); + -- Emit a specific diagnostic message concerning accept alternative + -- with entity Alt_Id. + + procedure Output_Call (Subp_Id : Entity_Id; Kind : String); + pragma Inline (Output_Call); + -- Emit a specific diagnostic message concerning a call of kind Kind + -- which invokes subprogram Subp_Id. + + procedure Output_Type_Actions (Subp_Id : Entity_Id; Action : String); + pragma Inline (Output_Type_Actions); + -- Emit a specific diagnostic message concerning action Action of a + -- type performed by subprogram Subp_Id. + + procedure Output_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String); + pragma Inline (Output_Verification_Call); + -- Emit a specific diagnostic message concerning the verification of + -- predicate Pred applied to related entity Id with kind Id_Kind. + + ------------------------------- + -- Output_Accept_Alternative -- + ------------------------------- + + procedure Output_Accept_Alternative (Alt_Id : Entity_Id) is + Entry_Id : constant Entity_Id := Receiving_Entry (Alt_Id); + + begin + pragma Assert (Present (Entry_Id)); + + Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); + end Output_Accept_Alternative; + + ----------------- + -- Output_Call -- + ----------------- + + procedure Output_Call (Subp_Id : Entity_Id; Kind : String) is + begin + Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Subp_Id); + end Output_Call; + + ------------------------- + -- Output_Type_Actions -- + ------------------------- + + procedure Output_Type_Actions + (Subp_Id : Entity_Id; + Action : String) + is + Typ : constant Entity_Id := First_Formal_Type (Subp_Id); + + begin + pragma Assert (Present (Typ)); + + Error_Msg_NE + ("\\ " & Action & " actions for type & #", Error_Nod, Typ); + end Output_Type_Actions; + + ------------------------------ + -- Output_Verification_Call -- + ------------------------------ + + procedure Output_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String) + is + begin + pragma Assert (Present (Id)); + + Error_Msg_NE + ("\\ " & Pred & " of " & Id_Kind & " & verified #", + Error_Nod, Id); + end Output_Verification_Call; + + -- Local variables + + Subp_Id : constant Entity_Id := Target (Call_Rep); + + -- Start of processing for Output_Call + + begin + Error_Msg_Sloc := Sloc (Call); + + -- Accept alternative + + if Is_Accept_Alternative_Proc (Subp_Id) then + Output_Accept_Alternative (Subp_Id); + + -- Adjustment + + elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then + Output_Type_Actions (Subp_Id, "adjustment"); + + -- Default_Initial_Condition + + elsif Is_Default_Initial_Condition_Proc (Subp_Id) then + Output_Verification_Call + (Pred => "Default_Initial_Condition", + Id => First_Formal_Type (Subp_Id), + Id_Kind => "type"); + + -- Entries + + elsif Is_Protected_Entry (Subp_Id) then + Output_Call (Subp_Id, "entry"); + + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. A + -- task entry call appears in the stack of active scenarios for the + -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and + -- nothing more. + + elsif Is_Task_Entry (Subp_Id) then + null; + + -- Finalization + + elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then + Output_Type_Actions (Subp_Id, "finalization"); + + -- Calls to _Finalizer procedures must not appear in the output + -- because this creates confusing noise. + + elsif Is_Finalizer_Proc (Subp_Id) then + null; + + -- Initial_Condition + + elsif Is_Initial_Condition_Proc (Subp_Id) then + Output_Verification_Call + (Pred => "Initial_Condition", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "package"); + + -- Initialization + + elsif Is_Init_Proc (Subp_Id) + or else Is_TSS (Subp_Id, TSS_Deep_Initialize) + then + Output_Type_Actions (Subp_Id, "initialization"); + + -- Invariant + + elsif Is_Invariant_Proc (Subp_Id) then + Output_Verification_Call + (Pred => "invariants", + Id => First_Formal_Type (Subp_Id), + Id_Kind => "type"); + + -- Partial invariant calls must not appear in the output because this + -- creates confusing noise. Note that a partial invariant is always + -- invoked by the "full" invariant which is already placed on the + -- stack. + + elsif Is_Partial_Invariant_Proc (Subp_Id) then + null; + + -- _Postconditions + + elsif Is_Postconditions_Proc (Subp_Id) then + Output_Verification_Call + (Pred => "postconditions", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "subprogram"); + + -- Subprograms must come last because some of the previous cases fall + -- under this category. + + elsif Ekind (Subp_Id) = E_Function then + Output_Call (Subp_Id, "function"); + + elsif Ekind (Subp_Id) = E_Procedure then + Output_Call (Subp_Id, "procedure"); + + else + pragma Assert (False); + return; + end if; + end Output_Call; + + ------------------- + -- Output_Header -- + ------------------- + + procedure Output_Header (Error_Nod : Node_Id) is + Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); + + begin + if Ekind (Unit_Id) = E_Package then + Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); + + elsif Ekind (Unit_Id) = E_Package_Body then + Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); + + else + Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); + end if; + end Output_Header; + + -------------------------- + -- Output_Instantiation -- + -------------------------- + + procedure Output_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); + pragma Inline (Output_Instantiation); + -- Emit a specific diagnostic message concerning an instantiation of + -- generic unit Gen_Id. Kind denotes the kind of the instantiation. + + -------------------------- + -- Output_Instantiation -- + -------------------------- + + procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is + begin + Error_Msg_NE + ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); + end Output_Instantiation; + + -- Local variables + + Gen_Id : constant Entity_Id := Target (Inst_Rep); + + -- Start of processing for Output_Instantiation + + begin + Error_Msg_Node_2 := Defining_Entity (Inst); + Error_Msg_Sloc := Sloc (Inst); + + if Nkind (Inst) = N_Function_Instantiation then + Output_Instantiation (Gen_Id, "function"); + + elsif Nkind (Inst) = N_Package_Instantiation then + Output_Instantiation (Gen_Id, "package"); + + elsif Nkind (Inst) = N_Procedure_Instantiation then + Output_Instantiation (Gen_Id, "procedure"); + + else + pragma Assert (False); + return; + end if; + end Output_Instantiation; + + --------------------------------- + -- Output_Refined_State_Pragma -- + --------------------------------- + + procedure Output_Refined_State_Pragma + (Prag : Node_Id; + Prag_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + pragma Unreferenced (Prag_Rep); + + begin + Error_Msg_Sloc := Sloc (Prag); + Error_Msg_N ("\\ refinement constituents read #", Error_Nod); + end Output_Refined_State_Pragma; + + ---------------------------- + -- Output_Task_Activation -- + ---------------------------- + + procedure Output_Task_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + pragma Unreferenced (Call_Rep); + + function Find_Activator return Entity_Id; + -- Find the nearest enclosing construct which houses call Call + + -------------------- + -- Find_Activator -- + -------------------- + + function Find_Activator return Entity_Id is + Par : Node_Id; + + begin + -- Climb the parent chain looking for a package [body] or a + -- construct with a statement sequence. + + Par := Parent (Call); + while Present (Par) loop + if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then + return Defining_Entity (Par); + + elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then + return Defining_Entity (Parent (Par)); + end if; + + Par := Parent (Par); + end loop; + + return Empty; + end Find_Activator; + + -- Local variables + + Activator : constant Entity_Id := Find_Activator; + + -- Start of processing for Output_Task_Activation + + begin + pragma Assert (Present (Activator)); + + Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); + end Output_Task_Activation; + + -------------------------------- + -- Output_Variable_Assignment -- + -------------------------------- + + procedure Output_Variable_Assignment + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + Var_Id : constant Entity_Id := Target (Asmt_Rep); + + begin + Error_Msg_Sloc := Sloc (Asmt); + Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); + end Output_Variable_Assignment; + + ------------------------------- + -- Output_Variable_Reference -- + ------------------------------- + + procedure Output_Variable_Reference + (Ref : Node_Id; + Ref_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + Var_Id : constant Entity_Id := Target (Ref_Rep); + + begin + Error_Msg_Sloc := Sloc (Ref); + Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); + end Output_Variable_Reference; + + ------------------------- + -- Pop_Active_Scenario -- + ------------------------- + + procedure Pop_Active_Scenario (N : Node_Id) is + package Scenarios renames Active_Scenario_Stack; + Top : Node_Id renames Scenarios.Table (Scenarios.Last); + + begin + pragma Assert (Top = N); + Scenarios.Decrement_Last; + end Pop_Active_Scenario; + + -------------------------- + -- Push_Active_Scenario -- + -------------------------- + + procedure Push_Active_Scenario (N : Node_Id) is + begin + Active_Scenario_Stack.Append (N); + end Push_Active_Scenario; + + ------------------- + -- Root_Scenario -- + ------------------- + + function Root_Scenario return Node_Id is + package Scenarios renames Active_Scenario_Stack; + + begin + -- Ensure that the scenario stack has at least one active scenario in + -- it. The one at the bottom (index First) is the root scenario. + + pragma Assert (Scenarios.Last >= Scenarios.First); + return Scenarios.Table (Scenarios.First); + end Root_Scenario; + end Active_Scenarios; + + -------------------------- + -- Activation_Processor -- + -------------------------- + + package body Activation_Processor is + + ------------------------ + -- Process_Activation -- + ------------------------ + + procedure Process_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Processor : Activation_Processor_Ptr; + In_State : Processing_In_State) + is + procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); + pragma Inline (Process_Task_Object); + -- Invoke Processor for task object Obj_Id of type Typ + + procedure Process_Task_Objects + (Task_Objs : NE_List.Doubly_Linked_List); + pragma Inline (Process_Task_Objects); + -- Invoke Processor for all task objects found in list Task_Objs + + procedure Traverse_List + (List : List_Id; + Task_Objs : NE_List.Doubly_Linked_List); + pragma Inline (Traverse_List); + -- Traverse declarative or statement list List while searching for + -- objects of a task type, or containing task components. If such an + -- object is found, first save it in list Task_Objs and then invoke + -- Processor on it. + + ------------------------- + -- Process_Task_Object -- + ------------------------- + + procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is + Root_Typ : constant Entity_Id := + Non_Private_View (Root_Type (Typ)); + Comp_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Root_Rep : Target_Rep_Id; + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state + + begin + if Is_Task_Type (Typ) then + Obj_Rep := Target_Representation_Of (Obj_Id, New_In_State); + Root_Rep := Target_Representation_Of (Root_Typ, New_In_State); + + -- Warnings are suppressed when a prior scenario is already in + -- that mode, or when the object, activation call, or task type + -- have warnings suppressed. Update the state of the Processing + -- phase to reflect this. + + New_In_State.Suppress_Warnings := + New_In_State.Suppress_Warnings + or else not Elaboration_Warnings_OK (Call_Rep) + or else not Elaboration_Warnings_OK (Obj_Rep) + or else not Elaboration_Warnings_OK (Root_Rep); + + -- Update the state of the Processing phase to indicate that + -- any further traversal is now within a task body. + + New_In_State.Within_Task_Body := True; + + -- Associate the current task type with the activation call + + Set_Activated_Task_Type (Call_Rep, Root_Typ); + + -- Process the activation of the current task object by calling + -- the supplied processor. + + Processor.all + (Call => Call, + Call_Rep => Call_Rep, + Obj_Id => Obj_Id, + Obj_Rep => Obj_Rep, + Task_Typ => Root_Typ, + Task_Rep => Root_Rep, + In_State => New_In_State); + + -- Reset the association between the current task and the + -- activtion call. + + Set_Activated_Task_Type (Call_Rep, Empty); + + -- Examine the component type when the object is an array + + elsif Is_Array_Type (Typ) and then Has_Task (Root_Typ) then + Process_Task_Object + (Obj_Id => Obj_Id, + Typ => Component_Type (Typ)); + + -- Examine individual component types when the object is a record + + elsif Is_Record_Type (Typ) and then Has_Task (Root_Typ) then + Comp_Id := First_Component (Typ); + while Present (Comp_Id) loop + Process_Task_Object + (Obj_Id => Obj_Id, + Typ => Etype (Comp_Id)); + + Next_Component (Comp_Id); + end loop; + end if; + end Process_Task_Object; + + -------------------------- + -- Process_Task_Objects -- + -------------------------- + + procedure Process_Task_Objects + (Task_Objs : NE_List.Doubly_Linked_List) + is + Iter : NE_List.Iterator; + Obj_Id : Entity_Id; + + begin + Iter := NE_List.Iterate (Task_Objs); + while NE_List.Has_Next (Iter) loop + NE_List.Next (Iter, Obj_Id); + + Process_Task_Object + (Obj_Id => Obj_Id, + Typ => Etype (Obj_Id)); + end loop; + end Process_Task_Objects; + + ------------------- + -- Traverse_List -- + ------------------- + + procedure Traverse_List + (List : List_Id; + Task_Objs : NE_List.Doubly_Linked_List) + is + Item : Node_Id; + Item_Id : Entity_Id; + Item_Typ : Entity_Id; + + begin + -- Examine the contents of the list looking for an object + -- declaration of a task type or one that contains a task + -- within. + + Item := First (List); + while Present (Item) loop + if Nkind (Item) = N_Object_Declaration then + Item_Id := Defining_Entity (Item); + Item_Typ := Etype (Item_Id); + + if Has_Task (Item_Typ) then + + -- The object is either of a task type, or contains a + -- task component. Save it in the list of task objects + -- associated with the activation call. + + NE_List.Append (Task_Objs, Item_Id); + + Process_Task_Object + (Obj_Id => Item_Id, + Typ => Item_Typ); + end if; + end if; + + Next (Item); + end loop; + end Traverse_List; + + -- Local variables + + Context : Node_Id; + Spec : Node_Id; + Task_Objs : NE_List.Doubly_Linked_List; + + -- Start of processing for Process_Activation + + begin + -- Nothing to do when the activation is a guaranteed ABE + + if Is_Known_Guaranteed_ABE (Call) then + return; + end if; + + Task_Objs := Activated_Task_Objects (Call_Rep); + + -- The activation call has been processed at least once, and all + -- task objects have already been collected. Directly process the + -- objects without having to reexamine the context of the call. + + if NE_List.Present (Task_Objs) then + Process_Task_Objects (Task_Objs); + + -- Otherwise the activation call is being processed for the first + -- time. Collect all task objects in case the call is reprocessed + -- multiple times. + + else + Task_Objs := NE_List.Create; + Set_Activated_Task_Objects (Call_Rep, Task_Objs); + + -- Find the context of the activation call where all task objects + -- being activated are declared. This is usually the parent of the + -- call. + + Context := Parent (Call); + + -- Handle the case where the activation call appears within the + -- handled statements of a block or a body. + + if Nkind (Context) = N_Handled_Sequence_Of_Statements then + Context := Parent (Context); + end if; + + -- Process all task objects in both the spec and body when the + -- activation call appears in a package body. + + if Nkind (Context) = N_Package_Body then + Spec := + Specification + (Unit_Declaration_Node (Corresponding_Spec (Context))); + + Traverse_List + (List => Visible_Declarations (Spec), + Task_Objs => Task_Objs); + + Traverse_List + (List => Private_Declarations (Spec), + Task_Objs => Task_Objs); + + Traverse_List + (List => Declarations (Context), + Task_Objs => Task_Objs); + + -- Process all task objects in the spec when the activation call + -- appears in a package spec. + + elsif Nkind (Context) = N_Package_Specification then + Traverse_List + (List => Visible_Declarations (Context), + Task_Objs => Task_Objs); + + Traverse_List + (List => Private_Declarations (Context), + Task_Objs => Task_Objs); + + -- Otherwise the context must be a block or a body. Process all + -- task objects found in the declarations. + + else + pragma Assert (Nkind_In (Context, N_Block_Statement, + N_Entry_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body)); + + Traverse_List + (List => Declarations (Context), + Task_Objs => Task_Objs); + end if; + end if; + end Process_Activation; + end Activation_Processor; + + ----------------------- + -- Assignment_Target -- + ----------------------- + + function Assignment_Target (Asmt : Node_Id) return Node_Id is + Nam : Node_Id; + + begin + Nam := Name (Asmt); + + -- When the name denotes an array or record component, find the whole + -- object. + + while Nkind_In (Nam, N_Explicit_Dereference, + N_Indexed_Component, + N_Selected_Component, + N_Slice) + loop + Nam := Prefix (Nam); + end loop; + + return Nam; + end Assignment_Target; + + -------------------- + -- Body_Processor -- + -------------------- + + package body Body_Processor is + + --------------------- + -- Data structures -- + --------------------- + + -- The following map relates scenario lists to subprogram bodies + + Nested_Scenarios_Map : NE_List_Map.Dynamic_Hash_Table := NE_List_Map.Nil; + + -- The following set contains all subprogram bodies that have been + -- processed by routine Traverse_Body. + + Traversed_Bodies_Set : NE_Set.Membership_Set := NE_Set.Nil; + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Is_Traversed_Body (N : Node_Id) return Boolean; + pragma Inline (Is_Traversed_Body); + -- Determine whether subprogram body N has already been traversed + + function Nested_Scenarios + (N : Node_Id) return NE_List.Doubly_Linked_List; + pragma Inline (Nested_Scenarios); + -- Obtain the list of scenarios associated with subprogram body N + + procedure Set_Is_Traversed_Body + (N : Node_Id; + Val : Boolean := True); + pragma Inline (Set_Is_Traversed_Body); + -- Mark subprogram body N as traversed depending on value Val + + procedure Set_Nested_Scenarios + (N : Node_Id; + Scenarios : NE_List.Doubly_Linked_List); + pragma Inline (Set_Nested_Scenarios); + -- Associate scenario list Scenarios with subprogram body N + + ----------------------------- + -- Finalize_Body_Processor -- + ----------------------------- + + procedure Finalize_Body_Processor is + begin + NE_List_Map.Destroy (Nested_Scenarios_Map); + NE_Set.Destroy (Traversed_Bodies_Set); + end Finalize_Body_Processor; + + ------------------------------- + -- Initialize_Body_Processor -- + ------------------------------- + + procedure Initialize_Body_Processor is + begin + Nested_Scenarios_Map := NE_List_Map.Create (250); + Traversed_Bodies_Set := NE_Set.Create (250); + end Initialize_Body_Processor; + + ----------------------- + -- Is_Traversed_Body -- + ----------------------- + + function Is_Traversed_Body (N : Node_Id) return Boolean is + pragma Assert (Present (N)); + begin + return NE_Set.Contains (Traversed_Bodies_Set, N); + end Is_Traversed_Body; + + ---------------------- + -- Nested_Scenarios -- + ---------------------- + + function Nested_Scenarios + (N : Node_Id) return NE_List.Doubly_Linked_List + is + pragma Assert (Present (N)); + pragma Assert (Nkind (N) = N_Subprogram_Body); + + begin + return NE_List_Map.Get (Nested_Scenarios_Map, N); + end Nested_Scenarios; + + ---------------------------- + -- Reset_Traversed_Bodies -- + ---------------------------- + + procedure Reset_Traversed_Bodies is + begin + NE_Set.Reset (Traversed_Bodies_Set); + end Reset_Traversed_Bodies; + + --------------------------- + -- Set_Is_Traversed_Body -- + --------------------------- + + procedure Set_Is_Traversed_Body + (N : Node_Id; + Val : Boolean := True) + is + pragma Assert (Present (N)); + + begin + if Val then + NE_Set.Insert (Traversed_Bodies_Set, N); + else + NE_Set.Delete (Traversed_Bodies_Set, N); + end if; + end Set_Is_Traversed_Body; + + -------------------------- + -- Set_Nested_Scenarios -- + -------------------------- + + procedure Set_Nested_Scenarios + (N : Node_Id; + Scenarios : NE_List.Doubly_Linked_List) + is + pragma Assert (Present (N)); + begin + NE_List_Map.Put (Nested_Scenarios_Map, N, Scenarios); + end Set_Nested_Scenarios; + + ------------------- + -- Traverse_Body -- + ------------------- + + procedure Traverse_Body + (N : Node_Id; + Requires_Processing : Scenario_Predicate_Ptr; + Processor : Scenario_Processor_Ptr; + In_State : Processing_In_State) + is + Scenarios : NE_List.Doubly_Linked_List := NE_List.Nil; + -- The list of scenarios that appear within the declarations and + -- statement of subprogram body N. The variable is intentionally + -- global because Is_Potential_Scenario needs to populate it. + + function In_Task_Body (Nod : Node_Id) return Boolean; + pragma Inline (In_Task_Body); + -- Determine whether arbitrary node Nod appears within a task body + + function Is_Synchronous_Suspension_Call + (Nod : Node_Id) return Boolean; + pragma Inline (Is_Synchronous_Suspension_Call); + -- Determine whether arbitrary node Nod denotes a call to one of + -- these routines: + -- + -- Ada.Synchronous_Barriers.Wait_For_Release + -- Ada.Synchronous_Task_Control.Suspend_Until_True + + procedure Traverse_Collected_Scenarios; + pragma Inline (Traverse_Collected_Scenarios); + -- Traverse the already collected scenarios in list Scenarios by + -- invoking Processor on each individual one. + + procedure Traverse_List (List : List_Id); + pragma Inline (Traverse_List); + -- Invoke Traverse_Potential_Scenarios on each node in list List + + function Traverse_Potential_Scenario + (Scen : Node_Id) return Traverse_Result; + pragma Inline (Traverse_Potential_Scenario); + -- Determine whether arbitrary node Scen is a suitable scenario using + -- predicate Is_Scenario and traverse it by invoking Processor on it. + + procedure Traverse_Potential_Scenarios is + new Traverse_Proc (Traverse_Potential_Scenario); + + ------------------ + -- In_Task_Body -- + ------------------ + + function In_Task_Body (Nod : Node_Id) return Boolean is + Par : Node_Id; + + begin + -- Climb the parent chain looking for a task body [procedure] + + Par := Nod; + while Present (Par) loop + if Nkind (Par) = N_Task_Body then + return True; + + elsif Nkind (Par) = N_Subprogram_Body + and then Is_Task_Body_Procedure (Par) + then + return True; + + -- Prevent the search from going too far. Note that this test + -- shares nodes with the two cases above, and must come last. + + elsif Is_Body_Or_Package_Declaration (Par) then + return False; + end if; + + Par := Parent (Par); + end loop; + + return False; + end In_Task_Body; + + ------------------------------------ + -- Is_Synchronous_Suspension_Call -- + ------------------------------------ + + function Is_Synchronous_Suspension_Call + (Nod : Node_Id) return Boolean + is + Subp_Id : Entity_Id; + + begin + -- To qualify, the call must invoke one of the runtime routines + -- which perform synchronous suspension. + + if Is_Suitable_Call (Nod) then + Subp_Id := Target (Nod); + + return + Is_RTE (Subp_Id, RE_Suspend_Until_True) + or else + Is_RTE (Subp_Id, RE_Wait_For_Release); + end if; + + return False; + end Is_Synchronous_Suspension_Call; + + ---------------------------------- + -- Traverse_Collected_Scenarios -- + ---------------------------------- + + procedure Traverse_Collected_Scenarios is + Iter : NE_List.Iterator; + Scen : Node_Id; + + begin + Iter := NE_List.Iterate (Scenarios); + while NE_List.Has_Next (Iter) loop + NE_List.Next (Iter, Scen); + + -- The current scenario satisfies the input predicate, process + -- it. + + if Requires_Processing.all (Scen) then + Processor.all (Scen, In_State); + end if; + end loop; + end Traverse_Collected_Scenarios; + + ------------------- + -- Traverse_List -- + ------------------- + + procedure Traverse_List (List : List_Id) is + Scen : Node_Id; + + begin + Scen := First (List); + while Present (Scen) loop + Traverse_Potential_Scenarios (Scen); + Next (Scen); + end loop; + end Traverse_List; + + --------------------------------- + -- Traverse_Potential_Scenario -- + --------------------------------- + + function Traverse_Potential_Scenario + (Scen : Node_Id) return Traverse_Result + is + begin + -- Special cases + + -- Skip constructs which do not have elaboration of their own and + -- need to be elaborated by other means such as invocation, task + -- activation, etc. + + if Is_Non_Library_Level_Encapsulator (Scen) then + return Skip; + + -- Terminate the traversal of a task body when encountering an + -- accept or select statement, and + -- + -- * Entry calls during elaboration are not allowed. In this + -- case the accept or select statement will cause the task + -- to block at elaboration time because there are no entry + -- calls to unblock it. + -- + -- or + -- + -- * Switch -gnatd_a (stop elaboration checks on accept or + -- select statement) is in effect. + + elsif (Debug_Flag_Underscore_A + or else Restriction_Active + (No_Entry_Calls_In_Elaboration_Code)) + and then Nkind_In (Original_Node (Scen), N_Accept_Statement, + N_Selective_Accept) + then + return Abandon; + + -- Terminate the traversal of a task body when encountering a + -- suspension call, and + -- + -- * Entry calls during elaboration are not allowed. In this + -- case the suspension call emulates an entry call and will + -- cause the task to block at elaboration time. + -- + -- or + -- + -- * Switch -gnatd_s (stop elaboration checks on synchronous + -- suspension) is in effect. + -- + -- Note that the guard should not be checking the state of flag + -- Within_Task_Body because only suspension calls which appear + -- immediately within the statements of the task are supported. + -- Flag Within_Task_Body carries over to deeper levels of the + -- traversal. + + elsif (Debug_Flag_Underscore_S + or else Restriction_Active + (No_Entry_Calls_In_Elaboration_Code)) + and then Is_Synchronous_Suspension_Call (Scen) + and then In_Task_Body (Scen) + then + return Abandon; + + -- Certain nodes carry semantic lists which act as repositories + -- until expansion transforms the node and relocates the contents. + -- Examine these lists in case expansion is disabled. + + elsif Nkind_In (Scen, N_And_Then, N_Or_Else) then + Traverse_List (Actions (Scen)); + + elsif Nkind_In (Scen, N_Elsif_Part, N_Iteration_Scheme) then + Traverse_List (Condition_Actions (Scen)); + + elsif Nkind (Scen) = N_If_Expression then + Traverse_List (Then_Actions (Scen)); + Traverse_List (Else_Actions (Scen)); + + elsif Nkind_In (Scen, N_Component_Association, + N_Iterated_Component_Association) + then + Traverse_List (Loop_Actions (Scen)); + + -- General case + + -- The current node satisfies the input predicate, process it + + elsif Requires_Processing.all (Scen) then + Processor.all (Scen, In_State); + end if; + + -- Save a general scenario regardless of whether it satisfies the + -- input predicate. This allows for quick subsequent traversals of + -- general scenarios, even with different predicates. + + if Is_Suitable_Access_Taken (Scen) + or else Is_Suitable_Call (Scen) + or else Is_Suitable_Instantiation (Scen) + or else Is_Suitable_Variable_Assignment (Scen) + or else Is_Suitable_Variable_Reference (Scen) + then + NE_List.Append (Scenarios, Scen); + end if; + + return OK; + end Traverse_Potential_Scenario; + + -- Start of processing for Traverse_Body + + begin + -- Nothing to do when the traversal is suppressed + + if In_State.Traversal = No_Traversal then + return; + + -- Nothing to do when there is no input + + elsif No (N) then + return; + + -- Nothing to do when the input is not a subprogram body + + elsif Nkind (N) /= N_Subprogram_Body then + return; + + -- Nothing to do if the subprogram body was already traversed + + elsif Is_Traversed_Body (N) then + return; + end if; + + -- Mark the subprogram body as traversed + + Set_Is_Traversed_Body (N); + + Scenarios := Nested_Scenarios (N); + + -- The subprogram body has been traversed at least once, and all + -- scenarios that appear within its declarations and statements + -- have already been collected. Directly retraverse the scenarios + -- without having to retraverse the subprogram body subtree. + + if NE_List.Present (Scenarios) then + Traverse_Collected_Scenarios; + + -- Otherwise the subprogram body is being traversed for the first + -- time. Collect all scenarios that appear within its declarations + -- and statements in case the subprogram body has to be retraversed + -- multiple times. + + else + Scenarios := NE_List.Create; + Set_Nested_Scenarios (N, Scenarios); + + Traverse_List (Declarations (N)); + Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); + end if; + end Traverse_Body; + end Body_Processor; ----------------------- -- Build_Call_Marker -- @@ -1882,19 +3393,16 @@ package body Sem_Elab is procedure Build_Call_Marker (N : Node_Id) is function In_External_Context - (Call : Node_Id; - Target_Attrs : Target_Attributes) return Boolean; + (Call : Node_Id; + Subp_Id : Entity_Id) return Boolean; pragma Inline (In_External_Context); - -- Determine whether a target described by attributes Target_Attrs is - -- external to call Call which must reside within an instance. + -- Determine whether entry, operator, or subprogram Subp_Id is external + -- to call Call which must reside within an instance. function In_Premature_Context (Call : Node_Id) return Boolean; + pragma Inline (In_Premature_Context); -- Determine whether call Call appears within a premature context - function Is_Bridge_Target (Id : Entity_Id) return Boolean; - pragma Inline (Is_Bridge_Target); - -- Determine whether arbitrary entity Id denotes a bridge target - function Is_Default_Expression (Call : Node_Id) return Boolean; pragma Inline (Is_Default_Expression); -- Determine whether call Call acts as the expression of a defaulted @@ -1910,16 +3418,16 @@ package body Sem_Elab is ------------------------- function In_External_Context - (Call : Node_Id; - Target_Attrs : Target_Attributes) return Boolean + (Call : Node_Id; + Subp_Id : Entity_Id) return Boolean is + Spec_Decl : constant Entity_Id := Unit_Declaration_Node (Subp_Id); + Inst : Node_Id; Inst_Body : Node_Id; - Inst_Decl : Node_Id; + Inst_Spec : Node_Id; begin - -- Performance note: parent traversal - Inst := Find_Enclosing_Instance (Call); -- The call appears within an instance @@ -1929,7 +3437,7 @@ package body Sem_Elab is -- The call comes from the main unit and the target does not if In_Extended_Main_Code_Unit (Call) - and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl) + and then not In_Extended_Main_Code_Unit (Spec_Decl) then return True; @@ -1937,16 +3445,14 @@ package body Sem_Elab is -- instance spec or body. else - Extract_Instance_Attributes - (Exp_Inst => Inst, - Inst_Decl => Inst_Decl, - Inst_Body => Inst_Body); - - -- Performance note: parent traversal + Spec_And_Body_From_Node + (N => Inst, + Spec_Decl => Inst_Spec, + Body_Decl => Inst_Body); return not In_Subtree - (N => Target_Attrs.Spec_Decl, - Root1 => Inst_Decl, + (N => Spec_Decl, + Root1 => Inst_Spec, Root2 => Inst_Body); end if; end if; @@ -1988,22 +3494,6 @@ package body Sem_Elab is return False; end In_Premature_Context; - ---------------------- - -- Is_Bridge_Target -- - ---------------------- - - function Is_Bridge_Target (Id : Entity_Id) return Boolean is - begin - return - Is_Accept_Alternative_Proc (Id) - or else Is_Finalizer_Proc (Id) - or else Is_Partial_Invariant_Proc (Id) - or else Is_Postconditions_Proc (Id) - or else Is_TSS (Id, TSS_Deep_Adjust) - or else Is_TSS (Id, TSS_Deep_Finalize) - or else Is_TSS (Id, TSS_Deep_Initialize); - end Is_Bridge_Target; - --------------------------- -- Is_Default_Expression -- --------------------------- @@ -2021,7 +3511,7 @@ package body Sem_Elab is N_Procedure_Call_Statement) and then Comes_From_Source (Outer_Call) then - Outer_Nam := Extract_Call_Name (Outer_Call); + Outer_Nam := Call_Name (Outer_Call); return Is_Entity_Name (Outer_Nam) @@ -2056,11 +3546,9 @@ package body Sem_Elab is -- Local variables - Call_Attrs : Call_Attributes; - Call_Nam : Node_Id; - Marker : Node_Id; - Target_Attrs : Target_Attributes; - Target_Id : Entity_Id; + Call_Nam : Node_Id; + Marker : Node_Id; + Subp_Id : Entity_Id; -- Start of processing for Build_Call_Marker @@ -2101,9 +3589,16 @@ package body Sem_Elab is and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) then return; + + -- Nothing to do when the call is analyzed/resolved too early within an + -- intermediate context. This check is saved for last because it incurs + -- a performance penalty. + + elsif In_Premature_Context (N) then + return; end if; - Call_Nam := Extract_Call_Name (N); + Call_Nam := Call_Name (N); -- Nothing to do when the call is erroneous or left in a bad state @@ -2112,6 +3607,9 @@ package body Sem_Elab is and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) then return; + end if; + + Subp_Id := Canonical_Subprogram (Entity (Call_Nam)); -- Nothing to do when the call invokes a generic formal subprogram and -- switch -gnatd.G (ignore calls through generic formal parameters for @@ -2119,44 +3617,24 @@ package body Sem_Elab is -- direct target of the call to avoid the side effects of mapping -- actuals to formals using renamings. - elsif Debug_Flag_Dot_GG + if Debug_Flag_Dot_GG and then Is_Generic_Formal_Subp (Entity (Call_Nam)) then return; - -- Nothing to do when the call is analyzed/resolved too early within an - -- intermediate context. This check is saved for last because it incurs - -- a performance penalty. - - -- Performance note: parent traversal - - elsif In_Premature_Context (N) then - return; - end if; - - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); - - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); - -- Nothing to do when the call appears within the expanded spec or -- body of an instantiated generic, the call does not invoke a generic -- formal subprogram, the target is external to the instance, and switch -- -gnatdL (ignore external calls from instances for elaboration) is in - -- effect. + -- effect. This check must be performed with the direct target of the + -- call to avoid the side effects of mapping actuals to formals using + -- renamings. - if Debug_Flag_LL + elsif Debug_Flag_LL and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) - - -- Performance note: parent traversal - and then In_External_Context - (Call => N, - Target_Attrs => Target_Attrs) + (Call => N, + Subp_Id => Subp_Id) then return; @@ -2165,20 +3643,20 @@ package body Sem_Elab is -- in effect. elsif Debug_Flag_Underscore_P - and then Is_Assertion_Pragma_Target (Target_Id) + and then Is_Assertion_Pragma_Target (Subp_Id) then return; -- Source calls to source targets are always considered because they -- reflect the original call graph. - elsif Target_Attrs.From_Source and then Call_Attrs.From_Source then + elsif Comes_From_Source (N) and then Comes_From_Source (Subp_Id) then null; -- A call to a source function which acts as the default expression in -- another call requires special detection. - elsif Target_Attrs.From_Source + elsif Comes_From_Source (Subp_Id) and then Nkind (N) = N_Function_Call and then Is_Default_Expression (N) then @@ -2186,17 +3664,17 @@ package body Sem_Elab is -- The target emulates Ada semantics - elsif Is_Ada_Semantic_Target (Target_Id) then + elsif Is_Ada_Semantic_Target (Subp_Id) then null; -- The target acts as a link between scenarios - elsif Is_Bridge_Target (Target_Id) then + elsif Is_Bridge_Target (Subp_Id) then null; -- The target emulates SPARK semantics - elsif Is_SPARK_Semantic_Target (Target_Id) then + elsif Is_SPARK_Semantic_Target (Subp_Id) then null; -- Otherwise the call is not suitable for ABE processing. This prevents @@ -2215,16 +3693,23 @@ package body Sem_Elab is -- Inherit the attributes of the original call - Set_Target (Marker, Target_Id); - Set_Is_Declaration_Level_Node (Marker, Call_Attrs.In_Declarations); - Set_Is_Dispatching_Call (Marker, Call_Attrs.Is_Dispatching); + Set_Is_Declaration_Level_Node + (Marker, Find_Enclosing_Level (N) = Declaration_Level); + + Set_Is_Dispatching_Call + (Marker, Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + and then Present (Controlling_Argument (N))); + Set_Is_Elaboration_Checks_OK_Node - (Marker, Call_Attrs.Elab_Checks_OK); + (Marker, Is_Elaboration_Checks_OK_Node (N)); + Set_Is_Elaboration_Warnings_OK_Node - (Marker, Call_Attrs.Elab_Warnings_OK); - Set_Is_Ignored_Ghost_Node (Marker, Call_Attrs.Ghost_Mode_Ignore); - Set_Is_Source_Call (Marker, Call_Attrs.From_Source); - Set_Is_SPARK_Mode_On_Node (Marker, Call_Attrs.SPARK_Mode_On); + (Marker, Is_Elaboration_Warnings_OK_Node (N)); + + Set_Is_Ignored_Ghost_Node (Marker, Is_Ignored_Ghost_Node (N)); + Set_Is_Source_Call (Marker, Comes_From_Source (N)); + Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); + Set_Target (Marker, Subp_Id); -- The marker is inserted prior to the original call. This placement has -- several desirable effects: @@ -2274,23 +3759,50 @@ package body Sem_Elab is Read : Boolean; Write : Boolean) is - Marker : Node_Id; - Var_Attrs : Variable_Attributes; - Var_Id : Entity_Id; + function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id; + pragma Inline (Ultimate_Variable); + -- Obtain the ultimate renamed variable of variable Var_Id - begin - Extract_Variable_Reference_Attributes - (Ref => N, - Var_Id => Var_Id, - Attrs => Var_Attrs); + ----------------------- + -- Ultimate_Variable -- + ----------------------- + + function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id is + Ren_Id : Entity_Id; + + begin + Ren_Id := Var_Id; + while Present (Renamed_Entity (Ren_Id)) + and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity + loop + Ren_Id := Renamed_Entity (Ren_Id); + end loop; + return Ren_Id; + end Ultimate_Variable; + + -- Local variables + + Var_Id : constant Entity_Id := Ultimate_Variable (Entity (N)); + Marker : Node_Id; + + -- Start of processing for Build_Variable_Reference_Marker + + begin Marker := Make_Variable_Reference_Marker (Sloc (N)); -- Inherit the attributes of the original variable reference - Set_Target (Marker, Var_Id); - Set_Is_Read (Marker, Read); - Set_Is_Write (Marker, Write); + Set_Is_Elaboration_Checks_OK_Node + (Marker, Is_Elaboration_Checks_OK_Node (N)); + + Set_Is_Elaboration_Warnings_OK_Node + (Marker, Is_Elaboration_Warnings_OK_Node (N)); + + Set_Is_Read (Marker, Read); + Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); + Set_Is_Write (Marker, Write); + Set_Target (Marker, Var_Id); -- The marker is inserted prior to the original variable reference. The -- insertion must take place even when the reference does not occur in @@ -2306,11 +3818,69 @@ package body Sem_Elab is Record_Elaboration_Scenario (Marker); end Build_Variable_Reference_Marker; + --------------- + -- Call_Name -- + --------------- + + function Call_Name (Call : Node_Id) return Node_Id is + Nam : Node_Id; + + begin + Nam := Name (Call); + + -- When the call invokes an entry family, the name appears as an indexed + -- component. + + if Nkind (Nam) = N_Indexed_Component then + Nam := Prefix (Nam); + end if; + + -- When the call employs the object.operation form, the name appears as + -- a selected component. + + if Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); + end if; + + return Nam; + end Call_Name; + + -------------------------- + -- Canonical_Subprogram -- + -------------------------- + + function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id is + Canon_Id : Entity_Id; + + begin + Canon_Id := Subp_Id; + + -- Use the original protected subprogram when dealing with one of the + -- specialized lock-manipulating versions. + + if Is_Protected_Body_Subp (Canon_Id) then + Canon_Id := Protected_Subprogram (Canon_Id); + end if; + + -- Obtain the original subprogram except when the subprogram is also + -- an instantiation. In this case the alias is the internally generated + -- subprogram which appears within the anonymous package created for the + -- instantiation, making it unuitable. + + if not Is_Generic_Instance (Canon_Id) then + Canon_Id := Get_Renamed_Entity (Canon_Id); + end if; + + return Canon_Id; + end Canonical_Subprogram; + --------------------------------- -- Check_Elaboration_Scenarios -- --------------------------------- procedure Check_Elaboration_Scenarios is + Iter : NE_Set.Iterator; + begin -- Nothing to do when switch -gnatH (legacy elaboration checking mode -- enabled) is in effect because the legacy ABE mechanism does not need @@ -2326,6 +3896,15 @@ package body Sem_Elab is return; end if; + -- Create all internal data structures + + Initialize_Body_Processor; + Initialize_Early_Call_Region_Processor; + Initialize_Elaborated_Units; + Initialize_Internal_Representation; + Initialize_Invocation_Graph; + Initialize_Scenario_Storage; + -- Restore the original elaboration model which was in effect when the -- scenarios were first recorded. The model may be specified by pragma -- Elaboration_Checks which appears on the initial declaration of the @@ -2336,2996 +3915,4910 @@ package body Sem_Elab is -- Examine the context of the main unit and record all units with prior -- elaboration with respect to it. - Find_Elaborated_Units; + Collect_Elaborated_Units; - -- Examine each top-level scenario saved during the Recording phase for - -- conditional ABEs and perform various actions depending on the model - -- in effect. The table of visited bodies is created for each new top- - -- level scenario. + -- Examine all scenarios saved during the Recording phase applying the + -- Ada or SPARK elaboration rules in order to detect and diagnose ABE + -- issues, install conditional ABE checks, and ensure the elaboration + -- of units. - for Index in Top_Level_Scenarios.First .. Top_Level_Scenarios.Last loop - Reset_Visited_Bodies; + Iter := Iterate_Declaration_Scenarios; + Check_Conditional_ABE_Scenarios (Iter); - Process_Conditional_ABE (Top_Level_Scenarios.Table (Index)); - end loop; + Iter := Iterate_Library_Body_Scenarios; + Check_Conditional_ABE_Scenarios (Iter); + + Iter := Iterate_Library_Spec_Scenarios; + Check_Conditional_ABE_Scenarios (Iter); -- Examine each SPARK scenario saved during the Recording phase which -- is not necessarily executable during elaboration, but still requires -- elaboration-related checks. - for Index in SPARK_Scenarios.First .. SPARK_Scenarios.Last loop - Check_SPARK_Scenario (SPARK_Scenarios.Table (Index)); - end loop; + Check_SPARK_Scenarios; + + -- Add conditional ABE checks for all scenarios that require one when + -- the dynamic model is in effect. + + Install_Dynamic_ABE_Checks; + + -- Examine all scenarios saved during the Recording phase along with + -- invocation constructs within the spec and body of the main unit. + -- Record the declarations and paths that reach into an external unit + -- in the ALI file of the main unit. + + Record_Invocation_Graph; + + -- Destroy all internal data structures + + Finalize_Body_Processor; + Finalize_Early_Call_Region_Processor; + Finalize_Elaborated_Units; + Finalize_Internal_Representation; + Finalize_Invocation_Graph; + Finalize_Scenario_Storage; end Check_Elaboration_Scenarios; - ------------------------------ - -- Check_Preelaborated_Call -- - ------------------------------ + --------------------- + -- Check_Installer -- + --------------------- - procedure Check_Preelaborated_Call (Call : Node_Id) is - function In_Preelaborated_Context (N : Node_Id) return Boolean; - -- Determine whether arbitrary node appears in a preelaborated context + package body Check_Installer is - ------------------------------ - -- In_Preelaborated_Context -- - ------------------------------ + ----------------------- + -- Local subprograms -- + ----------------------- - function In_Preelaborated_Context (N : Node_Id) return Boolean is - Body_Id : constant Entity_Id := Find_Code_Unit (N); - Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); + function ABE_Check_Or_Failure_OK + (N : Node_Id; + Targ_Id : Entity_Id; + Unit_Id : Entity_Id) return Boolean; + pragma Inline (ABE_Check_Or_Failure_OK); + -- Determine whether a conditional ABE check or guaranteed ABE failure + -- can be installed for scenario N with target Targ_Id which resides in + -- unit Unit_Id. + + function Insertion_Node (N : Node_Id) return Node_Id; + pragma Inline (Insertion_Node); + -- Obtain the proper insertion node of an ABE check or failure for + -- scenario N. + + procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id); + pragma Inline (Insert_ABE_Check_Or_Failure); + -- Insert conditional ABE check or guaranteed ABE failure Check prior to + -- scenario N. + + procedure Install_Scenario_ABE_Check_Common + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id); + pragma Inline (Install_Scenario_ABE_Check_Common); + -- Install a conditional ABE check for scenario N to ensure that target + -- Targ_Id is properly elaborated. Targ_Rep is the representation of the + -- target. + + procedure Install_Scenario_ABE_Failure_Common (N : Node_Id); + pragma Inline (Install_Scenario_ABE_Failure_Common); + -- Install a guaranteed ABE failure for scenario N + + procedure Install_Unit_ABE_Check_Common + (N : Node_Id; + Unit_Id : Entity_Id); + pragma Inline (Install_Unit_ABE_Check_Common); + -- Install a conditional ABE check for scenario N to ensure that unit + -- Unit_Id is properly elaborated. + + ----------------------------- + -- ABE_Check_Or_Failure_OK -- + ----------------------------- + + function ABE_Check_Or_Failure_OK + (N : Node_Id; + Targ_Id : Entity_Id; + Unit_Id : Entity_Id) return Boolean + is + pragma Unreferenced (Targ_Id); + + Ins_Node : constant Node_Id := Insertion_Node (N); begin - -- The node appears within a package body whose corresponding spec is - -- subject to pragma Remote_Call_Interface or Remote_Types. This does - -- not result in a preelaborated context because the package body may - -- be on another machine. + if not Check_Or_Failure_Generation_OK then + return False; - if Ekind (Body_Id) = E_Package_Body - and then Ekind_In (Spec_Id, E_Generic_Package, E_Package) - and then (Is_Remote_Call_Interface (Spec_Id) - or else Is_Remote_Types (Spec_Id)) + -- Nothing to do when the scenario denots a compilation unit because + -- there is no executable environment at that level. + + elsif Nkind (Parent (Ins_Node)) = N_Compilation_Unit then + return False; + + -- An ABE check or failure is not needed when the target is defined + -- in a unit which is elaborated prior to the main unit. This check + -- must also consider the following cases: + -- + -- * The unit of the target appears in the context of the main unit + -- + -- * The unit of the target is subject to pragma Elaborate_Body. An + -- ABE check MUST NOT be generated because the unit is always + -- elaborated prior to the main unit. + -- + -- * The unit of the target is the main unit. An ABE check MUST be + -- added in this case because a conditional ABE may be raised + -- depending on the flow of execution within the main unit (flag + -- Same_Unit_OK is False). + + elsif Has_Prior_Elaboration + (Unit_Id => Unit_Id, + Context_OK => True, + Elab_Body_OK => True) then return False; + end if; - -- Otherwise the node appears within a preelaborated context when the - -- associated unit is preelaborated. + return True; + end ABE_Check_Or_Failure_OK; - else - return Is_Preelaborated_Unit (Spec_Id); - end if; - end In_Preelaborated_Context; + ------------------------------------ + -- Check_Or_Failure_Generation_OK -- + ------------------------------------ - -- Local variables + function Check_Or_Failure_Generation_OK return Boolean is + begin + -- An ABE check or failure is not needed when the compilation will + -- not produce an executable. - Call_Attrs : Call_Attributes; - Level : Enclosing_Level_Kind; - Target_Id : Entity_Id; + if Serious_Errors_Detected > 0 then + return False; - -- Start of processing for Check_Preelaborated_Call + -- An ABE check or failure must not be installed when compiling for + -- GNATprove because raise statements are not supported. - begin - Extract_Call_Attributes - (Call => Call, - Target_Id => Target_Id, - Attrs => Call_Attrs); + elsif GNATprove_Mode then + return False; + end if; - -- Nothing to do when the call is internally generated because it is - -- assumed that it will never violate preelaboration. + return True; + end Check_Or_Failure_Generation_OK; - if not Call_Attrs.From_Source then - return; - end if; + -------------------- + -- Insertion_Node -- + -------------------- - -- Performance note: parent traversal + function Insertion_Node (N : Node_Id) return Node_Id is + begin + -- When the scenario denotes an instantiation, the proper insertion + -- node is the instance spec. This ensures that the generic actuals + -- will not be evaluated prior to a potential ABE. - Level := Find_Enclosing_Level (Call); + if Nkind (N) in N_Generic_Instantiation + and then Present (Instance_Spec (N)) + then + return Instance_Spec (N); - -- Library-level calls are always considered because they are part of - -- the associated unit's elaboration actions. + -- Otherwise the proper insertion node is the scenario itself - if Level in Library_Level then - null; + else + return N; + end if; + end Insertion_Node; - -- Calls at the library level of a generic package body must be checked - -- because they would render an instantiation illegal if the template is - -- marked as preelaborated. Note that this does not apply to calls at - -- the library level of a generic package spec. + --------------------------------- + -- Insert_ABE_Check_Or_Failure -- + --------------------------------- - elsif Level = Generic_Package_Body then - null; + procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id) is + Ins_Nod : constant Node_Id := Insertion_Node (N); + Scop_Id : constant Entity_Id := Find_Enclosing_Scope (Ins_Nod); - -- Otherwise the call does not appear at the proper level and must not - -- be considered for this check. + begin + -- Install the nearest enclosing scope of the scenario as there must + -- be something on the scope stack. - else - return; - end if; + Push_Scope (Scop_Id); - -- The call appears within a preelaborated unit. Emit a warning only for - -- internal uses, otherwise this is an error. + Insert_Action (Ins_Nod, Check); - if In_Preelaborated_Context (Call) then - Error_Msg_Warn := GNAT_Mode; - Error_Msg_N - ("<<non-static call not allowed in preelaborated unit", Call); - end if; - end Check_Preelaborated_Call; + Pop_Scope; + end Insert_ABE_Check_Or_Failure; - ------------------------------ - -- Check_SPARK_Derived_Type -- - ------------------------------ + -------------------------------- + -- Install_Dynamic_ABE_Checks -- + -------------------------------- - procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id) is - Typ : constant Entity_Id := Defining_Entity (Typ_Decl); + procedure Install_Dynamic_ABE_Checks is + Iter : NE_Set.Iterator; + N : Node_Id; - -- NOTE: The routines within Check_SPARK_Derived_Type are intentionally - -- unnested to avoid deep indentation of code. + begin + if not Check_Or_Failure_Generation_OK then + return; - Stop_Check : exception; - -- This exception is raised when the freeze node violates the placement - -- rules. + -- Nothing to do if the dynamic model is not in effect - procedure Check_Overriding_Primitive - (Prim : Entity_Id; - FNode : Node_Id); - pragma Inline (Check_Overriding_Primitive); - -- Verify that freeze node FNode is within the early call region of - -- overriding primitive Prim's body. + elsif not Dynamic_Elaboration_Checks then + return; + end if; - function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; - pragma Inline (Freeze_Node_Location); - -- Return a more accurate source location associated with freeze node - -- FNode. + -- Install a conditional ABE check for each saved scenario - function Precedes_Source_Construct (N : Node_Id) return Boolean; - pragma Inline (Precedes_Source_Construct); - -- Determine whether arbitrary node N appears prior to some source - -- construct. + Iter := Iterate_Dynamic_ABE_Check_Scenarios; + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - procedure Suggest_Elaborate_Body - (N : Node_Id; - Body_Decl : Node_Id; - Error_Nod : Node_Id); - pragma Inline (Suggest_Elaborate_Body); - -- Suggest the use of pragma Elaborate_Body when the pragma will allow - -- for node N to appear within the early call region of subprogram body - -- Body_Decl. The suggestion is attached to Error_Nod as a continuation - -- error. + Process_Conditional_ABE + (N => N, + In_State => Dynamic_Model_State); + end loop; + end Install_Dynamic_ABE_Checks; -------------------------------- - -- Check_Overriding_Primitive -- + -- Install_Scenario_ABE_Check -- -------------------------------- - procedure Check_Overriding_Primitive - (Prim : Entity_Id; - FNode : Node_Id) + procedure Install_Scenario_ABE_Check + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Scenario_Rep_Id) is - Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); - Body_Decl : Node_Id; - Body_Id : Entity_Id; - Region : Node_Id; - begin - -- Nothing to do for predefined primitives because they are artifacts - -- of tagged type expansion and cannot override source primitives. + -- Nothing to do when the scenario does not need an ABE check - if Is_Predefined_Dispatching_Operation (Prim) then + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Targ_Id, + Unit_Id => Unit (Targ_Rep)) + then return; end if; - Body_Id := Corresponding_Body (Prim_Decl); + -- Prevent multiple attempts to install the same ABE check - -- Nothing to do when the primitive does not have a corresponding - -- body. This can happen when the unit with the bodies is not the - -- main unit subjected to ABE checks. + Disable_Elaboration_Checks (Disable); - if No (Body_Id) then + Install_Scenario_ABE_Check_Common + (N => N, + Targ_Id => Targ_Id, + Targ_Rep => Targ_Rep); + end Install_Scenario_ABE_Check; + + -------------------------------- + -- Install_Scenario_ABE_Check -- + -------------------------------- + + procedure Install_Scenario_ABE_Check + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Target_Rep_Id) + is + begin + -- Nothing to do when the scenario does not need an ABE check + + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Targ_Id, + Unit_Id => Unit (Targ_Rep)) + then return; + end if; - -- The primitive overrides a parent or progenitor primitive + -- Prevent multiple attempts to install the same ABE check - elsif Present (Overridden_Operation (Prim)) then + Disable_Elaboration_Checks (Disable); - -- Nothing to do when overriding an interface primitive happens by - -- inheriting a non-interface primitive as the check would be done - -- on the parent primitive. + Install_Scenario_ABE_Check_Common + (N => N, + Targ_Id => Targ_Id, + Targ_Rep => Targ_Rep); + end Install_Scenario_ABE_Check; - if Present (Alias (Prim)) then + --------------------------------------- + -- Install_Scenario_ABE_Check_Common -- + --------------------------------------- + + procedure Install_Scenario_ABE_Check_Common + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id) + is + Targ_Body : constant Node_Id := Body_Declaration (Targ_Rep); + Targ_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); + + pragma Assert (Present (Targ_Body)); + pragma Assert (Present (Targ_Decl)); + + procedure Build_Elaboration_Entity; + pragma Inline (Build_Elaboration_Entity); + -- Create a new elaboration flag for Targ_Id, insert it prior to + -- Targ_Decl, and set it after Targ_Body. + + ------------------------------ + -- Build_Elaboration_Entity -- + ------------------------------ + + procedure Build_Elaboration_Entity is + Loc : constant Source_Ptr := Sloc (Targ_Id); + Flag_Id : Entity_Id; + + begin + -- Nothing to do if the target has an elaboration flag + + if Present (Elaboration_Entity (Targ_Id)) then return; end if; - -- Nothing to do when the primitive is not overriding. The body of - -- such a primitive cannot be targeted by a dispatching call which - -- is executable during elaboration, and cannot cause an ABE. + -- Create the declaration of the elaboration flag. The name + -- carries a unique counter in case the name is overloaded. - else - return; - end if; + Flag_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Targ_Id), 'E', -1)); - Body_Decl := Unit_Declaration_Node (Body_Id); - Region := Find_Early_Call_Region (Body_Decl); + Set_Elaboration_Entity (Targ_Id, Flag_Id); + Set_Elaboration_Entity_Required (Targ_Id); - -- The freeze node appears prior to the early call region of the - -- primitive body. + Push_Scope (Scope (Targ_Id)); - -- IMPORTANT: This check must always be performed even when -gnatd.v - -- (enforce SPARK elaboration rules in SPARK code) is not specified - -- because the static model cannot guarantee the absence of ABEs in - -- in the presence of dispatching calls. + -- Generate: + -- Enn : Short_Integer := 0; - if Earlier_In_Extended_Unit (FNode, Region) then - Error_Msg_Node_2 := Prim; - Error_Msg_NE - ("first freezing point of type & must appear within early call " - & "region of primitive body & (SPARK RM 7.7(8))", - Typ_Decl, Typ); + Insert_Action (Targ_Decl, + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Occurrence_Of (Standard_Short_Integer, Loc), + Expression => Make_Integer_Literal (Loc, Uint_0))); - Error_Msg_Sloc := Sloc (Region); - Error_Msg_N ("\region starts #", Typ_Decl); + -- Generate: + -- Enn := 1; - Error_Msg_Sloc := Sloc (Body_Decl); - Error_Msg_N ("\region ends #", Typ_Decl); + Set_Elaboration_Flag (Targ_Body, Targ_Id); + + Pop_Scope; + end Build_Elaboration_Entity; - Error_Msg_Sloc := Freeze_Node_Location (FNode); - Error_Msg_N ("\first freezing point #", Typ_Decl); + -- Local variables - -- If applicable, suggest the use of pragma Elaborate_Body in the - -- associated package spec. + Loc : constant Source_Ptr := Sloc (N); - Suggest_Elaborate_Body - (N => FNode, - Body_Decl => Body_Decl, - Error_Nod => Typ_Decl); + -- Start for processing for Install_Scenario_ABE_Check_Common - raise Stop_Check; - end if; - end Check_Overriding_Primitive; + begin + -- Create an elaboration flag for the target when it does not have + -- one. - -------------------------- - -- Freeze_Node_Location -- - -------------------------- + Build_Elaboration_Entity; - function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is - Context : constant Node_Id := Parent (FNode); - Loc : constant Source_Ptr := Sloc (FNode); + -- Generate: + -- if not Targ_Id'Elaborated then + -- raise Program_Error with "access before elaboration"; + -- end if; + + Insert_ABE_Check_Or_Failure + (N => N, + Check => + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Targ_Id, Loc), + Attribute_Name => Name_Elaborated)), + Reason => PE_Access_Before_Elaboration)); + end Install_Scenario_ABE_Check_Common; - Prv_Decls : List_Id; - Vis_Decls : List_Id; + ---------------------------------- + -- Install_Scenario_ABE_Failure -- + ---------------------------------- + procedure Install_Scenario_ABE_Failure + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Scenario_Rep_Id) + is begin - -- In general, the source location of the freeze node is as close as - -- possible to the real freeze point, except when the freeze node is - -- at the "bottom" of a package spec. + -- Nothing to do when the scenario does not require an ABE failure - if Nkind (Context) = N_Package_Specification then - Prv_Decls := Private_Declarations (Context); - Vis_Decls := Visible_Declarations (Context); + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Targ_Id, + Unit_Id => Unit (Targ_Rep)) + then + return; + end if; - -- The freeze node appears in the private declarations of the - -- package. + -- Prevent multiple attempts to install the same ABE check - if Present (Prv_Decls) - and then List_Containing (FNode) = Prv_Decls - then - null; + Disable_Elaboration_Checks (Disable); - -- The freeze node appears in the visible declarations of the - -- package and there are no private declarations. + Install_Scenario_ABE_Failure_Common (N); + end Install_Scenario_ABE_Failure; - elsif Present (Vis_Decls) - and then List_Containing (FNode) = Vis_Decls - and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) - then - null; + ---------------------------------- + -- Install_Scenario_ABE_Failure -- + ---------------------------------- - -- Otherwise the freeze node is not in the "last" declarative list - -- of the package. Use the existing source location of the freeze - -- node. + procedure Install_Scenario_ABE_Failure + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Target_Rep_Id) + is + begin + -- Nothing to do when the scenario does not require an ABE failure - else - return Loc; - end if; + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Targ_Id, + Unit_Id => Unit (Targ_Rep)) + then + return; + end if; - -- The freeze node appears at the "bottom" of the package when it - -- is in the "last" declarative list and is either the last in the - -- list or is followed by internal constructs only. In that case - -- the more appropriate source location is that of the package end - -- label. + -- Prevent multiple attempts to install the same ABE check - if not Precedes_Source_Construct (FNode) then - return Sloc (End_Label (Context)); - end if; - end if; + Disable_Elaboration_Checks (Disable); - return Loc; - end Freeze_Node_Location; + Install_Scenario_ABE_Failure_Common (N); + end Install_Scenario_ABE_Failure; - ------------------------------- - -- Precedes_Source_Construct -- - ------------------------------- + ----------------------------------------- + -- Install_Scenario_ABE_Failure_Common -- + ----------------------------------------- - function Precedes_Source_Construct (N : Node_Id) return Boolean is - Decl : Node_Id; + procedure Install_Scenario_ABE_Failure_Common (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); begin - Decl := Next (N); - while Present (Decl) loop - if Comes_From_Source (Decl) then - return True; + -- Generate: + -- raise Program_Error with "access before elaboration"; - -- A generated body for a source expression function is treated as - -- a source construct. + Insert_ABE_Check_Or_Failure + (N => N, + Check => + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration)); + end Install_Scenario_ABE_Failure_Common; - elsif Nkind (Decl) = N_Subprogram_Body - and then Was_Expression_Function (Decl) - and then Comes_From_Source (Original_Node (Decl)) - then - return True; - end if; + ---------------------------- + -- Install_Unit_ABE_Check -- + ---------------------------- - Next (Decl); - end loop; + procedure Install_Unit_ABE_Check + (N : Node_Id; + Unit_Id : Entity_Id; + Disable : Scenario_Rep_Id) + is + Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); - return False; - end Precedes_Source_Construct; + begin + -- Nothing to do when the scenario does not require an ABE check + + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Empty, + Unit_Id => Spec_Id) + then + return; + end if; + + -- Prevent multiple attempts to install the same ABE check + + Disable_Elaboration_Checks (Disable); + + Install_Unit_ABE_Check_Common + (N => N, + Unit_Id => Unit_Id); + end Install_Unit_ABE_Check; ---------------------------- - -- Suggest_Elaborate_Body -- + -- Install_Unit_ABE_Check -- ---------------------------- - procedure Suggest_Elaborate_Body - (N : Node_Id; - Body_Decl : Node_Id; - Error_Nod : Node_Id) + procedure Install_Unit_ABE_Check + (N : Node_Id; + Unit_Id : Entity_Id; + Disable : Target_Rep_Id) is - Unt : constant Node_Id := Unit (Cunit (Main_Unit)); - Region : Node_Id; + Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); begin - -- The suggestion applies only when the subprogram body resides in a - -- compilation package body, and a pragma Elaborate_Body would allow - -- for the node to appear in the early call region of the subprogram - -- body. This implies that all code from the subprogram body up to - -- the node is preelaborable. + -- Nothing to do when the scenario does not require an ABE check - if Nkind (Unt) = N_Package_Body then + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Empty, + Unit_Id => Spec_Id) + then + return; + end if; - -- Find the start of the early call region again assuming that the - -- package spec has pragma Elaborate_Body. Note that the internal - -- data structures are intentionally not updated because this is a - -- speculative search. + -- Prevent multiple attempts to install the same ABE check - Region := - Find_Early_Call_Region - (Body_Decl => Body_Decl, - Assume_Elab_Body => True, - Skip_Memoization => True); + Disable_Elaboration_Checks (Disable); - -- If the node appears within the early call region, assuming that - -- the package spec carries pragma Elaborate_Body, then it is safe - -- to suggest the pragma. + Install_Unit_ABE_Check_Common + (N => N, + Unit_Id => Unit_Id); + end Install_Unit_ABE_Check; - if Earlier_In_Extended_Unit (Region, N) then - Error_Msg_Name_1 := Name_Elaborate_Body; - Error_Msg_NE - ("\consider adding pragma % in spec of unit &", - Error_Nod, Defining_Entity (Unt)); - end if; - end if; - end Suggest_Elaborate_Body; + ----------------------------------- + -- Install_Unit_ABE_Check_Common -- + ----------------------------------- - -- Local variables + procedure Install_Unit_ABE_Check_Common + (N : Node_Id; + Unit_Id : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); - FNode : constant Node_Id := Freeze_Node (Typ); - Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); + begin + -- Generate: + -- if not Spec_Id'Elaborated then + -- raise Program_Error with "access before elaboration"; + -- end if; + + Insert_ABE_Check_Or_Failure + (N => N, + Check => + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Spec_Id, Loc), + Attribute_Name => Name_Elaborated)), + Reason => PE_Access_Before_Elaboration)); + end Install_Unit_ABE_Check_Common; + end Check_Installer; - Prim_Elmt : Elmt_Id; + ---------------------- + -- Compilation_Unit -- + ---------------------- - -- Start of processing for Check_SPARK_Derived_Type + function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is + Comp_Unit : Node_Id; begin - -- A type should have its freeze node set by the time SPARK scenarios - -- are being verified. + Comp_Unit := Parent (Unit_Id); - pragma Assert (Present (FNode)); + -- Handle the case where a concurrent subunit is rewritten as a null + -- statement due to expansion activities. - -- Verify that the freeze node of the derived type is within the early - -- call region of each overriding primitive body (SPARK RM 7.7(8)). + if Nkind (Comp_Unit) = N_Null_Statement + and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body, + N_Task_Body) + then + Comp_Unit := Parent (Comp_Unit); + pragma Assert (Nkind (Comp_Unit) = N_Subunit); - if Present (Prims) then - Prim_Elmt := First_Elmt (Prims); - while Present (Prim_Elmt) loop - Check_Overriding_Primitive - (Prim => Node (Prim_Elmt), - FNode => FNode); + -- Otherwise use the declaration node of the unit - Next_Elmt (Prim_Elmt); - end loop; + else + Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); end if; - exception - when Stop_Check => - null; - end Check_SPARK_Derived_Type; + -- Handle the case where a subprogram instantiation which acts as a + -- compilation unit is expanded into an anonymous package that wraps + -- the instantiated subprogram. + + if Nkind (Comp_Unit) = N_Package_Specification + and then Nkind_In (Original_Node (Parent (Comp_Unit)), + N_Function_Instantiation, + N_Procedure_Instantiation) + then + Comp_Unit := Parent (Parent (Comp_Unit)); + + -- Handle the case where the compilation unit is a subunit + + elsif Nkind (Comp_Unit) = N_Subunit then + Comp_Unit := Parent (Comp_Unit); + end if; + + pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); + + return Comp_Unit; + end Compilation_Unit; ------------------------------- - -- Check_SPARK_Instantiation -- + -- Conditional_ABE_Processor -- ------------------------------- - procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id) is - Gen_Attrs : Target_Attributes; - Gen_Id : Entity_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; + package body Conditional_ABE_Processor is - begin - Extract_Instantiation_Attributes - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + ----------------------- + -- Local subprograms -- + ----------------------- - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Conditional_ABE_Scenario); + -- Determine whether node N is a suitable scenario for conditional ABE + -- checks and diagnostics. + + procedure Process_Conditional_ABE_Access_Taken + (Attr : Node_Id; + Attr_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Access_Taken); + -- Perform ABE checks and diagnostics for attribute reference Attr with + -- representation Attr_Rep which takes 'Access of an entry, operator, or + -- subprogram. In_State is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Activation); + -- Perform common conditional ABE checks and diagnostics for activation + -- call Call which activates object Obj_Id of task type Task_Typ. Formal + -- Call_Rep denotes the representation of the call. Obj_Rep denotes the + -- representation of the object. Task_Rep denotes the representation of + -- the task type. In_State is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Call); + -- Top-level dispatcher for processing of calls. Perform ABE checks and + -- diagnostics for call Call with representation Call_Rep. In_State is + -- the current state of the Processing phase. + + procedure Process_Conditional_ABE_Call_Ada + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Call_Ada); + -- Perform ABE checks and diagnostics for call Call which invokes entry, + -- operator, or subprogram Subp_Id using the Ada rules. Call_Rep denotes + -- the representation of the call. Subp_Rep denotes the representation + -- of the subprogram. In_State is the current state of the Processing + -- phase. + + procedure Process_Conditional_ABE_Call_SPARK + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Call_SPARK); + -- Perform ABE checks and diagnostics for call Call which invokes entry, + -- operator, or subprogram Subp_Id using the SPARK rules. Call_Rep is + -- the representation of the call. Subp_Rep denotes the representation + -- of the subprogram. In_State is the current state of the Processing + -- phase. + + procedure Process_Conditional_ABE_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Instantiation); + -- Top-level dispatcher for processing of instantiations. Perform ABE + -- checks and diagnostics for instantiation Inst with representation + -- Inst_Rep. In_State is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Instantiation_Ada + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Instantiation_Ada); + -- Perform ABE checks and diagnostics for instantiation Inst of generic + -- Gen_Id using the Ada rules. Inst_Rep denotes the representation of + -- the instnace. Gen_Rep is the representation of the generic. In_State + -- is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Instantiation_SPARK + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Instantiation_SPARK); + -- Perform ABE checks and diagnostics for instantiation Inst of generic + -- Gen_Id using the SPARK rules. Inst_Rep denotes the representation of + -- the instnace. Gen_Rep is the representation of the generic. In_State + -- is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Variable_Assignment + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Variable_Assignment); + -- Top-level dispatcher for processing of variable assignments. Perform + -- ABE checks and diagnostics for assignment Asmt with representation + -- Asmt_Rep. In_State denotes the current state of the Processing phase. + + procedure Process_Conditional_ABE_Variable_Assignment_Ada + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Var_Id : Entity_Id; + Var_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Variable_Assignment_Ada); + -- Perform ABE checks and diagnostics for assignment statement Asmt that + -- modifies the value of variable Var_Id using the Ada rules. Asmt_Rep + -- denotes the representation of the assignment. Var_Rep denotes the + -- representation of the variable. In_State is the current state of the + -- Processing phase. + + procedure Process_Conditional_ABE_Variable_Assignment_SPARK + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Var_Id : Entity_Id; + Var_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Variable_Assignment_SPARK); + -- Perform ABE checks and diagnostics for assignment statement Asmt that + -- modifies the value of variable Var_Id using the SPARK rules. Asmt_Rep + -- denotes the representation of the assignment. Var_Rep denotes the + -- representation of the variable. In_State is the current state of the + -- Processing phase. + + procedure Process_Conditional_ABE_Variable_Reference + (Ref : Node_Id; + Ref_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Variable_Reference); + -- Perform ABE checks and diagnostics for variable reference Ref with + -- representation Ref_Rep. In_State denotes the current state of the + -- Processing phase. + + procedure Traverse_Conditional_ABE_Body + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Traverse_Conditional_ABE_Body); + -- Traverse subprogram body N looking for suitable scenarios that need + -- to be processed for conditional ABE checks and diagnostics. In_State + -- is the current state of the Processing phase. + + ------------------------------------- + -- Check_Conditional_ABE_Scenarios -- + ------------------------------------- + + procedure Check_Conditional_ABE_Scenarios + (Iter : in out NE_Set.Iterator) + is + N : Node_Id; - -- The instantiation and the generic body are both in the main unit + begin + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - if Present (Gen_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) + -- Reset the traversed status of all subprogram bodies because the + -- current conditional scenario acts as a new DFS traversal root. - -- If the instantiation appears prior to the generic body, then the - -- instantiation is illegal (SPARK RM 7.7(6)). + Reset_Traversed_Bodies; - -- IMPORTANT: This check must always be performed even when -gnatd.v - -- (enforce SPARK elaboration rules in SPARK code) is not specified - -- because the rule prevents use-before-declaration of objects that - -- may precede the generic body. + Process_Conditional_ABE + (N => N, + In_State => Conditional_ABE_State); + end loop; + end Check_Conditional_ABE_Scenarios; - and then Earlier_In_Extended_Unit (Inst, Gen_Attrs.Body_Decl) - then - Error_Msg_NE ("cannot instantiate & before body seen", Inst, Gen_Id); - end if; - end Check_SPARK_Instantiation; + --------------------------------- + -- Is_Conditional_ABE_Scenario -- + --------------------------------- - --------------------------------- - -- Check_SPARK_Model_In_Effect -- - --------------------------------- + function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean is + begin + return + Is_Suitable_Access_Taken (N) + or else Is_Suitable_Call (N) + or else Is_Suitable_Instantiation (N) + or else Is_Suitable_Variable_Assignment (N) + or else Is_Suitable_Variable_Reference (N); + end Is_Conditional_ABE_Scenario; - SPARK_Model_Warning_Posted : Boolean := False; - -- This flag prevents the same SPARK model-related warning from being - -- emitted multiple times. + ----------------------------- + -- Process_Conditional_ABE -- + ----------------------------- - procedure Check_SPARK_Model_In_Effect (N : Node_Id) is - begin - -- Do not emit the warning multiple times as this creates useless noise + procedure Process_Conditional_ABE + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); + Scen_Rep : Scenario_Rep_Id; - if SPARK_Model_Warning_Posted then - null; + begin + -- Add the current scenario to the stack of active scenarios - -- SPARK rule verification requires the "strict" static model + Push_Active_Scenario (Scen); - elsif Static_Elaboration_Checks and not Relaxed_Elaboration_Checks then - null; + -- 'Access - -- Any other combination of models does not guarantee the absence of ABE - -- problems for SPARK rule verification purposes. Note that there is no - -- need to check for the legacy ABE mechanism because the legacy code - -- has its own orthogonal processing for SPARK rules. + if Is_Suitable_Access_Taken (Scen) then + Process_Conditional_ABE_Access_Taken + (Attr => Scen, + Attr_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - else - SPARK_Model_Warning_Posted := True; + -- Call or task activation - Error_Msg_N - ("??SPARK elaboration checks require static elaboration model", N); + elsif Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - if Dynamic_Elaboration_Checks then - Error_Msg_N ("\dynamic elaboration model is in effect", N); - else - pragma Assert (Relaxed_Elaboration_Checks); - Error_Msg_N ("\relaxed elaboration model is in effect", N); - end if; - end if; - end Check_SPARK_Model_In_Effect; + -- Routine Build_Call_Marker creates call markers regardless of + -- whether the call occurs within the main unit or not. This way + -- the serialization of internal names is kept consistent. Only + -- call markers found within the main unit must be processed. - -------------------------- - -- Check_SPARK_Scenario -- - -------------------------- + if In_Main_Context (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - procedure Check_SPARK_Scenario (N : Node_Id) is - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + if Kind (Scen_Rep) = Call_Scenario then + Process_Conditional_ABE_Call + (Call => Scen, + Call_Rep => Scen_Rep, + In_State => In_State); - Check_SPARK_Model_In_Effect (N); + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); - -- Add the current scenario to the stack of active scenarios + Process_Activation + (Call => Scen, + Call_Rep => Scen_Rep, + Processor => Process_Conditional_ABE_Activation'Access, + In_State => In_State); + end if; + end if; - Push_Active_Scenario (N); + -- Instantiation - if Is_Suitable_SPARK_Derived_Type (N) then - Check_SPARK_Derived_Type (N); + elsif Is_Suitable_Instantiation (Scen) then + Process_Conditional_ABE_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - elsif Is_Suitable_SPARK_Instantiation (N) then - Check_SPARK_Instantiation (N); + -- Variable assignments - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Check_SPARK_Refined_State_Pragma (N); - end if; + elsif Is_Suitable_Variable_Assignment (Scen) then + Process_Conditional_ABE_Variable_Assignment + (Asmt => Scen, + Asmt_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - -- Remove the current scenario from the stack of active scenarios once - -- all ABE diagnostics and checks have been performed. + -- Variable references - Pop_Active_Scenario (N); - end Check_SPARK_Scenario; + elsif Is_Suitable_Variable_Reference (Scen) then - -------------------------------------- - -- Check_SPARK_Refined_State_Pragma -- - -------------------------------------- + -- Routine Build_Variable_Reference_Marker makes variable markers + -- regardless of whether the reference occurs within the main unit + -- or not. This way the serialization of internal names is kept + -- consistent. Only variable markers within the main unit must be + -- processed. - procedure Check_SPARK_Refined_State_Pragma (N : Node_Id) is + if In_Main_Context (Scen) then + Process_Conditional_ABE_Variable_Reference + (Ref => Scen, + Ref_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); + end if; + end if; - -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are - -- intentionally unnested to avoid deep indentation of code. + -- Remove the current scenario from the stack of active scenarios + -- once all ABE diagnostics and checks have been performed. - procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); - pragma Inline (Check_SPARK_Constituent); - -- Ensure that a single constituent Constit_Id is elaborated prior to - -- the main unit. + Pop_Active_Scenario (Scen); + end Process_Conditional_ABE; - procedure Check_SPARK_Constituents (Constits : Elist_Id); - pragma Inline (Check_SPARK_Constituents); - -- Ensure that all constituents found in list Constits are elaborated - -- prior to the main unit. + ------------------------------------------ + -- Process_Conditional_ABE_Access_Taken -- + ------------------------------------------ - procedure Check_SPARK_Initialized_State (State : Node_Id); - pragma Inline (Check_SPARK_Initialized_State); - -- Ensure that the constituents of single abstract state State are - -- elaborated prior to the main unit. + procedure Process_Conditional_ABE_Access_Taken + (Attr : Node_Id; + Attr_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id; + pragma Inline (Build_Access_Marker); + -- Create a suitable call marker which invokes subprogram Subp_Id - procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); - pragma Inline (Check_SPARK_Initialized_States); - -- Ensure that the constituents of all abstract states which appear in - -- the Initializes pragma of package Pack_Id are elaborated prior to the - -- main unit. + ------------------------- + -- Build_Access_Marker -- + ------------------------- - ----------------------------- - -- Check_SPARK_Constituent -- - ----------------------------- + function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id is + Marker : Node_Id; - procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is - Prag : Node_Id; + begin + Marker := Make_Call_Marker (Sloc (Attr)); - begin - -- Nothing to do for "null" constituents + -- Inherit relevant attributes from the attribute - if Nkind (Constit_Id) = N_Null then - return; + Set_Target (Marker, Subp_Id); + Set_Is_Declaration_Level_Node + (Marker, Level (Attr_Rep) = Declaration_Level); + Set_Is_Dispatching_Call + (Marker, False); + Set_Is_Elaboration_Checks_OK_Node + (Marker, Elaboration_Checks_OK (Attr_Rep)); + Set_Is_Elaboration_Warnings_OK_Node + (Marker, Elaboration_Warnings_OK (Attr_Rep)); + Set_Is_Source_Call + (Marker, Comes_From_Source (Attr)); + Set_Is_SPARK_Mode_On_Node + (Marker, SPARK_Mode_Of (Attr_Rep) = Is_On); - -- Nothing to do for illegal constituents + -- Partially insert the call marker into the tree by setting its + -- parent pointer. - elsif Error_Posted (Constit_Id) then - return; - end if; + Set_Parent (Marker, Attr); + + return Marker; + end Build_Access_Marker; + + -- Local variables + + Root : constant Node_Id := Root_Scenario; + Subp_Id : constant Entity_Id := Target (Attr_Rep); + Subp_Rep : constant Target_Rep_Id := + Target_Representation_Of (Subp_Id, In_State); + Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state - Prag := SPARK_Pragma (Constit_Id); + -- Start of processing for Process_Conditional_ABE_Access - -- The check applies only when the constituent is subject to pragma - -- SPARK_Mode On. + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - if Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On + if Elab_Info_Messages + and then not New_In_State.Suppress_Info_Messages then - -- An external constituent of an abstract state which appears in - -- the Initializes pragma of a package spec imposes an Elaborate - -- requirement on the context of the main unit. Determine whether - -- the context has a pragma strong enough to meet the requirement. + Error_Msg_NE + ("info: access to & during elaboration", Attr, Subp_Id); + end if; - -- IMPORTANT: This check is performed only when -gnatd.v (enforce - -- SPARK elaboration rules in SPARK code) is in effect because the - -- static model can ensure the prior elaboration of the unit which - -- contains a constituent by installing implicit Elaborate pragma. + -- Warnings are suppressed when a prior scenario is already in that + -- mode or when the attribute or the target have warnings suppressed. + -- Update the state of the Processing phase to reflect this. - if Debug_Flag_Dot_V then - Meet_Elaboration_Requirement - (N => N, - Target_Id => Constit_Id, - Req_Nam => Name_Elaborate); + New_In_State.Suppress_Warnings := + New_In_State.Suppress_Warnings + or else not Elaboration_Warnings_OK (Attr_Rep) + or else not Elaboration_Warnings_OK (Subp_Rep); - -- Otherwise ensure that the unit with the external constituent is - -- elaborated prior to the main unit. + -- Do not emit any ABE diagnostics when the current or previous + -- scenario in this traversal has suppressed elaboration warnings. - else - Ensure_Prior_Elaboration - (N => N, - Unit_Id => Find_Top_Unit (Constit_Id), - Prag_Nam => Name_Elaborate, - State => Initial_State); - end if; + if New_In_State.Suppress_Warnings then + null; + + -- Both the attribute and the corresponding subprogram body are in + -- the same unit. The body must appear prior to the root scenario + -- which started the recursive search. If this is not the case, then + -- there is a potential ABE if the access value is used to call the + -- subprogram. Emit a warning only when switch -gnatw.f (warnings on + -- suspucious 'Access) is in effect. + + elsif Warn_On_Elab_Access + and then Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + and then Earlier_In_Extended_Unit (Root, Body_Decl) + then + Error_Msg_Name_1 := Attribute_Name (Attr); + Error_Msg_NE + ("??% attribute of & before body seen", Attr, Subp_Id); + Error_Msg_N ("\possible Program_Error on later references", Attr); + + Output_Active_Scenarios (Attr, New_In_State); end if; - end Check_SPARK_Constituent; - ------------------------------ - -- Check_SPARK_Constituents -- - ------------------------------ + -- Treat the attribute an an immediate invocation of the target when + -- switch -gnatd.o (conservative elaboration order for indirect + -- calls) is in effect. This has the following desirable effects: + -- + -- * Ensure that the unit with the corresponding body is elaborated + -- prior to the main unit. + -- + -- * Perform conditional ABE checks and diagnostics + -- + -- * Traverse the body of the target (if available) - procedure Check_SPARK_Constituents (Constits : Elist_Id) is - Constit_Elmt : Elmt_Id; + if Debug_Flag_Dot_O then + Process_Conditional_ABE + (N => Build_Access_Marker (Subp_Id), + In_State => New_In_State); - begin - if Present (Constits) then - Constit_Elmt := First_Elmt (Constits); - while Present (Constit_Elmt) loop - Check_SPARK_Constituent (Node (Constit_Elmt)); - Next_Elmt (Constit_Elmt); - end loop; + -- Otherwise ensure that the unit with the corresponding body is + -- elaborated prior to the main unit. + + else + Ensure_Prior_Elaboration + (N => Attr, + Unit_Id => Unit (Subp_Rep), + Prag_Nam => Name_Elaborate_All, + In_State => New_In_State); end if; - end Check_SPARK_Constituents; + end Process_Conditional_ABE_Access_Taken; - ----------------------------------- - -- Check_SPARK_Initialized_State -- - ----------------------------------- + ---------------------------------------- + -- Process_Conditional_ABE_Activation -- + ---------------------------------------- - procedure Check_SPARK_Initialized_State (State : Node_Id) is - Prag : Node_Id; - State_Id : Entity_Id; + procedure Process_Conditional_ABE_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Task_Typ); + + Body_Decl : constant Node_Id := Body_Declaration (Task_Rep); + Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); + Root : constant Node_Id := Root_Scenario; + Unit_Id : constant Node_Id := Unit (Task_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Obj_Rep) + and then Elaboration_Checks_OK (Task_Rep); + -- A run-time ABE check may be installed only when the object and the + -- task type have active elaboration checks, and both are not ignored + -- Ghost constructs. + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state begin - -- Nothing to do for "null" initialization items + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - if Nkind (State) = N_Null then - return; + if Elab_Info_Messages + and then not New_In_State.Suppress_Info_Messages + then + Error_Msg_NE + ("info: activation of & during elaboration", Call, Obj_Id); + end if; - -- Nothing to do for illegal states + -- Nothing to do when the call activates a task whose type is defined + -- within an instance and switch -gnatd_i (ignore activations and + -- calls to instances for elaboration) is in effect. - elsif Error_Posted (State) then + if Debug_Flag_Underscore_I + and then In_External_Instance + (N => Call, + Target_Decl => Spec_Decl) + then return; - end if; - - State_Id := Entity_Of (State); - -- Sanitize the state + -- Nothing to do when the activation is a guaranteed ABE - if No (State_Id) then + elsif Is_Known_Guaranteed_ABE (Call) then return; - elsif Error_Posted (State_Id) then + -- Nothing to do when the root scenario appears at the declaration + -- level and the task is in the same unit, but outside this context. + -- + -- task type Task_Typ; -- task declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- T : Task_Typ; + -- begin + -- <activation call> -- activation site + -- end; + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- task body Task_Typ is + -- ... + -- end Task_Typ; + -- + -- In the example above, the context of X is the declarative list of + -- Proc. The "elaboration" of X may reach the activation of T whose + -- body is defined outside of X's context. The task body is relevant + -- only when Proc is invoked, but this happens only during "normal" + -- elaboration, therefore the task body must not be considered if + -- this is not the case. + + elsif Is_Up_Level_Target + (Targ_Decl => Spec_Decl, + In_State => New_In_State) + then return; - elsif Ekind (State_Id) /= E_Abstract_State then - return; - end if; + -- Nothing to do when the activation is ABE-safe + -- + -- generic + -- package Gen is + -- task type Task_Typ; + -- end Gen; + -- + -- package body Gen is + -- task body Task_Typ is + -- begin + -- ... + -- end Task_Typ; + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- package Nested is + -- package Inst is new Gen; + -- T : Inst.Task_Typ; + -- <activation call> -- safe activation + -- end Nested; + -- ... + + elsif Is_Safe_Activation (Call, Task_Rep) then - -- The check is performed only when the abstract state is subject to - -- SPARK_Mode On. + -- Note that the task body must still be examined for any nested + -- scenarios. - Prag := SPARK_Pragma (State_Id); + null; - if Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On + -- The activation call and the task body are both in the main unit + -- + -- If the root scenario appears prior to the task body, then this is + -- a possible ABE with respect to the root scenario. + -- + -- task type Task_Typ; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Pack is + -- T : Task_Typ; + -- end Pack; -- activation of T + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- + -- task body Task_Typ is -- task body + -- ... + -- end Task_Typ; + -- + -- Y : ... := A; -- root scenario + -- + -- IMPORTANT: The activation of T is a possible ABE for X, but + -- not for Y. Intalling an unconditional ABE raise prior to the + -- activation call would be wrong as it will fail for Y as well + -- but in Y's case the activation of T is never an ABE. + + elsif Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) then - Check_SPARK_Constituents (Refinement_Constituents (State_Id)); - end if; - end Check_SPARK_Initialized_State; + if Earlier_In_Extended_Unit (Root, Body_Decl) then - ------------------------------------ - -- Check_SPARK_Initialized_States -- - ------------------------------------ + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is - Prag : constant Node_Id := Get_Pragma (Pack_Id, Pragma_Initializes); - Init : Node_Id; - Inits : Node_Id; + if New_In_State.Suppress_Warnings then + null; - begin - if Present (Prag) then - Inits := Expression (Get_Argument (Prag, Pack_Id)); + -- Do not emit any ABE diagnostics when the activation occurs + -- in a partial finalization context because this action leads + -- to confusing noise. - -- Avoid processing a "null" initialization list. The only other - -- alternative is an aggregate. + elsif New_In_State.Within_Partial_Finalization then + null; - if Nkind (Inits) = N_Aggregate then + -- Otherwise emit the ABE disgnostic - -- The initialization items appear in list form: - -- - -- (state1, state2) - - if Present (Expressions (Inits)) then - Init := First (Expressions (Inits)); - while Present (Init) loop - Check_SPARK_Initialized_State (Init); - Next (Init); - end loop; + else + Error_Msg_Sloc := Sloc (Call); + Error_Msg_N + ("??task & will be activated # before elaboration of its " + & "body", Obj_Id); + Error_Msg_N + ("\Program_Error may be raised at run time", Obj_Id); + + Output_Active_Scenarios (Obj_Id, New_In_State); end if; - -- The initialization items appear in associated form: - -- - -- (state1 => item1, - -- state2 => (item2, item3)) - - if Present (Component_Associations (Inits)) then - Init := First (Component_Associations (Inits)); - while Present (Init) loop - Check_SPARK_Initialized_State (Init); - Next (Init); - end loop; + -- Install a conditional run-time ABE check to verify that the + -- task body has been elaborated prior to the activation call. + + if Check_OK then + Install_Scenario_ABE_Check + (N => Call, + Targ_Id => Defining_Entity (Spec_Decl), + Targ_Rep => Task_Rep, + Disable => Obj_Rep); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragma must be generated from + -- this point on. + -- + -- task type Task_Typ; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Pack is + -- <ABE check> + -- T : Task_Typ; + -- end Pack; -- activation of T + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- task body Task_Typ is + -- begin + -- External.Subp; -- imparts Elaborate_All + -- end Task_Typ; + -- + -- If Some_Condition is True, then the ABE check will fail + -- at runtime and the call to External.Subp will never take + -- place, rendering the implicit Elaborate_All useless. + -- + -- If the value of Some_Condition is False, then the call + -- to External.Subp will never take place, rendering the + -- implicit Elaborate_All useless. + + New_In_State.Suppress_Implicit_Pragmas := True; end if; end if; + + -- Otherwise the task body is not available in this compilation or + -- it resides in an external unit. Install a run-time ABE check to + -- verify that the task body has been elaborated prior to the + -- activation call when the dynamic model is in effect. + + elsif Check_OK + and then New_In_State.Processing = Dynamic_Model_Processing + then + Install_Unit_ABE_Check + (N => Call, + Unit_Id => Unit_Id, + Disable => Obj_Rep); end if; - end Check_SPARK_Initialized_States; - -- Local variables + -- Both the activation call and task type are subject to SPARK_Mode + -- On, this triggers the SPARK rules for task activation. Compared + -- to calls and instantiations, task activation in SPARK does not + -- require the presence of Elaborate[_All] pragmas in case the task + -- type is defined outside the main unit. This is because SPARK uses + -- a special policy which activates all tasks after the main unit has + -- finished its elaboration. - Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (N); + if SPARK_Mode_Of (Call_Rep) = Is_On + and then SPARK_Mode_Of (Task_Rep) = Is_On + then + null; - -- Start of processing for Check_SPARK_Refined_State_Pragma + -- Otherwise the Ada rules are in effect. Ensure that the unit with + -- the task body is elaborated prior to the main unit. - begin - -- Pragma Refined_State must be associated with a package body + else + Ensure_Prior_Elaboration + (N => Call, + Unit_Id => Unit_Id, + Prag_Nam => Name_Elaborate_All, + In_State => New_In_State); + end if; - pragma Assert - (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); + Traverse_Conditional_ABE_Body + (N => Body_Decl, + In_State => New_In_State); + end Process_Conditional_ABE_Activation; - -- Verify that each external contitunent of an abstract state mentioned - -- in pragma Initializes is properly elaborated. + ---------------------------------- + -- Process_Conditional_ABE_Call -- + ---------------------------------- - Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); - end Check_SPARK_Refined_State_Pragma; + procedure Process_Conditional_ABE_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + function In_Initialization_Context (N : Node_Id) return Boolean; + pragma Inline (In_Initialization_Context); + -- Determine whether arbitrary node N appears within a type init + -- proc, primitive [Deep_]Initialize, or a block created for + -- initialization purposes. + + function Is_Partial_Finalization_Proc + (Subp_Id : Entity_Id) return Boolean; + pragma Inline (Is_Partial_Finalization_Proc); + -- Determine whether subprogram Subp_Id is a partial finalization + -- procedure. - ---------------------- - -- Compilation_Unit -- - ---------------------- + ------------------------------- + -- In_Initialization_Context -- + ------------------------------- - function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is - Comp_Unit : Node_Id; + function In_Initialization_Context (N : Node_Id) return Boolean is + Par : Node_Id; + Spec_Id : Entity_Id; - begin - Comp_Unit := Parent (Unit_Id); + begin + -- Climb the parent chain looking for initialization actions - -- Handle the case where a concurrent subunit is rewritten as a null - -- statement due to expansion activities. + Par := Parent (N); + while Present (Par) loop - if Nkind (Comp_Unit) = N_Null_Statement - and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body, - N_Task_Body) - then - Comp_Unit := Parent (Comp_Unit); - pragma Assert (Nkind (Comp_Unit) = N_Subunit); + -- A block may be part of the initialization actions of a + -- default initialized object. - -- Otherwise use the declaration node of the unit + if Nkind (Par) = N_Block_Statement + and then Is_Initialization_Block (Par) + then + return True; - else - Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); - end if; + -- A subprogram body may denote an initialization routine - -- Handle the case where a subprogram instantiation which acts as a - -- compilation unit is expanded into an anonymous package that wraps - -- the instantiated subprogram. + elsif Nkind (Par) = N_Subprogram_Body then + Spec_Id := Unique_Defining_Entity (Par); - if Nkind (Comp_Unit) = N_Package_Specification - and then Nkind_In (Original_Node (Parent (Comp_Unit)), - N_Function_Instantiation, - N_Procedure_Instantiation) - then - Comp_Unit := Parent (Parent (Comp_Unit)); + -- The current subprogram body denotes a type init proc or + -- primitive [Deep_]Initialize. - -- Handle the case where the compilation unit is a subunit + if Is_Init_Proc (Spec_Id) + or else Is_Controlled_Proc (Spec_Id, Name_Initialize) + or else Is_TSS (Spec_Id, TSS_Deep_Initialize) + then + return True; + end if; - elsif Nkind (Comp_Unit) = N_Subunit then - Comp_Unit := Parent (Comp_Unit); - end if; + -- Prevent the search from going too far - pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; - return Comp_Unit; - end Compilation_Unit; + Par := Parent (Par); + end loop; - ----------------------- - -- Early_Call_Region -- - ----------------------- + return False; + end In_Initialization_Context; - function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is - begin - pragma Assert (Ekind_In (Body_Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure, - E_Subprogram_Body)); - - if Early_Call_Regions_In_Use then - return Early_Call_Regions.Get (Body_Id); - end if; + ---------------------------------- + -- Is_Partial_Finalization_Proc -- + ---------------------------------- - return Early_Call_Regions_No_Element; - end Early_Call_Region; + function Is_Partial_Finalization_Proc + (Subp_Id : Entity_Id) return Boolean + is + begin + -- To qualify, the subprogram must denote a finalizer procedure + -- or primitive [Deep_]Finalize, and the call must appear within + -- an initialization context. - ----------------------------- - -- Early_Call_Regions_Hash -- - ----------------------------- + return + (Is_Controlled_Proc (Subp_Id, Name_Finalize) + or else Is_Finalizer_Proc (Subp_Id) + or else Is_TSS (Subp_Id, TSS_Deep_Finalize)) + and then In_Initialization_Context (Call); + end Is_Partial_Finalization_Proc; - function Early_Call_Regions_Hash - (Key : Entity_Id) return Early_Call_Regions_Index - is - begin - return Early_Call_Regions_Index (Key mod Early_Call_Regions_Max); - end Early_Call_Regions_Hash; + -- Local variables - ----------------- - -- Elab_Msg_NE -- - ----------------- + Subp_Id : constant Entity_Id := Target (Call_Rep); + Subp_Rep : constant Target_Rep_Id := + Target_Representation_Of (Subp_Id, In_State); + Subp_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); - procedure Elab_Msg_NE - (Msg : String; - N : Node_Id; - Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean) - is - function Prefix return String; - -- Obtain the prefix of the message + SPARK_Rules_On : constant Boolean := + SPARK_Mode_Of (Call_Rep) = Is_On + and then SPARK_Mode_Of (Subp_Rep) = Is_On; - function Suffix return String; - -- Obtain the suffix of the message + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state - ------------ - -- Prefix -- - ------------ + -- Start of processing for Process_Conditional_ABE_Call - function Prefix return String is begin - if Info_Msg then - return "info: "; - else - return ""; + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. + + if Elab_Info_Messages + and then not New_In_State.Suppress_Info_Messages + then + Info_Call + (Call => Call, + Subp_Id => Subp_Id, + Info_Msg => True, + In_SPARK => SPARK_Rules_On); end if; - end Prefix; - ------------ - -- Suffix -- - ------------ + -- Check whether the invocation of an entry clashes with an existing + -- restriction. This check is relevant only when the processing was + -- started from some library-level scenario. - function Suffix return String is - begin - if In_SPARK then - return " in SPARK"; - else - return ""; + if Is_Protected_Entry (Subp_Id) then + Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); + + elsif Is_Task_Entry (Subp_Id) then + Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); + + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. + + return; end if; - end Suffix; - -- Start of processing for Elab_Msg_NE + -- Nothing to do when the call invokes a target defined within an + -- instance and switch -gnatd_i (ignore activations and calls to + -- instances for elaboration) is in effect. - begin - Error_Msg_NE (Prefix & Msg & Suffix, N, Id); - end Elab_Msg_NE; + if Debug_Flag_Underscore_I + and then In_External_Instance + (N => Call, + Target_Decl => Subp_Decl) + then + return; - ------------------------ - -- Elaboration_Status -- - ------------------------ + -- Nothing to do when the call is a guaranteed ABE - function Elaboration_Status - (Unit_Id : Entity_Id) return Elaboration_Attributes - is - begin - if Elaboration_Statuses_In_Use then - return Elaboration_Statuses.Get (Unit_Id); - end if; + elsif Is_Known_Guaranteed_ABE (Call) then + return; - return Elaboration_Statuses_No_Element; - end Elaboration_Status; + -- Nothing to do when the root scenario appears at the declaration + -- level and the target is in the same unit but outside this context. + -- + -- function B ...; -- target declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- function B ... is + -- ... + -- end B; + -- + -- In the example above, the context of X is the declarative region + -- of Proc. The "elaboration" of X may eventually reach B which is + -- defined outside of X's context. B is relevant only when Proc is + -- invoked, but this happens only by means of "normal" elaboration, + -- therefore B must not be considered if this is not the case. + + elsif Is_Up_Level_Target + (Targ_Decl => Subp_Decl, + In_State => New_In_State) + then + return; + end if; - ------------------------------- - -- Elaboration_Statuses_Hash -- - ------------------------------- + -- Warnings are suppressed when a prior scenario is already in that + -- mode, or the call or target have warnings suppressed. Update the + -- state of the Processing phase to reflect this. - function Elaboration_Statuses_Hash - (Key : Entity_Id) return Elaboration_Statuses_Index - is - begin - return Elaboration_Statuses_Index (Key mod Elaboration_Statuses_Max); - end Elaboration_Statuses_Hash; + New_In_State.Suppress_Warnings := + New_In_State.Suppress_Warnings + or else not Elaboration_Warnings_OK (Call_Rep) + or else not Elaboration_Warnings_OK (Subp_Rep); - ------------------------------ - -- Ensure_Prior_Elaboration -- - ------------------------------ + -- The call occurs in an initial condition context when a prior + -- scenario is already in that mode, or when the target is an + -- Initial_Condition procedure. Update the state of the Processing + -- phase to reflect this. - procedure Ensure_Prior_Elaboration - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id; - State : Processing_Attributes) - is - begin - pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); + New_In_State.Within_Initial_Condition := + New_In_State.Within_Initial_Condition + or else Is_Initial_Condition_Proc (Subp_Id); - -- Nothing to do when the caller has suppressed the generation of - -- implicit Elaborate[_All] pragmas. + -- The call occurs in a partial finalization context when a prior + -- scenario is already in that mode, or when the target denotes a + -- [Deep_]Finalize primitive or a finalizer within an initialization + -- context. Update the state of the Processing phase to reflect this. - if State.Suppress_Implicit_Pragmas then - return; + New_In_State.Within_Partial_Finalization := + New_In_State.Within_Partial_Finalization + or else Is_Partial_Finalization_Proc (Subp_Id); - -- Nothing to do when the need for prior elaboration came from a partial - -- finalization routine which occurs in an initialization context. This - -- behaviour parallels that of the old ABE mechanism. + -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK + -- elaboration rules in SPARK code) is intentionally not taken into + -- account here because Process_Conditional_ABE_Call_SPARK has two + -- separate modes of operation. - elsif State.Within_Partial_Finalization then - return; + if SPARK_Rules_On then + Process_Conditional_ABE_Call_SPARK + (Call => Call, + Call_Rep => Call_Rep, + Subp_Id => Subp_Id, + Subp_Rep => Subp_Rep, + In_State => New_In_State); - -- Nothing to do when the need for prior elaboration came from a task - -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on - -- task bodies) is in effect. + -- Otherwise the Ada rules are in effect - elsif Debug_Flag_Dot_Y and then State.Within_Task_Body then - return; + else + Process_Conditional_ABE_Call_Ada + (Call => Call, + Call_Rep => Call_Rep, + Subp_Id => Subp_Id, + Subp_Rep => Subp_Rep, + In_State => New_In_State); + end if; - -- Nothing to do when the unit is elaborated prior to the main unit. - -- This check must also consider the following cases: - - -- * No check is made against the context of the main unit because this - -- is specific to the elaboration model in effect and requires custom - -- handling (see Ensure_xxx_Prior_Elaboration). - - -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma - -- Elaborate[_All] MUST be generated even though Unit_Id is always - -- elaborated prior to the main unit. This is a conservative strategy - -- which ensures that other units withed by Unit_Id will not lead to - -- an ABE. - - -- package A is package body A is - -- procedure ABE; procedure ABE is ... end ABE; - -- end A; end A; - - -- with A; - -- package B is package body B is - -- pragma Elaborate_Body; procedure Proc is - -- begin - -- procedure Proc; A.ABE; - -- package B; end Proc; - -- end B; - - -- with B; - -- package C is package body C is - -- ... ... - -- end C; begin - -- B.Proc; - -- end C; - - -- In the example above, the elaboration of C invokes B.Proc. B is - -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is - -- generated for B in C, then the following elaboratio order will lead - -- to an ABE: - - -- spec of A elaborated - -- spec of B elaborated - -- body of B elaborated - -- spec of C elaborated - -- body of C elaborated <-- calls B.Proc which calls A.ABE - -- body of A elaborated <-- problem - - -- The generation of an implicit pragma Elaborate_All (B) ensures that - -- the elaboration order mechanism will not pick the above order. - - -- An implicit Elaborate is NOT generated when the unit is subject to - -- Elaborate_Body because both pragmas have the exact same effect. - - -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST - -- NOT be generated in this case because a unit cannot depend on its - -- own elaboration. This case is therefore treated as valid prior - -- elaboration. - - elsif Has_Prior_Elaboration - (Unit_Id => Unit_Id, - Same_Unit_OK => True, - Elab_Body_OK => Prag_Nam = Name_Elaborate) - then - return; + -- Inspect the target body (and barried function) for other suitable + -- elaboration scenarios. - -- Suggest the use of pragma Prag_Nam when the dynamic model is in - -- effect. + Traverse_Conditional_ABE_Body + (N => Barrier_Body_Declaration (Subp_Rep), + In_State => New_In_State); - elsif Dynamic_Elaboration_Checks then - Ensure_Prior_Elaboration_Dynamic - (N => N, - Unit_Id => Unit_Id, - Prag_Nam => Prag_Nam); + Traverse_Conditional_ABE_Body + (N => Body_Declaration (Subp_Rep), + In_State => New_In_State); + end Process_Conditional_ABE_Call; - -- Install an implicit pragma Prag_Nam when the static model is in - -- effect. + -------------------------------------- + -- Process_Conditional_ABE_Call_Ada -- + -------------------------------------- - else - pragma Assert (Static_Elaboration_Checks); + procedure Process_Conditional_ABE_Call_Ada + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); + Root : constant Node_Id := Root_Scenario; + Unit_Id : constant Node_Id := Unit (Subp_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Call_Rep) + and then Elaboration_Checks_OK (Subp_Rep); + -- A run-time ABE check may be installed only when both the call + -- and the target have active elaboration checks, and both are not + -- ignored Ghost constructs. + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state - Ensure_Prior_Elaboration_Static - (N => N, - Unit_Id => Unit_Id, - Prag_Nam => Prag_Nam); - end if; - end Ensure_Prior_Elaboration; + begin + -- Nothing to do for an Ada dispatching call because there are no + -- ABE diagnostics for either models. ABE checks for the dynamic + -- model are handled by Install_Primitive_Elaboration_Check. - -------------------------------------- - -- Ensure_Prior_Elaboration_Dynamic -- - -------------------------------------- + if Is_Dispatching_Call (Call_Rep) then + return; - procedure Ensure_Prior_Elaboration_Dynamic - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id) - is - procedure Info_Missing_Pragma; - pragma Inline (Info_Missing_Pragma); - -- Output information concerning missing Elaborate or Elaborate_All - -- pragma with name Prag_Nam for scenario N, which would ensure the - -- prior elaboration of Unit_Id. + -- Nothing to do when the call is ABE-safe + -- + -- generic + -- function Gen ...; + -- + -- function Gen ... is + -- begin + -- ... + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- function Inst is new Gen; + -- X : ... := Inst; -- safe call + -- ... - ------------------------- - -- Info_Missing_Pragma -- - ------------------------- + elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then + return; - procedure Info_Missing_Pragma is - begin - -- Internal units are ignored as they cause unnecessary noise + -- The call and the target body are both in the main unit + -- + -- If the root scenario appears prior to the target body, then this + -- is a possible ABE with respect to the root scenario. + -- + -- function B ...; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- + -- function B ... is -- target body + -- ... + -- end B; + -- + -- Y : ... := A; -- root scenario + -- + -- IMPORTANT: The call to B from A is a possible ABE for X, but + -- not for Y. Installing an unconditional ABE raise prior to the + -- call to B would be wrong as it will fail for Y as well, but in + -- Y's case the call to B is never an ABE. - if not In_Internal_Unit (Unit_Id) then + elsif Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + then + if Earlier_In_Extended_Unit (Root, Body_Decl) then - -- The name of the unit subjected to the elaboration pragma is - -- fully qualified to improve the clarity of the info message. + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - Error_Msg_Name_1 := Prag_Nam; - Error_Msg_Qual_Level := Nat'Last; + if New_In_State.Suppress_Warnings then + null; - Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); - Error_Msg_Qual_Level := 0; - end if; - end Info_Missing_Pragma; + -- Do not emit any ABE diagnostics when the call occurs in a + -- partial finalization context because this leads to confusing + -- noise. - -- Local variables + elsif New_In_State.Within_Partial_Finalization then + null; - Elab_Attrs : Elaboration_Attributes; - Level : Enclosing_Level_Kind; + -- Otherwise emit the ABE diagnostic - -- Start of processing for Ensure_Prior_Elaboration_Dynamic + else + Error_Msg_NE + ("??cannot call & before body seen", Call, Subp_Id); + Error_Msg_N + ("\Program_Error may be raised at run time", Call); - begin - Elab_Attrs := Elaboration_Status (Unit_Id); + Output_Active_Scenarios (Call, New_In_State); + end if; - -- Nothing to do when the unit is guaranteed prior elaboration by means - -- of a source Elaborate[_All] pragma. + -- Install a conditional run-time ABE check to verify that the + -- target body has been elaborated prior to the call. + + if Check_OK then + Install_Scenario_ABE_Check + (N => Call, + Targ_Id => Subp_Id, + Targ_Rep => Subp_Rep, + Disable => Call_Rep); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragma must be generated from + -- this point on. + -- + -- function B ...; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- <ABE check> + -- return B; + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- function B ... is + -- External.Subp; -- imparts Elaborate_All + -- end B; + -- + -- If Some_Condition is True, then the ABE check will fail + -- at runtime and the call to External.Subp will never take + -- place, rendering the implicit Elaborate_All useless. + -- + -- If the value of Some_Condition is False, then the call + -- to External.Subp will never take place, rendering the + -- implicit Elaborate_All useless. + + New_In_State.Suppress_Implicit_Pragmas := True; + end if; + end if; - if Present (Elab_Attrs.Source_Pragma) then - return; - end if; + -- Otherwise the target body is not available in this compilation or + -- it resides in an external unit. Install a run-time ABE check to + -- verify that the target body has been elaborated prior to the call + -- site when the dynamic model is in effect. - -- Output extra information on a missing Elaborate[_All] pragma when - -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas - -- is in effect. + elsif Check_OK + and then New_In_State.Processing = Dynamic_Model_Processing + then + Install_Unit_ABE_Check + (N => Call, + Unit_Id => Unit_Id, + Disable => Call_Rep); + end if; - if Elab_Info_Messages then + -- Ensure that the unit with the target body is elaborated prior to + -- the main unit. The implicit Elaborate[_All] is generated only when + -- the call has elaboration checks enabled. This behaviour parallels + -- that of the old ABE mechanism. + + if Elaboration_Checks_OK (Call_Rep) then + Ensure_Prior_Elaboration + (N => Call, + Unit_Id => Unit_Id, + Prag_Nam => Name_Elaborate_All, + In_State => New_In_State); + end if; + end Process_Conditional_ABE_Call_Ada; - -- Performance note: parent traversal + ---------------------------------------- + -- Process_Conditional_ABE_Call_SPARK -- + ---------------------------------------- + + procedure Process_Conditional_ABE_Call_SPARK + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Call_Rep); - Level := Find_Enclosing_Level (N); + Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); + Region : Node_Id; - -- Declaration-level scenario + begin + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) - and then Level = Declaration_Level + Check_SPARK_Model_In_Effect; + + -- The call and the target body are both in the main unit + + if Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + and then Earlier_In_Extended_Unit (Call, Body_Decl) then - null; + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - -- Library-level scenario + if In_State.Suppress_Warnings then + null; - elsif Level in Library_Level then - null; + -- Do not emit any ABE diagnostics when the call occurs in an + -- initial condition context because this leads to incorrect + -- diagnostics. - -- Instantiation library-level scenario + elsif In_State.Within_Initial_Condition then + null; - elsif Level = Instantiation then - null; + -- Do not emit any ABE diagnostics when the call occurs in a + -- partial finalization context because this leads to confusing + -- noise. - -- Otherwise the scenario does not appear at the proper level and - -- cannot possibly act as a top-level scenario. + elsif In_State.Within_Partial_Finalization then + null; + + -- Ensure that a call that textually precedes the subprogram body + -- it invokes appears within the early call region of the body. + -- + -- IMPORTANT: This check must always be performed even when switch + -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not + -- specified because the static model cannot guarantee the absence + -- of elaboration issues when dispatching calls are involved. + + else + Region := Find_Early_Call_Region (Body_Decl); + + if Earlier_In_Extended_Unit (Call, Region) then + Error_Msg_NE + ("call must appear within early call region of subprogram " + & "body & (SPARK RM 7.7(3))", + Call, Subp_Id); + + Error_Msg_Sloc := Sloc (Region); + Error_Msg_N ("\region starts #", Call); + + Error_Msg_Sloc := Sloc (Body_Decl); + Error_Msg_N ("\region ends #", Call); + + Output_Active_Scenarios (Call, In_State); + end if; + end if; + end if; + + -- A call to a source target or to a target which emulates Ada + -- or SPARK semantics imposes an Elaborate_All requirement on the + -- context of the main unit. Determine whether the context has a + -- pragma strong enough to meet the requirement. + -- + -- IMPORTANT: This check must be performed only when switch -gnatd.v + -- (enforce SPARK elaboration rules in SPARK code) is active because + -- the static model can ensure the prior elaboration of the unit + -- which contains a body by installing an implicit Elaborate[_All] + -- pragma. + + if Debug_Flag_Dot_V then + if Comes_From_Source (Subp_Id) + or else Is_Ada_Semantic_Target (Subp_Id) + or else Is_SPARK_Semantic_Target (Subp_Id) + then + Meet_Elaboration_Requirement + (N => Call, + Targ_Id => Subp_Id, + Req_Nam => Name_Elaborate_All, + In_State => In_State); + end if; + + -- Otherwise ensure that the unit with the target body is elaborated + -- prior to the main unit. else + Ensure_Prior_Elaboration + (N => Call, + Unit_Id => Unit (Subp_Rep), + Prag_Nam => Name_Elaborate_All, + In_State => In_State); + end if; + end Process_Conditional_ABE_Call_SPARK; + + ------------------------------------------- + -- Process_Conditional_ABE_Instantiation -- + ------------------------------------------- + + procedure Process_Conditional_ABE_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + Gen_Id : constant Entity_Id := Target (Inst_Rep); + Gen_Rep : constant Target_Rep_Id := + Target_Representation_Of (Gen_Id, In_State); + + SPARK_Rules_On : constant Boolean := + SPARK_Mode_Of (Inst_Rep) = Is_On + and then SPARK_Mode_Of (Gen_Rep) = Is_On; + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state + + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. + + if Elab_Info_Messages + and then not New_In_State.Suppress_Info_Messages + then + Info_Instantiation + (Inst => Inst, + Gen_Id => Gen_Id, + Info_Msg => True, + In_SPARK => SPARK_Rules_On); + end if; + + -- Nothing to do when the instantiation is a guaranteed ABE + + if Is_Known_Guaranteed_ABE (Inst) then + return; + + -- Nothing to do when the root scenario appears at the declaration + -- level and the generic is in the same unit, but outside this + -- context. + -- + -- generic + -- procedure Gen is ...; -- generic declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- procedure I is new Gen; -- instantiation site + -- ... + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- procedure Gen is + -- ... + -- end Gen; + -- + -- In the example above, the context of X is the declarative region + -- of Proc. The "elaboration" of X may eventually reach Gen which + -- appears outside of X's context. Gen is relevant only when Proc is + -- invoked, but this happens only by means of "normal" elaboration, + -- therefore Gen must not be considered if this is not the case. + + elsif Is_Up_Level_Target + (Targ_Decl => Spec_Declaration (Gen_Rep), + In_State => New_In_State) + then return; end if; - Info_Missing_Pragma; - end if; - end Ensure_Prior_Elaboration_Dynamic; + -- Warnings are suppressed when a prior scenario is already in that + -- mode, or when the instantiation has warnings suppressed. Update + -- the state of the processing phase to reflect this. - ------------------------------------- - -- Ensure_Prior_Elaboration_Static -- - ------------------------------------- + New_In_State.Suppress_Warnings := + New_In_State.Suppress_Warnings + or else not Elaboration_Warnings_OK (Inst_Rep); - procedure Ensure_Prior_Elaboration_Static - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id) - is - function Find_With_Clause - (Items : List_Id; - Withed_Id : Entity_Id) return Node_Id; - pragma Inline (Find_With_Clause); - -- Find a nonlimited with clause in the list of context items Items - -- that withs unit Withed_Id. Return Empty if no such clause is found. - - procedure Info_Implicit_Pragma; - pragma Inline (Info_Implicit_Pragma); - -- Output information concerning an implicitly generated Elaborate or - -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures - -- the prior elaboration of unit Unit_Id. + -- The SPARK rules are in effect - ---------------------- - -- Find_With_Clause -- - ---------------------- + if SPARK_Rules_On then + Process_Conditional_ABE_Instantiation_SPARK + (Inst => Inst, + Inst_Rep => Inst_Rep, + Gen_Id => Gen_Id, + Gen_Rep => Gen_Rep, + In_State => New_In_State); + + -- Otherwise the Ada rules are in effect, or SPARK code is allowed to + -- violate the SPARK rules. - function Find_With_Clause - (Items : List_Id; - Withed_Id : Entity_Id) return Node_Id + else + Process_Conditional_ABE_Instantiation_Ada + (Inst => Inst, + Inst_Rep => Inst_Rep, + Gen_Id => Gen_Id, + Gen_Rep => Gen_Rep, + In_State => New_In_State); + end if; + end Process_Conditional_ABE_Instantiation; + + ----------------------------------------------- + -- Process_Conditional_ABE_Instantiation_Ada -- + ----------------------------------------------- + + procedure Process_Conditional_ABE_Instantiation_Ada + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id; + In_State : Processing_In_State) is - Item : Node_Id; + Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); + Root : constant Node_Id := Root_Scenario; + Unit_Id : constant Entity_Id := Unit (Gen_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Inst_Rep) + and then Elaboration_Checks_OK (Gen_Rep); + -- A run-time ABE check may be installed only when both the instance + -- and the generic have active elaboration checks and both are not + -- ignored Ghost constructs. + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state begin - -- Examine the context clauses looking for a suitable with. Note that - -- limited clauses do not affect the elaboration order. + -- Nothing to do when the instantiation is ABE-safe + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- package body Gen is + -- ... + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- package Inst is new Gen (ABE); -- safe instantiation + -- ... - Item := First (Items); - while Present (Item) loop - if Nkind (Item) = N_With_Clause - and then not Error_Posted (Item) - and then not Limited_Present (Item) - and then Entity (Name (Item)) = Withed_Id - then - return Item; + if Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then + return; + + -- The instantiation and the generic body are both in the main unit + -- + -- If the root scenario appears prior to the generic body, then this + -- is a possible ABE with respect to the root scenario. + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Inst is new Gen; -- instantiation site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- + -- package body Gen is -- generic body + -- ... + -- end Gen; + -- + -- Y : ... := A; -- root scenario + -- + -- IMPORTANT: The instantiation of Gen is a possible ABE for X, + -- but not for Y. Installing an unconditional ABE raise prior to + -- the instance site would be wrong as it will fail for Y as well, + -- but in Y's case the instantiation of Gen is never an ABE. + + elsif Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + then + if Earlier_In_Extended_Unit (Root, Body_Decl) then + + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if New_In_State.Suppress_Warnings then + null; + + -- Do not emit any ABE diagnostics when the instantiation + -- occurs in partial finalization context because this leads + -- to unwanted noise. + + elsif New_In_State.Within_Partial_Finalization then + null; + + -- Otherwise output the diagnostic + + else + Error_Msg_NE + ("??cannot instantiate & before body seen", Inst, Gen_Id); + Error_Msg_N + ("\Program_Error may be raised at run time", Inst); + + Output_Active_Scenarios (Inst, New_In_State); + end if; + + -- Install a conditional run-time ABE check to verify that the + -- generic body has been elaborated prior to the instantiation. + + if Check_OK then + Install_Scenario_ABE_Check + (N => Inst, + Targ_Id => Gen_Id, + Targ_Rep => Gen_Rep, + Disable => Inst_Rep); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragma must be generated from + -- this point on. + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- <ABE check> + -- declare Inst is new Gen; + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- package body Gen is + -- begin + -- External.Subp; -- imparts Elaborate_All + -- end Gen; + -- + -- If Some_Condition is True, then the ABE check will fail + -- at runtime and the call to External.Subp will never take + -- place, rendering the implicit Elaborate_All useless. + -- + -- If the value of Some_Condition is False, then the call + -- to External.Subp will never take place, rendering the + -- implicit Elaborate_All useless. + + New_In_State.Suppress_Implicit_Pragmas := True; + end if; end if; - Next (Item); - end loop; + -- Otherwise the generic body is not available in this compilation + -- or it resides in an external unit. Install a run-time ABE check + -- to verify that the generic body has been elaborated prior to the + -- instantiation when the dynamic model is in effect. - return Empty; - end Find_With_Clause; + elsif Check_OK + and then New_In_State.Processing = Dynamic_Model_Processing + then + Install_Unit_ABE_Check + (N => Inst, + Unit_Id => Unit_Id, + Disable => Inst_Rep); + end if; - -------------------------- - -- Info_Implicit_Pragma -- - -------------------------- + -- Ensure that the unit with the generic body is elaborated prior + -- to the main unit. No implicit pragma has to be generated if the + -- instantiation has elaboration checks suppressed. This behaviour + -- parallels that of the old ABE mechanism. + + if Elaboration_Checks_OK (Inst_Rep) then + Ensure_Prior_Elaboration + (N => Inst, + Unit_Id => Unit_Id, + Prag_Nam => Name_Elaborate, + In_State => New_In_State); + end if; + end Process_Conditional_ABE_Instantiation_Ada; + + ------------------------------------------------- + -- Process_Conditional_ABE_Instantiation_SPARK -- + ------------------------------------------------- + + procedure Process_Conditional_ABE_Instantiation_SPARK + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Inst_Rep); + + Req_Nam : Name_Id; - procedure Info_Implicit_Pragma is begin - -- Internal units are ignored as they cause unnecessary noise + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - if not In_Internal_Unit (Unit_Id) then + Check_SPARK_Model_In_Effect; - -- The name of the unit subjected to the elaboration pragma is - -- fully qualified to improve the clarity of the info message. + -- A source instantiation imposes an Elaborate[_All] requirement + -- on the context of the main unit. Determine whether the context + -- has a pragma strong enough to meet the requirement. The check + -- is orthogonal to the ABE ramifications of the instantiation. + -- + -- IMPORTANT: This check must be performed only when switch -gnatd.v + -- (enforce SPARK elaboration rules in SPARK code) is active because + -- the static model can ensure the prior elaboration of the unit + -- which contains a body by installing an implicit Elaborate[_All] + -- pragma. + + if Debug_Flag_Dot_V then + if Nkind (Inst) = N_Package_Instantiation then + Req_Nam := Name_Elaborate_All; + else + Req_Nam := Name_Elaborate; + end if; - Error_Msg_Name_1 := Prag_Nam; - Error_Msg_Qual_Level := Nat'Last; + Meet_Elaboration_Requirement + (N => Inst, + Targ_Id => Gen_Id, + Req_Nam => Req_Nam, + In_State => In_State); - Error_Msg_NE - ("info: implicit pragma % generated for unit &", N, Unit_Id); + -- Otherwise ensure that the unit with the target body is elaborated + -- prior to the main unit. - Error_Msg_Qual_Level := 0; - Output_Active_Scenarios (N); + else + Ensure_Prior_Elaboration + (N => Inst, + Unit_Id => Unit (Gen_Rep), + Prag_Nam => Name_Elaborate, + In_State => In_State); end if; - end Info_Implicit_Pragma; + end Process_Conditional_ABE_Instantiation_SPARK; - -- Local variables + ------------------------------------------------- + -- Process_Conditional_ABE_Variable_Assignment -- + ------------------------------------------------- - Main_Cunit : constant Node_Id := Cunit (Main_Unit); - Loc : constant Source_Ptr := Sloc (Main_Cunit); - Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); + procedure Process_Conditional_ABE_Variable_Assignment + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is - Clause : Node_Id; - Elab_Attrs : Elaboration_Attributes; - Items : List_Id; + Var_Id : constant Entity_Id := Target (Asmt_Rep); + Var_Rep : constant Target_Rep_Id := + Target_Representation_Of (Var_Id, In_State); - -- Start of processing for Ensure_Prior_Elaboration_Static + SPARK_Rules_On : constant Boolean := + SPARK_Mode_Of (Asmt_Rep) = Is_On + and then SPARK_Mode_Of (Var_Rep) = Is_On; - begin - Elab_Attrs := Elaboration_Status (Unit_Id); + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. + + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + Elab_Msg_NE + (Msg => "assignment to & during elaboration", + N => Asmt, + Id => Var_Id, + Info_Msg => True, + In_SPARK => SPARK_Rules_On); + end if; - -- Nothing to do when the unit is guaranteed prior elaboration by means - -- of a source Elaborate[_All] pragma. + -- The SPARK rules are in effect. These rules are applied regardless + -- of whether switch -gnatd.v (enforce SPARK elaboration rules in + -- SPARK code) is in effect because the static model cannot ensure + -- safe assignment of variables. - if Present (Elab_Attrs.Source_Pragma) then - return; + if SPARK_Rules_On then + Process_Conditional_ABE_Variable_Assignment_SPARK + (Asmt => Asmt, + Asmt_Rep => Asmt_Rep, + Var_Id => Var_Id, + Var_Rep => Var_Rep, + In_State => In_State); - -- Nothing to do when the unit has an existing implicit Elaborate[_All] - -- pragma installed by a previous scenario. + -- Otherwise the Ada rules are in effect - elsif Present (Elab_Attrs.With_Clause) then + else + Process_Conditional_ABE_Variable_Assignment_Ada + (Asmt => Asmt, + Asmt_Rep => Asmt_Rep, + Var_Id => Var_Id, + Var_Rep => Var_Rep, + In_State => In_State); + end if; + end Process_Conditional_ABE_Variable_Assignment; + + ----------------------------------------------------- + -- Process_Conditional_ABE_Variable_Assignment_Ada -- + ----------------------------------------------------- + + procedure Process_Conditional_ABE_Variable_Assignment_Ada + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Var_Id : Entity_Id; + Var_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Asmt_Rep); - -- The unit is already guaranteed prior elaboration by means of an - -- implicit Elaborate pragma, however the current scenario imposes - -- a stronger requirement of Elaborate_All. "Upgrade" the existing - -- pragma to match this new requirement. + Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); + Unit_Id : constant Entity_Id := Unit (Var_Rep); - if Elaborate_Desirable (Elab_Attrs.With_Clause) - and then Prag_Nam = Name_Elaborate_All + begin + -- Emit a warning when an uninitialized variable declared in a + -- package spec without a pragma Elaborate_Body is initialized + -- by elaboration code within the corresponding body. + + if Is_Elaboration_Warnings_OK_Id (Var_Id) + and then not Is_Initialized (Var_Decl) + and then not Has_Pragma_Elaborate_Body (Unit_Id) then - Set_Elaborate_All_Desirable (Elab_Attrs.With_Clause); - Set_Elaborate_Desirable (Elab_Attrs.With_Clause, False); + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if not In_State.Suppress_Warnings then + Error_Msg_NE + ("??variable & can be accessed by clients before this " + & "initialization", Asmt, Var_Id); + + Error_Msg_NE + ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " + & "initialization", Asmt, Unit_Id); + + Output_Active_Scenarios (Asmt, In_State); + end if; + + -- Generate an implicit Elaborate_Body in the spec + + Set_Elaborate_Body_Desirable (Unit_Id); end if; + end Process_Conditional_ABE_Variable_Assignment_Ada; + + ------------------------------------------------------- + -- Process_Conditional_ABE_Variable_Assignment_SPARK -- + ------------------------------------------------------- + + procedure Process_Conditional_ABE_Variable_Assignment_SPARK + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Var_Id : Entity_Id; + Var_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Asmt_Rep); - return; - end if; + Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); + Unit_Id : constant Entity_Id := Unit (Var_Rep); - -- At this point it is known that the unit has no prior elaboration - -- according to pragmas and hierarchical relationships. + begin + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - Items := Context_Items (Main_Cunit); + Check_SPARK_Model_In_Effect; - if No (Items) then - Items := New_List; - Set_Context_Items (Main_Cunit, Items); - end if; + -- Do not emit any ABE diagnostics when a previous scenario in this + -- traversal has suppressed elaboration warnings. - -- Locate the with clause for the unit. Note that there may not be a - -- clause if the unit is visible through a subunit-body, body-spec, or - -- spec-parent relationship. + if In_State.Suppress_Warnings then + null; - Clause := - Find_With_Clause - (Items => Items, - Withed_Id => Unit_Id); + -- Emit an error when an initialized variable declared in a package + -- spec that is missing pragma Elaborate_Body is further modified by + -- elaboration code within the corresponding body. - -- Generate: - -- with Id; + elsif Is_Elaboration_Warnings_OK_Id (Var_Id) + and then Is_Initialized (Var_Decl) + and then not Has_Pragma_Elaborate_Body (Unit_Id) + then + Error_Msg_NE + ("variable & modified by elaboration code in package body", + Asmt, Var_Id); - -- Note that adding implicit with clauses is safe because analysis, - -- resolution, and expansion have already taken place and it is not - -- possible to interfere with visibility. + Error_Msg_NE + ("\add pragma ""Elaborate_Body"" to spec & to ensure full " + & "initialization", Asmt, Unit_Id); - if No (Clause) then - Clause := - Make_With_Clause (Loc, - Name => New_Occurrence_Of (Unit_Id, Loc)); + Output_Active_Scenarios (Asmt, In_State); + end if; + end Process_Conditional_ABE_Variable_Assignment_SPARK; - Set_Implicit_With (Clause); - Set_Library_Unit (Clause, Unit_Cunit); + ------------------------------------------------ + -- Process_Conditional_ABE_Variable_Reference -- + ------------------------------------------------ - Append_To (Items, Clause); - end if; + procedure Process_Conditional_ABE_Variable_Reference + (Ref : Node_Id; + Ref_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + Var_Id : constant Entity_Id := Target (Ref); + Var_Rep : Target_Rep_Id; + Unit_Id : Entity_Id; - -- Mark the with clause depending on the pragma required + begin + -- Nothing to do when the variable reference is not a read - if Prag_Nam = Name_Elaborate then - Set_Elaborate_Desirable (Clause); - else - Set_Elaborate_All_Desirable (Clause); - end if; + if not Is_Read_Reference (Ref_Rep) then + return; + end if; - -- The implicit Elaborate[_All] ensures the prior elaboration of the - -- unit. Include the unit in the elaboration context of the main unit. + Var_Rep := Target_Representation_Of (Var_Id, In_State); + Unit_Id := Unit (Var_Rep); - Set_Elaboration_Status - (Unit_Id => Unit_Id, - Val => Elaboration_Attributes'(Source_Pragma => Empty, - With_Clause => Clause)); + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - -- Output extra information on an implicit Elaborate[_All] pragma when - -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is - -- in effect. + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + Elab_Msg_NE + (Msg => "read of variable & during elaboration", + N => Ref, + Id => Var_Id, + Info_Msg => True, + In_SPARK => True); + end if; - if Elab_Info_Messages then - Info_Implicit_Pragma; - end if; - end Ensure_Prior_Elaboration_Static; + -- Nothing to do when the variable appears within the main unit + -- because diagnostics on reads are relevant only for external + -- variables. - ----------------------------- - -- Extract_Assignment_Name -- - ----------------------------- + if Is_Same_Unit (Unit_Id, Cunit_Entity (Main_Unit)) then + null; - function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is - Nam : Node_Id; + -- Nothing to do when the variable is already initialized. Note that + -- the variable may be further modified by the external unit. - begin - Nam := Name (Asmt); + elsif Is_Initialized (Variable_Declaration (Var_Rep)) then + null; - -- When the name denotes an array or record component, find the whole - -- object. + -- Nothing to do when the external unit guarantees the initialization + -- of the variable by means of pragma Elaborate_Body. - while Nkind_In (Nam, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) - loop - Nam := Prefix (Nam); - end loop; + elsif Has_Pragma_Elaborate_Body (Unit_Id) then + null; - return Nam; - end Extract_Assignment_Name; + -- A variable read imposes an Elaborate requirement on the context of + -- the main unit. Determine whether the context has a pragma strong + -- enough to meet the requirement. - ----------------------------- - -- Extract_Call_Attributes -- - ----------------------------- + else + Meet_Elaboration_Requirement + (N => Ref, + Targ_Id => Var_Id, + Req_Nam => Name_Elaborate, + In_State => In_State); + end if; + end Process_Conditional_ABE_Variable_Reference; - procedure Extract_Call_Attributes - (Call : Node_Id; - Target_Id : out Entity_Id; - Attrs : out Call_Attributes) - is - From_Source : Boolean; - In_Declarations : Boolean; - Is_Dispatching : Boolean; + ----------------------------------- + -- Traverse_Conditional_ABE_Body -- + ----------------------------------- + procedure Traverse_Conditional_ABE_Body + (N : Node_Id; + In_State : Processing_In_State) + is + begin + Traverse_Body + (N => N, + Requires_Processing => Is_Conditional_ABE_Scenario'Access, + Processor => Process_Conditional_ABE'Access, + In_State => In_State); + end Traverse_Conditional_ABE_Body; + end Conditional_ABE_Processor; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (NE : in out Node_Or_Entity_Id) is + pragma Unreferenced (NE); begin - -- Extraction for call markers + null; + end Destroy; - if Nkind (Call) = N_Call_Marker then - Target_Id := Target (Call); - From_Source := Is_Source_Call (Call); - In_Declarations := Is_Declaration_Level_Node (Call); - Is_Dispatching := Is_Dispatching_Call (Call); + ----------------- + -- Diagnostics -- + ----------------- - -- Extraction for entry calls, requeue, and subprogram calls + package body Diagnostics is - else - pragma Assert (Nkind_In (Call, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement, - N_Requeue_Statement)); + ----------------- + -- Elab_Msg_NE -- + ----------------- - Target_Id := Entity (Extract_Call_Name (Call)); - From_Source := Comes_From_Source (Call); + procedure Elab_Msg_NE + (Msg : String; + N : Node_Id; + Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is + function Prefix return String; + pragma Inline (Prefix); + -- Obtain the prefix of the message - -- Performance note: parent traversal + function Suffix return String; + pragma Inline (Suffix); + -- Obtain the suffix of the message - In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level; - Is_Dispatching := - Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement) - and then Present (Controlling_Argument (Call)); - end if; + ------------ + -- Prefix -- + ------------ - -- Obtain the original entry or subprogram which the target may rename - -- except when the target is an instantiation. In this case the alias - -- is the internally generated subprogram which appears within the the - -- anonymous package created for the instantiation. Such an alias is not - -- a suitable target. + function Prefix return String is + begin + if Info_Msg then + return "info: "; + else + return ""; + end if; + end Prefix; - if not (Is_Subprogram (Target_Id) - and then Is_Generic_Instance (Target_Id)) - then - Target_Id := Get_Renamed_Entity (Target_Id); - end if; + ------------ + -- Suffix -- + ------------ - -- Set all attributes + function Suffix return String is + begin + if In_SPARK then + return " in SPARK"; + else + return ""; + end if; + end Suffix; - Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); - Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); - Attrs.From_Source := From_Source; - Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call); - Attrs.In_Declarations := In_Declarations; - Attrs.Is_Dispatching := Is_Dispatching; - Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call); - end Extract_Call_Attributes; + -- Start of processing for Elab_Msg_NE - ----------------------- - -- Extract_Call_Name -- - ----------------------- + begin + Error_Msg_NE (Prefix & Msg & Suffix, N, Id); + end Elab_Msg_NE; - function Extract_Call_Name (Call : Node_Id) return Node_Id is - Nam : Node_Id; + --------------- + -- Info_Call -- + --------------- - begin - Nam := Name (Call); + procedure Info_Call + (Call : Node_Id; + Subp_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is + procedure Info_Accept_Alternative; + pragma Inline (Info_Accept_Alternative); + -- Output information concerning an accept alternative - -- When the call invokes an entry family, the name appears as an indexed - -- component. + procedure Info_Simple_Call; + pragma Inline (Info_Simple_Call); + -- Output information concerning the call - if Nkind (Nam) = N_Indexed_Component then - Nam := Prefix (Nam); - end if; + procedure Info_Type_Actions (Action : String); + pragma Inline (Info_Type_Actions); + -- Output information concerning action Action of a type - -- When the call employs the object.operation form, the name appears as - -- a selected component. + procedure Info_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String); + pragma Inline (Info_Verification_Call); + -- Output information concerning the verification of predicate Pred + -- applied to related entity Id with kind Id_Kind. - if Nkind (Nam) = N_Selected_Component then - Nam := Selector_Name (Nam); - end if; + ----------------------------- + -- Info_Accept_Alternative -- + ----------------------------- - return Nam; - end Extract_Call_Name; + procedure Info_Accept_Alternative is + Entry_Id : constant Entity_Id := Receiving_Entry (Subp_Id); + pragma Assert (Present (Entry_Id)); - --------------------------------- - -- Extract_Instance_Attributes -- - --------------------------------- + begin + Elab_Msg_NE + (Msg => "accept for entry & during elaboration", + N => Call, + Id => Entry_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Accept_Alternative; + + ---------------------- + -- Info_Simple_Call -- + ---------------------- + + procedure Info_Simple_Call is + begin + Elab_Msg_NE + (Msg => "call to & during elaboration", + N => Call, + Id => Subp_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Simple_Call; + + ----------------------- + -- Info_Type_Actions -- + ----------------------- + + procedure Info_Type_Actions (Action : String) is + Typ : constant Entity_Id := First_Formal_Type (Subp_Id); + pragma Assert (Present (Typ)); - procedure Extract_Instance_Attributes - (Exp_Inst : Node_Id; - Inst_Body : out Node_Id; - Inst_Decl : out Node_Id) - is - Body_Id : Entity_Id; + begin + Elab_Msg_NE + (Msg => Action & " actions for type & during elaboration", + N => Call, + Id => Typ, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Type_Actions; + + ---------------------------- + -- Info_Verification_Call -- + ---------------------------- + + procedure Info_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String) + is + pragma Assert (Present (Id)); - begin - -- Assume that the attributes are unavailable + begin + Elab_Msg_NE + (Msg => + "verification of " & Pred & " of " & Id_Kind & " & during " + & "elaboration", + N => Call, + Id => Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Verification_Call; + + -- Start of processing for Info_Call - Inst_Body := Empty; - Inst_Decl := Empty; + begin + -- Do not output anything for targets defined in internal units + -- because this creates noise. - -- Generic package or subprogram spec + if not In_Internal_Unit (Subp_Id) then - if Nkind_In (Exp_Inst, N_Package_Declaration, - N_Subprogram_Declaration) - then - Inst_Decl := Exp_Inst; - Body_Id := Corresponding_Body (Inst_Decl); + -- Accept alternative - if Present (Body_Id) then - Inst_Body := Unit_Declaration_Node (Body_Id); - end if; + if Is_Accept_Alternative_Proc (Subp_Id) then + Info_Accept_Alternative; - -- Generic package or subprogram body + -- Adjustment - else - pragma Assert - (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body)); + elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then + Info_Type_Actions ("adjustment"); - Inst_Body := Exp_Inst; - Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body)); - end if; - end Extract_Instance_Attributes; + -- Default_Initial_Condition - -------------------------------------- - -- Extract_Instantiation_Attributes -- - -------------------------------------- + elsif Is_Default_Initial_Condition_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "Default_Initial_Condition", + Id => First_Formal_Type (Subp_Id), + Id_Kind => "type"); - procedure Extract_Instantiation_Attributes - (Exp_Inst : Node_Id; - Inst : out Node_Id; - Inst_Id : out Entity_Id; - Gen_Id : out Entity_Id; - Attrs : out Instantiation_Attributes) - is - begin - Inst := Original_Node (Exp_Inst); - Inst_Id := Defining_Entity (Inst); + -- Entries - -- Traverse a possible chain of renamings to obtain the original generic - -- being instantiatied. + elsif Is_Protected_Entry (Subp_Id) then + Info_Simple_Call; - Gen_Id := Get_Renamed_Entity (Entity (Name (Inst))); + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. - -- Set all attributes + elsif Is_Task_Entry (Subp_Id) then + null; - Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); - Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); - Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst); - Attrs.In_Declarations := Is_Declaration_Level_Node (Inst); - Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst); - end Extract_Instantiation_Attributes; + -- Finalization - ------------------------------- - -- Extract_Target_Attributes -- - ------------------------------- + elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then + Info_Type_Actions ("finalization"); - procedure Extract_Target_Attributes - (Target_Id : Entity_Id; - Attrs : out Target_Attributes) - is - procedure Extract_Package_Or_Subprogram_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id); - -- Obtain the attributes associated with a package or a subprogram. - -- Spec_Id is the package or subprogram. Body_Decl is the declaration - -- of the corresponding package or subprogram body. - - procedure Extract_Protected_Entry_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id; - Body_Barf : out Node_Id); - -- Obtain the attributes associated with a protected entry [family]. - -- Spec_Id is the entity of the protected body subprogram. Body_Decl - -- is the declaration of Spec_Id's corresponding body. Body_Barf is - -- the declaration of the barrier function body. - - procedure Extract_Protected_Subprogram_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id); - -- Obtain the attributes associated with a protected subprogram. Formal - -- Spec_Id is the entity of the protected body subprogram. Body_Decl is - -- the declaration of Spec_Id's corresponding body. - - procedure Extract_Task_Entry_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id); - -- Obtain the attributes associated with a task entry [family]. Formal - -- Spec_Id is the entity of the task body procedure. Body_Decl is the - -- declaration of Spec_Id's corresponding body. - - ---------------------------------------------- - -- Extract_Package_Or_Subprogram_Attributes -- - ---------------------------------------------- - - procedure Extract_Package_Or_Subprogram_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id) - is - Body_Id : Entity_Id; - Init_Id : Entity_Id; - Spec_Decl : Node_Id; + -- Calls to _Finalizer procedures must not appear in the output + -- because this creates confusing noise. - begin - -- Assume that the body is not available + elsif Is_Finalizer_Proc (Subp_Id) then + null; - Body_Decl := Empty; - Spec_Id := Target_Id; + -- Initial_Condition - -- For body retrieval purposes, the entity of the initial declaration - -- is that of the spec. + elsif Is_Initial_Condition_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "Initial_Condition", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "package"); - Init_Id := Spec_Id; + -- Initialization - -- The only exception to the above is a function which returns a - -- constrained array type in a SPARK-to-C compilation. In this case - -- the function receives a corresponding procedure which has an out - -- parameter. The proper body for ABE checks and diagnostics is that - -- of the procedure. + elsif Is_Init_Proc (Subp_Id) + or else Is_TSS (Subp_Id, TSS_Deep_Initialize) + then + Info_Type_Actions ("initialization"); - if Ekind (Init_Id) = E_Function - and then Rewritten_For_C (Init_Id) - then - Init_Id := Corresponding_Procedure (Init_Id); - end if; + -- Invariant - -- Extract the attributes of the body + elsif Is_Invariant_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "invariants", + Id => First_Formal_Type (Subp_Id), + Id_Kind => "type"); - Spec_Decl := Unit_Declaration_Node (Init_Id); + -- Partial invariant calls must not appear in the output because + -- this creates confusing noise. - -- The initial declaration is a stand alone subprogram body + elsif Is_Partial_Invariant_Proc (Subp_Id) then + null; - if Nkind (Spec_Decl) = N_Subprogram_Body then - Body_Decl := Spec_Decl; + -- _Postconditions - -- Otherwise the package or subprogram has a spec and a completing - -- body. + elsif Is_Postconditions_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "postconditions", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "subprogram"); - elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Subprogram_Body_Stub, - N_Subprogram_Declaration) - then - Body_Id := Corresponding_Body (Spec_Decl); + -- Subprograms must come last because some of the previous cases + -- fall under this category. - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); + elsif Ekind (Subp_Id) = E_Function then + Info_Simple_Call; + + elsif Ekind (Subp_Id) = E_Procedure then + Info_Simple_Call; + + else + pragma Assert (False); + return; end if; end if; - end Extract_Package_Or_Subprogram_Attributes; + end Info_Call; - ---------------------------------------- - -- Extract_Protected_Entry_Attributes -- - ---------------------------------------- + ------------------------ + -- Info_Instantiation -- + ------------------------ - procedure Extract_Protected_Entry_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id; - Body_Barf : out Node_Id) + procedure Info_Instantiation + (Inst : Node_Id; + Gen_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) is - Barf_Id : Entity_Id; - Body_Id : Entity_Id; + begin + Elab_Msg_NE + (Msg => "instantiation of & during elaboration", + N => Inst, + Id => Gen_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Instantiation; + ----------------------------- + -- Info_Variable_Reference -- + ----------------------------- + + procedure Info_Variable_Reference + (Ref : Node_Id; + Var_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is begin - -- Assume that the bodies are not available + if Is_Read (Ref) then + Elab_Msg_NE + (Msg => "read of variable & during elaboration", + N => Ref, + Id => Var_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end if; + end Info_Variable_Reference; + end Diagnostics; - Body_Barf := Empty; - Body_Decl := Empty; + --------------------------------- + -- Early_Call_Region_Processor -- + --------------------------------- - -- When the entry [family] has already been expanded, it carries both - -- the procedure which emulates the behavior of the entry [family] as - -- well as the barrier function. + package body Early_Call_Region_Processor is - if Present (Protected_Body_Subprogram (Target_Id)) then - Spec_Id := Protected_Body_Subprogram (Target_Id); + --------------------- + -- Data structures -- + --------------------- - -- Extract the attributes of the barrier function + -- The following map relates early call regions to subprogram bodies - Barf_Id := - Corresponding_Body - (Unit_Declaration_Node (Barrier_Function (Target_Id))); + procedure Destroy (N : in out Node_Id); + -- Destroy node N - if Present (Barf_Id) then - Body_Barf := Unit_Declaration_Node (Barf_Id); - end if; + package ECR_Map is new Dynamic_Hash_Tables + (Key_Type => Entity_Id, + Value_Type => Node_Id, + No_Value => Empty, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy, + Hash => Hash); - -- Otherwise no expansion took place + Early_Call_Regions_Map : ECR_Map.Dynamic_Hash_Table := ECR_Map.Nil; - else - Spec_Id := Target_Id; - end if; + ----------------------- + -- Local subprograms -- + ----------------------- - -- Extract the attributes of the entry body + function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; + pragma Inline (Early_Call_Region); + -- Obtain the early call region associated with entry or subprogram body + -- Body_Id. - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); + pragma Inline (Set_Early_Call_Region); + -- Associate an early call region with begins at construct Start with + -- entry or subprogram body Body_Id. - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; - end Extract_Protected_Entry_Attributes; + ------------- + -- Destroy -- + ------------- - --------------------------------------------- - -- Extract_Protected_Subprogram_Attributes -- - --------------------------------------------- + procedure Destroy (N : in out Node_Id) is + pragma Unreferenced (N); + begin + null; + end Destroy; - procedure Extract_Protected_Subprogram_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id) - is - Body_Id : Entity_Id; + ----------------------- + -- Early_Call_Region -- + ----------------------- + function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is + pragma Assert (Present (Body_Id)); begin - -- Assume that the body is not available + return ECR_Map.Get (Early_Call_Regions_Map, Body_Id); + end Early_Call_Region; - Body_Decl := Empty; + ------------------------------------------ + -- Finalize_Early_Call_Region_Processor -- + ------------------------------------------ - -- When the protected subprogram has already been expanded, it - -- carries the subprogram which seizes the lock and invokes the - -- original statements. + procedure Finalize_Early_Call_Region_Processor is + begin + ECR_Map.Destroy (Early_Call_Regions_Map); + end Finalize_Early_Call_Region_Processor; - if Present (Protected_Subprogram (Target_Id)) then - Spec_Id := - Protected_Body_Subprogram (Protected_Subprogram (Target_Id)); + ---------------------------- + -- Find_Early_Call_Region -- + ---------------------------- - -- Otherwise no expansion took place + function Find_Early_Call_Region + (Body_Decl : Node_Id; + Assume_Elab_Body : Boolean := False; + Skip_Memoization : Boolean := False) return Node_Id + is + -- NOTE: The routines within Find_Early_Call_Region are intentionally + -- unnested to avoid deep indentation of code. + + ECR_Found : exception; + -- This exception is raised when the early call region has been found + + Start : Node_Id := Empty; + -- The start of the early call region. This variable is updated by + -- the various nested routines. Due to the use of exceptions, the + -- variable must be global to the nested routines. + + -- The algorithm implemented in this routine attempts to find the + -- early call region of a subprogram body by inspecting constructs + -- in reverse declarative order, while navigating the tree. The + -- algorithm consists of an Inspection phase and Advancement phase. + -- The pseudocode is as follows: + -- + -- loop + -- inspection phase + -- advancement phase + -- end loop + -- + -- The infinite loop is terminated by raising exception ECR_Found. + -- The algorithm utilizes two pointers, Curr and Start, to represent + -- the current construct to inspect and the start of the early call + -- region. + -- + -- IMPORTANT: The algorithm must maintain the following invariant at + -- all time for it to function properly: + -- + -- A nested construct is entered only when it contains suitable + -- constructs. + -- + -- This guarantees that leaving a nested or encapsulating construct + -- functions properly. + -- + -- The Inspection phase determines whether the current construct is + -- non-preelaborable, and if it is, the algorithm terminates. + -- + -- The Advancement phase walks the tree in reverse declarative order, + -- while entering and leaving nested and encapsulating constructs. It + -- may also terminate the elaborithm. There are several special cases + -- of advancement. + -- + -- 1) General case: + -- + -- <construct 1> + -- ... + -- <construct N-1> <- Curr + -- <construct N> <- Start + -- <subprogram body> + -- + -- In the general case, a declarative or statement list is traversed + -- in reverse order where Curr is the lead pointer, and Start is the + -- last preelaborable construct. + -- + -- 2) Entering handled bodies + -- + -- package body Nested is <- Curr (2.3) + -- <declarations> <- Curr (2.2) + -- begin + -- <statements> <- Curr (2.1) + -- end Nested; + -- <construct> <- Start + -- + -- In this case, the algorithm enters a handled body by starting from + -- the last statement (2.1), or the last declaration (2.2), or the + -- body is consumed (2.3) because it is empty and thus preelaborable. + -- + -- 3) Entering package declarations + -- + -- package Nested is <- Curr (2.3) + -- <visible declarations> <- Curr (2.2) + -- private + -- <private declarations> <- Curr (2.1) + -- end Nested; + -- <construct> <- Start + -- + -- In this case, the algorithm enters a package declaration by + -- starting from the last private declaration (2.1), the last visible + -- declaration (2.2), or the package is consumed (2.3) because it is + -- empty and thus preelaborable. + -- + -- 4) Transitioning from list to list of the same construct + -- + -- Certain constructs have two eligible lists. The algorithm must + -- thus transition from the second to the first list when the second + -- list is exhausted. + -- + -- declare <- Curr (4.2) + -- <declarations> <- Curr (4.1) + -- begin + -- <statements> <- Start + -- end; + -- + -- In this case, the algorithm has exhausted the second list (the + -- statements in the example above), and continues with the last + -- declaration (4.1) or the construct is consumed (4.2) because it + -- contains only preelaborable code. + -- + -- 5) Transitioning from list to construct + -- + -- tack body Task is <- Curr (5.1) + -- <- Curr (Empty) + -- <construct 1> <- Start + -- + -- In this case, the algorithm has exhausted a list, Curr is Empty, + -- and the owner of the list is consumed (5.1). + -- + -- 6) Transitioning from unit to unit + -- + -- A package body with a spec subject to pragma Elaborate_Body + -- extends the possible range of the early call region to the package + -- spec. + -- + -- package Pack is <- Curr (6.3) + -- pragma Elaborate_Body; <- Curr (6.2) + -- <visible declarations> <- Curr (6.2) + -- private + -- <private declarations> <- Curr (6.1) + -- end Pack; + -- + -- package body Pack is <- Curr, Start + -- + -- In this case, the algorithm has reached a package body compilation + -- unit whose spec is subject to pragma Elaborate_Body, or the caller + -- of the algorithm has specified this behavior. This transition is + -- equivalent to 3). + -- + -- 7) Transitioning from unit to termination + -- + -- Reaching a compilation unit always terminates the algorithm as + -- there are no more lists to examine. This must take case 6) into + -- account. + -- + -- 8) Transitioning from subunit to stub + -- + -- package body Pack is separate; <- Curr (8.1) + -- + -- separate (...) + -- package body Pack is <- Curr, Start + -- + -- Reaching a subunit continues the search from the corresponding + -- stub (8.1). + + procedure Advance (Curr : in out Node_Id); + pragma Inline (Advance); + -- Update the Curr and Start pointers depending on their location + -- in the tree to the next eligible construct. This routine raises + -- ECR_Found. + + procedure Enter_Handled_Body (Curr : in out Node_Id); + pragma Inline (Enter_Handled_Body); + -- Update the Curr and Start pointers to enter a nested handled body + -- if applicable. This routine raises ECR_Found. + + procedure Enter_Package_Declaration (Curr : in out Node_Id); + pragma Inline (Enter_Package_Declaration); + -- Update the Curr and Start pointers to enter a nested package spec + -- if applicable. This routine raises ECR_Found. + + function Find_ECR (N : Node_Id) return Node_Id; + pragma Inline (Find_ECR); + -- Find an early call region starting from arbitrary node N + + function Has_Suitable_Construct (List : List_Id) return Boolean; + pragma Inline (Has_Suitable_Construct); + -- Determine whether list List contains a suitable construct for + -- inclusion into an early call region. + + procedure Include (N : Node_Id; Curr : out Node_Id); + pragma Inline (Include); + -- Update the Curr and Start pointers to include arbitrary construct + -- N in the early call region. This routine raises ECR_Found. + + function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; + pragma Inline (Is_OK_Preelaborable_Construct); + -- Determine whether arbitrary node N denotes a preelaboration-safe + -- construct. + + function Is_Suitable_Construct (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Construct); + -- Determine whether arbitrary node N denotes a suitable construct + -- for inclusion into the early call region. + + procedure Transition_Body_Declarations + (Bod : Node_Id; + Curr : out Node_Id); + pragma Inline (Transition_Body_Declarations); + -- Update the Curr and Start pointers when construct Bod denotes a + -- block statement or a suitable body. This routine raises ECR_Found. + + procedure Transition_Handled_Statements + (HSS : Node_Id; + Curr : out Node_Id); + pragma Inline (Transition_Handled_Statements); + -- Update the Curr and Start pointers when node HSS denotes a handled + -- sequence of statements. This routine raises ECR_Found. + + procedure Transition_Spec_Declarations + (Spec : Node_Id; + Curr : out Node_Id); + pragma Inline (Transition_Spec_Declarations); + -- Update the Curr and Start pointers when construct Spec denotes + -- a concurrent definition or a package spec. This routine raises + -- ECR_Found. + + procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); + pragma Inline (Transition_Unit); + -- Update the Curr and Start pointers when node Unit denotes a + -- potential compilation unit. This routine raises ECR_Found. + + ------------- + -- Advance -- + ------------- + + procedure Advance (Curr : in out Node_Id) is + Context : Node_Id; - else - Spec_Id := Target_Id; - end if; + begin + -- Curr denotes one of the following cases upon entry into this + -- routine: + -- + -- * Empty - There is no current construct when a declarative or + -- a statement list has been exhausted. This does not indicate + -- that the early call region has been computed as it is still + -- possible to transition to another list. + -- + -- * Encapsulator - The current construct wraps declarations + -- and/or statements. This indicates that the early call + -- region may extend within the nested construct. + -- + -- * Preelaborable - The current construct is preelaborable + -- because Find_ECR would not invoke Advance if this was not + -- the case. - -- Extract the attributes of the body + -- The current construct is an encapsulator or is preelaborable - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + if Present (Curr) then - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; - end Extract_Protected_Subprogram_Attributes; + -- Enter encapsulators by inspecting their declarations and/or + -- statements. - ----------------------------------- - -- Extract_Task_Entry_Attributes -- - ----------------------------------- + if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then + Enter_Handled_Body (Curr); - procedure Extract_Task_Entry_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id) - is - Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id)); - Body_Id : Entity_Id; + elsif Nkind (Curr) = N_Package_Declaration then + Enter_Package_Declaration (Curr); - begin - -- Assume that the body is not available + -- Early call regions have a property which can be exploited to + -- optimize the algorithm. + -- + -- <preceding subprogram body> + -- <preelaborable construct 1> + -- ... + -- <preelaborable construct N> + -- <initiating subprogram body> + -- + -- If a traversal initiated from a subprogram body reaches a + -- preceding subprogram body, then both bodies share the same + -- early call region. + -- + -- The property results in the following desirable effects: + -- + -- * If the preceding body already has an early call region, + -- then the initiating body can reuse it. This minimizes the + -- amount of processing performed by the algorithm. + -- + -- * If the preceding body lack an early call region, then the + -- algorithm can compute the early call region, and reuse it + -- for the initiating body. This processing performs the same + -- amount of work, but has the beneficial effect of computing + -- the early call regions of all preceding bodies. - Body_Decl := Empty; + elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then + Start := + Find_Early_Call_Region + (Body_Decl => Curr, + Assume_Elab_Body => Assume_Elab_Body, + Skip_Memoization => Skip_Memoization); - -- The the task type has already been expanded, it carries the - -- procedure which emulates the behavior of the task body. + raise ECR_Found; - if Present (Task_Body_Procedure (Task_Typ)) then - Spec_Id := Task_Body_Procedure (Task_Typ); + -- Otherwise current construct is preelaborable. Unpdate the + -- early call region to include it. - -- Otherwise no expansion took place + else + Include (Curr, Curr); + end if; - else - Spec_Id := Task_Typ; - end if; + -- Otherwise the current construct is missing, indicating that the + -- current list has been exhausted. Depending on the context of + -- the list, several transitions are possible. - -- Extract the attributes of the body + else + -- The invariant of the algorithm ensures that Curr and Start + -- are at the same level of nesting at the point of transition. + -- The algorithm can determine which list the traversal came + -- from by examining Start. - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + Context := Parent (Start); - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; - end Extract_Task_Entry_Attributes; + -- Attempt the following transitions: + -- + -- private declarations -> visible declarations + -- private declarations -> upper level + -- private declarations -> terminate + -- visible declarations -> upper level + -- visible declarations -> terminate + + if Nkind_In (Context, N_Package_Specification, + N_Protected_Definition, + N_Task_Definition) + then + Transition_Spec_Declarations (Context, Curr); - -- Local variables + -- Attempt the following transitions: + -- + -- statements -> declarations + -- statements -> upper level + -- statements -> corresponding package spec (Elab_Body) + -- statements -> terminate - Prag : constant Node_Id := SPARK_Pragma (Target_Id); - Body_Barf : Node_Id; - Body_Decl : Node_Id; - Spec_Id : Entity_Id; + elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then + Transition_Handled_Statements (Context, Curr); - -- Start of processing for Extract_Target_Attributes + -- Attempt the following transitions: + -- + -- declarations -> upper level + -- declarations -> corresponding package spec (Elab_Body) + -- declarations -> terminate + + elsif Nkind_In (Context, N_Block_Statement, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) + then + Transition_Body_Declarations (Context, Curr); - begin - -- Assume that the body of the barrier function is not available + -- Otherwise it is not possible to transition. Stop the search + -- because there are no more declarations or statements to + -- check. - Body_Barf := Empty; + else + raise ECR_Found; + end if; + end if; + end Advance; - -- The target is a protected entry [family] + -------------------------- + -- Enter_Handled_Body -- + -------------------------- - if Is_Protected_Entry (Target_Id) then - Extract_Protected_Entry_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl, - Body_Barf => Body_Barf); + procedure Enter_Handled_Body (Curr : in out Node_Id) is + Decls : constant List_Id := Declarations (Curr); + HSS : constant Node_Id := Handled_Statement_Sequence (Curr); + Stmts : List_Id := No_List; - -- The target is a protected subprogram + begin + if Present (HSS) then + Stmts := Statements (HSS); + end if; - elsif Is_Protected_Subp (Target_Id) - or else Is_Protected_Body_Subp (Target_Id) - then - Extract_Protected_Subprogram_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl); + -- The handled body has a non-empty statement sequence. The + -- construct to inspect is the last statement. - -- The target is a task entry [family] + if Has_Suitable_Construct (Stmts) then + Curr := Last (Stmts); - elsif Is_Task_Entry (Target_Id) then - Extract_Task_Entry_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl); + -- The handled body lacks statements, but has non-empty + -- declarations. The construct to inspect is the last declaration. - -- Otherwise the target is a package or a subprogram + elsif Has_Suitable_Construct (Decls) then + Curr := Last (Decls); - else - Extract_Package_Or_Subprogram_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl); - end if; + -- Otherwise the handled body lacks both declarations and + -- statements. The construct to inspect is the node which precedes + -- the handled body. Update the early call region to include the + -- handled body. - -- Set all attributes + else + Include (Curr, Curr); + end if; + end Enter_Handled_Body; - Attrs.Body_Barf := Body_Barf; - Attrs.Body_Decl := Body_Decl; - Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id); - Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Target_Id); - Attrs.From_Source := Comes_From_Source (Target_Id); - Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id); - Attrs.SPARK_Mode_On := - Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; - Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id); - Attrs.Spec_Id := Spec_Id; - Attrs.Unit_Id := Find_Top_Unit (Target_Id); + ------------------------------- + -- Enter_Package_Declaration -- + ------------------------------- - -- At this point certain attributes should always be available + procedure Enter_Package_Declaration (Curr : in out Node_Id) is + Pack_Spec : constant Node_Id := Specification (Curr); + Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); + Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); - pragma Assert (Present (Attrs.Spec_Decl)); - pragma Assert (Present (Attrs.Spec_Id)); - pragma Assert (Present (Attrs.Unit_Id)); - end Extract_Target_Attributes; + begin + -- The package has a non-empty private declarations. The construct + -- to inspect is the last private declaration. - ----------------------------- - -- Extract_Task_Attributes -- - ----------------------------- + if Has_Suitable_Construct (Prv_Decls) then + Curr := Last (Prv_Decls); - procedure Extract_Task_Attributes - (Typ : Entity_Id; - Attrs : out Task_Attributes) - is - Task_Typ : constant Entity_Id := Non_Private_View (Typ); + -- The package lacks private declarations, but has non-empty + -- visible declarations. In this case the construct to inspect + -- is the last visible declaration. - Body_Decl : Node_Id; - Body_Id : Entity_Id; - Prag : Node_Id; - Spec_Id : Entity_Id; + elsif Has_Suitable_Construct (Vis_Decls) then + Curr := Last (Vis_Decls); - begin - -- Assume that the body of the task procedure is not available + -- Otherwise the package lacks any declarations. The construct + -- to inspect is the node which precedes the package. Update the + -- early call region to include the package declaration. - Body_Decl := Empty; + else + Include (Curr, Curr); + end if; + end Enter_Package_Declaration; - -- The initial declaration is that of the task body procedure + -------------- + -- Find_ECR -- + -------------- - Spec_Id := Get_Task_Body_Procedure (Task_Typ); - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + function Find_ECR (N : Node_Id) return Node_Id is + Curr : Node_Id; - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; + begin + -- The early call region starts at N - Prag := SPARK_Pragma (Task_Typ); + Curr := Prev (N); + Start := N; - -- Set all attributes + -- Inspect each node in reverse declarative order while going in + -- and out of nested and enclosing constructs. Note that the only + -- way to terminate this infinite loop is to raise ECR_Found. - Attrs.Body_Decl := Body_Decl; - Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ); - Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Task_Typ); - Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ); - Attrs.SPARK_Mode_On := - Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; - Attrs.Spec_Id := Spec_Id; - Attrs.Task_Decl := Declaration_Node (Task_Typ); - Attrs.Unit_Id := Find_Top_Unit (Task_Typ); + loop + -- The current construct is not preelaboration-safe. Terminate + -- the traversal. - -- At this point certain attributes should always be available + if Present (Curr) + and then not Is_OK_Preelaborable_Construct (Curr) + then + raise ECR_Found; + end if; - pragma Assert (Present (Attrs.Spec_Id)); - pragma Assert (Present (Attrs.Task_Decl)); - pragma Assert (Present (Attrs.Unit_Id)); - end Extract_Task_Attributes; + -- Advance to the next suitable construct. This may terminate + -- the traversal by raising ECR_Found. - ------------------------------------------- - -- Extract_Variable_Reference_Attributes -- - ------------------------------------------- + Advance (Curr); + end loop; - procedure Extract_Variable_Reference_Attributes - (Ref : Node_Id; - Var_Id : out Entity_Id; - Attrs : out Variable_Attributes) - is - function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id; - -- Obtain the ultimate renamed variable of variable Id + exception + when ECR_Found => + return Start; + end Find_ECR; - -------------------------- - -- Get_Renamed_Variable -- - -------------------------- + ---------------------------- + -- Has_Suitable_Construct -- + ---------------------------- - function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is - Ren_Id : Entity_Id; + function Has_Suitable_Construct (List : List_Id) return Boolean is + Item : Node_Id; - begin - Ren_Id := Id; - while Present (Renamed_Entity (Ren_Id)) - and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity - loop - Ren_Id := Renamed_Entity (Ren_Id); - end loop; + begin + -- Examine the list in reverse declarative order, looking for a + -- suitable construct. + + if Present (List) then + Item := Last (List); + while Present (Item) loop + if Is_Suitable_Construct (Item) then + return True; + end if; - return Ren_Id; - end Get_Renamed_Variable; + Prev (Item); + end loop; + end if; - -- Start of processing for Extract_Variable_Reference_Attributes + return False; + end Has_Suitable_Construct; - begin - -- Extraction for variable reference markers + ------------- + -- Include -- + ------------- - if Nkind (Ref) = N_Variable_Reference_Marker then - Var_Id := Target (Ref); + procedure Include (N : Node_Id; Curr : out Node_Id) is + begin + Start := N; - -- Extraction for expanded names and identifiers + -- The input node is a compilation unit. This terminates the + -- search because there are no more lists to inspect and there are + -- no more enclosing constructs to climb up to. The transitions + -- are: + -- + -- private declarations -> terminate + -- visible declarations -> terminate + -- statements -> terminate + -- declarations -> terminate - else - Var_Id := Entity (Ref); - end if; + if Nkind (Parent (Start)) = N_Compilation_Unit then + raise ECR_Found; - -- Obtain the original variable which the reference mentions + -- Otherwise the input node is still within some list - Var_Id := Get_Renamed_Variable (Var_Id); - Attrs.Unit_Id := Find_Top_Unit (Var_Id); + else + Curr := Prev (Start); + end if; + end Include; - -- At this point certain attributes should always be available + ----------------------------------- + -- Is_OK_Preelaborable_Construct -- + ----------------------------------- - pragma Assert (Present (Attrs.Unit_Id)); - end Extract_Variable_Reference_Attributes; + function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is + begin + -- Assignment statements are acceptable as long as they were + -- produced by the ABE mechanism to update elaboration flags. - -------------------- - -- Find_Code_Unit -- - -------------------- + if Nkind (N) = N_Assignment_Statement then + return Is_Elaboration_Code (N); - function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is - begin - return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N)))); - end Find_Code_Unit; + -- Block statements are acceptable even though they directly + -- violate preelaborability. The intention is not to penalize + -- the early call region when a block contains only preelaborable + -- constructs. + -- + -- declare + -- Val : constant Integer := 1; + -- begin + -- pragma Assert (Val = 1); + -- null; + -- end; + -- + -- Note that the Advancement phase does enter blocks, and will + -- detect any non-preelaborable declarations or statements within. - ---------------------------- - -- Find_Early_Call_Region -- - ---------------------------- + elsif Nkind (N) = N_Block_Statement then + return True; + end if; - function Find_Early_Call_Region - (Body_Decl : Node_Id; - Assume_Elab_Body : Boolean := False; - Skip_Memoization : Boolean := False) return Node_Id - is - -- NOTE: The routines within Find_Early_Call_Region are intentionally - -- unnested to avoid deep indentation of code. - - ECR_Found : exception; - -- This exception is raised when the early call region has been found - - Start : Node_Id := Empty; - -- The start of the early call region. This variable is updated by the - -- various nested routines. Due to the use of exceptions, the variable - -- must be global to the nested routines. - - -- The algorithm implemented in this routine attempts to find the early - -- call region of a subprogram body by inspecting constructs in reverse - -- declarative order, while navigating the tree. The algorithm consists - -- of an Inspection phase and an Advancement phase. The pseudocode is as - -- follows: - -- - -- loop - -- inspection phase - -- advancement phase - -- end loop - -- - -- The infinite loop is terminated by raising exception ECR_Found. The - -- algorithm utilizes two pointers, Curr and Start, to represent the - -- current construct to inspect and the start of the early call region. - -- - -- IMPORTANT: The algorithm must maintain the following invariant at all - -- time for it to function properly - a nested construct is entered only - -- when it contains suitable constructs. This guarantees that leaving a - -- nested or encapsulating construct functions properly. - -- - -- The Inspection phase determines whether the current construct is non- - -- preelaborable, and if it is, the algorithm terminates. - -- - -- The Advancement phase walks the tree in reverse declarative order, - -- while entering and leaving nested and encapsulating constructs. It - -- may also terminate the elaborithm. There are several special cases - -- of advancement. - -- - -- 1) General case: - -- - -- <construct 1> - -- ... - -- <construct N-1> <- Curr - -- <construct N> <- Start - -- <subprogram body> - -- - -- In the general case, a declarative or statement list is traversed in - -- reverse order where Curr is the lead pointer, and Start indicates the - -- last preelaborable construct. - -- - -- 2) Entering handled bodies - -- - -- package body Nested is <- Curr (2.3) - -- <declarations> <- Curr (2.2) - -- begin - -- <statements> <- Curr (2.1) - -- end Nested; - -- <construct> <- Start - -- - -- In this case, the algorithm enters a handled body by starting from - -- the last statement (2.1), or the last declaration (2.2), or the body - -- is consumed (2.3) because it is empty and thus preelaborable. - -- - -- 3) Entering package declarations - -- - -- package Nested is <- Curr (2.3) - -- <visible declarations> <- Curr (2.2) - -- private - -- <private declarations> <- Curr (2.1) - -- end Nested; - -- <construct> <- Start - -- - -- In this case, the algorithm enters a package declaration by starting - -- from the last private declaration (2.1), the last visible declaration - -- (2.2), or the package is consumed (2.3) because it is empty and thus - -- preelaborable. - -- - -- 4) Transitioning from list to list of the same construct - -- - -- Certain constructs have two eligible lists. The algorithm must thus - -- transition from the second to the first list when the second list is - -- exhausted. - -- - -- declare <- Curr (4.2) - -- <declarations> <- Curr (4.1) - -- begin - -- <statements> <- Start - -- end; - -- - -- In this case, the algorithm has exhausted the second list (statements - -- in the example), and continues with the last declaration (4.1) or the - -- construct is consumed (4.2) because it contains only preelaborable - -- code. - -- - -- 5) Transitioning from list to construct - -- - -- tack body Task is <- Curr (5.1) - -- <- Curr (Empty) - -- <construct 1> <- Start - -- - -- In this case, the algorithm has exhausted a list, Curr is Empty, and - -- the owner of the list is consumed (5.1). - -- - -- 6) Transitioning from unit to unit - -- - -- A package body with a spec subject to pragma Elaborate_Body extends - -- the possible range of the early call region to the package spec. - -- - -- package Pack is <- Curr (6.3) - -- pragma Elaborate_Body; <- Curr (6.2) - -- <visible declarations> <- Curr (6.2) - -- private - -- <private declarations> <- Curr (6.1) - -- end Pack; - -- - -- package body Pack is <- Curr, Start - -- - -- In this case, the algorithm has reached a package body compilation - -- unit whose spec is subject to pragma Elaborate_Body, or the caller - -- of the algorithm has specified this behavior. This transition is - -- equivalent to 3). - -- - -- 7) Transitioning from unit to termination - -- - -- Reaching a compilation unit always terminates the algorithm as there - -- are no more lists to examine. This must take 6) into account. - -- - -- 8) Transitioning from subunit to stub - -- - -- package body Pack is separate; <- Curr (8.1) - -- - -- separate (...) - -- package body Pack is <- Curr, Start - -- - -- Reaching a subunit continues the search from the corresponding stub - -- (8.1). - - procedure Advance (Curr : in out Node_Id); - pragma Inline (Advance); - -- Update the Curr and Start pointers depending on their location in the - -- tree to the next eligible construct. This routine raises ECR_Found. - - procedure Enter_Handled_Body (Curr : in out Node_Id); - pragma Inline (Enter_Handled_Body); - -- Update the Curr and Start pointers to enter a nested handled body if - -- applicable. This routine raises ECR_Found. - - procedure Enter_Package_Declaration (Curr : in out Node_Id); - pragma Inline (Enter_Package_Declaration); - -- Update the Curr and Start pointers to enter a nested package spec if - -- applicable. This routine raises ECR_Found. - - function Find_ECR (N : Node_Id) return Node_Id; - pragma Inline (Find_ECR); - -- Find an early call region starting from arbitrary node N - - function Has_Suitable_Construct (List : List_Id) return Boolean; - pragma Inline (Has_Suitable_Construct); - -- Determine whether list List contains at least one suitable construct - -- for inclusion into an early call region. - - procedure Include (N : Node_Id; Curr : out Node_Id); - pragma Inline (Include); - -- Update the Curr and Start pointers to include arbitrary construct N - -- in the early call region. This routine raises ECR_Found. - - function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; - pragma Inline (Is_OK_Preelaborable_Construct); - -- Determine whether arbitrary node N denotes a preelaboration-safe - -- construct. - - function Is_Suitable_Construct (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Construct); - -- Determine whether arbitrary node N denotes a suitable construct for - -- inclusion into the early call region. - - procedure Transition_Body_Declarations - (Bod : Node_Id; - Curr : out Node_Id); - pragma Inline (Transition_Body_Declarations); - -- Update the Curr and Start pointers when construct Bod denotes a block - -- statement or a suitable body. This routine raises ECR_Found. - - procedure Transition_Handled_Statements - (HSS : Node_Id; - Curr : out Node_Id); - pragma Inline (Transition_Handled_Statements); - -- Update the Curr and Start pointers when node HSS denotes a handled - -- sequence of statements. This routine raises ECR_Found. - - procedure Transition_Spec_Declarations - (Spec : Node_Id; - Curr : out Node_Id); - pragma Inline (Transition_Spec_Declarations); - -- Update the Curr and Start pointers when construct Spec denotes - -- a concurrent definition or a package spec. This routine raises - -- ECR_Found. - - procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); - pragma Inline (Transition_Unit); - -- Update the Curr and Start pointers when node Unit denotes a potential - -- compilation unit. This routine raises ECR_Found. + -- Otherwise the construct must be preelaborable. The check must + -- take the syntactic and semantic structure of the construct. DO + -- NOT use Is_Preelaborable_Construct here. - ------------- - -- Advance -- - ------------- + return not Is_Non_Preelaborable_Construct (N); + end Is_OK_Preelaborable_Construct; - procedure Advance (Curr : in out Node_Id) is - Context : Node_Id; + --------------------------- + -- Is_Suitable_Construct -- + --------------------------- - begin - -- Curr denotes one of the following cases upon entry into this - -- routine: - -- - -- * Empty - There is no current construct when a declarative or a - -- statement list has been exhausted. This does not necessarily - -- indicate that the early call region has been computed as it - -- may still be possible to transition to another list. - -- - -- * Encapsulator - The current construct encapsulates declarations - -- and/or statements. This indicates that the early call region - -- may extend within the nested construct. - -- - -- * Preelaborable - The current construct is always preelaborable - -- because Find_ECR would not invoke Advance if this was not the - -- case. + function Is_Suitable_Construct (N : Node_Id) return Boolean is + Context : constant Node_Id := Parent (N); - -- The current construct is an encapsulator or is preelaborable + begin + -- An internally-generated statement sequence which contains only + -- a single null statement is not a suitable construct because it + -- is a byproduct of the parser. Such a null statement should be + -- excluded from the early call region because it carries the + -- source location of the "end" keyword, and may lead to confusing + -- diagnistics. + + if Nkind (N) = N_Null_Statement + and then not Comes_From_Source (N) + and then Present (Context) + and then Nkind (Context) = N_Handled_Sequence_Of_Statements + then + return False; + end if; - if Present (Curr) then + -- Otherwise only constructs which correspond to pure Ada + -- constructs are considered suitable. + + case Nkind (N) is + when N_Call_Marker + | N_Freeze_Entity + | N_Freeze_Generic_Entity + | N_Implicit_Label_Declaration + | N_Itype_Reference + | N_Pop_Constraint_Error_Label + | N_Pop_Program_Error_Label + | N_Pop_Storage_Error_Label + | N_Push_Constraint_Error_Label + | N_Push_Program_Error_Label + | N_Push_Storage_Error_Label + | N_SCIL_Dispatch_Table_Tag_Init + | N_SCIL_Dispatching_Call + | N_SCIL_Membership_Test + | N_Variable_Reference_Marker + => + return False; - -- Enter encapsulators by inspecting their declarations and/or - -- statements. + when others => + return True; + end case; + end Is_Suitable_Construct; - if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then - Enter_Handled_Body (Curr); + ---------------------------------- + -- Transition_Body_Declarations -- + ---------------------------------- - elsif Nkind (Curr) = N_Package_Declaration then - Enter_Package_Declaration (Curr); + procedure Transition_Body_Declarations + (Bod : Node_Id; + Curr : out Node_Id) + is + Decls : constant List_Id := Declarations (Bod); - -- Early call regions have a property which can be exploited to - -- optimize the algorithm. - -- - -- <preceding subprogram body> - -- <preelaborable construct 1> - -- ... - -- <preelaborable construct N> - -- <initiating subprogram body> - -- - -- If a traversal initiated from a subprogram body reaches a - -- preceding subprogram body, then both bodies share the same - -- early call region. - -- - -- The property results in the following desirable effects: - -- - -- * If the preceding body already has an early call region, then - -- the initiating body can reuse it. This minimizes the amount - -- of processing performed by the algorithm. + begin + -- The search must come from the declarations of the body + + pragma Assert + (Is_Non_Empty_List (Decls) + and then List_Containing (Start) = Decls); + + -- The search finished inspecting the declarations. The construct + -- to inspect is the node which precedes the handled body, unless + -- the body is a compilation unit. The transitions are: -- - -- * If the preceding body lack an early call region, then the - -- algorithm can compute the early call region, and reuse it - -- for the initiating body. This processing performs the same - -- amount of work, but has the beneficial effect of computing - -- the early call regions of all preceding bodies. - - elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then - Start := - Find_Early_Call_Region - (Body_Decl => Curr, - Assume_Elab_Body => Assume_Elab_Body, - Skip_Memoization => Skip_Memoization); + -- declarations -> upper level + -- declarations -> corresponding package spec (Elab_Body) + -- declarations -> terminate - raise ECR_Found; + Transition_Unit (Bod, Curr); + end Transition_Body_Declarations; - -- Otherwise current construct is preelaborable. Unpdate the early - -- call region to include it. + ----------------------------------- + -- Transition_Handled_Statements -- + ----------------------------------- - else - Include (Curr, Curr); - end if; + procedure Transition_Handled_Statements + (HSS : Node_Id; + Curr : out Node_Id) + is + Bod : constant Node_Id := Parent (HSS); + Decls : constant List_Id := Declarations (Bod); + Stmts : constant List_Id := Statements (HSS); - -- Otherwise the current construct is missing, indicating that the - -- current list has been exhausted. Depending on the context of the - -- list, several transitions are possible. + begin + -- The search must come from the statements of certain bodies or + -- statements. - else - -- The invariant of the algorithm ensures that Curr and Start are - -- at the same level of nesting at the point of a transition. The - -- algorithm can determine which list the traversal came from by - -- examining Start. + pragma Assert (Nkind_In (Bod, N_Block_Statement, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body)); - Context := Parent (Start); + -- The search must come from the statements of the handled + -- sequence. - -- Attempt the following transitions: + pragma Assert + (Is_Non_Empty_List (Stmts) + and then List_Containing (Start) = Stmts); + + -- The search finished inspecting the statements. The handled body + -- has non-empty declarations. The construct to inspect is the + -- last declaration. The transitions are: -- - -- private declarations -> visible declarations - -- private declarations -> upper level - -- private declarations -> terminate - -- visible declarations -> upper level - -- visible declarations -> terminate + -- statements -> declarations - if Nkind_In (Context, N_Package_Specification, - N_Protected_Definition, - N_Task_Definition) - then - Transition_Spec_Declarations (Context, Curr); + if Has_Suitable_Construct (Decls) then + Curr := Last (Decls); - -- Attempt the following transitions: + -- Otherwise the handled body lacks declarations. The construct to + -- inspect is the node which precedes the handled body, unless the + -- body is a compilation unit. The transitions are: -- - -- statements -> declarations -- statements -> upper level -- statements -> corresponding package spec (Elab_Body) -- statements -> terminate - elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then - Transition_Handled_Statements (Context, Curr); + else + Transition_Unit (Bod, Curr); + end if; + end Transition_Handled_Statements; + + ---------------------------------- + -- Transition_Spec_Declarations -- + ---------------------------------- + + procedure Transition_Spec_Declarations + (Spec : Node_Id; + Curr : out Node_Id) + is + Prv_Decls : constant List_Id := Private_Declarations (Spec); + Vis_Decls : constant List_Id := Visible_Declarations (Spec); + + begin + pragma Assert (Present (Start) and then Is_List_Member (Start)); - -- Attempt the following transitions: + -- The search came from the private declarations and finished + -- their inspection. + + if Has_Suitable_Construct (Prv_Decls) + and then List_Containing (Start) = Prv_Decls + then + -- The context has non-empty visible declarations. The node to + -- inspect is the last visible declaration. The transitions + -- are: + -- + -- private declarations -> visible declarations + + if Has_Suitable_Construct (Vis_Decls) then + Curr := Last (Vis_Decls); + + -- Otherwise the context lacks visible declarations. The + -- construct to inspect is the node which precedes the context + -- unless the context is a compilation unit. The transitions + -- are: + -- + -- private declarations -> upper level + -- private declarations -> terminate + + else + Transition_Unit (Parent (Spec), Curr); + end if; + + -- The search came from the visible declarations and finished + -- their inspections. The construct to inspect is the node which + -- precedes the context, unless the context is a compilaton unit. + -- The transitions are: -- - -- declarations -> upper level - -- declarations -> corresponding package spec (Elab_Body) - -- declarations -> terminate + -- visible declarations -> upper level + -- visible declarations -> terminate - elsif Nkind_In (Context, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) + elsif Has_Suitable_Construct (Vis_Decls) + and then List_Containing (Start) = Vis_Decls then - Transition_Body_Declarations (Context, Curr); + Transition_Unit (Parent (Spec), Curr); - -- Otherwise it is not possible to transition. Stop the search - -- because there are no more declarations or statements to check. + -- At this point both declarative lists are empty, but the + -- traversal still came from within the spec. This indicates + -- that the invariant of the algorithm has been violated. else + pragma Assert (False); raise ECR_Found; end if; - end if; - end Advance; + end Transition_Spec_Declarations; - -------------------------- - -- Enter_Handled_Body -- - -------------------------- + --------------------- + -- Transition_Unit -- + --------------------- - procedure Enter_Handled_Body (Curr : in out Node_Id) is - Decls : constant List_Id := Declarations (Curr); - HSS : constant Node_Id := Handled_Statement_Sequence (Curr); - Stmts : List_Id := No_List; + procedure Transition_Unit + (Unit : Node_Id; + Curr : out Node_Id) + is + Context : constant Node_Id := Parent (Unit); - begin - if Present (HSS) then - Stmts := Statements (HSS); - end if; + begin + -- The unit is a compilation unit. This terminates the search + -- because there are no more lists to inspect and there are no + -- more enclosing constructs to climb up to. + + if Nkind (Context) = N_Compilation_Unit then + + -- A package body with a corresponding spec subject to pragma + -- Elaborate_Body is an exception to the above. The annotation + -- allows the search to continue into the package declaration. + -- The transitions are: + -- + -- statements -> corresponding package spec (Elab_Body) + -- declarations -> corresponding package spec (Elab_Body) + + if Nkind (Unit) = N_Package_Body + and then (Assume_Elab_Body + or else Has_Pragma_Elaborate_Body + (Corresponding_Spec (Unit))) + then + Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); + Enter_Package_Declaration (Curr); - -- The handled body has a non-empty statement sequence. The construct - -- to inspect is the last statement. + -- Otherwise terminate the search. The transitions are: + -- + -- private declarations -> terminate + -- visible declarations -> terminate + -- statements -> terminate + -- declarations -> terminate - if Has_Suitable_Construct (Stmts) then - Curr := Last (Stmts); + else + raise ECR_Found; + end if; - -- The handled body lacks statements, but has non-empty declarations. - -- The construct to inspect is the last declaration. + -- The unit is a subunit. The construct to inspect is the node + -- which precedes the corresponding stub. Update the early call + -- region to include the unit. - elsif Has_Suitable_Construct (Decls) then - Curr := Last (Decls); + elsif Nkind (Context) = N_Subunit then + Start := Unit; + Curr := Corresponding_Stub (Context); - -- Otherwise the handled body lacks both declarations and statements. - -- The construct to inspect is the node which precedes the handled - -- body. Update the early call region to include the handled body. + -- Otherwise the unit is nested. The construct to inspect is the + -- node which precedes the unit. Update the early call region to + -- include the unit. - else - Include (Curr, Curr); - end if; - end Enter_Handled_Body; + else + Include (Unit, Curr); + end if; + end Transition_Unit; - ------------------------------- - -- Enter_Package_Declaration -- - ------------------------------- + -- Local variables + + Body_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl); + Region : Node_Id; - procedure Enter_Package_Declaration (Curr : in out Node_Id) is - Pack_Spec : constant Node_Id := Specification (Curr); - Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); - Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); + -- Start of processing for Find_Early_Call_Region begin - -- The package has a non-empty private declarations. The construct to - -- inspect is the last private declaration. + -- The caller demands the start of the early call region without + -- saving or retrieving it to/from internal data structures. - if Has_Suitable_Construct (Prv_Decls) then - Curr := Last (Prv_Decls); + if Skip_Memoization then + Region := Find_ECR (Body_Decl); - -- The package lacks private declarations, but has non-empty visible - -- declarations. In this case the construct to inspect is the last - -- visible declaration. + -- Default behavior - elsif Has_Suitable_Construct (Vis_Decls) then - Curr := Last (Vis_Decls); + else + -- Check whether the early call region of the subprogram body is + -- available. - -- Otherwise the package lacks any declarations. The construct to - -- inspect is the node which precedes the package. Update the early - -- call region to include the package declaration. + Region := Early_Call_Region (Body_Id); - else - Include (Curr, Curr); + if No (Region) then + Region := Find_ECR (Body_Decl); + + -- Associate the early call region with the subprogram body in + -- case other scenarios need it. + + Set_Early_Call_Region (Body_Id, Region); + end if; end if; - end Enter_Package_Declaration; - -------------- - -- Find_ECR -- - -------------- + -- A subprogram body must always have an early call region + + pragma Assert (Present (Region)); - function Find_ECR (N : Node_Id) return Node_Id is - Curr : Node_Id; + return Region; + end Find_Early_Call_Region; + -------------------------------------------- + -- Initialize_Early_Call_Region_Processor -- + -------------------------------------------- + + procedure Initialize_Early_Call_Region_Processor is begin - -- The early call region starts at N + Early_Call_Regions_Map := ECR_Map.Create (100); + end Initialize_Early_Call_Region_Processor; - Curr := Prev (N); - Start := N; + --------------------------- + -- Set_Early_Call_Region -- + --------------------------- - -- Inspect each node in reverse declarative order while going in and - -- out of nested and enclosing constructs. Note that the only way to - -- terminate this infinite loop is to raise exception ECR_Found. + procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is + pragma Assert (Present (Body_Id)); + pragma Assert (Present (Start)); - loop - -- The current construct is not preelaboration-safe. Terminate the - -- traversal. + begin + ECR_Map.Put (Early_Call_Regions_Map, Body_Id, Start); + end Set_Early_Call_Region; + end Early_Call_Region_Processor; - if Present (Curr) - and then not Is_OK_Preelaborable_Construct (Curr) - then - raise ECR_Found; + ---------------------- + -- Elaborated_Units -- + ---------------------- + + package body Elaborated_Units is + + ----------- + -- Types -- + ----------- + + -- The following type idenfities the elaboration attributes of a unit + + type Elaboration_Attributes_Id is new Natural; + + No_Elaboration_Attributes : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Id'First; + First_Elaboration_Attributes : constant Elaboration_Attributes_Id := + No_Elaboration_Attributes + 1; + + -- The following type represents the elaboration attributes of a unit + + type Elaboration_Attributes_Record is record + Elab_Pragma : Node_Id := Empty; + -- This attribute denotes a source Elaborate or Elaborate_All pragma + -- which guarantees the prior elaboration of some unit with respect + -- to the main unit. The pragma may come from the following contexts: + -- + -- * The main unit + -- * The spec of the main unit (if applicable) + -- * Any parent spec of the main unit (if applicable) + -- * Any parent subunit of the main unit (if applicable) + -- + -- The attribute remains Empty if no such pragma is available. Source + -- pragmas play a role in satisfying SPARK elaboration requirements. + + With_Clause : Node_Id := Empty; + -- This attribute denotes an internally-generated or a source with + -- clause for some unit withed by the main unit. With clauses carry + -- flags which represent implicit Elaborate or Elaborate_All pragmas. + -- These clauses play a role in supplying elaboration dependencies to + -- binde. + end record; + + --------------------- + -- Data structures -- + --------------------- + + -- The following table stores all elaboration attributes + + package Elaboration_Attributes is new Table.Table + (Table_Index_Type => Elaboration_Attributes_Id, + Table_Component_Type => Elaboration_Attributes_Record, + Table_Low_Bound => First_Elaboration_Attributes, + Table_Initial => 250, + Table_Increment => 200, + Table_Name => "Elaboration_Attributes"); + + procedure Destroy (EA_Id : in out Elaboration_Attributes_Id); + -- Destroy elaboration attributes EA_Id + + package UA_Map is new Dynamic_Hash_Tables + (Key_Type => Entity_Id, + Value_Type => Elaboration_Attributes_Id, + No_Value => No_Elaboration_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy, + Hash => Hash); + + -- The following map relates an elaboration attributes of a unit to the + -- unit. + + Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := + UA_Map.Create (250); + + ------------------ + -- Constructors -- + ------------------ + + function Elaboration_Attributes_Of + (Unit_Id : Entity_Id) return Elaboration_Attributes_Id; + pragma Inline (Elaboration_Attributes_Of); + -- Obtain the elaboration attributes of unit Unit_Id + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Elab_Pragma (EA_Id : Elaboration_Attributes_Id) return Node_Id; + pragma Inline (Elab_Pragma); + -- Obtain the Elaborate[_All] pragma of elaboration attributes EA_Id + + procedure Ensure_Prior_Elaboration_Dynamic + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State); + pragma Inline (Ensure_Prior_Elaboration_Dynamic); + -- Guarantee the elaboration of unit Unit_Id with respect to the main + -- unit by suggesting the use of Elaborate[_All] with name Prag_Nam. N + -- denotes the related scenario. In_State is the current state of the + -- Processing phase. + + procedure Ensure_Prior_Elaboration_Static + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State); + pragma Inline (Ensure_Prior_Elaboration_Static); + -- Guarantee the elaboration of unit Unit_Id with respect to the main + -- unit by installing an implicit Elaborate[_All] pragma with name + -- Prag_Nam. N denotes the related scenario. In_State is the current + -- state of the Processing phase. + + function Present (EA_Id : Elaboration_Attributes_Id) return Boolean; + pragma Inline (Present); + -- Determine whether elaboration attributes UA_Id exist + + procedure Set_Elab_Pragma + (EA_Id : Elaboration_Attributes_Id; + Prag : Node_Id); + pragma Inline (Set_Elab_Pragma); + -- Set the Elaborate[_All] pragma of elaboration attributes EA_Id to + -- Prag. + + procedure Set_With_Clause + (EA_Id : Elaboration_Attributes_Id; + Clause : Node_Id); + pragma Inline (Set_With_Clause); + -- Set the with clause of elaboration attributes EA_Id to Clause + + function With_Clause (EA_Id : Elaboration_Attributes_Id) return Node_Id; + pragma Inline (With_Clause); + -- Obtain the implicit or source with clause of elaboration attributes + -- EA_Id. + + ------------------------------ + -- Collect_Elaborated_Units -- + ------------------------------ + + procedure Collect_Elaborated_Units is + procedure Add_Pragma (Prag : Node_Id); + pragma Inline (Add_Pragma); + -- Determine whether pragma Prag denotes a legal Elaborate[_All] + -- pragma. If this is the case, add the related unit to the context. + -- For pragma Elaborate_All, include recursively all units withed by + -- the related unit. + + procedure Add_Unit + (Unit_Id : Entity_Id; + Prag : Node_Id; + Full_Context : Boolean); + pragma Inline (Add_Unit); + -- Add unit Unit_Id to the elaboration context. Prag denotes the + -- pragma which prompted the inclusion of the unit to the context. + -- If flag Full_Context is set, examine the nonlimited clauses of + -- unit Unit_Id and add each withed unit to the context. + + procedure Find_Elaboration_Context (Comp_Unit : Node_Id); + pragma Inline (Find_Elaboration_Context); + -- Examine the context items of compilation unit Comp_Unit for + -- suitable elaboration-related pragmas and add all related units + -- to the context. + + ---------------- + -- Add_Pragma -- + ---------------- + + procedure Add_Pragma (Prag : Node_Id) is + Prag_Args : constant List_Id := + Pragma_Argument_Associations (Prag); + Prag_Nam : constant Name_Id := Pragma_Name (Prag); + Unit_Arg : Node_Id; + + begin + -- Nothing to do if the pragma is not related to elaboration + + if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then + return; + + -- Nothing to do when the pragma is illegal + + elsif Error_Posted (Prag) then + return; end if; - -- Advance to the next suitable construct. This may terminate the - -- traversal by raising ECR_Found. + Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); - Advance (Curr); - end loop; + -- The argument of the pragma may appear in package.package form - exception - when ECR_Found => - return Start; - end Find_ECR; + if Nkind (Unit_Arg) = N_Selected_Component then + Unit_Arg := Selector_Name (Unit_Arg); + end if; - ---------------------------- - -- Has_Suitable_Construct -- - ---------------------------- + Add_Unit + (Unit_Id => Entity (Unit_Arg), + Prag => Prag, + Full_Context => Prag_Nam = Name_Elaborate_All); + end Add_Pragma; - function Has_Suitable_Construct (List : List_Id) return Boolean is - Item : Node_Id; + -------------- + -- Add_Unit -- + -------------- - begin - -- Examine the list in reverse declarative order, looking for a - -- suitable construct. + procedure Add_Unit + (Unit_Id : Entity_Id; + Prag : Node_Id; + Full_Context : Boolean) + is + Clause : Node_Id; + EA_Id : Elaboration_Attributes_Id; + Unit_Prag : Node_Id; - if Present (List) then - Item := Last (List); - while Present (Item) loop - if Is_Suitable_Construct (Item) then - return True; + begin + -- Nothing to do when some previous error left a with clause or a + -- pragma in a bad state. + + if No (Unit_Id) then + return; + end if; + + EA_Id := Elaboration_Attributes_Of (Unit_Id); + Unit_Prag := Elab_Pragma (EA_Id); + + -- The unit is already included in the context by means of pragma + -- Elaborate[_All]. + + if Present (Unit_Prag) then + + -- Upgrade an existing pragma Elaborate when the unit is + -- subject to Elaborate_All because the new pragma covers a + -- larger set of units. + + if Pragma_Name (Unit_Prag) = Name_Elaborate + and then Pragma_Name (Prag) = Name_Elaborate_All + then + Set_Elab_Pragma (EA_Id, Prag); + + -- Otherwise the unit retains its existing pragma and does not + -- need to be included in the context again. + + else + return; end if; - Prev (Item); - end loop; - end if; + -- Otherwise the current unit is not included in the context - return False; - end Has_Suitable_Construct; + else + Set_Elab_Pragma (EA_Id, Prag); + end if; - ------------- - -- Include -- - ------------- + -- Includes all units withed by the current one when computing the + -- full context. - procedure Include (N : Node_Id; Curr : out Node_Id) is - begin - Start := N; + if Full_Context then - -- The input node is a compilation unit. This terminates the search - -- because there are no more lists to inspect and there are no more - -- enclosing constructs to climb up to. The transitions are: - -- - -- private declarations -> terminate - -- visible declarations -> terminate - -- statements -> terminate - -- declarations -> terminate + -- Process all nonlimited with clauses found in the context of + -- the current unit. Note that limited clauses do not impose an + -- elaboration order. - if Nkind (Parent (Start)) = N_Compilation_Unit then - raise ECR_Found; + Clause := First (Context_Items (Compilation_Unit (Unit_Id))); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then not Error_Posted (Clause) + and then not Limited_Present (Clause) + then + Add_Unit + (Unit_Id => Entity (Name (Clause)), + Prag => Prag, + Full_Context => Full_Context); + end if; - -- Otherwise the input node is still within some list + Next (Clause); + end loop; + end if; + end Add_Unit; - else - Curr := Prev (Start); - end if; - end Include; + ------------------------------ + -- Find_Elaboration_Context -- + ------------------------------ - ----------------------------------- - -- Is_OK_Preelaborable_Construct -- - ----------------------------------- + procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is + pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); - function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is - begin - -- Assignment statements are acceptable as long as they were produced - -- by the ABE mechanism to update elaboration flags. + Prag : Node_Id; - if Nkind (N) = N_Assignment_Statement then - return Is_Elaboration_Code (N); + begin + -- Process all elaboration-related pragmas found in the context of + -- the compilation unit. + + Prag := First (Context_Items (Comp_Unit)); + while Present (Prag) loop + if Nkind (Prag) = N_Pragma then + Add_Pragma (Prag); + end if; - -- Block statements are acceptable even though they directly violate - -- preelaborability. The intention is not to penalize the early call - -- region when a block contains only preelaborable constructs. + Next (Prag); + end loop; + end Find_Elaboration_Context; + + -- Local variables + + Par_Id : Entity_Id; + Unit_Id : Node_Id; + + -- Start of processing for Collect_Elaborated_Units + + begin + -- Perform a traversal to examines the context of the main unit. The + -- traversal performs the following jumps: -- - -- declare - -- Val : constant Integer := 1; - -- begin - -- pragma Assert (Val = 1); - -- null; - -- end; + -- subunit -> parent subunit + -- parent subunit -> body + -- body -> spec + -- spec -> parent spec + -- parent spec -> grandparent spec and so on -- - -- Note that the Advancement phase does enter blocks, and will detect - -- any non-preelaborable declarations or statements within. + -- The traversal relies on units rather than scopes because the scope + -- of a subunit is some spec, while this traversal must process the + -- body as well. Given that protected and task bodies can also be + -- subunits, this complicates the scope approach even further. - elsif Nkind (N) = N_Block_Statement then - return True; - end if; + Unit_Id := Unit (Cunit (Main_Unit)); - -- Otherwise the construct must be preelaborable. The check must take - -- the syntactic and semantic structure of the construct. DO NOT use - -- Is_Preelaborable_Construct here. + -- Perform the following traversals when the main unit is a subunit + -- + -- subunit -> parent subunit + -- parent subunit -> body - return not Is_Non_Preelaborable_Construct (N); - end Is_OK_Preelaborable_Construct; + while Present (Unit_Id) and then Nkind (Unit_Id) = N_Subunit loop + Find_Elaboration_Context (Parent (Unit_Id)); - --------------------------- - -- Is_Suitable_Construct -- - --------------------------- + -- Continue the traversal by going to the unit which contains the + -- corresponding stub. - function Is_Suitable_Construct (N : Node_Id) return Boolean is - Context : constant Node_Id := Parent (N); + if Present (Corresponding_Stub (Unit_Id)) then + Unit_Id := + Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unit_Id)))); - begin - -- An internally-generated statement sequence which contains only a - -- single null statement is not a suitable construct because it is a - -- byproduct of the parser. Such a null statement should be excluded - -- from the early call region because it carries the source location - -- of the "end" keyword, and may lead to confusing diagnistics. + -- Otherwise the subunit may be erroneous or left in a bad state + + else + exit; + end if; + end loop; + + -- Perform the following traversal now that subunits have been taken + -- care of, or the main unit is a body. + -- + -- body -> spec - if Nkind (N) = N_Null_Statement - and then not Comes_From_Source (N) - and then Present (Context) - and then Nkind (Context) = N_Handled_Sequence_Of_Statements + if Present (Unit_Id) + and then Nkind_In (Unit_Id, N_Package_Body, N_Subprogram_Body) then - return False; + Find_Elaboration_Context (Parent (Unit_Id)); + + -- Continue the traversal by going to the unit which contains the + -- corresponding spec. + + if Present (Corresponding_Spec (Unit_Id)) then + Unit_Id := + Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unit_Id)))); + end if; end if; - -- Otherwise only constructs which correspond to pure Ada constructs - -- are considered suitable. + -- Perform the following traversals now that the body has been taken + -- care of, or the main unit is a spec. + -- + -- spec -> parent spec + -- parent spec -> grandparent spec and so on + + if Present (Unit_Id) + and then Nkind_In (Unit_Id, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Subprogram_Declaration) + then + Find_Elaboration_Context (Parent (Unit_Id)); - case Nkind (N) is - when N_Call_Marker - | N_Freeze_Entity - | N_Freeze_Generic_Entity - | N_Implicit_Label_Declaration - | N_Itype_Reference - | N_Pop_Constraint_Error_Label - | N_Pop_Program_Error_Label - | N_Pop_Storage_Error_Label - | N_Push_Constraint_Error_Label - | N_Push_Program_Error_Label - | N_Push_Storage_Error_Label - | N_SCIL_Dispatch_Table_Tag_Init - | N_SCIL_Dispatching_Call - | N_SCIL_Membership_Test - | N_Variable_Reference_Marker - => - return False; + -- Process a potential chain of parent units which ends with the + -- main unit spec. The traversal can now safely rely on the scope + -- chain. - when others => - return True; - end case; - end Is_Suitable_Construct; + Par_Id := Scope (Defining_Entity (Unit_Id)); + while Present (Par_Id) and then Par_Id /= Standard_Standard loop + Find_Elaboration_Context (Compilation_Unit (Par_Id)); - ---------------------------------- - -- Transition_Body_Declarations -- - ---------------------------------- + Par_Id := Scope (Par_Id); + end loop; + end if; + end Collect_Elaborated_Units; - procedure Transition_Body_Declarations - (Bod : Node_Id; - Curr : out Node_Id) + ------------- + -- Destroy -- + ------------- + + procedure Destroy (EA_Id : in out Elaboration_Attributes_Id) is + pragma Unreferenced (EA_Id); + begin + null; + end Destroy; + + ----------------- + -- Elab_Pragma -- + ----------------- + + function Elab_Pragma + (EA_Id : Elaboration_Attributes_Id) return Node_Id is - Decls : constant List_Id := Declarations (Bod); + pragma Assert (Present (EA_Id)); + begin + return Elaboration_Attributes.Table (EA_Id).Elab_Pragma; + end Elab_Pragma; + + ------------------------------- + -- Elaboration_Attributes_Of -- + ------------------------------- + + function Elaboration_Attributes_Of + (Unit_Id : Entity_Id) return Elaboration_Attributes_Id + is + EA_Id : Elaboration_Attributes_Id; begin - -- The search must come from the declarations of the body + EA_Id := UA_Map.Get (Unit_To_Attributes_Map, Unit_Id); - pragma Assert - (Is_Non_Empty_List (Decls) - and then List_Containing (Start) = Decls); + -- The unit lacks elaboration attributes. This indicates that the + -- unit is encountered for the first time. Create the elaboration + -- attributes for it. - -- The search finished inspecting the declarations. The construct - -- to inspect is the node which precedes the handled body, unless - -- the body is a compilation unit. The transitions are: - -- - -- declarations -> upper level - -- declarations -> corresponding package spec (Elab_Body) - -- declarations -> terminate + if not Present (EA_Id) then + Elaboration_Attributes.Append + ((Elab_Pragma => Empty, + With_Clause => Empty)); + EA_Id := Elaboration_Attributes.Last; - Transition_Unit (Bod, Curr); - end Transition_Body_Declarations; + -- Associate the elaboration attributes with the unit - ----------------------------------- - -- Transition_Handled_Statements -- - ----------------------------------- + UA_Map.Put (Unit_To_Attributes_Map, Unit_Id, EA_Id); + end if; + + pragma Assert (Present (EA_Id)); + + return EA_Id; + end Elaboration_Attributes_Of; - procedure Transition_Handled_Statements - (HSS : Node_Id; - Curr : out Node_Id) + ------------------------------ + -- Ensure_Prior_Elaboration -- + ------------------------------ + + procedure Ensure_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State) is - Bod : constant Node_Id := Parent (HSS); - Decls : constant List_Id := Declarations (Bod); - Stmts : constant List_Id := Statements (HSS); + pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); begin - -- The search must come from the statements of certain bodies or - -- statements. + -- Nothing to do when the need for prior elaboration came from a + -- partial finalization routine which occurs in an initialization + -- context. This behaviour parallels that of the old ABE mechanism. - pragma Assert (Nkind_In (Bod, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body)); + if In_State.Within_Partial_Finalization then + return; - -- The search must come from the statements of the handled sequence + -- Nothing to do when the need for prior elaboration came from a task + -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on + -- task bodies) is in effect. - pragma Assert - (Is_Non_Empty_List (Stmts) - and then List_Containing (Start) = Stmts); + elsif Debug_Flag_Dot_Y and then In_State.Within_Task_Body then + return; - -- The search finished inspecting the statements. The handled body - -- has non-empty declarations. The construct to inspect is the last - -- declaration. The transitions are: + -- Nothing to do when the unit is elaborated prior to the main unit. + -- This check must also consider the following cases: + -- + -- * No check is made against the context of the main unit because + -- this is specific to the elaboration model in effect and requires + -- custom handling (see Ensure_xxx_Prior_Elaboration). + -- + -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma + -- Elaborate[_All] MUST be generated even though Unit_Id is always + -- elaborated prior to the main unit. This conservative strategy + -- ensures that other units withed by Unit_Id will not lead to an + -- ABE. + -- + -- package A is package body A is + -- procedure ABE; procedure ABE is ... end ABE; + -- end A; end A; + -- + -- with A; + -- package B is package body B is + -- pragma Elaborate_Body; procedure Proc is + -- begin + -- procedure Proc; A.ABE; + -- package B; end Proc; + -- end B; -- - -- statements -> declarations + -- with B; + -- package C is package body C is + -- ... ... + -- end C; begin + -- B.Proc; + -- end C; + -- + -- In the example above, the elaboration of C invokes B.Proc. B is + -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] + -- is gnerated for B in C, then the following elaboratio order will + -- lead to an ABE: + -- + -- spec of A elaborated + -- spec of B elaborated + -- body of B elaborated + -- spec of C elaborated + -- body of C elaborated <-- calls B.Proc which calls A.ABE + -- body of A elaborated <-- problem + -- + -- The generation of an implicit pragma Elaborate_All (B) ensures + -- that the elaboration order mechanism will not pick the above + -- order. + -- + -- An implicit Elaborate is NOT generated when the unit is subject + -- to Elaborate_Body because both pragmas have the same effect. + -- + -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] + -- MUST NOT be generated in this case because a unit cannot depend + -- on its own elaboration. This case is therefore treated as valid + -- prior elaboration. + + elsif Has_Prior_Elaboration + (Unit_Id => Unit_Id, + Same_Unit_OK => True, + Elab_Body_OK => Prag_Nam = Name_Elaborate) + then + return; + end if; - if Has_Suitable_Construct (Decls) then - Curr := Last (Decls); + -- Suggest the use of pragma Prag_Nam when the dynamic model is in + -- effect. - -- Otherwise the handled body lacks declarations. The construct to - -- inspect is the node which precedes the handled body, unless the - -- body is a compilation unit. The transitions are: - -- - -- statements -> upper level - -- statements -> corresponding package spec (Elab_Body) - -- statements -> terminate + if Dynamic_Elaboration_Checks then + Ensure_Prior_Elaboration_Dynamic + (N => N, + Unit_Id => Unit_Id, + Prag_Nam => Prag_Nam, + In_State => In_State); + + -- Install an implicit pragma Prag_Nam when the static model is in + -- effect. else - Transition_Unit (Bod, Curr); + pragma Assert (Static_Elaboration_Checks); + + Ensure_Prior_Elaboration_Static + (N => N, + Unit_Id => Unit_Id, + Prag_Nam => Prag_Nam, + In_State => In_State); end if; - end Transition_Handled_Statements; + end Ensure_Prior_Elaboration; - ---------------------------------- - -- Transition_Spec_Declarations -- - ---------------------------------- + -------------------------------------- + -- Ensure_Prior_Elaboration_Dynamic -- + -------------------------------------- - procedure Transition_Spec_Declarations - (Spec : Node_Id; - Curr : out Node_Id) + procedure Ensure_Prior_Elaboration_Dynamic + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State) is - Prv_Decls : constant List_Id := Private_Declarations (Spec); - Vis_Decls : constant List_Id := Visible_Declarations (Spec); + procedure Info_Missing_Pragma; + pragma Inline (Info_Missing_Pragma); + -- Output information concerning missing Elaborate or Elaborate_All + -- pragma with name Prag_Nam for scenario N, which would ensure the + -- prior elaboration of Unit_Id. - begin - pragma Assert (Present (Start) and then Is_List_Member (Start)); + ------------------------- + -- Info_Missing_Pragma -- + ------------------------- - -- The search came from the private declarations and finished their - -- inspection. + procedure Info_Missing_Pragma is + begin + -- Internal units are ignored as they cause unnecessary noise - if Has_Suitable_Construct (Prv_Decls) - and then List_Containing (Start) = Prv_Decls - then - -- The context has non-empty visible declarations. The node to - -- inspect is the last visible declaration. The transitions are: - -- - -- private declarations -> visible declarations + if not In_Internal_Unit (Unit_Id) then - if Has_Suitable_Construct (Vis_Decls) then - Curr := Last (Vis_Decls); + -- The name of the unit subjected to the elaboration pragma is + -- fully qualified to improve the clarity of the info message. - -- Otherwise the context lacks visible declarations. The construct - -- to inspect is the node which precedes the context unless the - -- context is a compilation unit. The transitions are: - -- - -- private declarations -> upper level - -- private declarations -> terminate + Error_Msg_Name_1 := Prag_Nam; + Error_Msg_Qual_Level := Nat'Last; - else - Transition_Unit (Parent (Spec), Curr); + Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); + Error_Msg_Qual_Level := 0; end if; + end Info_Missing_Pragma; - -- The search came from the visible declarations and finished their - -- inspections. The construct to inspect is the node which precedes - -- the context, unless the context is a compilaton unit. The - -- transitions are: - -- - -- visible declarations -> upper level - -- visible declarations -> terminate + -- Local variables - elsif Has_Suitable_Construct (Vis_Decls) - and then List_Containing (Start) = Vis_Decls - then - Transition_Unit (Parent (Spec), Curr); + EA_Id : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Of (Unit_Id); + N_Lvl : Enclosing_Level_Kind; + N_Rep : Scenario_Rep_Id; - -- At this point both declarative lists are empty, but the traversal - -- still came from within the spec. This indicates that the invariant - -- of the algorithm has been violated. + -- Start of processing for Ensure_Prior_Elaboration_Dynamic - else - pragma Assert (False); - raise ECR_Found; + begin + -- Nothing to do when the unit is guaranteed prior elaboration by + -- means of a source Elaborate[_All] pragma. + + if Present (Elab_Pragma (EA_Id)) then + return; end if; - end Transition_Spec_Declarations; - --------------------- - -- Transition_Unit -- - --------------------- + -- Output extra information on a missing Elaborate[_All] pragma when + -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas + -- is in effect. - procedure Transition_Unit - (Unit : Node_Id; - Curr : out Node_Id) - is - Context : constant Node_Id := Parent (Unit); + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + N_Rep := Scenario_Representation_Of (N, In_State); + N_Lvl := Level (N_Rep); - begin - -- The unit is a compilation unit. This terminates the search because - -- there are no more lists to inspect and there are no more enclosing - -- constructs to climb up to. + -- Declaration-level scenario - if Nkind (Context) = N_Compilation_Unit then + if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) + and then N_Lvl = Declaration_Level + then + null; - -- A package body with a corresponding spec subject to pragma - -- Elaborate_Body is an exception to the above. The annotation - -- allows the search to continue into the package declaration. - -- The transitions are: - -- - -- statements -> corresponding package spec (Elab_Body) - -- declarations -> corresponding package spec (Elab_Body) + -- Library-level scenario - if Nkind (Unit) = N_Package_Body - and then (Assume_Elab_Body - or else Has_Pragma_Elaborate_Body - (Corresponding_Spec (Unit))) - then - Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); - Enter_Package_Declaration (Curr); + elsif N_Lvl in Library_Level then + null; - -- Otherwise terminate the search. The transitions are: - -- - -- private declarations -> terminate - -- visible declarations -> terminate - -- statements -> terminate - -- declarations -> terminate + -- Instantiation library-level scenario + + elsif N_Lvl = Instantiation_Level then + null; + + -- Otherwise the scenario does not appear at the proper level else - raise ECR_Found; + return; end if; - -- The unit is a subunit. The construct to inspect is the node which - -- precedes the corresponding stub. Update the early call region to - -- include the unit. + Info_Missing_Pragma; + end if; + end Ensure_Prior_Elaboration_Dynamic; - elsif Nkind (Context) = N_Subunit then - Start := Unit; - Curr := Corresponding_Stub (Context); + ------------------------------------- + -- Ensure_Prior_Elaboration_Static -- + ------------------------------------- - -- Otherwise the unit is nested. The construct to inspect is the node - -- which precedes the unit. Update the early call region to include - -- the unit. + procedure Ensure_Prior_Elaboration_Static + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State) + is + function Find_With_Clause + (Items : List_Id; + Withed_Id : Entity_Id) return Node_Id; + pragma Inline (Find_With_Clause); + -- Find a nonlimited with clause in the list of context items Items + -- that withs unit Withed_Id. Return Empty if no such clause exists. + + procedure Info_Implicit_Pragma; + pragma Inline (Info_Implicit_Pragma); + -- Output information concerning an implicitly generated Elaborate + -- or Elaborate_All pragma with name Prag_Nam for scenario N which + -- ensures the prior elaboration of unit Unit_Id. + + ---------------------- + -- Find_With_Clause -- + ---------------------- + + function Find_With_Clause + (Items : List_Id; + Withed_Id : Entity_Id) return Node_Id + is + Item : Node_Id; - else - Include (Unit, Curr); - end if; - end Transition_Unit; + begin + -- Examine the context clauses looking for a suitable with. Note + -- that limited clauses do not affect the elaboration order. - -- Local variables + Item := First (Items); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then not Error_Posted (Item) + and then not Limited_Present (Item) + and then Entity (Name (Item)) = Withed_Id + then + return Item; + end if; - Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); - Region : Node_Id; + Next (Item); + end loop; - -- Start of processing for Find_Early_Call_Region + return Empty; + end Find_With_Clause; - begin - -- The caller demands the start of the early call region without saving - -- or retrieving it to/from internal data structures. + -------------------------- + -- Info_Implicit_Pragma -- + -------------------------- - if Skip_Memoization then - Region := Find_ECR (Body_Decl); + procedure Info_Implicit_Pragma is + begin + -- Internal units are ignored as they cause unnecessary noise - -- Default behavior + if not In_Internal_Unit (Unit_Id) then - else - -- Check whether the early call region of the subprogram body is - -- available. + -- The name of the unit subjected to the elaboration pragma is + -- fully qualified to improve the clarity of the info message. - Region := Early_Call_Region (Body_Id); + Error_Msg_Name_1 := Prag_Nam; + Error_Msg_Qual_Level := Nat'Last; - if No (Region) then + Error_Msg_NE + ("info: implicit pragma % generated for unit &", N, Unit_Id); - -- Traverse the declarations in reverse order, starting from the - -- subprogram body, searching for the nearest non-preelaborable - -- construct. The early call region starts after this construct - -- and ends at the subprogram body. + Error_Msg_Qual_Level := 0; + Output_Active_Scenarios (N, In_State); + end if; + end Info_Implicit_Pragma; - Region := Find_ECR (Body_Decl); + -- Local variables - -- Associate the early call region with the subprogram body in - -- case other scenarios need it. + EA_Id : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Of (Unit_Id); - Set_Early_Call_Region (Body_Id, Region); - end if; - end if; + Main_Cunit : constant Node_Id := Cunit (Main_Unit); + Loc : constant Source_Ptr := Sloc (Main_Cunit); + Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); + Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); + Unit_With : constant Node_Id := With_Clause (EA_Id); - -- A subprogram body must always have an early call region + Clause : Node_Id; + Items : List_Id; - pragma Assert (Present (Region)); + -- Start of processing for Ensure_Prior_Elaboration_Static - return Region; - end Find_Early_Call_Region; + begin + -- Nothing to do when the caller has suppressed the generation of + -- implicit Elaborate[_All] pragmas. - --------------------------- - -- Find_Elaborated_Units -- - --------------------------- + if In_State.Suppress_Implicit_Pragmas then + return; - procedure Find_Elaborated_Units is - procedure Add_Pragma (Prag : Node_Id); - -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma. - -- If this is the case, add the related unit to the elaboration context. - -- For pragma Elaborate_All, include recursively all units withed by the - -- related unit. + -- Nothing to do when the unit is guaranteed prior elaboration by + -- means of a source Elaborate[_All] pragma. - procedure Add_Unit - (Unit_Id : Entity_Id; - Prag : Node_Id; - Full_Context : Boolean); - -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma - -- which prompted the inclusion of the unit to the elaboration context. - -- If flag Full_Context is set, examine the nonlimited clauses of unit - -- Unit_Id and add each withed unit to the context. + elsif Present (Unit_Prag) then + return; - procedure Find_Elaboration_Context (Comp_Unit : Node_Id); - -- Examine the context items of compilation unit Comp_Unit for suitable - -- elaboration-related pragmas and add all related units to the context. + -- Nothing to do when the unit has an existing implicit Elaborate or + -- Elaborate_All pragma installed by a previous scenario. - ---------------- - -- Add_Pragma -- - ---------------- + elsif Present (Unit_With) then - procedure Add_Pragma (Prag : Node_Id) is - Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag); - Prag_Nam : constant Name_Id := Pragma_Name (Prag); - Unit_Arg : Node_Id; + -- The unit is already guaranteed prior elaboration by means of an + -- implicit Elaborate pragma, however the current scenario imposes + -- a stronger requirement of Elaborate_All. "Upgrade" the existing + -- pragma to match this new requirement. - begin - -- Nothing to do if the pragma is not related to elaboration + if Elaborate_Desirable (Unit_With) + and then Prag_Nam = Name_Elaborate_All + then + Set_Elaborate_All_Desirable (Unit_With); + Set_Elaborate_Desirable (Unit_With, False); + end if; - if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then return; + end if; - -- Nothing to do when the pragma is illegal + -- At this point it is known that the unit has no prior elaboration + -- according to pragmas and hierarchical relationships. - elsif Error_Posted (Prag) then - return; + Items := Context_Items (Main_Cunit); + + if No (Items) then + Items := New_List; + Set_Context_Items (Main_Cunit, Items); end if; - Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); + -- Locate the with clause for the unit. Note that there may not be a + -- clause if the unit is visible through a subunit-body, body-spec, + -- or spec-parent relationship. - -- The argument of the pragma may appear in package.package form + Clause := + Find_With_Clause + (Items => Items, + Withed_Id => Unit_Id); + + -- Generate: + -- with Id; - if Nkind (Unit_Arg) = N_Selected_Component then - Unit_Arg := Selector_Name (Unit_Arg); + -- Note that adding implicit with clauses is safe because analysis, + -- resolution, and expansion have already taken place and it is not + -- possible to interfere with visibility. + + if No (Clause) then + Clause := + Make_With_Clause (Loc, + Name => New_Occurrence_Of (Unit_Id, Loc)); + + Set_Implicit_With (Clause); + Set_Library_Unit (Clause, Unit_Cunit); + + Append_To (Items, Clause); end if; - Add_Unit - (Unit_Id => Entity (Unit_Arg), - Prag => Prag, - Full_Context => Prag_Nam = Name_Elaborate_All); - end Add_Pragma; + -- Mark the with clause depending on the pragma required - -------------- - -- Add_Unit -- - -------------- + if Prag_Nam = Name_Elaborate then + Set_Elaborate_Desirable (Clause); + else + Set_Elaborate_All_Desirable (Clause); + end if; + + -- The implicit Elaborate[_All] ensures the prior elaboration of + -- the unit. Include the unit in the elaboration context of the + -- main unit. + + Set_With_Clause (EA_Id, Clause); + + -- Output extra information on an implicit Elaborate[_All] pragma + -- when switch -gnatel (info messages on implicit Elaborate[_All] + -- pragmas is in effect. + + if Elab_Info_Messages then + Info_Implicit_Pragma; + end if; + end Ensure_Prior_Elaboration_Static; + + ------------------------------- + -- Finalize_Elaborated_Units -- + ------------------------------- + + procedure Finalize_Elaborated_Units is + begin + UA_Map.Destroy (Unit_To_Attributes_Map); + end Finalize_Elaborated_Units; - procedure Add_Unit + --------------------------- + -- Has_Prior_Elaboration -- + --------------------------- + + function Has_Prior_Elaboration (Unit_Id : Entity_Id; - Prag : Node_Id; - Full_Context : Boolean) + Context_OK : Boolean := False; + Elab_Body_OK : Boolean := False; + Same_Unit_OK : Boolean := False) return Boolean is - Clause : Node_Id; - Elab_Attrs : Elaboration_Attributes; + EA_Id : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Of (Unit_Id); + + Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); + Unit_With : constant Node_Id := With_Clause (EA_Id); begin - -- Nothing to do when some previous error left a with clause or a - -- pragma in a bad state. + -- A preelaborated unit is always elaborated prior to the main unit - if No (Unit_Id) then - return; + if Is_Preelaborated_Unit (Unit_Id) then + return True; + + -- An internal unit is always elaborated prior to a non-internal main + -- unit. + + elsif In_Internal_Unit (Unit_Id) + and then not In_Internal_Unit (Main_Id) + then + return True; + + -- A unit has prior elaboration if it appears within the context + -- of the main unit. Consider this case only when requested by the + -- caller. + + elsif Context_OK + and then (Present (Unit_Prag) or else Present (Unit_With)) + then + return True; + + -- A unit whose body is elaborated together with its spec has prior + -- elaboration except with respect to itself. Consider this case only + -- when requested by the caller. + + elsif Elab_Body_OK + and then Has_Pragma_Elaborate_Body (Unit_Id) + and then not Is_Same_Unit (Unit_Id, Main_Id) + then + return True; + + -- A unit has no prior elaboration with respect to itself, but does + -- not require any means of ensuring its own elaboration either. + -- Treat this case as valid prior elaboration only when requested by + -- the caller. + + elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then + return True; end if; - Elab_Attrs := Elaboration_Status (Unit_Id); + return False; + end Has_Prior_Elaboration; - -- The unit is already included in the context by means of pragma - -- Elaborate[_All]. + --------------------------------- + -- Initialize_Elaborated_Units -- + --------------------------------- - if Present (Elab_Attrs.Source_Pragma) then + procedure Initialize_Elaborated_Units is + begin + null; + end Initialize_Elaborated_Units; - -- Upgrade an existing pragma Elaborate when the unit is subject - -- to Elaborate_All because the new pragma covers a larger set of - -- units. + ---------------------------------- + -- Meet_Elaboration_Requirement -- + ---------------------------------- - if Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate - and then Pragma_Name (Prag) = Name_Elaborate_All - then - Elab_Attrs.Source_Pragma := Prag; + procedure Meet_Elaboration_Requirement + (N : Node_Id; + Targ_Id : Entity_Id; + Req_Nam : Name_Id; + In_State : Processing_In_State) + is + pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); + + Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id); - -- Otherwise the unit retains its existing pragma and does not - -- need to be included in the context again. + procedure Elaboration_Requirement_Error; + pragma Inline (Elaboration_Requirement_Error); + -- Emit an error concerning scenario N which has failed to meet the + -- elaboration requirement. + + function Find_Preelaboration_Pragma + (Prag_Nam : Name_Id) return Node_Id; + pragma Inline (Find_Preelaboration_Pragma); + -- Traverse the visible declarations of unit Unit_Id and locate a + -- source preelaboration-related pragma with name Prag_Nam. + + procedure Info_Requirement_Met (Prag : Node_Id); + pragma Inline (Info_Requirement_Met); + -- Output information concerning pragma Prag which meets requirement + -- Req_Nam. + + ----------------------------------- + -- Elaboration_Requirement_Error -- + ----------------------------------- + + procedure Elaboration_Requirement_Error is + begin + if Is_Suitable_Call (N) then + Info_Call + (Call => N, + Subp_Id => Targ_Id, + Info_Msg => False, + In_SPARK => True); + + elsif Is_Suitable_Instantiation (N) then + Info_Instantiation + (Inst => N, + Gen_Id => Targ_Id, + Info_Msg => False, + In_SPARK => True); + + elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then + Error_Msg_N + ("read of refinement constituents during elaboration in " + & "SPARK", N); + + elsif Is_Suitable_Variable_Reference (N) then + Info_Variable_Reference + (Ref => N, + Var_Id => Targ_Id, + Info_Msg => False, + In_SPARK => True); + + -- No other scenario may impose a requirement on the context of + -- the main unit. else + pragma Assert (False); return; end if; - -- The current unit is not part of the context. Prepare a new set of - -- attributes. + Error_Msg_Name_1 := Req_Nam; + Error_Msg_Node_2 := Unit_Id; + Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); - else - Elab_Attrs := - Elaboration_Attributes'(Source_Pragma => Prag, - With_Clause => Empty); - end if; + Output_Active_Scenarios (N, In_State); + end Elaboration_Requirement_Error; - -- Add or update the attributes of the unit + -------------------------------- + -- Find_Preelaboration_Pragma -- + -------------------------------- - Set_Elaboration_Status (Unit_Id, Elab_Attrs); + function Find_Preelaboration_Pragma + (Prag_Nam : Name_Id) return Node_Id + is + Spec : constant Node_Id := Parent (Unit_Id); + Decl : Node_Id; - -- Includes all units withed by the current one when computing the - -- full context. + begin + -- A preelaboration-related pragma comes from source and appears + -- at the top of the visible declarations of a package. - if Full_Context then + if Nkind (Spec) = N_Package_Specification then + Decl := First (Visible_Declarations (Spec)); + while Present (Decl) loop + if Comes_From_Source (Decl) then + if Nkind (Decl) = N_Pragma + and then Pragma_Name (Decl) = Prag_Nam + then + return Decl; - -- Process all nonlimited with clauses found in the context of - -- the current unit. Note that limited clauses do not impose an - -- elaboration order. + -- Otherwise the construct terminates the region where + -- the preelaboration-related pragma may appear. - Clause := First (Context_Items (Compilation_Unit (Unit_Id))); - while Present (Clause) loop - if Nkind (Clause) = N_With_Clause - and then not Error_Posted (Clause) - and then not Limited_Present (Clause) - then - Add_Unit - (Unit_Id => Entity (Name (Clause)), - Prag => Prag, - Full_Context => Full_Context); - end if; + else + exit; + end if; + end if; - Next (Clause); - end loop; - end if; - end Add_Unit; + Next (Decl); + end loop; + end if; - ------------------------------ - -- Find_Elaboration_Context -- - ------------------------------ + return Empty; + end Find_Preelaboration_Pragma; - procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is - Prag : Node_Id; + -------------------------- + -- Info_Requirement_Met -- + -------------------------- + + procedure Info_Requirement_Met (Prag : Node_Id) is + pragma Assert (Present (Prag)); + + begin + Error_Msg_Name_1 := Req_Nam; + Error_Msg_Sloc := Sloc (Prag); + Error_Msg_NE + ("\\% requirement for unit & met by pragma #", N, Unit_Id); + end Info_Requirement_Met; + + -- Local variables + + EA_Id : Elaboration_Attributes_Id; + Elab_Nam : Name_Id; + Req_Met : Boolean; + Unit_Prag : Node_Id; + + -- Start of processing for Meet_Elaboration_Requirement begin - pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); + -- Assume that the requirement has not been met - -- Process all elaboration-related pragmas found in the context of - -- the compilation unit. + Req_Met := False; - Prag := First (Context_Items (Comp_Unit)); - while Present (Prag) loop - if Nkind (Prag) = N_Pragma then - Add_Pragma (Prag); - end if; + -- If the target is within the main unit, either at the source level + -- or through an instantiation, then there is no real requirement to + -- meet because the main unit cannot force its own elaboration by + -- means of an Elaborate[_All] pragma. Treat this case as valid + -- coverage. - Next (Prag); - end loop; - end Find_Elaboration_Context; + if In_Extended_Main_Code_Unit (Targ_Id) then + Req_Met := True; - -- Local variables + -- Otherwise the target resides in an external unit - Par_Id : Entity_Id; - Unt : Node_Id; + -- The requirement is met when the target comes from an internal unit + -- because such a unit is elaborated prior to a non-internal unit. - -- Start of processing for Find_Elaborated_Units + elsif In_Internal_Unit (Unit_Id) + and then not In_Internal_Unit (Main_Id) + then + Req_Met := True; - begin - -- Perform a traversal which examines the context of the main unit and - -- populates the Elaboration_Context table with all units elaborated - -- prior to the main unit. The traversal performs the following jumps: + -- The requirement is met when the target comes from a preelaborated + -- unit. This portion must parallel predicate Is_Preelaborated_Unit. - -- subunit -> parent subunit - -- parent subunit -> body - -- body -> spec - -- spec -> parent spec - -- parent spec -> grandparent spec and so on + elsif Is_Preelaborated_Unit (Unit_Id) then + Req_Met := True; - -- The traversal relies on units rather than scopes because the scope of - -- a subunit is some spec, while this traversal must process the body as - -- well. Given that protected and task bodies can also be subunits, this - -- complicates the scope approach even further. + -- Output extra information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas. - Unt := Unit (Cunit (Main_Unit)); + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + if Is_Preelaborated (Unit_Id) then + Elab_Nam := Name_Preelaborate; - -- Perform the following traversals when the main unit is a subunit + elsif Is_Pure (Unit_Id) then + Elab_Nam := Name_Pure; - -- subunit -> parent subunit - -- parent subunit -> body + elsif Is_Remote_Call_Interface (Unit_Id) then + Elab_Nam := Name_Remote_Call_Interface; - while Present (Unt) and then Nkind (Unt) = N_Subunit loop - Find_Elaboration_Context (Parent (Unt)); + elsif Is_Remote_Types (Unit_Id) then + Elab_Nam := Name_Remote_Types; - -- Continue the traversal by going to the unit which contains the - -- corresponding stub. + else + pragma Assert (Is_Shared_Passive (Unit_Id)); + Elab_Nam := Name_Shared_Passive; + end if; - if Present (Corresponding_Stub (Unt)) then - Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unt)))); + Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); + end if; - -- Otherwise the subunit may be erroneous or left in a bad state + -- Determine whether the context of the main unit has a pragma strong + -- enough to meet the requirement. else - exit; - end if; - end loop; + EA_Id := Elaboration_Attributes_Of (Unit_Id); + Unit_Prag := Elab_Pragma (EA_Id); - -- Perform the following traversal now that subunits have been taken - -- care of, or the main unit is a body. + -- The pragma must be either Elaborate_All or be as strong as the + -- requirement. - -- body -> spec + if Present (Unit_Prag) + and then Nam_In (Pragma_Name (Unit_Prag), Name_Elaborate_All, + Req_Nam) + then + Req_Met := True; - if Present (Unt) - and then Nkind_In (Unt, N_Package_Body, N_Subprogram_Body) - then - Find_Elaboration_Context (Parent (Unt)); + -- Output extra information when switch -gnatel (info messages + -- on implicit Elaborate[_All] pragmas. - -- Continue the traversal by going to the unit which contains the - -- corresponding spec. + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + Info_Requirement_Met (Unit_Prag); + end if; + end if; + end if; + + -- The requirement was not met by the context of the main unit, issue + -- an error. - if Present (Corresponding_Spec (Unt)) then - Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unt)))); + if not Req_Met then + Elaboration_Requirement_Error; end if; - end if; + end Meet_Elaboration_Requirement; - -- Perform the following traversals now that the body has been taken - -- care of, or the main unit is a spec. + ------------- + -- Present -- + ------------- - -- spec -> parent spec - -- parent spec -> grandparent spec and so on + function Present (EA_Id : Elaboration_Attributes_Id) return Boolean is + begin + return EA_Id /= No_Elaboration_Attributes; + end Present; - if Present (Unt) - and then Nkind_In (Unt, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Subprogram_Declaration) - then - Find_Elaboration_Context (Parent (Unt)); + --------------------- + -- Set_Elab_Pragma -- + --------------------- - -- Process a potential chain of parent units which ends with the - -- main unit spec. The traversal can now safely rely on the scope - -- chain. + procedure Set_Elab_Pragma + (EA_Id : Elaboration_Attributes_Id; + Prag : Node_Id) + is + pragma Assert (Present (EA_Id)); + begin + Elaboration_Attributes.Table (EA_Id).Elab_Pragma := Prag; + end Set_Elab_Pragma; - Par_Id := Scope (Defining_Entity (Unt)); - while Present (Par_Id) and then Par_Id /= Standard_Standard loop - Find_Elaboration_Context (Compilation_Unit (Par_Id)); + --------------------- + -- Set_With_Clause -- + --------------------- - Par_Id := Scope (Par_Id); - end loop; - end if; - end Find_Elaborated_Units; + procedure Set_With_Clause + (EA_Id : Elaboration_Attributes_Id; + Clause : Node_Id) + is + pragma Assert (Present (EA_Id)); + begin + Elaboration_Attributes.Table (EA_Id).With_Clause := Clause; + end Set_With_Clause; + + ----------------- + -- With_Clause -- + ----------------- + + function With_Clause + (EA_Id : Elaboration_Attributes_Id) return Node_Id + is + pragma Assert (Present (EA_Id)); + begin + return Elaboration_Attributes.Table (EA_Id).With_Clause; + end With_Clause; + end Elaborated_Units; ----------------------------- -- Find_Enclosing_Instance -- ----------------------------- function Find_Enclosing_Instance (N : Node_Id) return Node_Id is - Par : Node_Id; - Spec_Id : Entity_Id; + Par : Node_Id; begin -- Climb the parent chain looking for an enclosing instance spec or body Par := N; while Present (Par) loop - - -- Generic package or subprogram spec - - if Nkind_In (Par, N_Package_Declaration, + if Nkind_In (Par, N_Package_Body, + N_Package_Declaration, + N_Subprogram_Body, N_Subprogram_Declaration) - and then Is_Generic_Instance (Defining_Entity (Par)) + and then Is_Generic_Instance (Unique_Defining_Entity (Par)) then return Par; - - -- Generic package or subprogram body - - elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then - Spec_Id := Corresponding_Spec (Par); - - if Present (Spec_Id) and then Is_Generic_Instance (Spec_Id) then - return Par; - end if; end if; Par := Parent (Par); @@ -5340,6 +8833,7 @@ package body Sem_Elab is function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind; + pragma Inline (Level_Of); -- Obtain the corresponding level of unit Unit -------------- @@ -5351,13 +8845,13 @@ package body Sem_Elab is begin if Nkind (Unit) in N_Generic_Instantiation then - return Instantiation; + return Instantiation_Level; elsif Nkind (Unit) = N_Generic_Package_Declaration then - return Generic_Package_Spec; + return Generic_Spec_Level; elsif Nkind (Unit) = N_Package_Declaration then - return Package_Spec; + return Library_Spec_Level; elsif Nkind (Unit) = N_Package_Body then Spec_Id := Corresponding_Spec (Unit); @@ -5367,14 +8861,14 @@ package body Sem_Elab is if Present (Spec_Id) and then Ekind (Spec_Id) = E_Generic_Package then - return Generic_Package_Body; + return Generic_Body_Level; -- Otherwise the body belongs to a non-generic package. This also -- treats an illegal package body without a corresponding spec as -- a non-generic package body. else - return Package_Body; + return Library_Body_Level; end if; end if; @@ -5472,9 +8966,9 @@ package body Sem_Elab is end if; -- The current construct is a non-library-level encapsulator which - -- indicates that the node cannot possibly appear at any level. - -- Note that this check must come after the declaration-level check - -- because both predicates share certain nodes. + -- indicates that the node cannot possibly appear at any level. Note + -- that the check must come after the declaration-level check because + -- both predicates share certain nodes. elsif Is_Non_Library_Level_Encapsulator (Curr) then Context := Parent (Curr); @@ -5591,22 +9085,554 @@ package body Sem_Elab is return Empty; end First_Formal_Type; + ------------------------------ + -- Guaranteed_ABE_Processor -- + ------------------------------ + + package body Guaranteed_ABE_Processor is + function Is_Guaranteed_ABE + (N : Node_Id; + Target_Decl : Node_Id; + Target_Body : Node_Id) return Boolean; + pragma Inline (Is_Guaranteed_ABE); + -- Determine whether scenario N with a target described by its initial + -- declaration Target_Decl and body Target_Decl results in a guaranteed + -- ABE. + + procedure Process_Guaranteed_ABE_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Guaranteed_ABE_Activation); + -- Perform common guaranteed ABE checks and diagnostics for activation + -- call Call which activates object Obj_Id of task type Task_Typ. Formal + -- Call_Rep denotes the representation of the call. Obj_Rep denotes the + -- representation of the object. Task_Rep denotes the representation of + -- the task type. In_State is the current state of the Processing phase. + + procedure Process_Guaranteed_ABE_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Guaranteed_ABE_Call); + -- Perform common guaranteed ABE checks and diagnostics for call Call + -- with representation Call_Rep. In_State denotes the current state of + -- the Processing phase. + + procedure Process_Guaranteed_ABE_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Guaranteed_ABE_Instantiation); + -- Perform common guaranteed ABE checks and diagnostics for instance + -- Inst with representation Inst_Rep. In_State is the current state of + -- the Processing phase. + + ----------------------- + -- Is_Guaranteed_ABE -- + ----------------------- + + function Is_Guaranteed_ABE + (N : Node_Id; + Target_Decl : Node_Id; + Target_Body : Node_Id) return Boolean + is + begin + -- Avoid cascaded errors if there were previous serious infractions. + -- As a result the scenario will not be treated as a guaranteed ABE. + -- This behaviour parallels that of the old ABE mechanism. + + if Serious_Errors_Detected > 0 then + return False; + + -- The scenario and the target appear in the same context ignoring + -- enclosing library levels. + + elsif In_Same_Context (N, Target_Decl) then + + -- The target body has already been encountered. The scenario + -- results in a guaranteed ABE if it appears prior to the body. + + if Present (Target_Body) then + return Earlier_In_Extended_Unit (N, Target_Body); + + -- Otherwise the body has not been encountered yet. The scenario + -- is a guaranteed ABE since the body will appear later. It is + -- assumed that the caller has already ensured that the scenario + -- is ABE-safe because optional bodies are not considered here. + + else + return True; + end if; + end if; + + return False; + end Is_Guaranteed_ABE; + + ---------------------------- + -- Process_Guaranteed_ABE -- + ---------------------------- + + procedure Process_Guaranteed_ABE + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); + Scen_Rep : Scenario_Rep_Id; + + begin + -- Add the current scenario to the stack of active scenarios + + Push_Active_Scenario (Scen); + + -- Only calls, instantiations, and task activations may result in a + -- guaranteed ABE. + + -- Call or task activation + + if Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); + + if Kind (Scen_Rep) = Call_Scenario then + Process_Guaranteed_ABE_Call + (Call => Scen, + Call_Rep => Scen_Rep, + In_State => In_State); + + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); + + Process_Activation + (Call => Scen, + Call_Rep => Scenario_Representation_Of (Scen, In_State), + Processor => Process_Guaranteed_ABE_Activation'Access, + In_State => In_State); + end if; + + -- Instantiation + + elsif Is_Suitable_Instantiation (Scen) then + Process_Guaranteed_ABE_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); + end if; + + -- Remove the current scenario from the stack of active scenarios + -- once all ABE diagnostics and checks have been performed. + + Pop_Active_Scenario (Scen); + end Process_Guaranteed_ABE; + + --------------------------------------- + -- Process_Guaranteed_ABE_Activation -- + --------------------------------------- + + procedure Process_Guaranteed_ABE_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Obj_Rep) + and then Elaboration_Checks_OK (Task_Rep); + -- A run-time ABE check may be installed only when the object and the + -- task type have active elaboration checks, and both are not ignored + -- Ghost constructs. + + begin + -- Nothing to do when the root scenario appears at the declaration + -- level and the task is in the same unit, but outside this context. + -- + -- task type Task_Typ; -- task declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- T : Task_Typ; + -- begin + -- <activation call> -- activation site + -- end; + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- task body Task_Typ is + -- ... + -- end Task_Typ; + -- + -- In the example above, the context of X is the declarative list + -- of Proc. The "elaboration" of X may reach the activation of T + -- whose body is defined outside of X's context. The task body is + -- relevant only when Proc is invoked, but this happens only in + -- "normal" elaboration, therefore the task body must not be + -- considered if this is not the case. + + if Is_Up_Level_Target + (Targ_Decl => Spec_Decl, + In_State => In_State) + then + return; + + -- Nothing to do when the activation is ABE-safe + -- + -- generic + -- package Gen is + -- task type Task_Typ; + -- end Gen; + -- + -- package body Gen is + -- task body Task_Typ is + -- begin + -- ... + -- end Task_Typ; + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- package Nested is + -- package Inst is new Gen; + -- T : Inst.Task_Typ; + -- end Nested; -- safe activation + -- ... + + elsif Is_Safe_Activation (Call, Task_Rep) then + return; + + -- An activation call leads to a guaranteed ABE when the activation + -- call and the task appear within the same context ignoring library + -- levels, and the body of the task has not been seen yet or appears + -- after the activation call. + -- + -- procedure Guaranteed_ABE is + -- task type Task_Typ; + -- + -- package Nested is + -- T : Task_Typ; + -- <activation call> -- guaranteed ABE + -- end Nested; + -- + -- task body Task_Typ is + -- ... + -- end Task_Typ; + -- ... + + elsif Is_Guaranteed_ABE + (N => Call, + Target_Decl => Spec_Decl, + Target_Body => Body_Declaration (Task_Rep)) + then + if Elaboration_Warnings_OK (Call_Rep) then + Error_Msg_Sloc := Sloc (Call); + Error_Msg_N + ("??task & will be activated # before elaboration of its " + & "body", Obj_Id); + Error_Msg_N + ("\Program_Error will be raised at run time", Obj_Id); + end if; + + -- Mark the activation call as a guaranteed ABE + + Set_Is_Known_Guaranteed_ABE (Call); + + -- Install a run-time ABE failue because this activation call will + -- always result in an ABE. + + if Check_OK then + Install_Scenario_ABE_Failure + (N => Call, + Targ_Id => Task_Typ, + Targ_Rep => Task_Rep, + Disable => Obj_Rep); + end if; + end if; + end Process_Guaranteed_ABE_Activation; + + --------------------------------- + -- Process_Guaranteed_ABE_Call -- + --------------------------------- + + procedure Process_Guaranteed_ABE_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + Subp_Id : constant Entity_Id := Target (Call_Rep); + Subp_Rep : constant Target_Rep_Id := + Target_Representation_Of (Subp_Id, In_State); + Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Call_Rep) + and then Elaboration_Checks_OK (Subp_Rep); + -- A run-time ABE check may be installed only when both the call + -- and the target have active elaboration checks, and both are not + -- ignored Ghost constructs. + + begin + -- Nothing to do when the root scenario appears at the declaration + -- level and the target is in the same unit but outside this context. + -- + -- function B ...; -- target declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- function B ... is + -- ... + -- end B; + -- + -- In the example above, the context of X is the declarative region + -- of Proc. The "elaboration" of X may eventually reach B which is + -- defined outside of X's context. B is relevant only when Proc is + -- invoked, but this happens only by means of "normal" elaboration, + -- therefore B must not be considered if this is not the case. + + if Is_Up_Level_Target + (Targ_Decl => Spec_Decl, + In_State => In_State) + then + return; + + -- Nothing to do when the call is ABE-safe + -- + -- generic + -- function Gen ...; + -- + -- function Gen ... is + -- begin + -- ... + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- function Inst is new Gen; + -- X : ... := Inst; -- safe call + -- ... + + elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then + return; + + -- A call leads to a guaranteed ABE when the call and the target + -- appear within the same context ignoring library levels, and the + -- body of the target has not been seen yet or appears after the + -- call. + -- + -- procedure Guaranteed_ABE is + -- function Func ...; + -- + -- package Nested is + -- Obj : ... := Func; -- guaranteed ABE + -- end Nested; + -- + -- function Func ... is + -- ... + -- end Func; + -- ... + + elsif Is_Guaranteed_ABE + (N => Call, + Target_Decl => Spec_Decl, + Target_Body => Body_Declaration (Subp_Rep)) + then + if Elaboration_Warnings_OK (Call_Rep) then + Error_Msg_NE + ("??cannot call & before body seen", Call, Subp_Id); + Error_Msg_N ("\Program_Error will be raised at run time", Call); + end if; + + -- Mark the call as a guarnateed ABE + + Set_Is_Known_Guaranteed_ABE (Call); + + -- Install a run-time ABE failure because the call will always + -- result in an ABE. + + if Check_OK then + Install_Scenario_ABE_Failure + (N => Call, + Targ_Id => Subp_Id, + Targ_Rep => Subp_Rep, + Disable => Call_Rep); + end if; + end if; + end Process_Guaranteed_ABE_Call; + + ------------------------------------------ + -- Process_Guaranteed_ABE_Instantiation -- + ------------------------------------------ + + procedure Process_Guaranteed_ABE_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + Gen_Id : constant Entity_Id := Target (Inst_Rep); + Gen_Rep : constant Target_Rep_Id := + Target_Representation_Of (Gen_Id, In_State); + Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Inst_Rep) + and then Elaboration_Checks_OK (Gen_Rep); + -- A run-time ABE check may be installed only when both the instance + -- and the generic have active elaboration checks and both are not + -- ignored Ghost constructs. + + begin + -- Nothing to do when the root scenario appears at the declaration + -- level and the generic is in the same unit, but outside this + -- context. + -- + -- generic + -- procedure Gen is ...; -- generic declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- procedure I is new Gen; -- instantiation site + -- ... + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- procedure Gen is + -- ... + -- end Gen; + -- + -- In the example above, the context of X is the declarative region + -- of Proc. The "elaboration" of X may eventually reach Gen which + -- appears outside of X's context. Gen is relevant only when Proc is + -- invoked, but this happens only by means of "normal" elaboration, + -- therefore Gen must not be considered if this is not the case. + + if Is_Up_Level_Target + (Targ_Decl => Spec_Decl, + In_State => In_State) + then + return; + + -- Nothing to do when the instantiation is ABE-safe + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- package body Gen is + -- ... + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- package Inst is new Gen (ABE); -- safe instantiation + -- ... + + elsif Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then + return; + + -- An instantiation leads to a guaranteed ABE when the instantiation + -- and the generic appear within the same context ignoring library + -- levels, and the body of the generic has not been seen yet or + -- appears after the instantiation. + -- + -- procedure Guaranteed_ABE is + -- generic + -- procedure Gen; + -- + -- package Nested is + -- procedure Inst is new Gen; -- guaranteed ABE + -- end Nested; + -- + -- procedure Gen is + -- ... + -- end Gen; + -- ... + + elsif Is_Guaranteed_ABE + (N => Inst, + Target_Decl => Spec_Decl, + Target_Body => Body_Declaration (Gen_Rep)) + then + if Elaboration_Warnings_OK (Inst_Rep) then + Error_Msg_NE + ("??cannot instantiate & before body seen", Inst, Gen_Id); + Error_Msg_N ("\Program_Error will be raised at run time", Inst); + end if; + + -- Mark the instantiation as a guarantee ABE. This automatically + -- suppresses the instantiation of the generic body. + + Set_Is_Known_Guaranteed_ABE (Inst); + + -- Install a run-time ABE failure because the instantiation will + -- always result in an ABE. + + if Check_OK then + Install_Scenario_ABE_Failure + (N => Inst, + Targ_Id => Gen_Id, + Targ_Rep => Gen_Rep, + Disable => Inst_Rep); + end if; + end if; + end Process_Guaranteed_ABE_Instantiation; + end Guaranteed_ABE_Processor; + -------------- -- Has_Body -- -------------- function Has_Body (Pack_Decl : Node_Id) return Boolean is function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id; + pragma Inline (Find_Corresponding_Body); -- Try to locate the corresponding body of spec Spec_Id. If no body is -- found, return Empty. function Find_Body (Spec_Id : Entity_Id; From : Node_Id) return Node_Id; + pragma Inline (Find_Body); -- Try to locate the corresponding body of spec Spec_Id in the node list -- which follows arbitrary node From. If no body is found, return Empty. function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id; + pragma Inline (Load_Package_Body); -- Attempt to load the body of unit Unit_Nam. If the load failed, return -- Empty. If the compilation will not generate code, return Empty. @@ -5823,60 +9849,15 @@ package body Sem_Elab is end if; end Has_Body; - --------------------------- - -- Has_Prior_Elaboration -- - --------------------------- - - function Has_Prior_Elaboration - (Unit_Id : Entity_Id; - Context_OK : Boolean := False; - Elab_Body_OK : Boolean := False; - Same_Unit_OK : Boolean := False) return Boolean - is - Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + ---------- + -- Hash -- + ---------- + function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type is + pragma Assert (Present (NE)); begin - -- A preelaborated unit is always elaborated prior to the main unit - - if Is_Preelaborated_Unit (Unit_Id) then - return True; - - -- An internal unit is always elaborated prior to a non-internal main - -- unit. - - elsif In_Internal_Unit (Unit_Id) - and then not In_Internal_Unit (Main_Id) - then - return True; - - -- A unit has prior elaboration if it appears within the context of the - -- main unit. Consider this case only when requested by the caller. - - elsif Context_OK - and then Elaboration_Status (Unit_Id) /= No_Elaboration_Attributes - then - return True; - - -- A unit whose body is elaborated together with its spec has prior - -- elaboration except with respect to itself. Consider this case only - -- when requested by the caller. - - elsif Elab_Body_OK - and then Has_Pragma_Elaborate_Body (Unit_Id) - and then not Is_Same_Unit (Unit_Id, Main_Id) - then - return True; - - -- A unit has no prior elaboration with respect to itself, but does not - -- require any means of ensuring its own elaboration either. Treat this - -- case as valid prior elaboration only when requested by the caller. - - elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then - return True; - end if; - - return False; - end Has_Prior_Elaboration; + return Bucket_Range_Type (NE); + end Hash; -------------------------- -- In_External_Instance -- @@ -5886,26 +9867,23 @@ package body Sem_Elab is (N : Node_Id; Target_Decl : Node_Id) return Boolean is - Dummy : Node_Id; + Inst : Node_Id; Inst_Body : Node_Id; - Inst_Decl : Node_Id; + Inst_Spec : Node_Id; begin - -- Performance note: parent traversal - - Inst_Decl := Find_Enclosing_Instance (Target_Decl); + Inst := Find_Enclosing_Instance (Target_Decl); -- The target declaration appears within an instance spec. Visibility is -- ignored because internally generated primitives for private types may -- reside in the private declarations and still be invoked from outside. - if Present (Inst_Decl) - and then Nkind (Inst_Decl) = N_Package_Declaration - then + if Present (Inst) and then Nkind (Inst) = N_Package_Declaration then + -- The scenario comes from the main unit and the instance does not if In_Extended_Main_Code_Unit (N) - and then not In_Extended_Main_Code_Unit (Inst_Decl) + and then not In_Extended_Main_Code_Unit (Inst) then return True; @@ -5913,16 +9891,14 @@ package body Sem_Elab is -- body. else - Extract_Instance_Attributes - (Exp_Inst => Inst_Decl, - Inst_Body => Inst_Body, - Inst_Decl => Dummy); - - -- Performance note: parent traversal + Spec_And_Body_From_Node + (N => Inst, + Spec_Decl => Inst_Spec, + Body_Decl => Inst_Body); return not In_Subtree (N => N, - Root1 => Inst_Decl, + Root1 => Inst_Spec, Root2 => Inst_Body); end if; end if; @@ -5962,6 +9938,7 @@ package body Sem_Elab is Nested_OK : Boolean := False) return Boolean is function Find_Enclosing_Context (N : Node_Id) return Node_Id; + pragma Inline (Find_Enclosing_Context); -- Return the nearest enclosing non-library-level or compilation unit -- node which which encapsulates arbitrary node N. Return Empty is no -- such context is available. @@ -5969,6 +9946,7 @@ package body Sem_Elab is function In_Nested_Context (Outer : Node_Id; Inner : Node_Id) return Boolean; + pragma Inline (In_Nested_Context); -- Determine whether arbitrary node Outer encapsulates arbitrary node -- Inner. @@ -6084,5123 +10062,5588 @@ package body Sem_Elab is return False; end In_Same_Context; - ------------------ - -- In_Task_Body -- - ------------------ + ---------------- + -- Initialize -- + ---------------- - function In_Task_Body (N : Node_Id) return Boolean is - Par : Node_Id; + procedure Initialize is + begin + -- Set the soft link which enables Atree.Rewrite to update a scenario + -- each time it is transformed into another node. + + Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); + end Initialize; + + -------------------------- + -- Instantiated_Generic -- + -------------------------- + function Instantiated_Generic (Inst : Node_Id) return Entity_Id is begin - -- Climb the parent chain looking for a task body [procedure] + -- Traverse a possible chain of renamings to obtain the original generic + -- being instantiatied. - Par := N; - while Present (Par) loop - if Nkind (Par) = N_Task_Body then - return True; + return Get_Renamed_Entity (Entity (Name (Inst))); + end Instantiated_Generic; - elsif Nkind (Par) = N_Subprogram_Body - and then Is_Task_Body_Procedure (Par) - then - return True; + ----------------------------- + -- Internal_Representation -- + ----------------------------- - -- Prevent the search from going too far. Note that this predicate - -- shares nodes with the two cases above, and must come last. + package body Internal_Representation is - elsif Is_Body_Or_Package_Declaration (Par) then - return False; - end if; + ----------- + -- Types -- + ----------- - Par := Parent (Par); - end loop; + -- The following type represents the contents of a scenario - return False; - end In_Task_Body; + type Scenario_Rep_Record is record + Elab_Checks_OK : Boolean := False; + -- The status of elaboration checks for the scenario - ---------------- - -- Initialize -- - ---------------- + Elab_Warnings_OK : Boolean := False; + -- The status of elaboration warnings for the scenario - procedure Initialize is - begin - -- Set the soft link which enables Atree.Rewrite to update a top-level - -- scenario each time it is transformed into another node. + GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; + -- The Ghost mode of the scenario - Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); - end Initialize; + Kind : Scenario_Kind := No_Scenario; + -- The nature of the scenario - --------------- - -- Info_Call -- - --------------- + Level : Enclosing_Level_Kind := No_Level; + -- The enclosing level where the scenario resides - procedure Info_Call - (Call : Node_Id; - Target_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean) - is - procedure Info_Accept_Alternative; - pragma Inline (Info_Accept_Alternative); - -- Output information concerning an accept alternative - - procedure Info_Simple_Call; - pragma Inline (Info_Simple_Call); - -- Output information concerning the call - - procedure Info_Type_Actions (Action : String); - pragma Inline (Info_Type_Actions); - -- Output information concerning action Action of a type - - procedure Info_Verification_Call - (Pred : String; - Id : Entity_Id; - Id_Kind : String); - pragma Inline (Info_Verification_Call); - -- Output information concerning the verification of predicate Pred - -- applied to related entity Id with kind Id_Kind. + SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; + -- The SPARK mode of the scenario - ----------------------------- - -- Info_Accept_Alternative -- - ----------------------------- + Target : Entity_Id := Empty; + -- The target of the scenario - procedure Info_Accept_Alternative is - Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); + -- The following attributes are multiplexed and depend on the Kind of + -- the scenario. They are mapped as follows: + -- + -- Call_Scenario + -- Is_Dispatching_Call (Flag_1) + -- + -- Task_Activation_Scenario + -- Activated_Task_Objects (List_1) + -- Activated_Task_Type (Field_1) + -- + -- Variable_Reference + -- Is_Read_Reference (Flag_1) - begin - pragma Assert (Present (Entry_Id)); + Flag_1 : Boolean := False; + Field_1 : Node_Or_Entity_Id := Empty; + List_1 : NE_List.Doubly_Linked_List := NE_List.Nil; + end record; - Elab_Msg_NE - (Msg => "accept for entry & during elaboration", - N => Call, - Id => Entry_Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Accept_Alternative; + -- The following type represents the contents of a target - ---------------------- - -- Info_Simple_Call -- - ---------------------- + type Target_Rep_Record is record + Body_Decl : Node_Id := Empty; + -- The declaration of the target body - procedure Info_Simple_Call is - begin - Elab_Msg_NE - (Msg => "call to & during elaboration", - N => Call, - Id => Target_Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Simple_Call; + Elab_Checks_OK : Boolean := False; + -- The status of elaboration checks for the target - ----------------------- - -- Info_Type_Actions -- - ----------------------- + Elab_Warnings_OK : Boolean := False; + -- The status of elaboration warnings for the target - procedure Info_Type_Actions (Action : String) is - Typ : constant Entity_Id := First_Formal_Type (Target_Id); + GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; + -- The Ghost mode of the target - begin - pragma Assert (Present (Typ)); + Kind : Target_Kind := No_Target; + -- The nature of the target - Elab_Msg_NE - (Msg => Action & " actions for type & during elaboration", - N => Call, - Id => Typ, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Type_Actions; + SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; + -- The SPARK mode of the target - ---------------------------- - -- Info_Verification_Call -- - ---------------------------- + Spec_Decl : Node_Id := Empty; + -- The declaration of the target spec - procedure Info_Verification_Call - (Pred : String; - Id : Entity_Id; - Id_Kind : String) - is - begin - pragma Assert (Present (Id)); + Unit : Entity_Id := Empty; + -- The top unit where the target is declared - Elab_Msg_NE - (Msg => - "verification of " & Pred & " of " & Id_Kind & " & during " - & "elaboration", - N => Call, - Id => Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Verification_Call; + Version : Representation_Kind := No_Representation; + -- The version of the target representation - -- Start of processing for Info_Call + -- The following attributes are multiplexed and depend on the Kind of + -- the target. They are mapped as follows: + -- + -- Subprogram_Target + -- Barrier_Body_Declaration (Field_1) + -- + -- Variable_Target + -- Variable_Declaration (Field_1) - begin - -- Do not output anything for targets defined in internal units because - -- this creates noise. + Field_1 : Node_Or_Entity_Id := Empty; + end record; - if not In_Internal_Unit (Target_Id) then + --------------------- + -- Data structures -- + --------------------- - -- Accept alternative + procedure Destroy (T_Id : in out Target_Rep_Id); + -- Destroy a target representation T_Id + + package ETT_Map is new Dynamic_Hash_Tables + (Key_Type => Entity_Id, + Value_Type => Target_Rep_Id, + No_Value => No_Target_Rep, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy, + Hash => Hash); + + -- The following map relates target representations to entities + + Entity_To_Target_Map : ETT_Map.Dynamic_Hash_Table := + ETT_Map.Create (500); + + procedure Destroy (S_Id : in out Scenario_Rep_Id); + -- Destroy a scenario representation S_Id + + package NTS_Map is new Dynamic_Hash_Tables + (Key_Type => Node_Id, + Value_Type => Scenario_Rep_Id, + No_Value => No_Scenario_Rep, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy, + Hash => Hash); + + -- The following map relates scenario representations to nodes + + Node_To_Scenario_Map : NTS_Map.Dynamic_Hash_Table := + NTS_Map.Create (500); + + -- The following table stores all scenario representations + + package Scenario_Reps is new Table.Table + (Table_Index_Type => Scenario_Rep_Id, + Table_Component_Type => Scenario_Rep_Record, + Table_Low_Bound => First_Scenario_Rep, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "Scenario_Reps"); + + -- The following table stores all target representations + + package Target_Reps is new Table.Table + (Table_Index_Type => Target_Rep_Id, + Table_Component_Type => Target_Rep_Record, + Table_Low_Bound => First_Target_Rep, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "Target_Reps"); - if Is_Accept_Alternative_Proc (Target_Id) then - Info_Accept_Alternative; + -------------- + -- Builders -- + -------------- - -- Adjustment + function Create_Access_Taken_Rep + (Attr : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Access_Taken_Rep); + -- Create the representation of 'Access attribute Attr + + function Create_Call_Or_Task_Activation_Rep + (Call : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Call_Or_Task_Activation_Rep); + -- Create the representation of call or task activation Call + + function Create_Derived_Type_Rep + (Typ_Decl : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Derived_Type_Rep); + -- Create the representation of a derived type described by declaration + -- Typ_Decl. + + function Create_Generic_Rep + (Gen_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Generic_Rep); + -- Create the representation of generic Gen_Id + + function Create_Instantiation_Rep + (Inst : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Instantiation_Rep); + -- Create the representation of instantiation Inst + + function Create_Protected_Entry_Rep + (PE_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Protected_Entry_Rep); + -- Create the representation of protected entry PE_Id + + function Create_Protected_Subprogram_Rep + (PS_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Protected_Subprogram_Rep); + -- Create the representation of protected subprogram PS_Id + + function Create_Refined_State_Pragma_Rep + (Prag : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Refined_State_Pragma_Rep); + -- Create the representation of Refined_State pragma Prag + + function Create_Scenario_Rep + (N : Node_Id; + In_State : Processing_In_State) return Scenario_Rep_Record; + pragma Inline (Create_Scenario_Rep); + -- Top level dispatcher. Create the representation of elaboration + -- scenario N. In_State is the current state of the Processing phase. + + function Create_Subprogram_Rep + (Subp_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Subprogram_Rep); + -- Create the representation of entry, operator, or subprogram Subp_Id + + function Create_Target_Rep + (Id : Entity_Id; + In_State : Processing_In_State) return Target_Rep_Record; + pragma Inline (Create_Target_Rep); + -- Top level dispatcher. Create the representation of elaboration target + -- Id. In_State is the current state of the Processing phase. + + function Create_Task_Entry_Rep + (TE_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Task_Entry_Rep); + -- Create the representation of task entry TE_Id + + function Create_Task_Rep (Task_Typ : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Task_Rep); + -- Create the representation of task type Typ + + function Create_Variable_Assignment_Rep + (Asmt : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Variable_Assignment_Rep); + -- Create the representation of variable assignment Asmt + + function Create_Variable_Reference_Rep + (Ref : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Variable_Reference_Rep); + -- Create the representation of variable reference Ref + + function Create_Variable_Rep + (Var_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Variable_Rep); + -- Create the representation of variable Var_Id - elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then - Info_Type_Actions ("adjustment"); + ----------------------- + -- Local subprograms -- + ----------------------- - -- Default_Initial_Condition + function Ghost_Mode_Of_Entity + (Id : Entity_Id) return Extended_Ghost_Mode; + pragma Inline (Ghost_Mode_Of_Entity); + -- Obtain the extended Ghost mode of arbitrary entity Id - elsif Is_Default_Initial_Condition_Proc (Target_Id) then - Info_Verification_Call - (Pred => "Default_Initial_Condition", - Id => First_Formal_Type (Target_Id), - Id_Kind => "type"); + function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode; + pragma Inline (Ghost_Mode_Of_Node); + -- Obtain the extended Ghost mode of arbitrary node N - -- Entries + function Present (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Present); + -- Determine whether scenario representation S_Id exists - elsif Is_Protected_Entry (Target_Id) then - Info_Simple_Call; + function Present (T_Id : Target_Rep_Id) return Boolean; + pragma Inline (Present); + -- Determine whether target representation T_Id exists - -- Task entry calls are never processed because the entry being - -- invoked does not have a corresponding "body", it has a select. + function SPARK_Mode_Of_Entity + (Id : Entity_Id) return Extended_SPARK_Mode; + pragma Inline (SPARK_Mode_Of_Entity); + -- Obtain the extended SPARK mode of arbitrary entity Id - elsif Is_Task_Entry (Target_Id) then - null; + function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode; + pragma Inline (SPARK_Mode_Of_Node); + -- Obtain the extended SPARK mode of arbitrary node N - -- Finalization + function To_Ghost_Mode + (Ignored_Status : Boolean) return Extended_Ghost_Mode; + pragma Inline (To_Ghost_Mode); + -- Convert a Ghost mode indicated by Ignored_Status into its extended + -- equivalent. - elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then - Info_Type_Actions ("finalization"); + function To_SPARK_Mode (On_Status : Boolean) return Extended_SPARK_Mode; + pragma Inline (To_SPARK_Mode); + -- Convert a SPARK mode indicated by On_Status into its extended + -- equivalent. - -- Calls to _Finalizer procedures must not appear in the output - -- because this creates confusing noise. + function Version (T_Id : Target_Rep_Id) return Representation_Kind; + pragma Inline (Version); + -- Obtain the version of target representation T_Id - elsif Is_Finalizer_Proc (Target_Id) then - null; + ---------------------------- + -- Activated_Task_Objects -- + ---------------------------- - -- Initial_Condition + function Activated_Task_Objects + (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List + is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Task_Activation_Scenario); - elsif Is_Initial_Condition_Proc (Target_Id) then - Info_Verification_Call - (Pred => "Initial_Condition", - Id => Find_Enclosing_Scope (Call), - Id_Kind => "package"); + begin + return Scenario_Reps.Table (S_Id).List_1; + end Activated_Task_Objects; - -- Initialization + ------------------------- + -- Activated_Task_Type -- + ------------------------- - elsif Is_Init_Proc (Target_Id) - or else Is_TSS (Target_Id, TSS_Deep_Initialize) - then - Info_Type_Actions ("initialization"); + function Activated_Task_Type + (S_Id : Scenario_Rep_Id) return Entity_Id + is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Task_Activation_Scenario); - -- Invariant + begin + return Scenario_Reps.Table (S_Id).Field_1; + end Activated_Task_Type; - elsif Is_Invariant_Proc (Target_Id) then - Info_Verification_Call - (Pred => "invariants", - Id => First_Formal_Type (Target_Id), - Id_Kind => "type"); + ------------------------------ + -- Barrier_Body_Declaration -- + ------------------------------ - -- Partial invariant calls must not appear in the output because this - -- creates confusing noise. + function Barrier_Body_Declaration + (T_Id : Target_Rep_Id) return Node_Id + is + pragma Assert (Present (T_Id)); + pragma Assert (Kind (T_Id) = Subprogram_Target); - elsif Is_Partial_Invariant_Proc (Target_Id) then - null; + begin + return Target_Reps.Table (T_Id).Field_1; + end Barrier_Body_Declaration; - -- _Postconditions + ---------------------- + -- Body_Declaration -- + ---------------------- - elsif Is_Postconditions_Proc (Target_Id) then - Info_Verification_Call - (Pred => "postconditions", - Id => Find_Enclosing_Scope (Call), - Id_Kind => "subprogram"); + function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Body_Decl; + end Body_Declaration; - -- Subprograms must come last because some of the previous cases fall - -- under this category. + ----------------------------- + -- Create_Access_Taken_Rep -- + ----------------------------- - elsif Ekind (Target_Id) = E_Function then - Info_Simple_Call; + function Create_Access_Taken_Rep + (Attr : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; + + begin + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Attr); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Attr); + Rec.GM := Is_Checked_Or_Not_Specified; + Rec.SM := SPARK_Mode_Of_Node (Attr); + Rec.Kind := Access_Taken_Scenario; + Rec.Target := Canonical_Subprogram (Entity (Prefix (Attr))); + + return Rec; + end Create_Access_Taken_Rep; + + ---------------------------------------- + -- Create_Call_Or_Task_Activation_Rep -- + ---------------------------------------- - elsif Ekind (Target_Id) = E_Procedure then - Info_Simple_Call; + function Create_Call_Or_Task_Activation_Rep + (Call : Node_Id) return Scenario_Rep_Record + is + Subp_Id : constant Entity_Id := Canonical_Subprogram (Target (Call)); + Kind : Scenario_Kind; + Rec : Scenario_Rep_Record; + begin + if Is_Activation_Proc (Subp_Id) then + Kind := Task_Activation_Scenario; else - pragma Assert (False); - null; + Kind := Call_Scenario; end if; - end if; - end Info_Call; - ------------------------ - -- Info_Instantiation -- - ------------------------ + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); + Rec.GM := Ghost_Mode_Of_Node (Call); + Rec.SM := SPARK_Mode_Of_Node (Call); + Rec.Kind := Kind; + Rec.Target := Subp_Id; - procedure Info_Instantiation - (Inst : Node_Id; - Gen_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean) - is - begin - Elab_Msg_NE - (Msg => "instantiation of & during elaboration", - N => Inst, - Id => Gen_Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Instantiation; + -- Scenario-specific attributes - ----------------------------- - -- Info_Variable_Reference -- - ----------------------------- + Rec.Flag_1 := Is_Dispatching_Call (Call); -- Dispatching_Call - procedure Info_Variable_Reference - (Ref : Node_Id; - Var_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean) - is - begin - if Is_Read (Ref) then - Elab_Msg_NE - (Msg => "read of variable & during elaboration", - N => Ref, - Id => Var_Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end if; - end Info_Variable_Reference; + return Rec; + end Create_Call_Or_Task_Activation_Rep; - -------------------- - -- Insertion_Node -- - -------------------- + ----------------------------- + -- Create_Derived_Type_Rep -- + ----------------------------- - function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id is - begin - -- When the scenario denotes an instantiation, the proper insertion node - -- is the instance spec. This ensures that the generic actuals will not - -- be evaluated prior to a potential ABE. + function Create_Derived_Type_Rep + (Typ_Decl : Node_Id) return Scenario_Rep_Record + is + Typ : constant Entity_Id := Defining_Entity (Typ_Decl); + Rec : Scenario_Rep_Record; - if Nkind (N) in N_Generic_Instantiation - and then Present (Instance_Spec (N)) - then - return Instance_Spec (N); + begin + Rec.Elab_Checks_OK := False; -- not relevant + Rec.Elab_Warnings_OK := False; -- not relevant + Rec.GM := Ghost_Mode_Of_Entity (Typ); + Rec.SM := SPARK_Mode_Of_Entity (Typ); + Rec.Kind := Derived_Type_Scenario; + Rec.Target := Typ; + + return Rec; + end Create_Derived_Type_Rep; + + ------------------------ + -- Create_Generic_Rep -- + ------------------------ + + function Create_Generic_Rep + (Gen_Id : Entity_Id) return Target_Rep_Record + is + Rec : Target_Rep_Record; - -- Otherwise the proper insertion node is the candidate insertion node + begin + Rec.Kind := Generic_Target; - else - return Ins_Nod; - end if; - end Insertion_Node; + Spec_And_Body_From_Entity + (Id => Gen_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - ----------------------- - -- Install_ABE_Check -- - ----------------------- + return Rec; + end Create_Generic_Rep; - procedure Install_ABE_Check - (N : Node_Id; - Id : Entity_Id; - Ins_Nod : Node_Id) - is - Check_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); - -- Insert the check prior to this node + ------------------------------ + -- Create_Instantiation_Rep -- + ------------------------------ - Loc : constant Source_Ptr := Sloc (N); - Spec_Id : constant Entity_Id := Unique_Entity (Id); - Unit_Id : constant Entity_Id := Find_Top_Unit (Id); - Scop_Id : Entity_Id; + function Create_Instantiation_Rep + (Inst : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; - begin - -- Nothing to do when compiling for GNATprove because raise statements - -- are not supported. + begin + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); + Rec.GM := Ghost_Mode_Of_Node (Inst); + Rec.SM := SPARK_Mode_Of_Node (Inst); + Rec.Kind := Instantiation_Scenario; + Rec.Target := Instantiated_Generic (Inst); - if GNATprove_Mode then - return; + return Rec; + end Create_Instantiation_Rep; - -- Nothing to do when the compilation will not produce an executable + -------------------------------- + -- Create_Protected_Entry_Rep -- + -------------------------------- - elsif Serious_Errors_Detected > 0 then - return; + function Create_Protected_Entry_Rep + (PE_Id : Entity_Id) return Target_Rep_Record + is + Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PE_Id); - -- Nothing to do for a compilation unit because there is no executable - -- environment at that level. + Barf_Id : Entity_Id; + Dummy : Node_Id; + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; - elsif Nkind (Parent (Check_Ins_Nod)) = N_Compilation_Unit then - return; + begin + -- When the entry [family] has already been expanded, it carries both + -- the procedure which emulates the behavior of the entry [family] as + -- well as the barrier function. - -- Nothing to do when the unit is elaborated prior to the main unit. - -- This check must also consider the following cases: + if Present (Prot_Id) then + Barf_Id := Barrier_Function (PE_Id); + Spec_Id := Prot_Id; - -- * Id's unit appears in the context of the main unit + -- Otherwise no expansion took place - -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST - -- NOT be generated because Id's unit is always elaborated prior to - -- the main unit. + else + Barf_Id := Empty; + Spec_Id := PE_Id; + end if; - -- * Id's unit is the main unit. An ABE check MUST be generated in this - -- case because a conditional ABE may be raised depending on the flow - -- of execution within the main unit (flag Same_Unit_OK is False). + Rec.Kind := Subprogram_Target; - elsif Has_Prior_Elaboration - (Unit_Id => Unit_Id, - Context_OK => True, - Elab_Body_OK => True) - then - return; - end if; + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - -- Prevent multiple scenarios from installing the same ABE check + -- Target-specific attributes - Set_Is_Elaboration_Checks_OK_Node (N, False); + if Present (Barf_Id) then + Spec_And_Body_From_Entity + (Id => Barf_Id, + Body_Decl => Rec.Field_1, -- Barrier_Body_Declaration + Spec_Decl => Dummy); + end if; - -- Install the nearest enclosing scope of the scenario as there must be - -- something on the scope stack. + return Rec; + end Create_Protected_Entry_Rep; - -- Performance note: parent traversal + ------------------------------------- + -- Create_Protected_Subprogram_Rep -- + ------------------------------------- - Scop_Id := Find_Enclosing_Scope (Check_Ins_Nod); - pragma Assert (Present (Scop_Id)); + function Create_Protected_Subprogram_Rep + (PS_Id : Entity_Id) return Target_Rep_Record + is + Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PS_Id); + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; - Push_Scope (Scop_Id); + begin + -- When the protected subprogram has already been expanded, it + -- carries the subprogram which seizes the lock and invokes the + -- original statements. - -- Generate: - -- if not Spec_Id'Elaborated then - -- raise Program_Error with "access before elaboration"; - -- end if; + if Present (Prot_Id) then + Spec_Id := Prot_Id; - Insert_Action (Check_Ins_Nod, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Not (Loc, - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Spec_Id, Loc), - Attribute_Name => Name_Elaborated)), - Reason => PE_Access_Before_Elaboration)); + -- Otherwise no expansion took place - Pop_Scope; - end Install_ABE_Check; + else + Spec_Id := PS_Id; + end if; - ----------------------- - -- Install_ABE_Check -- - ----------------------- + Rec.Kind := Subprogram_Target; - procedure Install_ABE_Check - (N : Node_Id; - Target_Id : Entity_Id; - Target_Decl : Node_Id; - Target_Body : Node_Id; - Ins_Nod : Node_Id) - is - procedure Build_Elaboration_Entity; - pragma Inline (Build_Elaboration_Entity); - -- Create a new elaboration flag for Target_Id, insert it prior to - -- Target_Decl, and set it after Body_Decl. + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - ------------------------------ - -- Build_Elaboration_Entity -- - ------------------------------ + return Rec; + end Create_Protected_Subprogram_Rep; + + ------------------------------------- + -- Create_Refined_State_Pragma_Rep -- + ------------------------------------- - procedure Build_Elaboration_Entity is - Loc : constant Source_Ptr := Sloc (Target_Id); - Flag_Id : Entity_Id; + function Create_Refined_State_Pragma_Rep + (Prag : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; begin - -- Create the declaration of the elaboration flag. The name carries a - -- unique counter in case of name overloading. + Rec.Elab_Checks_OK := False; -- not relevant + Rec.Elab_Warnings_OK := False; -- not relevant + Rec.GM := + To_Ghost_Mode (Is_Ignored_Ghost_Pragma (Prag)); + Rec.SM := Is_Off_Or_Not_Specified; + Rec.Kind := Refined_State_Pragma_Scenario; + Rec.Target := Empty; - Flag_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Target_Id), 'E', -1)); + return Rec; + end Create_Refined_State_Pragma_Rep; - Set_Elaboration_Entity (Target_Id, Flag_Id); - Set_Elaboration_Entity_Required (Target_Id); + ------------------------- + -- Create_Scenario_Rep -- + ------------------------- - Push_Scope (Scope (Target_Id)); + function Create_Scenario_Rep + (N : Node_Id; + In_State : Processing_In_State) return Scenario_Rep_Record + is + pragma Unreferenced (In_State); - -- Generate: - -- Enn : Short_Integer := 0; + Rec : Scenario_Rep_Record; - Insert_Action (Target_Decl, - Make_Object_Declaration (Loc, - Defining_Identifier => Flag_Id, - Object_Definition => - New_Occurrence_Of (Standard_Short_Integer, Loc), - Expression => Make_Integer_Literal (Loc, Uint_0))); + begin + if Is_Suitable_Access_Taken (N) then + Rec := Create_Access_Taken_Rep (N); - -- Generate: - -- Enn := 1; + elsif Is_Suitable_Call (N) then + Rec := Create_Call_Or_Task_Activation_Rep (N); - Set_Elaboration_Flag (Target_Body, Target_Id); + elsif Is_Suitable_Instantiation (N) then + Rec := Create_Instantiation_Rep (N); - Pop_Scope; - end Build_Elaboration_Entity; + elsif Is_Suitable_SPARK_Derived_Type (N) then + Rec := Create_Derived_Type_Rep (N); - -- Local variables + elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then + Rec := Create_Refined_State_Pragma_Rep (N); - Target_Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); + elsif Is_Suitable_Variable_Assignment (N) then + Rec := Create_Variable_Assignment_Rep (N); - -- Start for processing for Install_ABE_Check + elsif Is_Suitable_Variable_Reference (N) then + Rec := Create_Variable_Reference_Rep (N); - begin - -- Nothing to do when compiling for GNATprove because raise statements - -- are not supported. + else + pragma Assert (False); + return Rec; + end if; - if GNATprove_Mode then - return; + -- Common scenario attributes - -- Nothing to do when the compilation will not produce an executable + Rec.Level := Find_Enclosing_Level (N); - elsif Serious_Errors_Detected > 0 then - return; + return Rec; + end Create_Scenario_Rep; - -- Nothing to do when the target is a protected subprogram because the - -- check is associated with the protected body subprogram. + --------------------------- + -- Create_Subprogram_Rep -- + --------------------------- - elsif Is_Protected_Subp (Target_Id) then - return; + function Create_Subprogram_Rep + (Subp_Id : Entity_Id) return Target_Rep_Record + is + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; - -- Nothing to do when the target is elaborated prior to the main unit. - -- This check must also consider the following cases: + begin + Spec_Id := Subp_Id; - -- * The unit of the target appears in the context of the main unit + -- The elaboration target denotes an internal function that returns a + -- constrained array type in a SPARK-to-C compilation. In this case + -- the function receives a corresponding procedure which has an out + -- parameter. The proper body for ABE checks and diagnostics is that + -- of the procedure. - -- * The unit of the target is subject to pragma Elaborate_Body. An ABE - -- check MUST NOT be generated because the unit is always elaborated - -- prior to the main unit. + if Ekind (Spec_Id) = E_Function + and then Rewritten_For_C (Spec_Id) + then + Spec_Id := Corresponding_Procedure (Spec_Id); + end if; - -- * The unit of the target is the main unit. An ABE check MUST be added - -- in this case because a conditional ABE may be raised depending on - -- the flow of execution within the main unit (flag Same_Unit_OK is - -- False). + Rec.Kind := Subprogram_Target; - elsif Has_Prior_Elaboration - (Unit_Id => Target_Unit_Id, - Context_OK => True, - Elab_Body_OK => True) - then - return; + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - -- Create an elaboration flag for the target when it does not have one + return Rec; + end Create_Subprogram_Rep; - elsif No (Elaboration_Entity (Target_Id)) then - Build_Elaboration_Entity; - end if; + ----------------------- + -- Create_Target_Rep -- + ----------------------- - Install_ABE_Check - (N => N, - Ins_Nod => Ins_Nod, - Id => Target_Id); - end Install_ABE_Check; + function Create_Target_Rep + (Id : Entity_Id; + In_State : Processing_In_State) return Target_Rep_Record + is + Rec : Target_Rep_Record; - ------------------------- - -- Install_ABE_Failure -- - ------------------------- + begin + if Is_Generic_Unit (Id) then + Rec := Create_Generic_Rep (Id); - procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id) is - Fail_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); - -- Insert the failure prior to this node + elsif Is_Protected_Entry (Id) then + Rec := Create_Protected_Entry_Rep (Id); - Loc : constant Source_Ptr := Sloc (N); - Scop_Id : Entity_Id; + elsif Is_Protected_Subp (Id) then + Rec := Create_Protected_Subprogram_Rep (Id); - begin - -- Nothing to do when compiling for GNATprove because raise statements - -- are not supported. + elsif Is_Task_Entry (Id) then + Rec := Create_Task_Entry_Rep (Id); - if GNATprove_Mode then - return; + elsif Is_Task_Type (Id) then + Rec := Create_Task_Rep (Id); - -- Nothing to do when the compilation will not produce an executable + elsif Ekind_In (Id, E_Constant, E_Variable) then + Rec := Create_Variable_Rep (Id); - elsif Serious_Errors_Detected > 0 then - return; + elsif Ekind_In (Id, E_Entry, + E_Function, + E_Operator, + E_Procedure) + then + Rec := Create_Subprogram_Rep (Id); - -- Do not install an ABE check for a compilation unit because there is - -- no executable environment at that level. + else + pragma Assert (False); + return Rec; + end if; - elsif Nkind (Parent (Fail_Ins_Nod)) = N_Compilation_Unit then - return; - end if; + -- Common target attributes + + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Id); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Id); + Rec.GM := Ghost_Mode_Of_Entity (Id); + Rec.SM := SPARK_Mode_Of_Entity (Id); + Rec.Unit := Find_Top_Unit (Id); + Rec.Version := In_State.Representation; + + return Rec; + end Create_Target_Rep; + + --------------------------- + -- Create_Task_Entry_Rep -- + --------------------------- - -- Prevent multiple scenarios from installing the same ABE failure + function Create_Task_Entry_Rep + (TE_Id : Entity_Id) return Target_Rep_Record + is + Task_Typ : constant Entity_Id := Non_Private_View (Scope (TE_Id)); + Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); - Set_Is_Elaboration_Checks_OK_Node (N, False); + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; + + begin + -- The the task type has already been expanded, it carries the + -- procedure which emulates the behavior of the task body. - -- Install the nearest enclosing scope of the scenario as there must be - -- something on the scope stack. + if Present (Task_Body_Id) then + Spec_Id := Task_Body_Id; - -- Performance note: parent traversal + -- Otherwise no expansion took place - Scop_Id := Find_Enclosing_Scope (Fail_Ins_Nod); - pragma Assert (Present (Scop_Id)); + else + Spec_Id := TE_Id; + end if; - Push_Scope (Scop_Id); + Rec.Kind := Subprogram_Target; - -- Generate: - -- raise Program_Error with "access before elaboration"; + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - Insert_Action (Fail_Ins_Nod, - Make_Raise_Program_Error (Loc, - Reason => PE_Access_Before_Elaboration)); + return Rec; + end Create_Task_Entry_Rep; - Pop_Scope; - end Install_ABE_Failure; + --------------------- + -- Create_Task_Rep -- + --------------------- - -------------------------------- - -- Is_Accept_Alternative_Proc -- - -------------------------------- + function Create_Task_Rep + (Task_Typ : Entity_Id) return Target_Rep_Record + is + Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); - function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a procedure with a receiving entry + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; - return Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); - end Is_Accept_Alternative_Proc; + begin + -- The the task type has already been expanded, it carries the + -- procedure which emulates the behavior of the task body. - ------------------------ - -- Is_Activation_Proc -- - ------------------------ + if Present (Task_Body_Id) then + Spec_Id := Task_Body_Id; - function Is_Activation_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote one of the runtime procedures in - -- charge of task activation. + -- Otherwise no expansion took place - if Ekind (Id) = E_Procedure then - if Restricted_Profile then - return Is_RTE (Id, RE_Activate_Restricted_Tasks); else - return Is_RTE (Id, RE_Activate_Tasks); + Spec_Id := Task_Typ; end if; - end if; - return False; - end Is_Activation_Proc; + Rec.Kind := Task_Target; - ---------------------------- - -- Is_Ada_Semantic_Target -- - ---------------------------- + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is - begin - return - Is_Activation_Proc (Id) - or else Is_Controlled_Proc (Id, Name_Adjust) - or else Is_Controlled_Proc (Id, Name_Finalize) - or else Is_Controlled_Proc (Id, Name_Initialize) - or else Is_Init_Proc (Id) - or else Is_Invariant_Proc (Id) - or else Is_Protected_Entry (Id) - or else Is_Protected_Subp (Id) - or else Is_Protected_Body_Subp (Id) - or else Is_Task_Entry (Id); - end Is_Ada_Semantic_Target; + return Rec; + end Create_Task_Rep; - -------------------------------- - -- Is_Assertion_Pragma_Target -- - -------------------------------- + ------------------------------------ + -- Create_Variable_Assignment_Rep -- + ------------------------------------ - function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is - begin - return - Is_Default_Initial_Condition_Proc (Id) - or else Is_Initial_Condition_Proc (Id) - or else Is_Invariant_Proc (Id) - or else Is_Partial_Invariant_Proc (Id) - or else Is_Postconditions_Proc (Id); - end Is_Assertion_Pragma_Target; + function Create_Variable_Assignment_Rep + (Asmt : Node_Id) return Scenario_Rep_Record + is + Var_Id : constant Entity_Id := Entity (Assignment_Target (Asmt)); + Rec : Scenario_Rep_Record; - ---------------------------- - -- Is_Bodiless_Subprogram -- - ---------------------------- + begin + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Asmt); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Var_Id); + Rec.GM := Ghost_Mode_Of_Node (Asmt); + Rec.SM := SPARK_Mode_Of_Node (Asmt); + Rec.Kind := Variable_Assignment_Scenario; + Rec.Target := Var_Id; - function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is - begin - -- An abstract subprogram does not have a body + return Rec; + end Create_Variable_Assignment_Rep; - if Ekind_In (Subp_Id, E_Function, - E_Operator, - E_Procedure) - and then Is_Abstract_Subprogram (Subp_Id) - then - return True; + ----------------------------------- + -- Create_Variable_Reference_Rep -- + ----------------------------------- - -- A formal subprogram does not have a body + function Create_Variable_Reference_Rep + (Ref : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; - elsif Is_Formal_Subprogram (Subp_Id) then - return True; + begin + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Ref); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Ref); + Rec.GM := Ghost_Mode_Of_Node (Ref); + Rec.SM := SPARK_Mode_Of_Node (Ref); + Rec.Kind := Variable_Reference_Scenario; + Rec.Target := Target (Ref); - -- An imported subprogram may have a body, however it is not known at - -- compile or bind time where the body resides and whether it will be - -- elaborated on time. + -- Scenario-specific attributes - elsif Is_Imported (Subp_Id) then - return True; - end if; + Rec.Flag_1 := Is_Read (Ref); -- Is_Read_Reference - return False; - end Is_Bodiless_Subprogram; + return Rec; + end Create_Variable_Reference_Rep; - ------------------------ - -- Is_Controlled_Proc -- - ------------------------ + ------------------------- + -- Create_Variable_Rep -- + ------------------------- - function Is_Controlled_Proc - (Subp_Id : Entity_Id; - Subp_Nam : Name_Id) return Boolean - is - Formal_Id : Entity_Id; + function Create_Variable_Rep + (Var_Id : Entity_Id) return Target_Rep_Record + is + Rec : Target_Rep_Record; - begin - pragma Assert (Nam_In (Subp_Nam, Name_Adjust, - Name_Finalize, - Name_Initialize)); + begin + Rec.Kind := Variable_Target; - -- To qualify, the subprogram must denote a source procedure with name - -- Adjust, Finalize, or Initialize where the sole formal is controlled. + -- Target-specific attributes - if Comes_From_Source (Subp_Id) - and then Ekind (Subp_Id) = E_Procedure - and then Chars (Subp_Id) = Subp_Nam - then - Formal_Id := First_Formal (Subp_Id); + Rec.Field_1 := Declaration_Node (Var_Id); -- Variable_Declaration - return - Present (Formal_Id) - and then Is_Controlled (Etype (Formal_Id)) - and then No (Next_Formal (Formal_Id)); - end if; + return Rec; + end Create_Variable_Rep; - return False; - end Is_Controlled_Proc; + ------------- + -- Destroy -- + ------------- - --------------------------------------- - -- Is_Default_Initial_Condition_Proc -- - --------------------------------------- + procedure Destroy (S_Id : in out Scenario_Rep_Id) is + pragma Unreferenced (S_Id); + begin + null; + end Destroy; - function Is_Default_Initial_Condition_Proc - (Id : Entity_Id) return Boolean - is - begin - -- To qualify, the entity must denote a Default_Initial_Condition - -- procedure. + ------------- + -- Destroy -- + ------------- - return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); - end Is_Default_Initial_Condition_Proc; + procedure Destroy (T_Id : in out Target_Rep_Id) is + pragma Unreferenced (T_Id); + begin + null; + end Destroy; - ----------------------- - -- Is_Finalizer_Proc -- - ----------------------- + -------------------------------- + -- Disable_Elaboration_Checks -- + -------------------------------- - function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a _Finalizer procedure + procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id) is + pragma Assert (Present (S_Id)); + begin + Scenario_Reps.Table (S_Id).Elab_Checks_OK := False; + end Disable_Elaboration_Checks; - return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; - end Is_Finalizer_Proc; + -------------------------------- + -- Disable_Elaboration_Checks -- + -------------------------------- - ----------------------- - -- Is_Guaranteed_ABE -- - ----------------------- + procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id) is + pragma Assert (Present (T_Id)); + begin + Target_Reps.Table (T_Id).Elab_Checks_OK := False; + end Disable_Elaboration_Checks; - function Is_Guaranteed_ABE - (N : Node_Id; - Target_Decl : Node_Id; - Target_Body : Node_Id) return Boolean - is - begin - -- Avoid cascaded errors if there were previous serious infractions. - -- As a result the scenario will not be treated as a guaranteed ABE. - -- This behaviour parallels that of the old ABE mechanism. + --------------------------- + -- Elaboration_Checks_OK -- + --------------------------- - if Serious_Errors_Detected > 0 then - return False; + function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).Elab_Checks_OK; + end Elaboration_Checks_OK; - -- The scenario and the target appear within the same context ignoring - -- enclosing library levels. + --------------------------- + -- Elaboration_Checks_OK -- + --------------------------- - -- Performance note: parent traversal + function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Elab_Checks_OK; + end Elaboration_Checks_OK; - elsif In_Same_Context (N, Target_Decl) then + ----------------------------- + -- Elaboration_Warnings_OK -- + ----------------------------- - -- The target body has already been encountered. The scenario results - -- in a guaranteed ABE if it appears prior to the body. + function Elaboration_Warnings_OK + (S_Id : Scenario_Rep_Id) return Boolean + is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).Elab_Warnings_OK; + end Elaboration_Warnings_OK; - if Present (Target_Body) then - return Earlier_In_Extended_Unit (N, Target_Body); + ----------------------------- + -- Elaboration_Warnings_OK -- + ----------------------------- - -- Otherwise the body has not been encountered yet. The scenario is - -- a guaranteed ABE since the body will appear later. It is assumed - -- that the caller has already checked whether the scenario is ABE- - -- safe as optional bodies are not considered here. + function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Elab_Warnings_OK; + end Elaboration_Warnings_OK; - else - return True; - end if; - end if; + -------------------------------------- + -- Finalize_Internal_Representation -- + -------------------------------------- - return False; - end Is_Guaranteed_ABE; + procedure Finalize_Internal_Representation is + begin + ETT_Map.Destroy (Entity_To_Target_Map); + NTS_Map.Destroy (Node_To_Scenario_Map); + end Finalize_Internal_Representation; - ------------------------------- - -- Is_Initial_Condition_Proc -- - ------------------------------- + ------------------- + -- Ghost_Mode_Of -- + ------------------- - function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote an Initial_Condition procedure + function Ghost_Mode_Of + (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode + is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).GM; + end Ghost_Mode_Of; - return - Ekind (Id) = E_Procedure and then Is_Initial_Condition_Procedure (Id); - end Is_Initial_Condition_Proc; + ------------------- + -- Ghost_Mode_Of -- + ------------------- - -------------------- - -- Is_Initialized -- - -------------------- + function Ghost_Mode_Of + (T_Id : Target_Rep_Id) return Extended_Ghost_Mode + is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).GM; + end Ghost_Mode_Of; - function Is_Initialized (Obj_Decl : Node_Id) return Boolean is - begin - -- To qualify, the object declaration must have an expression + -------------------------- + -- Ghost_Mode_Of_Entity -- + -------------------------- - return - Present (Expression (Obj_Decl)) or else Has_Init_Expression (Obj_Decl); - end Is_Initialized; + function Ghost_Mode_Of_Entity + (Id : Entity_Id) return Extended_Ghost_Mode + is + begin + return To_Ghost_Mode (Is_Ignored_Ghost_Entity (Id)); + end Ghost_Mode_Of_Entity; - ----------------------- - -- Is_Invariant_Proc -- - ----------------------- + ------------------------ + -- Ghost_Mode_Of_Node -- + ------------------------ - function Is_Invariant_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote the "full" invariant procedure + function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode is + begin + return To_Ghost_Mode (Is_Ignored_Ghost_Node (N)); + end Ghost_Mode_Of_Node; - return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); - end Is_Invariant_Proc; + ---------------------------------------- + -- Initialize_Internal_Representation -- + ---------------------------------------- - --------------------------------------- - -- Is_Non_Library_Level_Encapsulator -- - --------------------------------------- + procedure Initialize_Internal_Representation is + begin + null; + end Initialize_Internal_Representation; - function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean is - begin - case Nkind (N) is - when N_Abstract_Subprogram_Declaration - | N_Aspect_Specification - | N_Component_Declaration - | N_Entry_Body - | N_Entry_Declaration - | N_Expression_Function - | N_Formal_Abstract_Subprogram_Declaration - | N_Formal_Concrete_Subprogram_Declaration - | N_Formal_Object_Declaration - | N_Formal_Package_Declaration - | N_Formal_Type_Declaration - | N_Generic_Association - | N_Implicit_Label_Declaration - | N_Incomplete_Type_Declaration - | N_Private_Extension_Declaration - | N_Private_Type_Declaration - | N_Protected_Body - | N_Protected_Type_Declaration - | N_Single_Protected_Declaration - | N_Single_Task_Declaration - | N_Subprogram_Body - | N_Subprogram_Declaration - | N_Task_Body - | N_Task_Type_Declaration - => - return True; + ------------------------- + -- Is_Dispatching_Call -- + ------------------------- - when others => - return Is_Generic_Declaration_Or_Body (N); - end case; - end Is_Non_Library_Level_Encapsulator; + function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Call_Scenario); - ------------------------------- - -- Is_Partial_Invariant_Proc -- - ------------------------------- + begin + return Scenario_Reps.Table (S_Id).Flag_1; + end Is_Dispatching_Call; - function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote the "partial" invariant procedure + ----------------------- + -- Is_Read_Reference -- + ----------------------- - return - Ekind (Id) = E_Procedure and then Is_Partial_Invariant_Procedure (Id); - end Is_Partial_Invariant_Proc; + function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Variable_Reference_Scenario); - ---------------------------- - -- Is_Postconditions_Proc -- - ---------------------------- + begin + return Scenario_Reps.Table (S_Id).Flag_1; + end Is_Read_Reference; - function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a _Postconditions procedure + ---------- + -- Kind -- + ---------- - return - Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; - end Is_Postconditions_Proc; + function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).Kind; + end Kind; - --------------------------- - -- Is_Preelaborated_Unit -- - --------------------------- + ---------- + -- Kind -- + ---------- - function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is - begin - return - Is_Preelaborated (Id) - or else Is_Pure (Id) - or else Is_Remote_Call_Interface (Id) - or else Is_Remote_Types (Id) - or else Is_Shared_Passive (Id); - end Is_Preelaborated_Unit; + function Kind (T_Id : Target_Rep_Id) return Target_Kind is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Kind; + end Kind; - ------------------------ - -- Is_Protected_Entry -- - ------------------------ + ----------- + -- Level -- + ----------- - function Is_Protected_Entry (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote an entry defined in a protected - -- type. + function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).Level; + end Level; - return - Is_Entry (Id) - and then Is_Protected_Type (Non_Private_View (Scope (Id))); - end Is_Protected_Entry; + ------------- + -- Present -- + ------------- - ----------------------- - -- Is_Protected_Subp -- - ----------------------- + function Present (S_Id : Scenario_Rep_Id) return Boolean is + begin + return S_Id /= No_Scenario_Rep; + end Present; - function Is_Protected_Subp (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a subprogram defined within a - -- protected type. + ------------- + -- Present -- + ------------- - return - Ekind_In (Id, E_Function, E_Procedure) - and then Is_Protected_Type (Non_Private_View (Scope (Id))); - end Is_Protected_Subp; + function Present (T_Id : Target_Rep_Id) return Boolean is + begin + return T_Id /= No_Target_Rep; + end Present; - ---------------------------- - -- Is_Protected_Body_Subp -- - ---------------------------- + -------------------------------- + -- Scenario_Representation_Of -- + -------------------------------- - function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a subprogram with attribute - -- Protected_Subprogram set. + function Scenario_Representation_Of + (N : Node_Id; + In_State : Processing_In_State) return Scenario_Rep_Id + is + S_Id : Scenario_Rep_Id; - return - Ekind_In (Id, E_Function, E_Procedure) - and then Present (Protected_Subprogram (Id)); - end Is_Protected_Body_Subp; + begin + S_Id := NTS_Map.Get (Node_To_Scenario_Map, N); - -------------------------------- - -- Is_Recorded_SPARK_Scenario -- - -------------------------------- + -- The elaboration scenario lacks a representation. This indicates + -- that the scenario is encountered for the first time. Create the + -- representation of it. - function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean is - begin - if Recorded_SPARK_Scenarios_In_Use then - return Recorded_SPARK_Scenarios.Get (N); - end if; + if not Present (S_Id) then + Scenario_Reps.Append (Create_Scenario_Rep (N, In_State)); + S_Id := Scenario_Reps.Last; - return Recorded_SPARK_Scenarios_No_Element; - end Is_Recorded_SPARK_Scenario; + -- Associate the internal representation with the elaboration + -- scenario. - ------------------------------------ - -- Is_Recorded_Top_Level_Scenario -- - ------------------------------------ + NTS_Map.Put (Node_To_Scenario_Map, N, S_Id); + end if; - function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean is - begin - if Recorded_Top_Level_Scenarios_In_Use then - return Recorded_Top_Level_Scenarios.Get (N); - end if; + pragma Assert (Present (S_Id)); - return Recorded_Top_Level_Scenarios_No_Element; - end Is_Recorded_Top_Level_Scenario; + return S_Id; + end Scenario_Representation_Of; - ------------------------ - -- Is_Safe_Activation -- - ------------------------ + -------------------------------- + -- Set_Activated_Task_Objects -- + -------------------------------- - function Is_Safe_Activation - (Call : Node_Id; - Task_Decl : Node_Id) return Boolean - is - begin - -- The activation of a task coming from an external instance cannot - -- cause an ABE because the generic was already instantiated. Note - -- that the instantiation itself may lead to an ABE. + procedure Set_Activated_Task_Objects + (S_Id : Scenario_Rep_Id; + Task_Objs : NE_List.Doubly_Linked_List) + is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Task_Activation_Scenario); - return - In_External_Instance - (N => Call, - Target_Decl => Task_Decl); - end Is_Safe_Activation; + begin + Scenario_Reps.Table (S_Id).List_1 := Task_Objs; + end Set_Activated_Task_Objects; - ------------------ - -- Is_Safe_Call -- - ------------------ + ----------------------------- + -- Set_Activated_Task_Type -- + ----------------------------- - function Is_Safe_Call - (Call : Node_Id; - Target_Attrs : Target_Attributes) return Boolean - is - begin - -- The target is either an abstract subprogram, formal subprogram, or - -- imported, in which case it does not have a body at compile or bind - -- time. Assume that the call is ABE-safe. + procedure Set_Activated_Task_Type + (S_Id : Scenario_Rep_Id; + Task_Typ : Entity_Id) + is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Task_Activation_Scenario); - if Is_Bodiless_Subprogram (Target_Attrs.Spec_Id) then - return True; + begin + Scenario_Reps.Table (S_Id).Field_1 := Task_Typ; + end Set_Activated_Task_Type; - -- The target is an instantiation of a generic subprogram. The call - -- cannot cause an ABE because the generic was already instantiated. - -- Note that the instantiation itself may lead to an ABE. + ------------------- + -- SPARK_Mode_Of -- + ------------------- - elsif Is_Generic_Instance (Target_Attrs.Spec_Id) then - return True; + function SPARK_Mode_Of + (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode + is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).SM; + end SPARK_Mode_Of; - -- The invocation of a target coming from an external instance cannot - -- cause an ABE because the generic was already instantiated. Note that - -- the instantiation itself may lead to an ABE. + ------------------- + -- SPARK_Mode_Of -- + ------------------- - elsif In_External_Instance - (N => Call, - Target_Decl => Target_Attrs.Spec_Decl) - then - return True; + function SPARK_Mode_Of + (T_Id : Target_Rep_Id) return Extended_SPARK_Mode + is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).SM; + end SPARK_Mode_Of; - -- The target is a subprogram body without a previous declaration. The - -- call cannot cause an ABE because the body has already been seen. + -------------------------- + -- SPARK_Mode_Of_Entity -- + -------------------------- - elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body - and then No (Corresponding_Spec (Target_Attrs.Spec_Decl)) - then - return True; + function SPARK_Mode_Of_Entity + (Id : Entity_Id) return Extended_SPARK_Mode + is + Prag : constant Node_Id := SPARK_Pragma (Id); - -- The target is a subprogram body stub without a prior declaration. - -- The call cannot cause an ABE because the proper body substitutes - -- the stub. + begin + return + To_SPARK_Mode + (Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On); + end SPARK_Mode_Of_Entity; - elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body_Stub - and then No (Corresponding_Spec_Of_Stub (Target_Attrs.Spec_Decl)) - then - return True; + ------------------------ + -- SPARK_Mode_Of_Node -- + ------------------------ - -- Subprogram bodies which wrap attribute references used as actuals - -- in instantiations are always ABE-safe. These bodies are artifacts - -- of expansion. + function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode is + begin + return To_SPARK_Mode (Is_SPARK_Mode_On_Node (N)); + end SPARK_Mode_Of_Node; - elsif Present (Target_Attrs.Body_Decl) - and then Nkind (Target_Attrs.Body_Decl) = N_Subprogram_Body - and then Was_Attribute_Reference (Target_Attrs.Body_Decl) - then - return True; - end if; + ---------------------- + -- Spec_Declaration -- + ---------------------- - return False; - end Is_Safe_Call; + function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Spec_Decl; + end Spec_Declaration; - --------------------------- - -- Is_Safe_Instantiation -- - --------------------------- + ------------ + -- Target -- + ------------ - function Is_Safe_Instantiation - (Inst : Node_Id; - Gen_Attrs : Target_Attributes) return Boolean - is - begin - -- The generic is an intrinsic subprogram in which case it does not - -- have a body at compile or bind time. Assume that the instantiation - -- is ABE-safe. + function Target (S_Id : Scenario_Rep_Id) return Entity_Id is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).Target; + end Target; - if Is_Bodiless_Subprogram (Gen_Attrs.Spec_Id) then - return True; + ------------------------------ + -- Target_Representation_Of -- + ------------------------------ - -- The instantiation of an external nested generic cannot cause an ABE - -- if the outer generic was already instantiated. Note that the instance - -- of the outer generic may lead to an ABE. + function Target_Representation_Of + (Id : Entity_Id; + In_State : Processing_In_State) return Target_Rep_Id + is + T_Id : Target_Rep_Id; - elsif In_External_Instance - (N => Inst, - Target_Decl => Gen_Attrs.Spec_Decl) - then - return True; + begin + T_Id := ETT_Map.Get (Entity_To_Target_Map, Id); - -- The generic is a package. The instantiation cannot cause an ABE when - -- the package has no body. + -- The elaboration target lacks an internal representation. This + -- indicates that the target is encountered for the first time. + -- Create the internal representation of it. - elsif Ekind (Gen_Attrs.Spec_Id) = E_Generic_Package - and then not Has_Body (Gen_Attrs.Spec_Decl) - then - return True; - end if; + if not Present (T_Id) then + Target_Reps.Append (Create_Target_Rep (Id, In_State)); + T_Id := Target_Reps.Last; - return False; - end Is_Safe_Instantiation; + -- Associate the internal representation with the elaboration + -- target. - ------------------ - -- Is_Same_Unit -- - ------------------ + ETT_Map.Put (Entity_To_Target_Map, Id, T_Id); - function Is_Same_Unit - (Unit_1 : Entity_Id; - Unit_2 : Entity_Id) return Boolean - is - begin - return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); - end Is_Same_Unit; + -- The Processing phase is working with a partially analyzed tree, + -- where various attributes become available as analysis continues. + -- This case arrises in the context of guaranteed ABE processing. + -- Update the existing representation by including new attributes. - ----------------- - -- Is_Scenario -- - ----------------- + elsif In_State.Representation = Inconsistent_Representation then + Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); - function Is_Scenario (N : Node_Id) return Boolean is - begin - case Nkind (N) is - when N_Assignment_Statement - | N_Attribute_Reference - | N_Call_Marker - | N_Entry_Call_Statement - | N_Expanded_Name - | N_Function_Call - | N_Function_Instantiation - | N_Identifier - | N_Package_Instantiation - | N_Procedure_Call_Statement - | N_Procedure_Instantiation - | N_Requeue_Statement - => - return True; + -- Otherwise the Processing phase imposes a particular representation + -- version which is not satisfied by the target. This case arrises + -- when the Processing phase switches from guaranteed ABE checks and + -- diagnostics to some other mode of operation. Update the existing + -- representation to include all attributes. - when others => - return False; - end case; - end Is_Scenario; + elsif In_State.Representation /= Version (T_Id) then + Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); + end if; - ------------------------------ - -- Is_SPARK_Semantic_Target -- - ------------------------------ + pragma Assert (Present (T_Id)); - function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is - begin - return - Is_Default_Initial_Condition_Proc (Id) - or else Is_Initial_Condition_Proc (Id); - end Is_SPARK_Semantic_Target; + return T_Id; + end Target_Representation_Of; - ------------------------ - -- Is_Suitable_Access -- - ------------------------ + ------------------- + -- To_Ghost_Mode -- + ------------------- - function Is_Suitable_Access (N : Node_Id) return Boolean is - Nam : Name_Id; - Pref : Node_Id; - Subp_Id : Entity_Id; + function To_Ghost_Mode + (Ignored_Status : Boolean) return Extended_Ghost_Mode + is + begin + if Ignored_Status then + return Is_Ignored; + else + return Is_Checked_Or_Not_Specified; + end if; + end To_Ghost_Mode; - begin - -- This scenario is relevant only when the static model is in effect - -- because it is graph-dependent and does not involve any run-time - -- checks. Allowing it in the dynamic model would create confusing - -- noise. + ------------------- + -- To_SPARK_Mode -- + ------------------- - if not Static_Elaboration_Checks then - return False; + function To_SPARK_Mode + (On_Status : Boolean) return Extended_SPARK_Mode + is + begin + if On_Status then + return Is_On; + else + return Is_Off_Or_Not_Specified; + end if; + end To_SPARK_Mode; - -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect + ---------- + -- Unit -- + ---------- - elsif Debug_Flag_Dot_UU then - return False; + function Unit (T_Id : Target_Rep_Id) return Entity_Id is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Unit; + end Unit; - -- Nothing to do when the scenario is not an attribute reference + -------------------------- + -- Variable_Declaration -- + -------------------------- - elsif Nkind (N) /= N_Attribute_Reference then - return False; + function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id is + pragma Assert (Present (T_Id)); + pragma Assert (Kind (T_Id) = Variable_Target); - -- Nothing to do for internally-generated attributes because they are - -- assumed to be ABE safe. + begin + return Target_Reps.Table (T_Id).Field_1; + end Variable_Declaration; - elsif not Comes_From_Source (N) then - return False; - end if; + ------------- + -- Version -- + ------------- - Nam := Attribute_Name (N); - Pref := Prefix (N); + function Version (T_Id : Target_Rep_Id) return Representation_Kind is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Version; + end Version; + end Internal_Representation; - -- Sanitize the prefix of the attribute + ---------------------- + -- Invocation_Graph -- + ---------------------- - if not Is_Entity_Name (Pref) then - return False; + package body Invocation_Graph is - elsif No (Entity (Pref)) then - return False; - end if; + ----------- + -- Types -- + ----------- - Subp_Id := Entity (Pref); + -- The following type represents simplified version of an invocation + -- relation. - if not Is_Subprogram_Or_Entry (Subp_Id) then - return False; - end if; + type Invoker_Target_Relation is record + Invoker : Entity_Id := Empty; + Target : Entity_Id := Empty; + end record; - -- Traverse a possible chain of renamings to obtain the original entry - -- or subprogram which the prefix may rename. + -- The following variables define the entities of the dummy elaboration + -- procedures used as origins of library level paths. - Subp_Id := Get_Renamed_Entity (Subp_Id); + Elab_Body_Id : Entity_Id := Empty; + Elab_Spec_Id : Entity_Id := Empty; - -- To qualify, the attribute must meet the following prerequisites: + --------------------- + -- Data structures -- + --------------------- - return + -- The following set contains all declared invocation constructs. It + -- ensures that the same construct is not declared multiple times in + -- the ALI file of the main unit. - -- The prefix must denote a source entry, operator, or subprogram - -- which is not imported. + Saved_Constructs_Set : NE_Set.Membership_Set := NE_Set.Nil; - Comes_From_Source (Subp_Id) - and then Is_Subprogram_Or_Entry (Subp_Id) - and then not Is_Bodiless_Subprogram (Subp_Id) + function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type; + -- Obtain the hash value of pair Key - -- The attribute name must be one of the 'Access forms. Note that - -- 'Unchecked_Access cannot apply to a subprogram. + package IR_Set is new Membership_Sets + (Element_Type => Invoker_Target_Relation, + "=" => "=", + Hash => Hash); - and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); - end Is_Suitable_Access; + -- The following set contains all recorded simple invocation relations. + -- It ensures that multiple relations involving the same invoker and + -- target do not appear in the ALI file of the main unit. - ---------------------- - -- Is_Suitable_Call -- - ---------------------- + Saved_Relations_Set : IR_Set.Membership_Set := IR_Set.Nil; - function Is_Suitable_Call (N : Node_Id) return Boolean is - begin - -- Entry and subprogram calls are intentionally ignored because they - -- may undergo expansion depending on the compilation mode, previous - -- errors, generic context, etc. Call markers play the role of calls - -- and provide a uniform foundation for ABE processing. + -------------- + -- Builders -- + -------------- - return Nkind (N) = N_Call_Marker; - end Is_Suitable_Call; + function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id; + pragma Inline (Signature_Of); + -- Obtain the invication signature id of arbitrary entity Id - ------------------------------- - -- Is_Suitable_Instantiation -- - ------------------------------- + ----------------------- + -- Local subprograms -- + ----------------------- - function Is_Suitable_Instantiation (N : Node_Id) return Boolean is - Orig_N : constant Node_Id := Original_Node (N); - -- Use the original node in case an instantiation library unit is - -- rewritten as a package or subprogram. + procedure Build_Elaborate_Body_Procedure; + pragma Inline (Build_Elaborate_Body_Procedure); + -- Create a dummy elaborate body procedure and store its entity in + -- Elab_Body_Id. + + procedure Build_Elaborate_Procedure + (Proc_Id : out Entity_Id; + Proc_Nam : Name_Id; + Loc : Source_Ptr); + pragma Inline (Build_Elaborate_Procedure); + -- Create a dummy elaborate procedure with name Proc_Nam and source + -- location Loc. The entity is returned in Proc_Id. + + procedure Build_Elaborate_Spec_Procedure; + pragma Inline (Build_Elaborate_Spec_Procedure); + -- Create a dummy elaborate spec procedure and store its entity in + -- Elab_Spec_Id. + + function Build_Subprogram_Invocation + (Subp_Id : Entity_Id) return Node_Id; + pragma Inline (Build_Subprogram_Invocation); + -- Create a dummy call marker that invokes subprogram Subp_Id + + function Build_Task_Activation + (Task_Typ : Entity_Id; + In_State : Processing_In_State) return Node_Id; + pragma Inline (Build_Task_Activation); + -- Create a dummy call marker that activates an anonymous task object of + -- type Task_Typ. + + procedure Declare_Invocation_Construct + (Constr_Id : Entity_Id; + In_State : Processing_In_State); + pragma Inline (Declare_Invocation_Construct); + -- Declare invocation construct Constr_Id by creating a declaration for + -- it in the ALI file of the main unit. In_State is the current state of + -- the Processing phase. + + function Invocation_Graph_Recording_OK return Boolean; + pragma Inline (Invocation_Graph_Recording_OK); + -- Determine whether the invocation graph can be recorded + + function Is_Invocation_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Invocation_Scenario); + -- Determine whether node N is a suitable scenario for invocation graph + -- recording purposes. + + function Is_Invocation_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Invocation_Target); + -- Determine whether arbitrary entity Id denotes an invocation target + + function Is_Saved_Construct (Constr : Entity_Id) return Boolean; + pragma Inline (Is_Saved_Construct); + -- Determine whether invocation construct Constr has already been + -- declared in the ALI file of the main unit. + + function Is_Saved_Relation + (Rel : Invoker_Target_Relation) return Boolean; + pragma Inline (Is_Saved_Relation); + -- Determine whether simple invocation relation Rel has already been + -- recorded in the ALI file of the main unit. + + procedure Process_Declarations + (Decls : List_Id; + In_State : Processing_In_State); + pragma Inline (Process_Declarations); + -- Process declaration list Decls by processing all invocation scenarios + -- within it. + + procedure Process_Freeze_Node + (Fnode : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Freeze_Node); + -- Process freeze node Fnode by processing all invocation scenarios in + -- its Actions list. + + procedure Process_Invocation_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Invocation_Activation); + -- Process activation call Call which activates object Obj_Id of task + -- type Task_Typ by processing all invocation scenarios within the task + -- body. Call_Rep is the representation of the call. Obj_Rep denotes the + -- representation of the object. Task_Rep is the representation of the + -- task type. In_State is the current state of the Processing phase. + + procedure Process_Invocation_Body_Scenarios; + pragma Inline (Process_Invocation_Body_Scenarios); + -- Process all library level body scenarios + + procedure Process_Invocation_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Invocation_Call); + -- Process invocation call scenario Call with representation Call_Rep. + -- In_State is the current state of the Processing phase. + + procedure Process_Invocation_Scenario + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Invocation_Scenario); + -- Process single invocation scenario N. In_State is the current state + -- of the Processing phase. + + procedure Process_Invocation_Scenarios + (Iter : in out NE_Set.Iterator; + In_State : Processing_In_State); + pragma Inline (Process_Invocation_Scenarios); + -- Process all invocation scenarios obtained via iterator Iter. In_State + -- is the current state of the Processing phase. + + procedure Process_Invocation_Spec_Scenarios; + pragma Inline (Process_Invocation_Spec_Scenarios); + -- Process all library level spec scenarios + + procedure Process_Main_Unit; + pragma Inline (Process_Main_Unit); + -- Process all invocation scenarios within the main unit + + procedure Process_Package_Declaration + (Pack_Decl : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Package_Declaration); + -- Process package declaration Pack_Decl by processing all invocation + -- scenarios in its visible and private declarations. If the main unit + -- contains a generic, the declarations of the body are also examined. + -- In_State is the current state of the Processing phase. + + procedure Process_Protected_Type_Declaration + (Prot_Decl : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Protected_Type_Declaration); + -- Process the declarations of protected type Prot_Decl. In_State is the + -- current state of the Processing phase. + + procedure Process_Subprogram_Declaration + (Subp_Decl : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Subprogram_Declaration); + -- Process subprogram declaration Subp_Decl by processing all invocation + -- scenarios within its body. In_State denotes the current state of the + -- Processing phase. + + procedure Process_Subprogram_Instantiation + (Inst : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Subprogram_Instantiation); + -- Process subprogram instantiation Inst. In_State is the current state + -- of the Processing phase. + + procedure Process_Task_Type_Declaration + (Task_Decl : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Task_Type_Declaration); + -- Process task declaration Task_Decl by processing all invocation + -- scenarios within its body. In_State is the current state of the + -- Processing phase. + + procedure Record_Full_Invocation_Path (In_State : Processing_In_State); + pragma Inline (Record_Full_Invocation_Path); + -- Record all relations between scenario pairs found in the stack of + -- active scenarios. In_State is the current state of the Processing + -- phase. + + procedure Record_Invocation_Path (In_State : Processing_In_State); + pragma Inline (Record_Invocation_Path); + -- Record the invocation relations found within the path represented in + -- the active scenario stack. In_State denotes the current state of the + -- Processing phase. + + procedure Record_Simple_Invocation_Path (In_State : Processing_In_State); + pragma Inline (Record_Simple_Invocation_Path); + -- Record a single relation from the start to the end of the stack of + -- active scenarios. In_State is the current state of the Processing + -- phase. + + procedure Record_Invocation_Relation + (Invk_Id : Entity_Id; + Targ_Id : Entity_Id; + In_State : Processing_In_State); + pragma Inline (Record_Invocation_Relation); + -- Record an invocation relation with invoker Invk_Id and target Targ_Id + -- by creating an entry for it in the ALI file of the main unit. Formal + -- In_State denotes the current state of the Processing phase. + + procedure Set_Is_Saved_Construct + (Constr : Entity_Id; + Val : Boolean := True); + pragma Inline (Set_Is_Saved_Construct); + -- Mark invocation construct Constr as declared in the ALI file of the + -- main unit depending on value Val. + + procedure Set_Is_Saved_Relation + (Rel : Invoker_Target_Relation; + Val : Boolean := True); + pragma Inline (Set_Is_Saved_Relation); + -- Mark simple invocation relation Rel as recorded in the ALI file of + -- the main unit depending on value Val. + + function Target_Of + (Pos : Active_Scenario_Pos; + In_State : Processing_In_State) return Entity_Id; + pragma Inline (Target_Of); + -- Given position within the active scenario stack Pos, obtain the + -- target of the indicated scenario. In_State is the current state + -- of the Processing phase. + + procedure Traverse_Invocation_Body + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Traverse_Invocation_Body); + -- Traverse subprogram body N looking for suitable invocation scenarios + -- that need to be processed for invocation graph recording purposes. + -- In_State is the current state of the Processing phase. + + procedure Write_Invocation_Path (In_State : Processing_In_State); + pragma Inline (Write_Invocation_Path); + -- Write out a path represented by the active scenario on the stack to + -- standard output. In_State denotes the current state of the Processing + -- phase. - begin - -- To qualify, the instantiation must come from source + ------------------------------------ + -- Build_Elaborate_Body_Procedure -- + ------------------------------------ - return - Comes_From_Source (Orig_N) - and then Nkind (Orig_N) in N_Generic_Instantiation; - end Is_Suitable_Instantiation; + procedure Build_Elaborate_Body_Procedure is + Body_Decl : Node_Id; + Spec_Decl : Node_Id; - -------------------------- - -- Is_Suitable_Scenario -- - -------------------------- + begin + -- Nothing to do when a previous call already created the procedure - function Is_Suitable_Scenario (N : Node_Id) return Boolean is - begin - -- NOTE: Derived types and pragma Refined_State are intentionally left - -- out because they are not executable during elaboration. + if Present (Elab_Body_Id) then + return; + end if; - return - Is_Suitable_Access (N) - or else Is_Suitable_Call (N) - or else Is_Suitable_Instantiation (N) - or else Is_Suitable_Variable_Assignment (N) - or else Is_Suitable_Variable_Reference (N); - end Is_Suitable_Scenario; + Spec_And_Body_From_Entity + (Id => Cunit_Entity (Main_Unit), + Body_Decl => Body_Decl, + Spec_Decl => Spec_Decl); - ------------------------------------ - -- Is_Suitable_SPARK_Derived_Type -- - ------------------------------------ + pragma Assert (Present (Body_Decl)); - function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is - Prag : Node_Id; - Typ : Entity_Id; + Build_Elaborate_Procedure + (Proc_Id => Elab_Body_Id, + Proc_Nam => Name_B, + Loc => Sloc (Body_Decl)); + end Build_Elaborate_Body_Procedure; - begin - -- To qualify, the type declaration must denote a derived tagged type - -- with primitive operations, subject to pragma SPARK_Mode On. + ------------------------------- + -- Build_Elaborate_Procedure -- + ------------------------------- - if Nkind (N) = N_Full_Type_Declaration - and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition - then - Typ := Defining_Entity (N); - Prag := SPARK_Pragma (Typ); + procedure Build_Elaborate_Procedure + (Proc_Id : out Entity_Id; + Proc_Nam : Name_Id; + Loc : Source_Ptr) + is + Proc_Decl : Node_Id; + pragma Unreferenced (Proc_Decl); - return - Is_Tagged_Type (Typ) - and then Has_Primitive_Operations (Typ) - and then Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On; - end if; + begin + Proc_Id := Make_Defining_Identifier (Loc, Proc_Nam); - return False; - end Is_Suitable_SPARK_Derived_Type; + -- Partially decorate the elaboration procedure because it will not + -- be insertred into the tree and analyzed. - ------------------------------------- - -- Is_Suitable_SPARK_Instantiation -- - ------------------------------------- + Set_Ekind (Proc_Id, E_Procedure); + Set_Etype (Proc_Id, Standard_Void_Type); + Set_Scope (Proc_Id, Unique_Entity (Cunit_Entity (Main_Unit))); - function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is - Gen_Attrs : Target_Attributes; - Gen_Id : Entity_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; + -- Create a dummy declaration for the elaboration procedure. The + -- declaration does not need to be syntactically legal, but must + -- carry an accurate source location. - begin - -- To qualify, both the instantiation and the generic must be subject to - -- SPARK_Mode On. + Proc_Decl := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id), + Declarations => No_List, + Handled_Statement_Sequence => Empty); + end Build_Elaborate_Procedure; - if Is_Suitable_Instantiation (N) then - Extract_Instantiation_Attributes - (Exp_Inst => N, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + ------------------------------------ + -- Build_Elaborate_Spec_Procedure -- + ------------------------------------ - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + procedure Build_Elaborate_Spec_Procedure is + Body_Decl : Node_Id; + Spec_Decl : Node_Id; - return Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; - end if; + begin + -- Nothing to do when a previous call already created the procedure - return False; - end Is_Suitable_SPARK_Instantiation; + if Present (Elab_Spec_Id) then + return; + end if; - -------------------------------------------- - -- Is_Suitable_SPARK_Refined_State_Pragma -- - -------------------------------------------- + Spec_And_Body_From_Entity + (Id => Cunit_Entity (Main_Unit), + Body_Decl => Body_Decl, + Spec_Decl => Spec_Decl); - function Is_Suitable_SPARK_Refined_State_Pragma - (N : Node_Id) return Boolean - is - begin - -- To qualfy, the pragma must denote Refined_State + pragma Assert (Present (Spec_Decl)); - return - Nkind (N) = N_Pragma - and then Pragma_Name (N) = Name_Refined_State; - end Is_Suitable_SPARK_Refined_State_Pragma; + Build_Elaborate_Procedure + (Proc_Id => Elab_Spec_Id, + Proc_Nam => Name_S, + Loc => Sloc (Spec_Decl)); + end Build_Elaborate_Spec_Procedure; - ------------------------------------- - -- Is_Suitable_Variable_Assignment -- - ------------------------------------- + --------------------------------- + -- Build_Subprogram_Invocation -- + --------------------------------- - function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is - N_Unit : Node_Id; - N_Unit_Id : Entity_Id; - Nam : Node_Id; - Var_Decl : Node_Id; - Var_Id : Entity_Id; - Var_Unit : Node_Id; - Var_Unit_Id : Entity_Id; + function Build_Subprogram_Invocation + (Subp_Id : Entity_Id) return Node_Id + is + Marker : constant Node_Id := Make_Call_Marker (Sloc (Subp_Id)); + Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); - begin - -- This scenario is relevant only when the static model is in effect - -- because it is graph-dependent and does not involve any run-time - -- checks. Allowing it in the dynamic model would create confusing - -- noise. + begin + -- Create a dummy call marker which invokes the subprogram - if not Static_Elaboration_Checks then - return False; + Set_Is_Declaration_Level_Node (Marker, False); + Set_Is_Dispatching_Call (Marker, False); + Set_Is_Elaboration_Checks_OK_Node (Marker, False); + Set_Is_Elaboration_Warnings_OK_Node (Marker, False); + Set_Is_Ignored_Ghost_Node (Marker, False); + Set_Is_Source_Call (Marker, False); + Set_Is_SPARK_Mode_On_Node (Marker, False); - -- Nothing to do when the scenario is not an assignment + -- Invoke the uniform canonical entity of the subprogram - elsif Nkind (N) /= N_Assignment_Statement then - return False; + Set_Target (Marker, Canonical_Subprogram (Subp_Id)); - -- Nothing to do for internally-generated assignments because they are - -- assumed to be ABE safe. + -- Partially insert the marker into the tree - elsif not Comes_From_Source (N) then - return False; + Set_Parent (Marker, Parent (Subp_Decl)); - -- Assignments are ignored in GNAT mode on the assumption that they are - -- ABE-safe. This behaviour parallels that of the old ABE mechanism. + return Marker; + end Build_Subprogram_Invocation; - elsif GNAT_Mode then - return False; - end if; + --------------------------- + -- Build_Task_Activation -- + --------------------------- - Nam := Extract_Assignment_Name (N); + function Build_Task_Activation + (Task_Typ : Entity_Id; + In_State : Processing_In_State) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Task_Typ); + Marker : constant Node_Id := Make_Call_Marker (Loc); + Task_Decl : constant Node_Id := Unit_Declaration_Node (Task_Typ); - -- Sanitize the left hand side of the assignment + Activ_Id : Entity_Id; + Marker_Rep_Id : Scenario_Rep_Id; + Task_Obj : Entity_Id; + Task_Objs : NE_List.Doubly_Linked_List; - if not Is_Entity_Name (Nam) then - return False; + begin + -- Create a dummy call marker which activates some tasks - elsif No (Entity (Nam)) then - return False; - end if; + Set_Is_Declaration_Level_Node (Marker, False); + Set_Is_Dispatching_Call (Marker, False); + Set_Is_Elaboration_Checks_OK_Node (Marker, False); + Set_Is_Elaboration_Warnings_OK_Node (Marker, False); + Set_Is_Ignored_Ghost_Node (Marker, False); + Set_Is_Source_Call (Marker, False); + Set_Is_SPARK_Mode_On_Node (Marker, False); - Var_Id := Entity (Nam); + -- Invoke the appropriate version of Activate_Tasks - -- Sanitize the variable + if Restricted_Profile then + Activ_Id := RTE (RE_Activate_Restricted_Tasks); + else + Activ_Id := RTE (RE_Activate_Tasks); + end if; - if Var_Id = Any_Id then - return False; + Set_Target (Marker, Activ_Id); - elsif Ekind (Var_Id) /= E_Variable then - return False; - end if; + -- Partially insert the marker into the tree - Var_Decl := Declaration_Node (Var_Id); + Set_Parent (Marker, Parent (Task_Decl)); - if Nkind (Var_Decl) /= N_Object_Declaration then - return False; - end if; + -- Create a dummy task object. Partially decorate the object because + -- it will not be inserted into the tree and analyzed. - N_Unit_Id := Find_Top_Unit (N); - N_Unit := Unit_Declaration_Node (N_Unit_Id); + Task_Obj := Make_Temporary (Loc, 'T'); + Set_Ekind (Task_Obj, E_Variable); + Set_Etype (Task_Obj, Task_Typ); - Var_Unit_Id := Find_Top_Unit (Var_Decl); - Var_Unit := Unit_Declaration_Node (Var_Unit_Id); + -- Associate the dummy task object with the activation call - -- To qualify, the assignment must meet the following prerequisites: + Task_Objs := NE_List.Create; + NE_List.Append (Task_Objs, Task_Obj); - return - Comes_From_Source (Var_Id) + Marker_Rep_Id := Scenario_Representation_Of (Marker, In_State); + Set_Activated_Task_Objects (Marker_Rep_Id, Task_Objs); + Set_Activated_Task_Type (Marker_Rep_Id, Task_Typ); - -- The variable must be declared in the spec of compilation unit U + return Marker; + end Build_Task_Activation; - and then Nkind (Var_Unit) = N_Package_Declaration + ---------------------------------- + -- Declare_Invocation_Construct -- + ---------------------------------- - -- Performance note: parent traversal + procedure Declare_Invocation_Construct + (Constr_Id : Entity_Id; + In_State : Processing_In_State) + is + function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind; + pragma Inline (Kind_Of); + -- Obtain the invocation construct kind of arbitrary entity Id - and then Find_Enclosing_Level (Var_Decl) = Package_Spec + function Placement_Of (Id : Entity_Id) return Body_Placement_Kind; + pragma Inline (Placement_Of); + -- Obtain the body placement of arbitrary entity Id - -- The assignment must occur in the body of compilation unit U + function Placement_Of_Node (N : Node_Id) return Body_Placement_Kind; + pragma Inline (Placement_Of_Node); + -- Obtain the body placement of arbitrary node N - and then Nkind (N_Unit) = N_Package_Body - and then Present (Corresponding_Body (Var_Unit)) - and then Corresponding_Body (Var_Unit) = N_Unit_Id; - end Is_Suitable_Variable_Assignment; + ------------- + -- Kind_Of -- + ------------- - ------------------------------------ - -- Is_Suitable_Variable_Reference -- - ------------------------------------ + function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is + begin + if Id = Elab_Body_Id then + return Elaborate_Body_Procedure; - function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is - begin - -- Expanded names and identifiers are intentionally ignored because they - -- be folded, optimized away, etc. Variable references markers play the - -- role of variable references and provide a uniform foundation for ABE - -- processing. + elsif Id = Elab_Spec_Id then + return Elaborate_Spec_Procedure; - return Nkind (N) = N_Variable_Reference_Marker; - end Is_Suitable_Variable_Reference; + else + return Regular_Construct; + end if; + end Kind_Of; - ------------------------------------ - -- Is_Synchronous_Suspension_Call -- - ------------------------------------ + ------------------ + -- Placement_Of -- + ------------------ - function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean is - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; + function Placement_Of (Id : Entity_Id) return Body_Placement_Kind is + Id_Rep : constant Target_Rep_Id := + Target_Representation_Of (Id, In_State); + Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); + Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); - begin - -- To qualify, the call must invoke one of the runtime routines which - -- perform synchronous suspension. + begin + -- The entity has a body - if Is_Suitable_Call (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); + if Present (Body_Decl) then + return Placement_Of_Node (Body_Decl); - return - Is_RTE (Target_Id, RE_Suspend_Until_True) - or else - Is_RTE (Target_Id, RE_Wait_For_Release); - end if; + -- Otherwise the entity must have a spec - return False; - end Is_Synchronous_Suspension_Call; + else + pragma Assert (Present (Spec_Decl)); + return Placement_Of_Node (Spec_Decl); + end if; + end Placement_Of; - ------------------- - -- Is_Task_Entry -- - ------------------- + ----------------------- + -- Placement_Of_Node -- + ----------------------- - function Is_Task_Entry (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote an entry defined in a task type + function Placement_Of_Node (N : Node_Id) return Body_Placement_Kind is + Main_Unit_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + N_Unit_Id : constant Entity_Id := Find_Top_Unit (N); - return - Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); - end Is_Task_Entry; + begin + -- The node is in the main unit, its placement depends on the main + -- unit kind. - ------------------------ - -- Is_Up_Level_Target -- - ------------------------ + if N_Unit_Id = Main_Unit_Id then - function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean is - Root : constant Node_Id := Root_Scenario; + -- The main unit is a body - begin - -- The root appears within the declaratons of a block statement, entry - -- body, subprogram body, or task body ignoring enclosing packages. The - -- root is always within the main unit. An up-level target is a notion - -- applicable only to the static model because scenarios are reached by - -- means of graph traversal started from a fixed declarative or library - -- level. + if Ekind_In (Main_Unit_Id, E_Package_Body, + E_Subprogram_Body) + then + return In_Body; - -- Performance note: parent traversal + -- The main unit is a stand-alone subprogram body - if Static_Elaboration_Checks - and then Find_Enclosing_Level (Root) = Declaration_Level - then - -- The target is within the main unit. It acts as an up-level target - -- when it appears within a context which encloses the root. + elsif Ekind_In (Main_Unit_Id, E_Function, E_Procedure) + and then Nkind (Unit_Declaration_Node (Main_Unit_Id)) = + N_Subprogram_Body + then + return In_Body; - -- package body Main_Unit is - -- function Func ...; -- target + -- Otherwise the main unit is a spec - -- procedure Proc is - -- X : ... := Func; -- root scenario + else + return In_Spec; + end if; - if In_Extended_Main_Code_Unit (Target_Decl) then + -- Otherwise the node is in the complementary unit of the main + -- unit. The main unit is a body, the node is in the spec. - -- Performance note: parent traversal + elsif Ekind_In (Main_Unit_Id, E_Package_Body, + E_Subprogram_Body) + then + return In_Spec; - return not In_Same_Context (Root, Target_Decl, Nested_OK => True); + -- The main unit is a spec, the node is in the body - -- Otherwise the target is external to the main unit which makes it - -- an up-level target. + else + return In_Body; + end if; + end Placement_Of_Node; - else - return True; - end if; - end if; + -- Local variables - return False; - end Is_Up_Level_Target; + IC_Rec : Invocation_Construct_Record; - --------------------- - -- Is_Visited_Body -- - --------------------- + -- Start of processing for Declare_Invocation_Construct - function Is_Visited_Body (Body_Decl : Node_Id) return Boolean is - begin - if Visited_Bodies_In_Use then - return Visited_Bodies.Get (Body_Decl); - end if; + begin + -- Nothing to do when the construct has already been declared in the + -- ALI file. - return Visited_Bodies_No_Element; - end Is_Visited_Body; + if Is_Saved_Construct (Constr_Id) then + return; + end if; - ------------------------------- - -- Kill_Elaboration_Scenario -- - ------------------------------- + -- Mark the construct as declared in the ALI file - procedure Kill_Elaboration_Scenario (N : Node_Id) is - procedure Kill_SPARK_Scenario; - pragma Inline (Kill_SPARK_Scenario); - -- Eliminate scenario N from table SPARK_Scenarios if it is recorded - -- there. + Set_Is_Saved_Construct (Constr_Id); - procedure Kill_Top_Level_Scenario; - pragma Inline (Kill_Top_Level_Scenario); - -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded - -- there. + IC_Rec.Kind := Kind_Of (Constr_Id); + IC_Rec.Placement := Placement_Of (Constr_Id); + IC_Rec.Signature := Signature_Of (Constr_Id); - ------------------------- - -- Kill_SPARK_Scenario -- - ------------------------- + -- Add the construct in the ALI file - procedure Kill_SPARK_Scenario is - package Scenarios renames SPARK_Scenarios; + Add_Invocation_Construct + (IC_Rec => IC_Rec, + Update_Units => False); + end Declare_Invocation_Construct; - begin - if Is_Recorded_SPARK_Scenario (N) then + ------------------------------- + -- Finalize_Invocation_Graph -- + ------------------------------- - -- Performance note: list traversal + procedure Finalize_Invocation_Graph is + begin + NE_Set.Destroy (Saved_Constructs_Set); + IR_Set.Destroy (Saved_Relations_Set); + end Finalize_Invocation_Graph; - for Index in Scenarios.First .. Scenarios.Last loop - if Scenarios.Table (Index) = N then - Scenarios.Table (Index) := Empty; + ---------- + -- Hash -- + ---------- - -- The SPARK scenario is no longer recorded + function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type is + pragma Assert (Present (Key.Invoker)); + pragma Assert (Present (Key.Target)); - Set_Is_Recorded_SPARK_Scenario (N, False); - return; - end if; - end loop; + begin + return + Hash_Two_Keys + (Bucket_Range_Type (Key.Invoker), + Bucket_Range_Type (Key.Target)); + end Hash; - -- A recorded SPARK scenario must be in the table of recorded - -- SPARK scenarios. + --------------------------------- + -- Initialize_Invocation_Graph -- + --------------------------------- - pragma Assert (False); - end if; - end Kill_SPARK_Scenario; + procedure Initialize_Invocation_Graph is + begin + Saved_Constructs_Set := NE_Set.Create (100); + Saved_Relations_Set := IR_Set.Create (200); + end Initialize_Invocation_Graph; - ----------------------------- - -- Kill_Top_Level_Scenario -- - ----------------------------- + ----------------------------------- + -- Invocation_Graph_Recording_OK -- + ----------------------------------- - procedure Kill_Top_Level_Scenario is - package Scenarios renames Top_Level_Scenarios; + function Invocation_Graph_Recording_OK return Boolean is + Main_Cunit : constant Node_Id := Cunit (Main_Unit); begin - if Is_Recorded_Top_Level_Scenario (N) then + -- Nothing to do when switch -gnatd_G (encode invocation graph in ALI + -- files) is not in effect. - -- Performance node: list traversal + if not Debug_Flag_Underscore_GG then + return False; - for Index in Scenarios.First .. Scenarios.Last loop - if Scenarios.Table (Index) = N then - Scenarios.Table (Index) := Empty; + -- Nothing to do when compiling for GNATprove because the invocation + -- graph is not needed. - -- The top-level scenario is no longer recorded + elsif GNATprove_Mode then + return False; - Set_Is_Recorded_Top_Level_Scenario (N, False); - return; - end if; - end loop; + -- Nothing to do when the compilation will not produce an ALI file - -- A recorded top-level scenario must be in the table of recorded - -- top-level scenarios. + elsif Serious_Errors_Detected > 0 then + return False; - pragma Assert (False); - end if; - end Kill_Top_Level_Scenario; + -- Nothing to do when the main unit requires a body. Processing the + -- completing body will create the ALI file for the unit and record + -- the invocation graph. - -- Start of processing for Kill_Elaboration_Scenario + elsif Body_Required (Main_Cunit) then + return False; + end if; - begin - -- Nothing to do when switch -gnatH (legacy elaboration checking mode - -- enabled) is in effect because the legacy ABE lechanism does not need - -- to carry out this action. + return True; + end Invocation_Graph_Recording_OK; - if Legacy_Elaboration_Checks then - return; - end if; + ---------------------------- + -- Is_Invocation_Scenario -- + ---------------------------- - -- Eliminate a recorded scenario when it appears within dead code - -- because it will not be executed at elaboration time. + function Is_Invocation_Scenario (N : Node_Id) return Boolean is + begin + return + Is_Suitable_Access_Taken (N) + or else Is_Suitable_Call (N) + or else Is_Suitable_Instantiation (N); + end Is_Invocation_Scenario; - if Is_Scenario (N) then - Kill_SPARK_Scenario; - Kill_Top_Level_Scenario; - end if; - end Kill_Elaboration_Scenario; + -------------------------- + -- Is_Invocation_Target -- + -------------------------- - ---------------------------------- - -- Meet_Elaboration_Requirement -- - ---------------------------------- + function Is_Invocation_Target (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must either come from source, or denote an + -- Ada, bridge, or SPARK target. - procedure Meet_Elaboration_Requirement - (N : Node_Id; - Target_Id : Entity_Id; - Req_Nam : Name_Id) - is - Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); - Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); + return + Comes_From_Source (Id) + or else Is_Ada_Semantic_Target (Id) + or else Is_Bridge_Target (Id) + or else Is_SPARK_Semantic_Target (Id); + end Is_Invocation_Target; + + ------------------------ + -- Is_Saved_Construct -- + ------------------------ + + function Is_Saved_Construct (Constr : Entity_Id) return Boolean is + pragma Assert (Present (Constr)); + begin + return NE_Set.Contains (Saved_Constructs_Set, Constr); + end Is_Saved_Construct; - function Find_Preelaboration_Pragma - (Prag_Nam : Name_Id) return Node_Id; - pragma Inline (Find_Preelaboration_Pragma); - -- Traverse the visible declarations of unit Unit_Id and locate a source - -- preelaboration-related pragma with name Prag_Nam. + ----------------------- + -- Is_Saved_Relation -- + ----------------------- - procedure Info_Requirement_Met (Prag : Node_Id); - pragma Inline (Info_Requirement_Met); - -- Output information concerning pragma Prag which meets requirement - -- Req_Nam. + function Is_Saved_Relation + (Rel : Invoker_Target_Relation) return Boolean + is + pragma Assert (Present (Rel.Invoker)); + pragma Assert (Present (Rel.Target)); - procedure Info_Scenario; - pragma Inline (Info_Scenario); - -- Output information concerning scenario N + begin + return IR_Set.Contains (Saved_Relations_Set, Rel); + end Is_Saved_Relation; - -------------------------------- - -- Find_Preelaboration_Pragma -- - -------------------------------- + -------------------------- + -- Process_Declarations -- + -------------------------- - function Find_Preelaboration_Pragma - (Prag_Nam : Name_Id) return Node_Id + procedure Process_Declarations + (Decls : List_Id; + In_State : Processing_In_State) is - Spec : constant Node_Id := Parent (Unit_Id); Decl : Node_Id; begin - -- A preelaboration-related pragma comes from source and appears at - -- the top of the visible declarations of a package. + Decl := First (Decls); + while Present (Decl) loop - if Nkind (Spec) = N_Package_Specification then - Decl := First (Visible_Declarations (Spec)); - while Present (Decl) loop - if Comes_From_Source (Decl) then - if Nkind (Decl) = N_Pragma - and then Pragma_Name (Decl) = Prag_Nam - then - return Decl; + -- Freeze node - -- Otherwise the construct terminates the region where the - -- preelaboration-related pragma may appear. + if Nkind (Decl) = N_Freeze_Entity then + Process_Freeze_Node + (Fnode => Decl, + In_State => In_State); - else - exit; - end if; - end if; + -- Package (nested) - Next (Decl); - end loop; - end if; + elsif Nkind (Decl) = N_Package_Declaration then + Process_Package_Declaration + (Pack_Decl => Decl, + In_State => In_State); - return Empty; - end Find_Preelaboration_Pragma; + -- Protected type - -------------------------- - -- Info_Requirement_Met -- - -------------------------- + elsif Nkind_In (Decl, N_Protected_Type_Declaration, + N_Single_Protected_Declaration) + then + Process_Protected_Type_Declaration + (Prot_Decl => Decl, + In_State => In_State); + + -- Subprogram or entry + + elsif Nkind_In (Decl, N_Entry_Declaration, + N_Subprogram_Declaration) + then + Process_Subprogram_Declaration + (Subp_Decl => Decl, + In_State => In_State); + + -- Subprogram body (stand alone) + + elsif Nkind (Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Decl)) + then + Process_Subprogram_Declaration + (Subp_Decl => Decl, + In_State => In_State); + + -- Subprogram instantiation + + elsif Nkind (Decl) in N_Subprogram_Instantiation then + Process_Subprogram_Instantiation + (Inst => Decl, + In_State => In_State); + + -- Task type - procedure Info_Requirement_Met (Prag : Node_Id) is + elsif Nkind_In (Decl, N_Single_Task_Declaration, + N_Task_Type_Declaration) + then + Process_Task_Type_Declaration + (Task_Decl => Decl, + In_State => In_State); + + -- Task type (derived) + + elsif Nkind (Decl) = N_Full_Type_Declaration + and then Is_Task_Type (Defining_Entity (Decl)) + then + Process_Task_Type_Declaration + (Task_Decl => Decl, + In_State => In_State); + end if; + + Next (Decl); + end loop; + end Process_Declarations; + + ------------------------- + -- Process_Freeze_Node -- + ------------------------- + + procedure Process_Freeze_Node + (Fnode : Node_Id; + In_State : Processing_In_State) + is begin - pragma Assert (Present (Prag)); + Process_Declarations + (Decls => Actions (Fnode), + In_State => In_State); + end Process_Freeze_Node; - Error_Msg_Name_1 := Req_Nam; - Error_Msg_Sloc := Sloc (Prag); - Error_Msg_NE - ("\\% requirement for unit & met by pragma #", N, Unit_Id); - end Info_Requirement_Met; + ----------------------------------- + -- Process_Invocation_Activation -- + ----------------------------------- - ------------------- - -- Info_Scenario -- - ------------------- + procedure Process_Invocation_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Call); + pragma Unreferenced (Call_Rep); + pragma Unreferenced (Obj_Id); + pragma Unreferenced (Obj_Rep); - procedure Info_Scenario is begin - if Is_Suitable_Call (N) then - Info_Call - (Call => N, - Target_Id => Target_Id, - Info_Msg => False, - In_SPARK => True); + -- Nothing to do when the task type appears within an internal unit - elsif Is_Suitable_Instantiation (N) then - Info_Instantiation - (Inst => N, - Gen_Id => Target_Id, - Info_Msg => False, - In_SPARK => True); + if In_Internal_Unit (Task_Typ) then + return; + end if; - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Error_Msg_N - ("read of refinement constituents during elaboration in SPARK", - N); + -- The task type being activated is within the main unit. Extend the + -- DFS traversal into its body. - elsif Is_Suitable_Variable_Reference (N) then - Info_Variable_Reference - (Ref => N, - Var_Id => Target_Id, - Info_Msg => False, - In_SPARK => True); + if In_Extended_Main_Code_Unit (Task_Typ) then + Traverse_Invocation_Body + (N => Body_Declaration (Task_Rep), + In_State => In_State); - -- No other scenario may impose a requirement on the context of the - -- main unit. + -- The task type being activated resides within an external unit + -- + -- Main unit External unit + -- +-----------+ +-------------+ + -- | | | | + -- | Start ------------> Task_Typ | + -- | | | | + -- +-----------+ +-------------+ + -- + -- Record the invocation path which originates from Start and reaches + -- the task type. else - pragma Assert (False); - null; + Record_Invocation_Path (In_State); end if; - end Info_Scenario; - - -- Local variables + end Process_Invocation_Activation; - Elab_Attrs : Elaboration_Attributes; - Elab_Nam : Name_Id; - Req_Met : Boolean; + --------------------------------------- + -- Process_Invocation_Body_Scenarios -- + --------------------------------------- - -- Start of processing for Meet_Elaboration_Requirement + procedure Process_Invocation_Body_Scenarios is + Iter : NE_Set.Iterator := Iterate_Library_Body_Scenarios; + begin + Process_Invocation_Scenarios + (Iter => Iter, + In_State => Invocation_Body_State); + end Process_Invocation_Body_Scenarios; - begin - pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); + ----------------------------- + -- Process_Invocation_Call -- + ----------------------------- - -- Assume that the requirement has not been met + procedure Process_Invocation_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Call); - Req_Met := False; + Subp_Id : constant Entity_Id := Target (Call_Rep); + Subp_Rep : constant Target_Rep_Id := + Target_Representation_Of (Subp_Id, In_State); - -- Elaboration requirements are verified only when the static model is - -- in effect because this diagnostic is graph-dependent. + begin + -- Nothing to do when the subprogram appears within an internal unit - if not Static_Elaboration_Checks then - return; + if In_Internal_Unit (Subp_Id) then + return; - -- If the target is within the main unit, either at the source level or - -- through an instantiation, then there is no real requirement to meet - -- because the main unit cannot force its own elaboration by means of an - -- Elaborate[_All] pragma. Treat this case as valid coverage. + -- Nothing to do for an abstract subprogram because it has no body to + -- examine. - elsif In_Extended_Main_Code_Unit (Target_Id) then - Req_Met := True; + elsif Ekind_In (Subp_Id, E_Function, E_Procedure) + and then Is_Abstract_Subprogram (Subp_Id) + then + return; - -- Otherwise the target resides in an external unit + -- Nothin to do for a formal subprogram because it has no body to + -- examine. - -- The requirement is met when the target comes from an internal unit - -- because such a unit is elaborated prior to a non-internal unit. + elsif Is_Formal_Subprogram (Subp_Id) then + return; + end if; - elsif In_Internal_Unit (Unit_Id) - and then not In_Internal_Unit (Main_Id) - then - Req_Met := True; + -- The subprogram being called is within the main unit. Extend the + -- DFS traversal into its barrier function and body. - -- The requirement is met when the target comes from a preelaborated - -- unit. This portion must parallel predicate Is_Preelaborated_Unit. + if In_Extended_Main_Code_Unit (Subp_Id) then + if Ekind_In (Subp_Id, E_Entry, E_Entry_Family, E_Procedure) then + Traverse_Invocation_Body + (N => Barrier_Body_Declaration (Subp_Rep), + In_State => In_State); + end if; - elsif Is_Preelaborated_Unit (Unit_Id) then - Req_Met := True; + Traverse_Invocation_Body + (N => Body_Declaration (Subp_Rep), + In_State => In_State); - -- Output extra information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas. + -- The subprogram being called resides within an external unit + -- + -- Main unit External unit + -- +-----------+ +-------------+ + -- | | | | + -- | Start ------------> Subp_Id | + -- | | | | + -- +-----------+ +-------------+ + -- + -- Record the invocation path which originates from Start and reaches + -- the subprogram. - if Elab_Info_Messages then - if Is_Preelaborated (Unit_Id) then - Elab_Nam := Name_Preelaborate; + else + Record_Invocation_Path (In_State); + end if; + end Process_Invocation_Call; - elsif Is_Pure (Unit_Id) then - Elab_Nam := Name_Pure; + --------------------------------- + -- Process_Invocation_Scenario -- + --------------------------------- - elsif Is_Remote_Call_Interface (Unit_Id) then - Elab_Nam := Name_Remote_Call_Interface; + procedure Process_Invocation_Scenario + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); + Scen_Rep : Scenario_Rep_Id; - elsif Is_Remote_Types (Unit_Id) then - Elab_Nam := Name_Remote_Types; + begin + -- Add the current scenario to the stack of active scenarios - else - pragma Assert (Is_Shared_Passive (Unit_Id)); - Elab_Nam := Name_Shared_Passive; - end if; + Push_Active_Scenario (Scen); - Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); - end if; + -- Call or task activation - -- Determine whether the context of the main unit has a pragma strong - -- enough to meet the requirement. + if Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - else - Elab_Attrs := Elaboration_Status (Unit_Id); + -- Routine Build_Call_Marker creates call markers regardless of + -- whether the call occurs within the main unit or not. This way + -- the serialization of internal names is kept consistent. Only + -- call markers found within the main unit must be processed. - -- The pragma must be either Elaborate_All or be as strong as the - -- requirement. + if In_Main_Context (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - if Present (Elab_Attrs.Source_Pragma) - and then Nam_In (Pragma_Name (Elab_Attrs.Source_Pragma), - Name_Elaborate_All, - Req_Nam) - then - Req_Met := True; + if Kind (Scen_Rep) = Call_Scenario then + Process_Invocation_Call + (Call => Scen, + Call_Rep => Scen_Rep, + In_State => In_State); - -- Output extra information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas. + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); - if Elab_Info_Messages then - Info_Requirement_Met (Elab_Attrs.Source_Pragma); + Process_Activation + (Call => Scen, + Call_Rep => Scen_Rep, + Processor => Process_Invocation_Activation'Access, + In_State => In_State); + end if; end if; end if; - end if; - - -- The requirement was not met by the context of the main unit, issue an - -- error. - if not Req_Met then - Info_Scenario; + -- Remove the current scenario from the stack of active scenarios + -- once all invocation constructs and paths have been saved. - Error_Msg_Name_1 := Req_Nam; - Error_Msg_Node_2 := Unit_Id; - Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); + Pop_Active_Scenario (Scen); + end Process_Invocation_Scenario; - Output_Active_Scenarios (N); - end if; - end Meet_Elaboration_Requirement; + ---------------------------------- + -- Process_Invocation_Scenarios -- + ---------------------------------- - ---------------------- - -- Non_Private_View -- - ---------------------- + procedure Process_Invocation_Scenarios + (Iter : in out NE_Set.Iterator; + In_State : Processing_In_State) + is + N : Node_Id; - function Non_Private_View (Typ : Entity_Id) return Entity_Id is - begin - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - return Full_View (Typ); - else - return Typ; - end if; - end Non_Private_View; + begin + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - ----------------------------- - -- Output_Active_Scenarios -- - ----------------------------- + -- Reset the traversed status of all subprogram bodies because the + -- current invocation scenario acts as a new DFS traversal root. - procedure Output_Active_Scenarios (Error_Nod : Node_Id) is - procedure Output_Access (N : Node_Id); - -- Emit a specific diagnostic message for 'Access denote by N + Reset_Traversed_Bodies; - procedure Output_Activation_Call (N : Node_Id); - -- Emit a specific diagnostic message for task activation N + Process_Invocation_Scenario (N, In_State); + end loop; + end Process_Invocation_Scenarios; - procedure Output_Call (N : Node_Id; Target_Id : Entity_Id); - -- Emit a specific diagnostic message for call N which invokes target - -- Target_Id. + --------------------------------------- + -- Process_Invocation_Spec_Scenarios -- + --------------------------------------- - procedure Output_Header; - -- Emit a specific diagnostic message for the unit of the root scenario + procedure Process_Invocation_Spec_Scenarios is + Iter : NE_Set.Iterator := Iterate_Library_Spec_Scenarios; + begin + Process_Invocation_Scenarios + (Iter => Iter, + In_State => Invocation_Spec_State); + end Process_Invocation_Spec_Scenarios; - procedure Output_Instantiation (N : Node_Id); - -- Emit a specific diagnostic message for instantiation N + ----------------------- + -- Process_Main_Unit -- + ----------------------- - procedure Output_SPARK_Refined_State_Pragma (N : Node_Id); - -- Emit a specific diagnostic message for Refined_State pragma N + procedure Process_Main_Unit is + Unit_Decl : constant Node_Id := Unit (Cunit (Main_Unit)); + Spec_Id : Entity_Id; - procedure Output_Variable_Assignment (N : Node_Id); - -- Emit a specific diagnostic message for assignment statement N + begin + -- The main unit is a [generic] package body - procedure Output_Variable_Reference (N : Node_Id); - -- Emit a specific diagnostic message for reference N which mentions a - -- variable. + if Nkind (Unit_Decl) = N_Package_Body then + Spec_Id := Corresponding_Spec (Unit_Decl); + pragma Assert (Present (Spec_Id)); - ------------------- - -- Output_Access -- - ------------------- + Process_Package_Declaration + (Pack_Decl => Unit_Declaration_Node (Spec_Id), + In_State => Invocation_Construct_State); - procedure Output_Access (N : Node_Id) is - Subp_Id : constant Entity_Id := Entity (Prefix (N)); + -- The main unit is a [generic] package declaration - begin - Error_Msg_Name_1 := Attribute_Name (N); - Error_Msg_Sloc := Sloc (N); - Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); - end Output_Access; + elsif Nkind (Unit_Decl) = N_Package_Declaration then + Process_Package_Declaration + (Pack_Decl => Unit_Decl, + In_State => Invocation_Construct_State); - ---------------------------- - -- Output_Activation_Call -- - ---------------------------- + -- The main unit is a [generic] subprogram body - procedure Output_Activation_Call (N : Node_Id) is - function Find_Activator (Call : Node_Id) return Entity_Id; - -- Find the nearest enclosing construct which houses call Call + elsif Nkind (Unit_Decl) = N_Subprogram_Body then + Spec_Id := Corresponding_Spec (Unit_Decl); - -------------------- - -- Find_Activator -- - -------------------- + -- The body completes a previous declaration - function Find_Activator (Call : Node_Id) return Entity_Id is - Par : Node_Id; + if Present (Spec_Id) then + Process_Subprogram_Declaration + (Subp_Decl => Unit_Declaration_Node (Spec_Id), + In_State => Invocation_Construct_State); - begin - -- Climb the parent chain looking for a package [body] or a - -- construct with a statement sequence. + -- Otherwise the body is stand-alone - Par := Parent (Call); - while Present (Par) loop - if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then - return Defining_Entity (Par); + else + Process_Subprogram_Declaration + (Subp_Decl => Unit_Decl, + In_State => Invocation_Construct_State); + end if; - elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then - return Defining_Entity (Parent (Par)); - end if; + -- The main unit is a subprogram instantiation - Par := Parent (Par); - end loop; + elsif Nkind (Unit_Decl) in N_Subprogram_Instantiation then + Process_Subprogram_Instantiation + (Inst => Unit_Decl, + In_State => Invocation_Construct_State); - return Empty; - end Find_Activator; + -- The main unit is an imported subprogram declaration - -- Local variables + elsif Nkind (Unit_Decl) = N_Subprogram_Declaration then + Process_Subprogram_Declaration + (Subp_Decl => Unit_Decl, + In_State => Invocation_Construct_State); + end if; + end Process_Main_Unit; - Activator : constant Entity_Id := Find_Activator (N); + --------------------------------- + -- Process_Package_Declaration -- + --------------------------------- - -- Start of processing for Output_Activation_Call + procedure Process_Package_Declaration + (Pack_Decl : Node_Id; + In_State : Processing_In_State) + is + Body_Id : constant Entity_Id := Corresponding_Body (Pack_Decl); + Spec : constant Node_Id := Specification (Pack_Decl); + Spec_Id : constant Entity_Id := Defining_Entity (Pack_Decl); begin - pragma Assert (Present (Activator)); + -- Add a declaration for the generic package in the ALI of the main + -- unit in case a client unit instantiates it. - Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); - end Output_Activation_Call; + if Ekind (Spec_Id) = E_Generic_Package then + Declare_Invocation_Construct + (Constr_Id => Spec_Id, + In_State => In_State); - ----------------- - -- Output_Call -- - ----------------- + -- Otherwise inspect the visible and private declarations of the + -- package for invocation constructs. - procedure Output_Call (N : Node_Id; Target_Id : Entity_Id) is - procedure Output_Accept_Alternative; - pragma Inline (Output_Accept_Alternative); - -- Emit a specific diagnostic message concerning an accept - -- alternative. + else + Process_Declarations + (Decls => Visible_Declarations (Spec), + In_State => In_State); + + Process_Declarations + (Decls => Private_Declarations (Spec), + In_State => In_State); + + -- The package body containst at least one generic unit or an + -- inlinable subprogram. Such constructs may grant clients of + -- the main unit access to the private enclosing contexts of + -- the constructs. Process the main unit body to discover and + -- encode relevant invocation constructs and relations that + -- may ultimately reach an external unit. + + if Present (Body_Id) + and then Save_Invocation_Graph_Of_Body (Cunit (Main_Unit)) + then + Process_Declarations + (Decls => Declarations (Unit_Declaration_Node (Body_Id)), + In_State => In_State); + end if; + end if; + end Process_Package_Declaration; - procedure Output_Call (Kind : String); - pragma Inline (Output_Call); - -- Emit a specific diagnostic message concerning a call of kind Kind + ---------------------------------------- + -- Process_Protected_Type_Declaration -- + ---------------------------------------- - procedure Output_Type_Actions (Action : String); - pragma Inline (Output_Type_Actions); - -- Emit a specific diagnostic message concerning action Action of a - -- type. + procedure Process_Protected_Type_Declaration + (Prot_Decl : Node_Id; + In_State : Processing_In_State) + is + Prot_Def : constant Node_Id := Protected_Definition (Prot_Decl); - procedure Output_Verification_Call - (Pred : String; - Id : Entity_Id; - Id_Kind : String); - pragma Inline (Output_Verification_Call); - -- Emit a specific diagnostic message concerning the verification of - -- predicate Pred applied to related entity Id with kind Id_Kind. + begin + if Present (Prot_Def) then + Process_Declarations + (Decls => Visible_Declarations (Prot_Def), + In_State => In_State); + end if; + end Process_Protected_Type_Declaration; - ------------------------------- - -- Output_Accept_Alternative -- - ------------------------------- + ------------------------------------ + -- Process_Subprogram_Declaration -- + ------------------------------------ + + procedure Process_Subprogram_Declaration + (Subp_Decl : Node_Id; + In_State : Processing_In_State) + is + Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); - procedure Output_Accept_Alternative is - Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); + begin + -- Nothing to do when the subprogram is not an invocation target - begin - pragma Assert (Present (Entry_Id)); + if not Is_Invocation_Target (Subp_Id) then + return; + end if; - Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); - end Output_Accept_Alternative; + -- Add a declaration for the subprogram in the ALI file of the main + -- unit in case a client unit calls or instantiates it. - ----------------- - -- Output_Call -- - ----------------- + Declare_Invocation_Construct + (Constr_Id => Subp_Id, + In_State => In_State); - procedure Output_Call (Kind : String) is - begin - Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Target_Id); - end Output_Call; + -- Do not process subprograms without a body because they do not + -- contain any invocation scenarios. - ------------------------- - -- Output_Type_Actions -- - ------------------------- + if Is_Bodiless_Subprogram (Subp_Id) then + null; - procedure Output_Type_Actions (Action : String) is - Typ : constant Entity_Id := First_Formal_Type (Target_Id); + -- Do not process generic subprograms because generics must not be + -- examined. - begin - pragma Assert (Present (Typ)); + elsif Is_Generic_Subprogram (Subp_Id) then + null; - Error_Msg_NE - ("\\ " & Action & " actions for type & #", Error_Nod, Typ); - end Output_Type_Actions; + -- Otherwise create a dummy scenario which calls the subprogram to + -- act as a root for a DFS traversal. - ------------------------------ - -- Output_Verification_Call -- - ------------------------------ + else + -- Reset the traversed status of all subprogram bodies because the + -- subprogram acts as a new DFS traversal root. - procedure Output_Verification_Call - (Pred : String; - Id : Entity_Id; - Id_Kind : String) - is - begin - pragma Assert (Present (Id)); + Reset_Traversed_Bodies; - Error_Msg_NE - ("\\ " & Pred & " of " & Id_Kind & " & verified #", - Error_Nod, Id); - end Output_Verification_Call; + Process_Invocation_Scenario + (N => Build_Subprogram_Invocation (Subp_Id), + In_State => In_State); + end if; + end Process_Subprogram_Declaration; - -- Start of processing for Output_Call + -------------------------------------- + -- Process_Subprogram_Instantiation -- + -------------------------------------- + procedure Process_Subprogram_Instantiation + (Inst : Node_Id; + In_State : Processing_In_State) + is begin - Error_Msg_Sloc := Sloc (N); + -- Add a declaration for the instantiation in the ALI file of the + -- main unit in case a client unit calls it. - -- Accept alternative + Declare_Invocation_Construct + (Constr_Id => Defining_Entity (Inst), + In_State => In_State); + end Process_Subprogram_Instantiation; - if Is_Accept_Alternative_Proc (Target_Id) then - Output_Accept_Alternative; + ----------------------------------- + -- Process_Task_Type_Declaration -- + ----------------------------------- - -- Adjustment + procedure Process_Task_Type_Declaration + (Task_Decl : Node_Id; + In_State : Processing_In_State) + is + Task_Typ : constant Entity_Id := Defining_Entity (Task_Decl); + Task_Def : Node_Id; - elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then - Output_Type_Actions ("adjustment"); + begin + -- Add a declaration for the task type the ALI file of the main unit + -- in case a client unit creates a task object and activates it. - -- Default_Initial_Condition + Declare_Invocation_Construct + (Constr_Id => Task_Typ, + In_State => In_State); - elsif Is_Default_Initial_Condition_Proc (Target_Id) then - Output_Verification_Call - (Pred => "Default_Initial_Condition", - Id => First_Formal_Type (Target_Id), - Id_Kind => "type"); + -- Process the entries of the task type because they represent valid + -- entry points into the task body. - -- Entries + if Nkind_In (Task_Decl, N_Single_Task_Declaration, + N_Task_Type_Declaration) + then + Task_Def := Task_Definition (Task_Decl); - elsif Is_Protected_Entry (Target_Id) then - Output_Call ("entry"); + if Present (Task_Def) then + Process_Declarations + (Decls => Visible_Declarations (Task_Def), + In_State => In_State); + end if; + end if; - -- Task entry calls are never processed because the entry being - -- invoked does not have a corresponding "body", it has a select. A - -- task entry call appears in the stack of active scenarios for the - -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and - -- nothing more. + -- Reset the traversed status of all subprogram bodies because the + -- task type acts as a new DFS traversal root. - elsif Is_Task_Entry (Target_Id) then - null; + Reset_Traversed_Bodies; - -- Finalization + -- Create a dummy scenario which activates an anonymous object of the + -- task type to acts as a root of a DFS traversal. - elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then - Output_Type_Actions ("finalization"); + Process_Invocation_Scenario + (N => Build_Task_Activation (Task_Typ, In_State), + In_State => In_State); + end Process_Task_Type_Declaration; - -- Calls to _Finalizer procedures must not appear in the output - -- because this creates confusing noise. + --------------------------------- + -- Record_Full_Invocation_Path -- + --------------------------------- - elsif Is_Finalizer_Proc (Target_Id) then - null; + procedure Record_Full_Invocation_Path (In_State : Processing_In_State) is + package Scenarios renames Active_Scenario_Stack; - -- Initial_Condition + begin + -- The path originates from the elaboration of the body. Add an extra + -- relation from the elaboration body procedure to the first active + -- scenario. - elsif Is_Initial_Condition_Proc (Target_Id) then - Output_Verification_Call - (Pred => "Initial_Condition", - Id => Find_Enclosing_Scope (N), - Id_Kind => "package"); + if In_State.Processing = Invocation_Body_Processing then + Build_Elaborate_Body_Procedure; - -- Initialization + Record_Invocation_Relation + (Invk_Id => Elab_Body_Id, + Targ_Id => Target_Of (Scenarios.First, In_State), + In_State => In_State); - elsif Is_Init_Proc (Target_Id) - or else Is_TSS (Target_Id, TSS_Deep_Initialize) - then - Output_Type_Actions ("initialization"); + -- The path originates from the elaboration of the spec. Add an extra + -- relation from the elaboration spec procedure to the first active + -- scenario. - -- Invariant + elsif In_State.Processing = Invocation_Spec_Processing then + Build_Elaborate_Spec_Procedure; - elsif Is_Invariant_Proc (Target_Id) then - Output_Verification_Call - (Pred => "invariants", - Id => First_Formal_Type (Target_Id), - Id_Kind => "type"); + Record_Invocation_Relation + (Invk_Id => Elab_Spec_Id, + Targ_Id => Target_Of (Scenarios.First, In_State), + In_State => In_State); + end if; - -- Partial invariant calls must not appear in the output because this - -- creates confusing noise. Note that a partial invariant is always - -- invoked by the "full" invariant which is already placed on the - -- stack. + -- Record individual relations formed by pairs of scenarios - elsif Is_Partial_Invariant_Proc (Target_Id) then - null; + for Index in Scenarios.First .. Scenarios.Last - 1 loop + Record_Invocation_Relation + (Invk_Id => Target_Of (Index, In_State), + Targ_Id => Target_Of (Index + 1, In_State), + In_State => In_State); + end loop; + end Record_Full_Invocation_Path; - -- _Postconditions + ----------------------------- + -- Record_Invocation_Graph -- + ----------------------------- - elsif Is_Postconditions_Proc (Target_Id) then - Output_Verification_Call - (Pred => "postconditions", - Id => Find_Enclosing_Scope (N), - Id_Kind => "subprogram"); + procedure Record_Invocation_Graph is + begin + -- Nothing to do when the invocation graph is not recorded - -- Subprograms must come last because some of the previous cases fall - -- under this category. + if not Invocation_Graph_Recording_OK then + return; + end if; - elsif Ekind (Target_Id) = E_Function then - Output_Call ("function"); + -- Examine all library level invocation scenarios and perform DFS + -- traversals from each one. Encode a path in the ALI file of the + -- main unit if it reaches into an external unit. - elsif Ekind (Target_Id) = E_Procedure then - Output_Call ("procedure"); + Process_Invocation_Body_Scenarios; + Process_Invocation_Spec_Scenarios; - else - pragma Assert (False); - null; - end if; - end Output_Call; + -- Examine all invocation constructs within the spec and body of the + -- main unit and perform DFS traversals from each one. Encode a path + -- in the ALI file of the main unit if it reaches into an external + -- unit. - ------------------- - -- Output_Header -- - ------------------- + Process_Main_Unit; + end Record_Invocation_Graph; - procedure Output_Header is - Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); + ---------------------------- + -- Record_Invocation_Path -- + ---------------------------- + + procedure Record_Invocation_Path (In_State : Processing_In_State) is + package Scenarios renames Active_Scenario_Stack; begin - if Ekind (Unit_Id) = E_Package then - Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); + -- Save a path when the active scenario stack contains at least one + -- invocation scenario. - elsif Ekind (Unit_Id) = E_Package_Body then - Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); + if Scenarios.Last - Scenarios.First < 0 then + return; + end if; + + -- Register all relations in the path when switch -gnatd_F (encode + -- full invocation paths in ALI files) is in effect. + + if Debug_Flag_Underscore_FF then + Record_Full_Invocation_Path (In_State); + + -- Otherwise register a single relation else - Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); + Record_Simple_Invocation_Path (In_State); end if; - end Output_Header; - -------------------------- - -- Output_Instantiation -- - -------------------------- + Write_Invocation_Path (In_State); + end Record_Invocation_Path; - procedure Output_Instantiation (N : Node_Id) is - procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); - pragma Inline (Output_Instantiation); - -- Emit a specific diagnostic message concerning an instantiation of - -- generic unit Gen_Id. Kind denotes the kind of the instantiation. + -------------------------------- + -- Record_Invocation_Relation -- + -------------------------------- - -------------------------- - -- Output_Instantiation -- - -------------------------- + procedure Record_Invocation_Relation + (Invk_Id : Entity_Id; + Targ_Id : Entity_Id; + In_State : Processing_In_State) + is + pragma Assert (Present (Invk_Id)); + pragma Assert (Present (Targ_Id)); - procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is + procedure Get_Invocation_Attributes + (Extra : out Entity_Id; + Kind : out Invocation_Kind); + pragma Inline (Get_Invocation_Attributes); + -- Return the additional entity used in error diagnostics in Extra + -- and the invocation kind in Kind which pertain to the invocation + -- relation with invoker Invk_Id and target Targ_Id. + + ------------------------------- + -- Get_Invocation_Attributes -- + ------------------------------- + + procedure Get_Invocation_Attributes + (Extra : out Entity_Id; + Kind : out Invocation_Kind) + is begin - Error_Msg_NE - ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); - end Output_Instantiation; + -- Accept within a task body - -- Local variables + if Is_Accept_Alternative_Proc (Targ_Id) then + Extra := Receiving_Entry (Targ_Id); + Kind := Accept_Alternative; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; - Gen_Id : Entity_Id; + -- Activation of a task object - -- Start of processing for Output_Instantiation + elsif Is_Activation_Proc (Targ_Id) + or else Is_Task_Type (Targ_Id) + then + Extra := Empty; + Kind := Task_Activation; - begin - Extract_Instantiation_Attributes - (Exp_Inst => N, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + -- Controlled adjustment actions - Error_Msg_Node_2 := Inst_Id; - Error_Msg_Sloc := Sloc (Inst); + elsif Is_Controlled_Proc (Targ_Id, Name_Adjust) then + Extra := First_Formal_Type (Targ_Id); + Kind := Controlled_Adjustment; - if Nkind (Inst) = N_Function_Instantiation then - Output_Instantiation (Gen_Id, "function"); + -- Controlled finalization actions - elsif Nkind (Inst) = N_Package_Instantiation then - Output_Instantiation (Gen_Id, "package"); + elsif Is_Controlled_Proc (Targ_Id, Name_Finalize) + or else Is_Finalizer_Proc (Targ_Id) + then + Extra := First_Formal_Type (Targ_Id); + Kind := Controlled_Finalization; - elsif Nkind (Inst) = N_Procedure_Instantiation then - Output_Instantiation (Gen_Id, "procedure"); + -- Controlled initialization actions - else - pragma Assert (False); - null; - end if; - end Output_Instantiation; + elsif Is_Controlled_Proc (Targ_Id, Name_Initialize) then + Extra := First_Formal_Type (Targ_Id); + Kind := Controlled_Initialization; - --------------------------------------- - -- Output_SPARK_Refined_State_Pragma -- - --------------------------------------- + -- Default_Initial_Condition verification - procedure Output_SPARK_Refined_State_Pragma (N : Node_Id) is - begin - Error_Msg_Sloc := Sloc (N); - Error_Msg_N ("\\ refinement constituents read #", Error_Nod); - end Output_SPARK_Refined_State_Pragma; + elsif Is_Default_Initial_Condition_Proc (Targ_Id) then + Extra := First_Formal_Type (Targ_Id); + Kind := Default_Initial_Condition_Verification; - -------------------------------- - -- Output_Variable_Assignment -- - -------------------------------- + -- Initialization of object - procedure Output_Variable_Assignment (N : Node_Id) is - Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (N)); + elsif Is_Init_Proc (Targ_Id) then + Extra := First_Formal_Type (Targ_Id); + Kind := Type_Initialization; - begin - Error_Msg_Sloc := Sloc (N); - Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); - end Output_Variable_Assignment; + -- Initial_Condition verification - ------------------------------- - -- Output_Variable_Reference -- - ------------------------------- + elsif Is_Initial_Condition_Proc (Targ_Id) then + Extra := First_Formal_Type (Targ_Id); + Kind := Initial_Condition_Verification; - procedure Output_Variable_Reference (N : Node_Id) is - Dummy : Variable_Attributes; - Var_Id : Entity_Id; + -- Instantiation - begin - Extract_Variable_Reference_Attributes - (Ref => N, - Var_Id => Var_Id, - Attrs => Dummy); + elsif Is_Generic_Unit (Targ_Id) then + Extra := Empty; + Kind := Instantiation; - Error_Msg_Sloc := Sloc (N); + -- Internal controlled adjustment actions - if Is_Read (N) then - Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); + elsif Is_TSS (Targ_Id, TSS_Deep_Adjust) then + Extra := First_Formal_Type (Targ_Id); + Kind := Internal_Controlled_Adjustment; - else - pragma Assert (False); - null; - end if; - end Output_Variable_Reference; + -- Internal controlled finalization actions - -- Local variables + elsif Is_TSS (Targ_Id, TSS_Deep_Finalize) then + Extra := First_Formal_Type (Targ_Id); + Kind := Internal_Controlled_Finalization; - package Stack renames Scenario_Stack; + -- Internal controlled initialization actions - Dummy : Call_Attributes; - N : Node_Id; - Posted : Boolean; - Target_Id : Entity_Id; + elsif Is_TSS (Targ_Id, TSS_Deep_Initialize) then + Extra := First_Formal_Type (Targ_Id); + Kind := Internal_Controlled_Initialization; - -- Start of processing for Output_Active_Scenarios + -- Invariant verification - begin - -- Active scenarios are emitted only when the static model is in effect - -- because there is an inherent order by which all these scenarios were - -- reached from the declaration or library level. + elsif Is_Invariant_Proc (Targ_Id) + or else Is_Partial_Invariant_Proc (Targ_Id) + then + Extra := First_Formal_Type (Targ_Id); + Kind := Invariant_Verification; - if not Static_Elaboration_Checks then - return; - end if; + -- Postcondition verification - Posted := False; + elsif Is_Postconditions_Proc (Targ_Id) then + Extra := Find_Enclosing_Scope (Targ_Id); + Kind := Postcondition_Verification; - for Index in Stack.First .. Stack.Last loop - N := Stack.Table (Index); + -- Protected entry call - if not Posted then - Posted := True; - Output_Header; - end if; + elsif Is_Protected_Entry (Targ_Id) then + Extra := Empty; + Kind := Protected_Entry_Call; - -- 'Access + -- Protected subprogram call - if Nkind (N) = N_Attribute_Reference then - Output_Access (N); + elsif Is_Protected_Subp (Targ_Id) then + Extra := Empty; + Kind := Protected_Subprogram_Call; - -- Calls + -- Task entry call - elsif Is_Suitable_Call (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Dummy); + elsif Is_Task_Entry (Targ_Id) then + Extra := Empty; + Kind := Task_Entry_Call; + + -- Entry, operator, or subprogram call. This case must come last + -- because most invocations above are variations of this case. + + elsif Ekind_In (Targ_Id, E_Entry, + E_Function, + E_Operator, + E_Procedure) + then + Extra := Empty; + Kind := Call; - if Is_Activation_Proc (Target_Id) then - Output_Activation_Call (N); else - Output_Call (N, Target_Id); + pragma Assert (False); + Extra := Empty; + Kind := No_Invocation; end if; + end Get_Invocation_Attributes; - -- Instantiations + -- Local variables - elsif Is_Suitable_Instantiation (N) then - Output_Instantiation (N); + Extra : Entity_Id; + Extra_Nam : Name_Id; + IR_Rec : Invocation_Relation_Record; + Kind : Invocation_Kind; + Rel : Invoker_Target_Relation; - -- Pragma Refined_State + -- Start of processing for Record_Invocation_Relation - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Output_SPARK_Refined_State_Pragma (N); + begin + Rel.Invoker := Invk_Id; + Rel.Target := Targ_Id; - -- Variable assignments + -- Nothing to do when the invocation relation has already been + -- recorded in ALI file of the main unit. + + if Is_Saved_Relation (Rel) then + return; + end if; - elsif Nkind (N) = N_Assignment_Statement then - Output_Variable_Assignment (N); + -- Mark the relation as recorded in the ALI file - -- Variable references + Set_Is_Saved_Relation (Rel); - elsif Is_Suitable_Variable_Reference (N) then - Output_Variable_Reference (N); + -- Declare the invoker in the ALI file + + Declare_Invocation_Construct + (Constr_Id => Invk_Id, + In_State => In_State); + + -- Obtain the invocation-specific attributes of the relation + Get_Invocation_Attributes (Extra, Kind); + + -- Certain invocations lack an extra entity used in error diagnostics + + if Present (Extra) then + Extra_Nam := Chars (Extra); else - pragma Assert (False); - null; + Extra_Nam := No_Name; end if; - end loop; - end Output_Active_Scenarios; - ------------------------- - -- Pop_Active_Scenario -- - ------------------------- + IR_Rec.Extra := Extra_Nam; + IR_Rec.Invoker := Signature_Of (Invk_Id); + IR_Rec.Kind := Kind; + IR_Rec.Target := Signature_Of (Targ_Id); - procedure Pop_Active_Scenario (N : Node_Id) is - Top : Node_Id renames Scenario_Stack.Table (Scenario_Stack.Last); + -- Add the relation in the ALI file - begin - pragma Assert (Top = N); - Scenario_Stack.Decrement_Last; - end Pop_Active_Scenario; + Add_Invocation_Relation + (IR_Rec => IR_Rec, + Update_Units => False); + end Record_Invocation_Relation; - -------------------------------- - -- Process_Activation_Generic -- - -------------------------------- + ----------------------------------- + -- Record_Simple_Invocation_Path -- + ----------------------------------- - procedure Process_Activation_Generic - (Call : Node_Id; - Call_Attrs : Call_Attributes; - State : Processing_Attributes) - is - procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); - -- Perform ABE checks and diagnostics for object Obj_Id with type Typ. - -- Typ may be a task type or a composite type with at least one task - -- component. + procedure Record_Simple_Invocation_Path + (In_State : Processing_In_State) + is + package Scenarios renames Active_Scenario_Stack; - procedure Process_Task_Objects (List : List_Id); - -- Perform ABE checks and diagnostics for all task objects found in the - -- list List. + Last_Targ : constant Entity_Id := + Target_Of (Scenarios.Last, In_State); + First_Targ : Entity_Id; - ------------------------- - -- Process_Task_Object -- - ------------------------- + begin + -- The path originates from the elaboration of the body. Add an extra + -- relation from the elaboration body procedure to the first active + -- scenario. - procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is - Base_Typ : constant Entity_Id := Base_Type (Typ); + if In_State.Processing = Invocation_Body_Processing then + Build_Elaborate_Body_Procedure; + First_Targ := Elab_Body_Id; - Comp_Id : Entity_Id; - Task_Attrs : Task_Attributes; + -- The path originates from the elaboration of the spec. Add an extra + -- relation from the elaboration spec procedure to the first active + -- scenario. - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + elsif In_State.Processing = Invocation_Spec_Processing then + Build_Elaborate_Spec_Procedure; + First_Targ := Elab_Spec_Id; + + else + First_Targ := Target_Of (Scenarios.First, In_State); + end if; + + -- Record a single relation from the first to the last scenario + + if First_Targ /= Last_Targ then + Record_Invocation_Relation + (Invk_Id => First_Targ, + Targ_Id => Last_Targ, + In_State => In_State); + end if; + end Record_Simple_Invocation_Path; + + ---------------------------- + -- Set_Is_Saved_Construct -- + ---------------------------- + + procedure Set_Is_Saved_Construct + (Constr : Entity_Id; + Val : Boolean := True) + is + pragma Assert (Present (Constr)); begin - if Is_Task_Type (Typ) then - Extract_Task_Attributes - (Typ => Base_Typ, - Attrs => Task_Attrs); + if Val then + NE_Set.Insert (Saved_Constructs_Set, Constr); + else + NE_Set.Delete (Saved_Constructs_Set, Constr); + end if; + end Set_Is_Saved_Construct; - -- Warnings are suppressed when a prior scenario is already in - -- that mode, or when the object, activation call, or task type - -- have warnings suppressed. Update the state of the Processing - -- phase to reflect this. + --------------------------- + -- Set_Is_Saved_Relation -- + --------------------------- - New_State.Suppress_Warnings := - New_State.Suppress_Warnings - or else not Is_Elaboration_Warnings_OK_Id (Obj_Id) - or else not Call_Attrs.Elab_Warnings_OK - or else not Task_Attrs.Elab_Warnings_OK; + procedure Set_Is_Saved_Relation + (Rel : Invoker_Target_Relation; + Val : Boolean := True) + is + begin + if Val then + IR_Set.Insert (Saved_Relations_Set, Rel); + else + IR_Set.Delete (Saved_Relations_Set, Rel); + end if; + end Set_Is_Saved_Relation; - -- Update the state of the Processing phase to indicate that any - -- further traversal is now within a task body. + ------------------ + -- Signature_Of -- + ------------------ - New_State.Within_Task_Body := True; + function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id is + Loc : constant Source_Ptr := Sloc (Id); - Process_Single_Activation - (Call => Call, - Call_Attrs => Call_Attrs, - Obj_Id => Obj_Id, - Task_Attrs => Task_Attrs, - State => New_State); + function Instantiation_Locations return Name_Id; + pragma Inline (Instantiation_Locations); + -- Create a concatenation of all lines and colums of each instance + -- where source location Loc appears. Return No_Name if no instances + -- exist. - -- Examine the component type when the object is an array + function Qualified_Scope return Name_Id; + pragma Inline (Qualified_Scope); + -- Obtain the qualified name of Id's scope - elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then - Process_Task_Object - (Obj_Id => Obj_Id, - Typ => Component_Type (Typ)); + ----------------------------- + -- Instantiation_Locations -- + ----------------------------- - -- Examine individual component types when the object is a record + function Instantiation_Locations return Name_Id is + Buffer : Bounded_String (2052); + Inst : Source_Ptr; + Loc_Nam : Name_Id; + SFI : Source_File_Index; - elsif Is_Record_Type (Typ) and then Has_Task (Base_Typ) then - Comp_Id := First_Component (Typ); - while Present (Comp_Id) loop - Process_Task_Object - (Obj_Id => Obj_Id, - Typ => Etype (Comp_Id)); + begin + SFI := Get_Source_File_Index (Loc); + Inst := Instantiation (SFI); - Next_Component (Comp_Id); - end loop; - end if; - end Process_Task_Object; + -- The location is within an instance. Construct a concatenation + -- of all lines and colums of each individual instance using the + -- following format: + -- + -- line1_column1_line2_column2_ ... _lineN_columnN - -------------------------- - -- Process_Task_Objects -- - -------------------------- + if Inst /= No_Location then + loop + Append (Buffer, Nat (Get_Logical_Line_Number (Inst))); + Append (Buffer, '_'); + Append (Buffer, Nat (Get_Column_Number (Inst))); - procedure Process_Task_Objects (List : List_Id) is - Item : Node_Id; - Item_Id : Entity_Id; - Item_Typ : Entity_Id; + SFI := Get_Source_File_Index (Inst); + Inst := Instantiation (SFI); - begin - -- Examine the contents of the list looking for an object declaration - -- of a task type or one that contains a task within. + exit when Inst = No_Location; - Item := First (List); - while Present (Item) loop - if Nkind (Item) = N_Object_Declaration then - Item_Id := Defining_Entity (Item); - Item_Typ := Etype (Item_Id); + Append (Buffer, '_'); + end loop; - if Has_Task (Item_Typ) then - Process_Task_Object - (Obj_Id => Item_Id, - Typ => Item_Typ); - end if; + Loc_Nam := Name_Find (Buffer); + return Loc_Nam; + + -- Otherwise there no instances are involved + + else + return No_Name; end if; + end Instantiation_Locations; - Next (Item); - end loop; - end Process_Task_Objects; + --------------------- + -- Qualified_Scope -- + --------------------- - -- Local variables + function Qualified_Scope return Name_Id is + Scop : Entity_Id; - Context : Node_Id; - Spec : Node_Id; + begin + Scop := Scope (Id); - -- Start of processing for Process_Activation_Generic + -- The entity appears within an anonymous concurrent type created + -- for a single protected or task type declaration. Use the entity + -- of the anonymous object as it represents the original scope. - begin - -- Nothing to do when the activation is a guaranteed ABE + if Is_Concurrent_Type (Scop) + and then Present (Anonymous_Object (Scop)) + then + Scop := Anonymous_Object (Scop); + end if; - if Is_Known_Guaranteed_ABE (Call) then - return; - end if; + return Get_Qualified_Name (Scop); + end Qualified_Scope; - -- Find the proper context of the activation call where all task objects - -- being activated are declared. This is usually the immediate parent of - -- the call. + -- Start of processing for Signature_Of - Context := Parent (Call); + begin + return + Invocation_Signature_Of + (Column => Nat (Get_Column_Number (Loc)), + Line => Nat (Get_Logical_Line_Number (Loc)), + Locations => Instantiation_Locations, + Name => Chars (Id), + Scope => Qualified_Scope); + end Signature_Of; - -- In the case of package bodies, the activation call is in the handled - -- sequence of statements, but the task objects are in the declaration - -- list of the body. + --------------- + -- Target_Of -- + --------------- - if Nkind (Context) = N_Handled_Sequence_Of_Statements - and then Nkind (Parent (Context)) = N_Package_Body - then - Context := Parent (Context); - end if; + function Target_Of + (Pos : Active_Scenario_Pos; + In_State : Processing_In_State) return Entity_Id + is + package Scenarios renames Active_Scenario_Stack; - -- Process all task objects defined in both the spec and body when the - -- activation call precedes the "begin" of a package body. + -- Ensure that the position is within the bounds of the active + -- scenario stack. - if Nkind (Context) = N_Package_Body then - Spec := - Specification - (Unit_Declaration_Node (Corresponding_Spec (Context))); + pragma Assert (Scenarios.First <= Pos); + pragma Assert (Pos <= Scenarios.Last); - Process_Task_Objects (Visible_Declarations (Spec)); - Process_Task_Objects (Private_Declarations (Spec)); - Process_Task_Objects (Declarations (Context)); + Scen_Rep : constant Scenario_Rep_Id := + Scenario_Representation_Of + (Scenarios.Table (Pos), In_State); - -- Process all task objects defined in the spec when the activation call - -- appears at the end of a package spec. + begin + -- The true target of an activation call is the current task type + -- rather than routine Activate_Tasks. - elsif Nkind (Context) = N_Package_Specification then - Process_Task_Objects (Visible_Declarations (Context)); - Process_Task_Objects (Private_Declarations (Context)); + if Kind (Scen_Rep) = Task_Activation_Scenario then + return Activated_Task_Type (Scen_Rep); + else + return Target (Scen_Rep); + end if; + end Target_Of; - -- Otherwise the context of the activation is some construct with a - -- declarative part. Note that the corresponding record type of a task - -- type is controlled. Because of this, the finalization machinery must - -- relocate the task object to the handled statements of the construct - -- to perform proper finalization in case of an exception. Examine the - -- statements of the construct rather than the declarations. + ------------------------------ + -- Traverse_Invocation_Body -- + ------------------------------ - else - pragma Assert (Nkind (Context) = N_Handled_Sequence_Of_Statements); + procedure Traverse_Invocation_Body + (N : Node_Id; + In_State : Processing_In_State) + is + begin + Traverse_Body + (N => N, + Requires_Processing => Is_Invocation_Scenario'Access, + Processor => Process_Invocation_Scenario'Access, + In_State => In_State); + end Traverse_Invocation_Body; - Process_Task_Objects (Statements (Context)); - end if; - end Process_Activation_Generic; + --------------------------- + -- Write_Invocation_Path -- + --------------------------- - ------------------------------------ - -- Process_Conditional_ABE_Access -- - ------------------------------------ + procedure Write_Invocation_Path (In_State : Processing_In_State) is + procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean); + pragma Inline (Write_Target); + -- Write out invocation target Targ_Id to standard output. Flag + -- Is_First should be set when the target is first in a path. - procedure Process_Conditional_ABE_Access - (Attr : Node_Id; - State : Processing_Attributes) - is - function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id; - pragma Inline (Build_Access_Marker); - -- Create a suitable call marker which invokes target Target_Id + ------------- + -- Targ_Id -- + ------------- - ------------------------- - -- Build_Access_Marker -- - ------------------------- + procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean) is + begin + if not Is_First then + Write_Str (" --> "); + end if; - function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id is - Marker : Node_Id; + Write_Name (Get_Qualified_Name (Targ_Id)); + Write_Eol; + end Write_Target; + + -- Local variables + + package Scenarios renames Active_Scenario_Stack; + + First_Seen : Boolean := False; + + -- Start of processing for Write_Invocation_Path begin - Marker := Make_Call_Marker (Sloc (Attr)); + -- Nothing to do when flag -gnatd_T (output trace information on + -- invocation path recording) is not in effect. - -- Inherit relevant attributes from the attribute + if not Debug_Flag_Underscore_TT then + return; + end if; - -- Performance note: parent traversal + -- The path originates from the elaboration of the body. Write the + -- elaboration body procedure. - Set_Target (Marker, Target_Id); - Set_Is_Declaration_Level_Node - (Marker, Find_Enclosing_Level (Attr) = Declaration_Level); - Set_Is_Dispatching_Call - (Marker, False); - Set_Is_Elaboration_Checks_OK_Node - (Marker, Is_Elaboration_Checks_OK_Node (Attr)); - Set_Is_Elaboration_Warnings_OK_Node - (Marker, Is_Elaboration_Warnings_OK_Node (Attr)); - Set_Is_Source_Call - (Marker, Comes_From_Source (Attr)); - Set_Is_SPARK_Mode_On_Node - (Marker, Is_SPARK_Mode_On_Node (Attr)); + if In_State.Processing = Invocation_Body_Processing then + Write_Target (Elab_Body_Id, True); + First_Seen := True; - -- Partially insert the call marker into the tree by setting its - -- parent pointer. + -- The path originates from the elaboration of the spec. Write the + -- elaboration spec procedure. - Set_Parent (Marker, Attr); + elsif In_State.Processing = Invocation_Spec_Processing then + Write_Target (Elab_Spec_Id, True); + First_Seen := True; + end if; - return Marker; - end Build_Access_Marker; + -- Write each individual target invoked by its corresponding scenario + -- on the active scenario stack. - -- Local variables + for Index in Scenarios.First .. Scenarios.Last loop + Write_Target + (Targ_Id => Target_Of (Index, In_State), + Is_First => Index = Scenarios.First and then not First_Seen); + end loop; - Root : constant Node_Id := Root_Scenario; - Target_Id : constant Entity_Id := Entity (Prefix (Attr)); + Write_Eol; + end Write_Invocation_Path; + end Invocation_Graph; - Target_Attrs : Target_Attributes; + ------------------------ + -- Is_Safe_Activation -- + ------------------------ + + function Is_Safe_Activation + (Call : Node_Id; + Task_Rep : Target_Rep_Id) return Boolean + is + begin + -- The activation of a task coming from an external instance cannot + -- cause an ABE because the generic was already instantiated. Note + -- that the instantiation itself may lead to an ABE. - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + return + In_External_Instance + (N => Call, + Target_Decl => Spec_Declaration (Task_Rep)); + end Is_Safe_Activation; - -- Start of processing for Process_Conditional_ABE_Access + ------------------ + -- Is_Safe_Call -- + ------------------ + + function Is_Safe_Call + (Call : Node_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id) return Boolean + is + Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); + Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); begin - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + -- The target is either an abstract subprogram, formal subprogram, or + -- imported, in which case it does not have a body at compile or bind + -- time. Assume that the call is ABE-safe. - if Elab_Info_Messages then - Error_Msg_NE - ("info: access to & during elaboration", Attr, Target_Id); - end if; + if Is_Bodiless_Subprogram (Subp_Id) then + return True; - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); + -- The target is an instantiation of a generic subprogram. The call + -- cannot cause an ABE because the generic was already instantiated. + -- Note that the instantiation itself may lead to an ABE. - -- Warnings are suppressed when a prior scenario is already in that - -- mode, or when the attribute or the target have warnings suppressed. - -- Update the state of the Processing phase to reflect this. + elsif Is_Generic_Instance (Subp_Id) then + return True; - New_State.Suppress_Warnings := - New_State.Suppress_Warnings - or else not Is_Elaboration_Warnings_OK_Node (Attr) - or else not Target_Attrs.Elab_Warnings_OK; + -- The invocation of a target coming from an external instance cannot + -- cause an ABE because the generic was already instantiated. Note that + -- the instantiation itself may lead to an ABE. - -- Do not emit any ABE diagnostics when the current or previous scenario - -- in this traversal has suppressed elaboration warnings. + elsif In_External_Instance + (N => Call, + Target_Decl => Spec_Decl) + then + return True; - if New_State.Suppress_Warnings then - null; + -- The target is a subprogram body without a previous declaration. The + -- call cannot cause an ABE because the body has already been seen. - -- Both the attribute and the corresponding body are in the same unit. - -- The corresponding body must appear prior to the root scenario which - -- started the recursive search. If this is not the case, then there is - -- a potential ABE if the access value is used to call the subprogram. - -- Emit a warning only when switch -gnatw.f (warnings on suspucious - -- 'Access) is in effect. - - elsif Warn_On_Elab_Access - and then Present (Target_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) - and then Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) + elsif Nkind (Spec_Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Spec_Decl)) then - Error_Msg_Name_1 := Attribute_Name (Attr); - Error_Msg_NE ("??% attribute of & before body seen", Attr, Target_Id); - Error_Msg_N ("\possible Program_Error on later references", Attr); + return True; + + -- The target is a subprogram body stub without a prior declaration. + -- The call cannot cause an ABE because the proper body substitutes + -- the stub. + + elsif Nkind (Spec_Decl) = N_Subprogram_Body_Stub + and then No (Corresponding_Spec_Of_Stub (Spec_Decl)) + then + return True; + + -- Subprogram bodies which wrap attribute references used as actuals + -- in instantiations are always ABE-safe. These bodies are artifacts + -- of expansion. - Output_Active_Scenarios (Attr); + elsif Present (Body_Decl) + and then Nkind (Body_Decl) = N_Subprogram_Body + and then Was_Attribute_Reference (Body_Decl) + then + return True; end if; - -- Treat the attribute as an immediate invocation of the target when - -- switch -gnatd.o (conservative elaboration order for indirect calls) - -- is in effect. Note that the prior elaboration of the unit containing - -- the target is ensured processing the corresponding call marker. + return False; + end Is_Safe_Call; - if Debug_Flag_Dot_O then - Process_Conditional_ABE - (N => Build_Access_Marker (Target_Id), - State => New_State); + --------------------------- + -- Is_Safe_Instantiation -- + --------------------------- - -- Otherwise ensure that the unit with the corresponding body is - -- elaborated prior to the main unit. + function Is_Safe_Instantiation + (Inst : Node_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id) return Boolean + is + Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); - else - Ensure_Prior_Elaboration - (N => Attr, - Unit_Id => Target_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - State => New_State); + begin + -- The generic is an intrinsic subprogram in which case it does not + -- have a body at compile or bind time. Assume that the instantiation + -- is ABE-safe. + + if Is_Bodiless_Subprogram (Gen_Id) then + return True; + + -- The instantiation of an external nested generic cannot cause an ABE + -- if the outer generic was already instantiated. Note that the instance + -- of the outer generic may lead to an ABE. + + elsif In_External_Instance + (N => Inst, + Target_Decl => Spec_Decl) + then + return True; + + -- The generic is a package. The instantiation cannot cause an ABE when + -- the package has no body. + + elsif Ekind (Gen_Id) = E_Generic_Package + and then not Has_Body (Spec_Decl) + then + return True; end if; - end Process_Conditional_ABE_Access; - - --------------------------------------------- - -- Process_Conditional_ABE_Activation_Impl -- - --------------------------------------------- - - procedure Process_Conditional_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - State : Processing_Attributes) - is - Check_OK : constant Boolean := - not Is_Ignored_Ghost_Entity (Obj_Id) - and then not Task_Attrs.Ghost_Mode_Ignore - and then Is_Elaboration_Checks_OK_Id (Obj_Id) - and then Task_Attrs.Elab_Checks_OK; - -- A run-time ABE check may be installed only when the object and the - -- task type have active elaboration checks, and both are not ignored - -- Ghost constructs. - Root : constant Node_Id := Root_Scenario; + return False; + end Is_Safe_Instantiation; - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + ------------------ + -- Is_Same_Unit -- + ------------------ + function Is_Same_Unit + (Unit_1 : Entity_Id; + Unit_2 : Entity_Id) return Boolean + is begin - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); + end Is_Same_Unit; - if Elab_Info_Messages then - Error_Msg_NE - ("info: activation of & during elaboration", Call, Obj_Id); - end if; + ------------------------------- + -- Kill_Elaboration_Scenario -- + ------------------------------- - -- Nothing to do when the call activates a task whose type is defined - -- within an instance and switch -gnatd_i (ignore activations and calls - -- to instances for elaboration) is in effect. + procedure Kill_Elaboration_Scenario (N : Node_Id) is + begin + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE lechanism does not need + -- to carry out this action. - if Debug_Flag_Underscore_I - and then In_External_Instance - (N => Call, - Target_Decl => Task_Attrs.Task_Decl) - then + if Legacy_Elaboration_Checks then return; + end if; - -- Nothing to do when the activation is a guaranteed ABE + -- Eliminate a recorded scenario when it appears within dead code + -- because it will not be executed at elaboration time. - elsif Is_Known_Guaranteed_ABE (Call) then - return; + if Is_Scenario (N) then + Delete_Scenario (N); + end if; + end Kill_Elaboration_Scenario; - -- Nothing to do when the root scenario appears at the declaration - -- level and the task is in the same unit, but outside this context. - -- - -- task type Task_Typ; -- task declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- T : Task_Typ; - -- begin - -- <activation call> -- activation site - -- end; - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- task body Task_Typ is - -- ... - -- end Task_Typ; - -- - -- In the example above, the context of X is the declarative list of - -- Proc. The "elaboration" of X may reach the activation of T whose body - -- is defined outside of X's context. The task body is relevant only - -- when Proc is invoked, but this happens only in "normal" elaboration, - -- therefore the task body must not be considered if this is not the - -- case. + ---------------------- + -- Non_Private_View -- + ---------------------- + + function Non_Private_View (Typ : Entity_Id) return Entity_Id is + begin + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + return Full_View (Typ); + else + return Typ; + end if; + end Non_Private_View; - -- Performance note: parent traversal + --------------------------------- + -- Record_Elaboration_Scenario -- + --------------------------------- - elsif Is_Up_Level_Target (Task_Attrs.Task_Decl) then - return; + procedure Record_Elaboration_Scenario (N : Node_Id) is + procedure Check_Preelaborated_Call + (Call : Node_Id; + Call_Lvl : Enclosing_Level_Kind); + pragma Inline (Check_Preelaborated_Call); + -- Verify that entry, operator, or subprogram call Call with enclosing + -- level Call_Lvl does not appear at the library level of preelaborated + -- unit. - -- Nothing to do when the activation is ABE-safe - -- - -- generic - -- package Gen is - -- task type Task_Typ; - -- end Gen; - -- - -- package body Gen is - -- task body Task_Typ is - -- begin - -- ... - -- end Task_Typ; - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- package Nested is - -- package Inst is new Gen; - -- T : Inst.Task_Typ; - -- <activation call> -- safe activation - -- end Nested; - -- ... + function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id; + pragma Inline (Find_Code_Unit); + -- Return the code unit which contains arbitrary node or entity Nod. + -- This is the unit of the file which physically contains the related + -- construct denoted by Nod except when Nod is within an instantiation. + -- In that case the unit is that of the top-level instantiation. + + function In_Preelaborated_Context (Nod : Node_Id) return Boolean; + pragma Inline (In_Preelaborated_Context); + -- Determine whether arbitrary node Nod appears within a preelaborated + -- context. + + procedure Record_Access_Taken + (Attr : Node_Id; + Attr_Lvl : Enclosing_Level_Kind); + pragma Inline (Record_Access_Taken); + -- Record 'Access scenario Attr with enclosing level Attr_Lvl + + procedure Record_Call_Or_Task_Activation + (Call : Node_Id; + Call_Lvl : Enclosing_Level_Kind); + pragma Inline (Record_Call_Or_Task_Activation); + -- Record call scenario Call with enclosing level Call_Lvl + + procedure Record_Instantiation + (Inst : Node_Id; + Inst_Lvl : Enclosing_Level_Kind); + pragma Inline (Record_Instantiation); + -- Record instantiation scenario Inst with enclosing level Inst_Lvl + + procedure Record_Variable_Assignment + (Asmt : Node_Id; + Asmt_Lvl : Enclosing_Level_Kind); + pragma Inline (Record_Variable_Assignment); + -- Record variable assignment scenario Asmt with enclosing level + -- Asmt_Lvl. + + procedure Record_Variable_Reference + (Ref : Node_Id; + Ref_Lvl : Enclosing_Level_Kind); + pragma Inline (Record_Variable_Reference); + -- Record variable reference scenario Ref with enclosing level Ref_Lvl - elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then + ------------------------------ + -- Check_Preelaborated_Call -- + ------------------------------ - -- Note that the task body must still be examined for any nested - -- scenarios. + procedure Check_Preelaborated_Call + (Call : Node_Id; + Call_Lvl : Enclosing_Level_Kind) + is + begin + -- Nothing to do when the call is internally generated because it is + -- assumed that it will never violate preelaboration. - null; + if not Is_Source_Call (Call) then + return; - -- The activation call and the task body are both in the main unit + -- Library-level calls are always considered because they are part of + -- the associated unit's elaboration actions. - elsif Present (Task_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Task_Attrs.Body_Decl) - then - -- If the root scenario appears prior to the task body, then this is - -- a possible ABE with respect to the root scenario. - -- - -- task type Task_Typ; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- package Pack is - -- T : Task_Typ; - -- end Pack; -- activation of T - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- - -- task body Task_Typ is -- task body - -- ... - -- end Task_Typ; - -- - -- Y : ... := A; -- root scenario - -- - -- IMPORTANT: The activation of T is a possible ABE for X, but - -- not for Y. Intalling an unconditional ABE raise prior to the - -- activation call would be wrong as it will fail for Y as well - -- but in Y's case the activation of T is never an ABE. + elsif Call_Lvl in Library_Level then + null; - if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then + -- Calls at the library level of a generic package body have to be + -- checked because they would render an instantiation illegal if the + -- template is marked as preelaborated. Note that this does not apply + -- to calls at the library level of a generic package spec. - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + elsif Call_Lvl = Generic_Body_Level then + null; - if State.Suppress_Warnings then - null; + -- Otherwise the call does not appear at the proper level and must + -- not be considered for this check. - -- Do not emit any ABE diagnostics when the activation occurs in - -- a partial finalization context because this leads to confusing - -- noise. + else + return; + end if; - elsif State.Within_Partial_Finalization then - null; + -- The call appears within a preelaborated unit. Emit a warning only + -- for internal uses, otherwise this is an error. - -- ABE diagnostics are emitted only in the static model because - -- there is a well-defined order to visiting scenarios. Without - -- this order diagnostics appear jumbled and result in unwanted - -- noise. + if In_Preelaborated_Context (Call) then + Error_Msg_Warn := GNAT_Mode; + Error_Msg_N + ("<<non-static call not allowed in preelaborated unit", Call); + end if; + end Check_Preelaborated_Call; - elsif Static_Elaboration_Checks then - Error_Msg_Sloc := Sloc (Call); - Error_Msg_N - ("??task & will be activated # before elaboration of its " - & "body", Obj_Id); - Error_Msg_N - ("\Program_Error may be raised at run time", Obj_Id); + -------------------- + -- Find_Code_Unit -- + -------------------- - Output_Active_Scenarios (Obj_Id); - end if; + function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id is + begin + return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (Nod)))); + end Find_Code_Unit; - -- Install a conditional run-time ABE check to verify that the - -- task body has been elaborated prior to the activation call. + ------------------------------ + -- In_Preelaborated_Context -- + ------------------------------ - if Check_OK then - Install_ABE_Check - (N => Call, - Ins_Nod => Call, - Target_Id => Task_Attrs.Spec_Id, - Target_Decl => Task_Attrs.Task_Decl, - Target_Body => Task_Attrs.Body_Decl); + function In_Preelaborated_Context (Nod : Node_Id) return Boolean is + Body_Id : constant Entity_Id := Find_Code_Unit (Nod); + Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); - -- Update the state of the Processing phase to indicate that - -- no implicit Elaborate[_All] pragmas must be generated from - -- this point on. - -- - -- task type Task_Typ; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- package Pack is - -- <ABE check> - -- T : Task_Typ; - -- end Pack; -- activation of T - -- ... - -- end A; - -- - -- X : ... := A; - -- - -- task body Task_Typ is - -- begin - -- External.Subp; -- imparts Elaborate_All - -- end Task_Typ; - -- - -- If Some_Condition is True, then the ABE check will fail at - -- runtime and the call to External.Subp will never take place, - -- rendering the implicit Elaborate_All useless. - -- - -- If Some_Condition is False, then the call to External.Subp - -- will never take place, rendering the implicit Elaborate_All - -- useless. + begin + -- The node appears within a package body whose corresponding spec is + -- subject to pragma Remote_Call_Interface or Remote_Types. This does + -- not result in a preelaborated context because the package body may + -- be on another machine. - New_State.Suppress_Implicit_Pragmas := True; - end if; + if Ekind (Body_Id) = E_Package_Body + and then Ekind_In (Spec_Id, E_Generic_Package, E_Package) + and then (Is_Remote_Call_Interface (Spec_Id) + or else Is_Remote_Types (Spec_Id)) + then + return False; + + -- Otherwise the node appears within a preelaborated context when the + -- associated unit is preelaborated. + + else + return Is_Preelaborated_Unit (Spec_Id); end if; + end In_Preelaborated_Context; - -- Otherwise the task body is not available in this compilation or it - -- resides in an external unit. Install a run-time ABE check to verify - -- that the task body has been elaborated prior to the activation call - -- when the dynamic model is in effect. + ------------------------- + -- Record_Access_Taken -- + ------------------------- - elsif Dynamic_Elaboration_Checks and then Check_OK then - Install_ABE_Check - (N => Call, - Ins_Nod => Call, - Id => Task_Attrs.Unit_Id); - end if; + procedure Record_Access_Taken + (Attr : Node_Id; + Attr_Lvl : Enclosing_Level_Kind) + is + begin + -- Signal any enclosing local exception handlers that the 'Access may + -- raise Program_Error due to a failed ABE check when switch -gnatd.o + -- (conservative elaboration order for indirect calls) is in effect. + -- Marking the exception handlers ensures proper expansion by both + -- the front and back end restriction when No_Exception_Propagation + -- is in effect. - -- Both the activation call and task type are subject to SPARK_Mode - -- On, this triggers the SPARK rules for task activation. Compared to - -- calls and instantiations, task activation in SPARK does not require - -- the presence of Elaborate[_All] pragmas in case the task type is - -- defined outside the main unit. This is because SPARK utilizes a - -- special policy which activates all tasks after the main unit has - -- finished its elaboration. + if Debug_Flag_Dot_O then + Possible_Local_Raise (Attr, Standard_Program_Error); + end if; - if Call_Attrs.SPARK_Mode_On and Task_Attrs.SPARK_Mode_On then - null; + -- Add 'Access to the appropriate set - -- Otherwise the Ada rules are in effect. Ensure that the unit with the - -- task body is elaborated prior to the main unit. + if Attr_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Attr); - else - Ensure_Prior_Elaboration + elsif Attr_Lvl = Library_Spec_Level + or else Attr_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Attr); + end if; + + -- 'Access requires a conditional ABE check when the dynamic model is + -- in effect. + + Add_Dynamic_ABE_Check_Scenario (Attr); + end Record_Access_Taken; + + ------------------------------------ + -- Record_Call_Or_Task_Activation -- + ------------------------------------ + + procedure Record_Call_Or_Task_Activation + (Call : Node_Id; + Call_Lvl : Enclosing_Level_Kind) + is + begin + -- Signal any enclosing local exception handlers that the call may + -- raise Program_Error due to failed ABE check. Marking the exception + -- handlers ensures proper expansion by both the front and back end + -- restriction when No_Exception_Propagation is in effect. + + Possible_Local_Raise (Call, Standard_Program_Error); + + -- Perform early detection of guaranteed ABEs in order to suppress + -- the instantiation of generic bodies because gigi cannot handle + -- certain types of premature instantiations. + + Process_Guaranteed_ABE (N => Call, - Unit_Id => Task_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - State => New_State); - end if; + In_State => Guaranteed_ABE_State); - Traverse_Body - (N => Task_Attrs.Body_Decl, - State => New_State); - end Process_Conditional_ABE_Activation_Impl; + -- Add the call or task activation to the appropriate set - procedure Process_Conditional_ABE_Activation is - new Process_Activation_Generic (Process_Conditional_ABE_Activation_Impl); + if Call_Lvl = Declaration_Level then + Add_Declaration_Scenario (Call); - ---------------------------------- - -- Process_Conditional_ABE_Call -- - ---------------------------------- + elsif Call_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Call); - procedure Process_Conditional_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - State : Processing_Attributes) - is - function In_Initialization_Context (N : Node_Id) return Boolean; - -- Determine whether arbitrary node N appears within a type init proc, - -- primitive [Deep_]Initialize, or a block created for initialization - -- purposes. + elsif Call_Lvl = Library_Spec_Level + or else Call_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Call); + end if; - function Is_Partial_Finalization_Proc return Boolean; - pragma Inline (Is_Partial_Finalization_Proc); - -- Determine whether call Call with target Target_Id invokes a partial - -- finalization procedure. + -- A call or a task activation requires a conditional ABE check when + -- the dynamic model is in effect. - ------------------------------- - -- In_Initialization_Context -- - ------------------------------- + Add_Dynamic_ABE_Check_Scenario (Call); + end Record_Call_Or_Task_Activation; - function In_Initialization_Context (N : Node_Id) return Boolean is - Par : Node_Id; - Spec_Id : Entity_Id; + -------------------------- + -- Record_Instantiation -- + -------------------------- + procedure Record_Instantiation + (Inst : Node_Id; + Inst_Lvl : Enclosing_Level_Kind) + is begin - -- Climb the parent chain looking for initialization actions + -- Signal enclosing local exception handlers that instantiation may + -- raise Program_Error due to failed ABE check. Marking the exception + -- handlers ensures proper expansion by both the front and back end + -- restriction when No_Exception_Propagation is in effect. - Par := Parent (N); - while Present (Par) loop + Possible_Local_Raise (Inst, Standard_Program_Error); - -- A block may be part of the initialization actions of a default - -- initialized object. + -- Perform early detection of guaranteed ABEs in order to suppress + -- the instantiation of generic bodies because gigi cannot handle + -- certain types of premature instantiations. - if Nkind (Par) = N_Block_Statement - and then Is_Initialization_Block (Par) - then - return True; + Process_Guaranteed_ABE + (N => Inst, + In_State => Guaranteed_ABE_State); - -- A subprogram body may denote an initialization routine + -- Add the instantiation to the appropriate set - elsif Nkind (Par) = N_Subprogram_Body then - Spec_Id := Unique_Defining_Entity (Par); + if Inst_Lvl = Declaration_Level then + Add_Declaration_Scenario (Inst); - -- The current subprogram body denotes a type init proc or - -- primitive [Deep_]Initialize. + elsif Inst_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Inst); - if Is_Init_Proc (Spec_Id) - or else Is_Controlled_Proc (Spec_Id, Name_Initialize) - or else Is_TSS (Spec_Id, TSS_Deep_Initialize) - then - return True; - end if; + elsif Inst_Lvl = Library_Spec_Level + or else Inst_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Inst); + end if; - -- Prevent the search from going too far + -- Instantiations of generics subject to SPARK_Mode On require + -- elaboration-related checks even though the instantiations may + -- not appear within elaboration code. - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; + if Is_Suitable_SPARK_Instantiation (Inst) then + Add_SPARK_Scenario (Inst); + end if; - Par := Parent (Par); - end loop; + -- An instantiation requires a conditional ABE check when the dynamic + -- model is in effect. - return False; - end In_Initialization_Context; + Add_Dynamic_ABE_Check_Scenario (Inst); + end Record_Instantiation; - ---------------------------------- - -- Is_Partial_Finalization_Proc -- - ---------------------------------- + -------------------------------- + -- Record_Variable_Assignment -- + -------------------------------- - function Is_Partial_Finalization_Proc return Boolean is + procedure Record_Variable_Assignment + (Asmt : Node_Id; + Asmt_Lvl : Enclosing_Level_Kind) + is begin - -- To qualify, the target must denote primitive [Deep_]Finalize or a - -- finalizer procedure, and the call must appear in an initialization - -- context. + -- Add the variable assignment to the appropriate set - return - (Is_Controlled_Proc (Target_Id, Name_Finalize) - or else Is_Finalizer_Proc (Target_Id) - or else Is_TSS (Target_Id, TSS_Deep_Finalize)) - and then In_Initialization_Context (Call); - end Is_Partial_Finalization_Proc; + if Asmt_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Asmt); - -- Local variables + elsif Asmt_Lvl = Library_Spec_Level + or else Asmt_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Asmt); + end if; + end Record_Variable_Assignment; - SPARK_Rules_On : Boolean; - Target_Attrs : Target_Attributes; + ------------------------------- + -- Record_Variable_Reference -- + ------------------------------- - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + procedure Record_Variable_Reference + (Ref : Node_Id; + Ref_Lvl : Enclosing_Level_Kind) + is + begin + -- Add the variable reference to the appropriate set - -- Start of processing for Process_Conditional_ABE_Call + if Ref_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Ref); - begin - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); + elsif Ref_Lvl = Library_Spec_Level + or else Ref_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Ref); + end if; + end Record_Variable_Reference; - -- The SPARK rules are in effect when both the call and target are - -- subject to SPARK_Mode On. + -- Local variables - SPARK_Rules_On := - Call_Attrs.SPARK_Mode_On and Target_Attrs.SPARK_Mode_On; + Scen : constant Node_Id := Scenario (N); + Scen_Lvl : Enclosing_Level_Kind; - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + -- Start of processing for Record_Elaboration_Scenario - if Elab_Info_Messages then - Info_Call - (Call => Call, - Target_Id => Target_Id, - Info_Msg => True, - In_SPARK => SPARK_Rules_On); - end if; + begin + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE mechanism does not need + -- to carry out this action. - -- Check whether the invocation of an entry clashes with an existing - -- restriction. + if Legacy_Elaboration_Checks then + return; - if Is_Protected_Entry (Target_Id) then - Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); + -- Nothing to do for ASIS because ABE checks and diagnostics are not + -- performed in this mode. - elsif Is_Task_Entry (Target_Id) then - Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); + elsif ASIS_Mode then + return; - -- Task entry calls are never processed because the entry being - -- invoked does not have a corresponding "body", it has a select. + -- Nothing to do when the scenario is being preanalyzed + elsif Preanalysis_Active then return; end if; - -- Nothing to do when the call invokes a target defined within an - -- instance and switch -gnatd_i (ignore activations and calls to - -- instances for elaboration) is in effect. + Scen_Lvl := Find_Enclosing_Level (Scen); - if Debug_Flag_Underscore_I - and then In_External_Instance - (N => Call, - Target_Decl => Target_Attrs.Spec_Decl) - then - return; + -- Ensure that a library-level call does not appear in a preelaborated + -- unit. The check must come before ignoring scenarios within external + -- units or inside generics because calls in those context must also be + -- verified. - -- Nothing to do when the call is a guaranteed ABE + if Is_Suitable_Call (Scen) then + Check_Preelaborated_Call (Scen, Scen_Lvl); + end if; - elsif Is_Known_Guaranteed_ABE (Call) then - return; + -- Nothing to do when the scenario does not appear within the main unit - -- Nothing to do when the root scenario appears at the declaration level - -- and the target is in the same unit, but outside this context. - -- - -- function B ...; -- target declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- function B ... is - -- ... - -- end B; - -- - -- In the example above, the context of X is the declarative region of - -- Proc. The "elaboration" of X may eventually reach B which is defined - -- outside of X's context. B is relevant only when Proc is invoked, but - -- this happens only by means of "normal" elaboration, therefore B must - -- not be considered if this is not the case. + if not In_Main_Context (Scen) then + return; - -- Performance note: parent traversal + -- Nothing to do when the scenario appears within a generic - elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then + elsif Inside_A_Generic then return; - end if; - - -- Warnings are suppressed when a prior scenario is already in that - -- mode, or the call or target have warnings suppressed. Update the - -- state of the Processing phase to reflect this. - New_State.Suppress_Warnings := - New_State.Suppress_Warnings - or else not Call_Attrs.Elab_Warnings_OK - or else not Target_Attrs.Elab_Warnings_OK; + -- 'Access - -- The call occurs in an initial condition context when a prior scenario - -- is already in that mode, or when the target is an Initial_Condition - -- procedure. Update the state of the Processing phase to reflect this. + elsif Is_Suitable_Access_Taken (Scen) then + Record_Access_Taken + (Attr => Scen, + Attr_Lvl => Scen_Lvl); - New_State.Within_Initial_Condition := - New_State.Within_Initial_Condition - or else Is_Initial_Condition_Proc (Target_Id); + -- Call or task activation - -- The call occurs in a partial finalization context when a prior - -- scenario is already in that mode, or when the target denotes a - -- [Deep_]Finalize primitive or a finalizer within an initialization - -- context. Update the state of the Processing phase to reflect this. + elsif Is_Suitable_Call (Scen) then + Record_Call_Or_Task_Activation + (Call => Scen, + Call_Lvl => Scen_Lvl); - New_State.Within_Partial_Finalization := - New_State.Within_Partial_Finalization - or else Is_Partial_Finalization_Proc; + -- Derived type declaration - -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK - -- elaboration rules in SPARK code) is intentionally not taken into - -- account here because Process_Conditional_ABE_Call_SPARK has two - -- separate modes of operation. + elsif Is_Suitable_SPARK_Derived_Type (Scen) then + Add_SPARK_Scenario (Scen); - if SPARK_Rules_On then - Process_Conditional_ABE_Call_SPARK - (Call => Call, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs, - State => New_State); + -- Instantiation - -- Otherwise the Ada rules are in effect + elsif Is_Suitable_Instantiation (Scen) then + Record_Instantiation + (Inst => Scen, + Inst_Lvl => Scen_Lvl); - else - Process_Conditional_ABE_Call_Ada - (Call => Call, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs, - State => New_State); - end if; + -- Refined_State pragma - -- Inspect the target body (and barried function) for other suitable - -- elaboration scenarios. + elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then + Add_SPARK_Scenario (Scen); - Traverse_Body - (N => Target_Attrs.Body_Barf, - State => New_State); + -- Variable assignment - Traverse_Body - (N => Target_Attrs.Body_Decl, - State => New_State); - end Process_Conditional_ABE_Call; + elsif Is_Suitable_Variable_Assignment (Scen) then + Record_Variable_Assignment + (Asmt => Scen, + Asmt_Lvl => Scen_Lvl); - -------------------------------------- - -- Process_Conditional_ABE_Call_Ada -- - -------------------------------------- + -- Variable reference - procedure Process_Conditional_ABE_Call_Ada - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - State : Processing_Attributes) - is - Check_OK : constant Boolean := - not Call_Attrs.Ghost_Mode_Ignore - and then not Target_Attrs.Ghost_Mode_Ignore - and then Call_Attrs.Elab_Checks_OK - and then Target_Attrs.Elab_Checks_OK; - -- A run-time ABE check may be installed only when both the call and the - -- target have active elaboration checks, and both are not ignored Ghost - -- constructs. + elsif Is_Suitable_Variable_Reference (Scen) then + Record_Variable_Reference + (Ref => Scen, + Ref_Lvl => Scen_Lvl); + end if; + end Record_Elaboration_Scenario; - Root : constant Node_Id := Root_Scenario; + -------------- + -- Scenario -- + -------------- - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + function Scenario (N : Node_Id) return Node_Id is + Orig_N : constant Node_Id := Original_Node (N); begin - -- Nothing to do for an Ada dispatching call because there are no ABE - -- diagnostics for either models. ABE checks for the dynamic model are - -- handled by Install_Primitive_Elaboration_Check. + -- An expanded instantiation is rewritten into a spec-body pair where + -- N denotes the spec. In this case the original instantiation is the + -- proper elaboration scenario. - if Call_Attrs.Is_Dispatching then - return; + if Nkind (Orig_N) in N_Generic_Instantiation then + return Orig_N; - -- Nothing to do when the call is ABE-safe - -- - -- generic - -- function Gen ...; - -- - -- function Gen ... is - -- begin - -- ... - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- function Inst is new Gen; - -- X : ... := Inst; -- safe call - -- ... + -- Otherwise the scenario is already in its proper form - elsif Is_Safe_Call (Call, Target_Attrs) then - return; + else + return N; + end if; + end Scenario; - -- The call and the target body are both in the main unit + ---------------------- + -- Scenario_Storage -- + ---------------------- - elsif Present (Target_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) - then - -- If the root scenario appears prior to the target body, then this - -- is a possible ABE with respect to the root scenario. - -- - -- function B ...; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- - -- function B ... is -- target body - -- ... - -- end B; - -- - -- Y : ... := A; -- root scenario - -- - -- IMPORTANT: The call to B from A is a possible ABE for X, but not - -- for Y. Installing an unconditional ABE raise prior to the call to - -- B would be wrong as it will fail for Y as well, but in Y's case - -- the call to B is never an ABE. + package body Scenario_Storage is - if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then + --------------------- + -- Data structures -- + --------------------- - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + -- The following sets store all scenarios - if State.Suppress_Warnings then - null; + Declaration_Scenarios : NE_Set.Membership_Set := + NE_Set.Create (1000); + Dynamic_ABE_Check_Scenarios : NE_Set.Membership_Set := + NE_Set.Create (500); + Library_Body_Scenarios : NE_Set.Membership_Set := + NE_Set.Create (1000); + Library_Spec_Scenarios : NE_Set.Membership_Set := + NE_Set.Create (1000); + SPARK_Scenarios : NE_Set.Membership_Set := + NE_Set.Create (100); - -- Do not emit any ABE diagnostics when the call occurs in a - -- partial finalization context because this leads to confusing - -- noise. + ------------------------------- + -- Finalize_Scenario_Storage -- + ------------------------------- - elsif State.Within_Partial_Finalization then - null; + procedure Finalize_Scenario_Storage is + begin + NE_Set.Destroy (Declaration_Scenarios); + NE_Set.Destroy (Dynamic_ABE_Check_Scenarios); + NE_Set.Destroy (Library_Body_Scenarios); + NE_Set.Destroy (Library_Spec_Scenarios); + NE_Set.Destroy (SPARK_Scenarios); + end Finalize_Scenario_Storage; + + --------------------------------- + -- Initialize_Scenario_Storage -- + --------------------------------- + + procedure Initialize_Scenario_Storage is + begin + null; + end Initialize_Scenario_Storage; - -- ABE diagnostics are emitted only in the static model because - -- there is a well-defined order to visiting scenarios. Without - -- this order diagnostics appear jumbled and result in unwanted - -- noise. + ------------------------------ + -- Add_Declaration_Scenario -- + ------------------------------ - elsif Static_Elaboration_Checks then - Error_Msg_NE - ("??cannot call & before body seen", Call, Target_Id); - Error_Msg_N ("\Program_Error may be raised at run time", Call); + procedure Add_Declaration_Scenario (N : Node_Id) is + pragma Assert (Present (N)); + begin + NE_Set.Insert (Declaration_Scenarios, N); + end Add_Declaration_Scenario; - Output_Active_Scenarios (Call); - end if; + ------------------------------------ + -- Add_Dynamic_ABE_Check_Scenario -- + ------------------------------------ - -- Install a conditional run-time ABE check to verify that the - -- target body has been elaborated prior to the call. + procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id) is + pragma Assert (Present (N)); - if Check_OK then - Install_ABE_Check - (N => Call, - Ins_Nod => Call, - Target_Id => Target_Attrs.Spec_Id, - Target_Decl => Target_Attrs.Spec_Decl, - Target_Body => Target_Attrs.Body_Decl); + begin + if not Check_Or_Failure_Generation_OK then + return; - -- Update the state of the Processing phase to indicate that - -- no implicit Elaborate[_All] pragmas must be generated from - -- this point on. - -- - -- function B ...; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- <ABE check> - -- return B; - -- ... - -- end A; - -- - -- X : ... := A; - -- - -- function B ... is - -- External.Subp; -- imparts Elaborate_All - -- end B; - -- - -- If Some_Condition is True, then the ABE check will fail at - -- runtime and the call to External.Subp will never take place, - -- rendering the implicit Elaborate_All useless. - -- - -- If Some_Condition is False, then the call to External.Subp - -- will never take place, rendering the implicit Elaborate_All - -- useless. + -- Nothing to do if the dynamic model is not in effect - New_State.Suppress_Implicit_Pragmas := True; - end if; + elsif not Dynamic_Elaboration_Checks then + return; end if; - -- Otherwise the target body is not available in this compilation or it - -- resides in an external unit. Install a run-time ABE check to verify - -- that the target body has been elaborated prior to the call site when - -- the dynamic model is in effect. + NE_Set.Insert (Dynamic_ABE_Check_Scenarios, N); + end Add_Dynamic_ABE_Check_Scenario; - elsif Dynamic_Elaboration_Checks and then Check_OK then - Install_ABE_Check - (N => Call, - Ins_Nod => Call, - Id => Target_Attrs.Unit_Id); - end if; + ------------------------------- + -- Add_Library_Body_Scenario -- + ------------------------------- - -- Ensure that the unit with the target body is elaborated prior to the - -- main unit. The implicit Elaborate[_All] is generated only when the - -- call has elaboration checks enabled. This behaviour parallels that of - -- the old ABE mechanism. + procedure Add_Library_Body_Scenario (N : Node_Id) is + pragma Assert (Present (N)); + begin + NE_Set.Insert (Library_Body_Scenarios, N); + end Add_Library_Body_Scenario; - if Call_Attrs.Elab_Checks_OK then - Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Target_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - State => New_State); - end if; - end Process_Conditional_ABE_Call_Ada; + ------------------------------- + -- Add_Library_Spec_Scenario -- + ------------------------------- - ---------------------------------------- - -- Process_Conditional_ABE_Call_SPARK -- - ---------------------------------------- + procedure Add_Library_Spec_Scenario (N : Node_Id) is + pragma Assert (Present (N)); + begin + NE_Set.Insert (Library_Spec_Scenarios, N); + end Add_Library_Spec_Scenario; - procedure Process_Conditional_ABE_Call_SPARK - (Call : Node_Id; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - State : Processing_Attributes) - is - Region : Node_Id; + ------------------------ + -- Add_SPARK_Scenario -- + ------------------------ - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + procedure Add_SPARK_Scenario (N : Node_Id) is + pragma Assert (Present (N)); + begin + NE_Set.Insert (SPARK_Scenarios, N); + end Add_SPARK_Scenario; - Check_SPARK_Model_In_Effect (Call); + --------------------- + -- Delete_Scenario -- + --------------------- - -- The call and the target body are both in the main unit + procedure Delete_Scenario (N : Node_Id) is + pragma Assert (Present (N)); - if Present (Target_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) - then - -- If the call appears prior to the target body, then the call must - -- appear within the early call region of the target body. - -- - -- function B ...; - -- - -- X : ... := B; -- call site - -- - -- <preelaborable construct 1> --+ - -- ... | early call region - -- <preelaborable construct N> --+ - -- - -- function B ... is -- target body - -- ... - -- end B; - -- - -- When the call to B is not nested within some other scenario, the - -- call is automatically illegal because it can never appear in the - -- early call region of B's body. This is equivalent to a guaranteed - -- ABE. - -- - -- <preelaborable construct 1> --+ - -- | - -- function B ...; | - -- | - -- function A ... is | - -- begin | early call region - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; | - -- | - -- <preelaborable construct N> --+ - -- - -- function B ... is -- target body - -- ... - -- end B; - -- - -- When the call to B is nested within some other scenario, the call - -- is always ABE-safe. It is not immediately obvious why this is the - -- case. The elaboration safety follows from the early call region - -- rule being applied to ALL calls preceding their associated bodies. - -- - -- In the example above, the call to B is safe as long as the call to - -- A is safe. There are several cases to consider: - -- - -- <call 1 to A> - -- function B ...; - -- - -- <call 2 to A> - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; - -- ... - -- end A; - -- - -- <call 3 to A> - -- function B ... is - -- ... - -- end B; - -- - -- * Call 1 - This call is either nested within some scenario or not, - -- which falls under the two general cases outlined above. - -- - -- * Call 2 - This is the same case as Call 1. - -- - -- * Call 3 - The placement of this call limits the range of B's - -- early call region unto call 3, therefore the call to B is no - -- longer within the early call region of B's body, making it ABE- - -- unsafe and therefore illegal. + begin + -- Delete the scenario from whichever set it belongs to - if Earlier_In_Extended_Unit (Call, Target_Attrs.Body_Decl) then + NE_Set.Delete (Declaration_Scenarios, N); + NE_Set.Delete (Dynamic_ABE_Check_Scenarios, N); + NE_Set.Delete (Library_Body_Scenarios, N); + NE_Set.Delete (Library_Spec_Scenarios, N); + NE_Set.Delete (SPARK_Scenarios, N); + end Delete_Scenario; - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + ----------------------------------- + -- Iterate_Declaration_Scenarios -- + ----------------------------------- - if State.Suppress_Warnings then - null; + function Iterate_Declaration_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Declaration_Scenarios); + end Iterate_Declaration_Scenarios; - -- Do not emit any ABE diagnostics when the call occurs in an - -- initial condition context because this leads to incorrect - -- diagnostics. + ----------------------------------------- + -- Iterate_Dynamic_ABE_Check_Scenarios -- + ----------------------------------------- - elsif State.Within_Initial_Condition then - null; + function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Dynamic_ABE_Check_Scenarios); + end Iterate_Dynamic_ABE_Check_Scenarios; - -- Do not emit any ABE diagnostics when the call occurs in a - -- partial finalization context because this leads to confusing - -- noise. + ------------------------------------ + -- Iterate_Library_Body_Scenarios -- + ------------------------------------ - elsif State.Within_Partial_Finalization then - null; + function Iterate_Library_Body_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Library_Body_Scenarios); + end Iterate_Library_Body_Scenarios; - -- ABE diagnostics are emitted only in the static model because - -- there is a well-defined order to visiting scenarios. Without - -- this order diagnostics appear jumbled and result in unwanted - -- noise. + ------------------------------------ + -- Iterate_Library_Spec_Scenarios -- + ------------------------------------ - elsif Static_Elaboration_Checks then + function Iterate_Library_Spec_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Library_Spec_Scenarios); + end Iterate_Library_Spec_Scenarios; - -- Ensure that a call which textually precedes the subprogram - -- body it invokes appears within the early call region of the - -- subprogram body. + ----------------------------- + -- Iterate_SPARK_Scenarios -- + ----------------------------- - -- IMPORTANT: This check must always be performed even when - -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is - -- not specified because the static model cannot guarantee the - -- absence of elaboration issues in the presence of dispatching - -- calls. + function Iterate_SPARK_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (SPARK_Scenarios); + end Iterate_SPARK_Scenarios; - Region := Find_Early_Call_Region (Target_Attrs.Body_Decl); + ---------------------- + -- Replace_Scenario -- + ---------------------- - if Earlier_In_Extended_Unit (Call, Region) then - Error_Msg_NE - ("call must appear within early call region of subprogram " - & "body & (SPARK RM 7.7(3))", Call, Target_Id); + procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id) is + procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set); + -- Determine whether scenario Old_N is present in set Scenarios, and + -- if this is the case it, replace it with New_N. - Error_Msg_Sloc := Sloc (Region); - Error_Msg_N ("\region starts #", Call); + ------------------------- + -- Replace_Scenario_In -- + ------------------------- - Error_Msg_Sloc := Sloc (Target_Attrs.Body_Decl); - Error_Msg_N ("\region ends #", Call); + procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set) is + begin + -- The set is intentionally checked for existance because node + -- rewriting may occur after Sem_Elab has verified all scenarios + -- and data structures have been destroyed. - Output_Active_Scenarios (Call); - end if; + if NE_Set.Present (Scenarios) + and then NE_Set.Contains (Scenarios, Old_N) + then + NE_Set.Delete (Scenarios, Old_N); + NE_Set.Insert (Scenarios, New_N); end if; + end Replace_Scenario_In; - -- Otherwise the call appears after the target body. The call is - -- ABE-safe as a consequence of applying the early call region rule - -- to ALL calls preceding their associated bodies. + -- Start of processing for Replace_Scenario - else - null; - end if; - end if; + begin + Replace_Scenario_In (Declaration_Scenarios); + Replace_Scenario_In (Dynamic_ABE_Check_Scenarios); + Replace_Scenario_In (Library_Body_Scenarios); + Replace_Scenario_In (Library_Spec_Scenarios); + Replace_Scenario_In (SPARK_Scenarios); + end Replace_Scenario; + end Scenario_Storage; - -- A call to a source target or to a target which emulates Ada or SPARK - -- semantics imposes an Elaborate_All requirement on the context of the - -- main unit. Determine whether the context has a pragma strong enough - -- to meet the requirement. + --------------- + -- Semantics -- + --------------- - -- IMPORTANT: This check must be performed only when -gnatd.v (enforce - -- SPARK elaboration rules in SPARK code) is active because the static - -- model can ensure the prior elaboration of the unit which contains a - -- body by installing an implicit Elaborate[_All] pragma. + package body Semantics is - if Debug_Flag_Dot_V then - if Target_Attrs.From_Source - or else Is_Ada_Semantic_Target (Target_Id) - or else Is_SPARK_Semantic_Target (Target_Id) - then - Meet_Elaboration_Requirement - (N => Call, - Target_Id => Target_Id, - Req_Nam => Name_Elaborate_All); - end if; + -------------------------------- + -- Is_Accept_Alternative_Proc -- + -------------------------------- - -- Otherwise ensure that the unit with the target body is elaborated - -- prior to the main unit. + function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a procedure with a receiving + -- entry. - else - Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Target_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - State => State); - end if; - end Process_Conditional_ABE_Call_SPARK; + return + Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); + end Is_Accept_Alternative_Proc; - ------------------------------------------- - -- Process_Conditional_ABE_Instantiation -- - ------------------------------------------- + ------------------------ + -- Is_Activation_Proc -- + ------------------------ - procedure Process_Conditional_ABE_Instantiation - (Exp_Inst : Node_Id; - State : Processing_Attributes) - is - Gen_Attrs : Target_Attributes; - Gen_Id : Entity_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; + function Is_Activation_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote one of the runtime procedures + -- in charge of task activation. - SPARK_Rules_On : Boolean; - -- This flag is set when the SPARK rules are in effect + if Ekind (Id) = E_Procedure then + if Restricted_Profile then + return Is_RTE (Id, RE_Activate_Restricted_Tasks); + else + return Is_RTE (Id, RE_Activate_Tasks); + end if; + end if; - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + return False; + end Is_Activation_Proc; - begin - Extract_Instantiation_Attributes - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + ---------------------------- + -- Is_Ada_Semantic_Target -- + ---------------------------- - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Activation_Proc (Id) + or else Is_Controlled_Proc (Id, Name_Adjust) + or else Is_Controlled_Proc (Id, Name_Finalize) + or else Is_Controlled_Proc (Id, Name_Initialize) + or else Is_Init_Proc (Id) + or else Is_Invariant_Proc (Id) + or else Is_Protected_Entry (Id) + or else Is_Protected_Subp (Id) + or else Is_Protected_Body_Subp (Id) + or else Is_Subprogram_Inst (Id) + or else Is_Task_Entry (Id); + end Is_Ada_Semantic_Target; - -- The SPARK rules are in effect when both the instantiation and generic - -- are subject to SPARK_Mode On. + -------------------------------- + -- Is_Assertion_Pragma_Target -- + -------------------------------- - SPARK_Rules_On := Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; + function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Default_Initial_Condition_Proc (Id) + or else Is_Initial_Condition_Proc (Id) + or else Is_Invariant_Proc (Id) + or else Is_Partial_Invariant_Proc (Id) + or else Is_Postconditions_Proc (Id); + end Is_Assertion_Pragma_Target; - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + ---------------------------- + -- Is_Bodiless_Subprogram -- + ---------------------------- - if Elab_Info_Messages then - Info_Instantiation - (Inst => Inst, - Gen_Id => Gen_Id, - Info_Msg => True, - In_SPARK => SPARK_Rules_On); - end if; + function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is + begin + -- An abstract subprogram does not have a body - -- Nothing to do when the instantiation is a guaranteed ABE + if Ekind_In (Subp_Id, E_Function, + E_Operator, + E_Procedure) + and then Is_Abstract_Subprogram (Subp_Id) + then + return True; - if Is_Known_Guaranteed_ABE (Inst) then - return; + -- A formal subprogram does not have a body - -- Nothing to do when the root scenario appears at the declaration level - -- and the generic is in the same unit, but outside this context. - -- - -- generic - -- procedure Gen is ...; -- generic declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- procedure I is new Gen; -- instantiation site - -- ... - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- procedure Gen is - -- ... - -- end Gen; - -- - -- In the example above, the context of X is the declarative region of - -- Proc. The "elaboration" of X may eventually reach Gen which appears - -- outside of X's context. Gen is relevant only when Proc is invoked, - -- but this happens only by means of "normal" elaboration, therefore - -- Gen must not be considered if this is not the case. + elsif Is_Formal_Subprogram (Subp_Id) then + return True; - -- Performance note: parent traversal + -- An imported subprogram may have a body, however it is not known at + -- compile or bind time where the body resides and whether it will be + -- elaborated on time. - elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then - return; - end if; + elsif Is_Imported (Subp_Id) then + return True; + end if; - -- Warnings are suppressed when a prior scenario is already in that - -- mode, or when the instantiation has warnings suppressed. Update - -- the state of the processing phase to reflect this. + return False; + end Is_Bodiless_Subprogram; - New_State.Suppress_Warnings := - New_State.Suppress_Warnings or else not Inst_Attrs.Elab_Warnings_OK; + ---------------------- + -- Is_Bridge_Target -- + ---------------------- - -- The SPARK rules are in effect + function Is_Bridge_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Accept_Alternative_Proc (Id) + or else Is_Finalizer_Proc (Id) + or else Is_Partial_Invariant_Proc (Id) + or else Is_Postconditions_Proc (Id) + or else Is_TSS (Id, TSS_Deep_Adjust) + or else Is_TSS (Id, TSS_Deep_Finalize) + or else Is_TSS (Id, TSS_Deep_Initialize); + end Is_Bridge_Target; - if SPARK_Rules_On then - Process_Conditional_ABE_Instantiation_SPARK - (Inst => Inst, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs, - State => New_State); + ------------------------ + -- Is_Controlled_Proc -- + ------------------------ - -- Otherwise the Ada rules are in effect, or SPARK code is allowed to - -- violate the SPARK rules. + function Is_Controlled_Proc + (Subp_Id : Entity_Id; + Subp_Nam : Name_Id) return Boolean + is + Formal_Id : Entity_Id; - else - Process_Conditional_ABE_Instantiation_Ada - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Attrs => Inst_Attrs, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs, - State => New_State); - end if; - end Process_Conditional_ABE_Instantiation; - - ----------------------------------------------- - -- Process_Conditional_ABE_Instantiation_Ada -- - ----------------------------------------------- - - procedure Process_Conditional_ABE_Instantiation_Ada - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - State : Processing_Attributes) - is - Check_OK : constant Boolean := - not Inst_Attrs.Ghost_Mode_Ignore - and then not Gen_Attrs.Ghost_Mode_Ignore - and then Inst_Attrs.Elab_Checks_OK - and then Gen_Attrs.Elab_Checks_OK; - -- A run-time ABE check may be installed only when both the instance and - -- the generic have active elaboration checks and both are not ignored - -- Ghost constructs. + begin + pragma Assert (Nam_In (Subp_Nam, Name_Adjust, + Name_Finalize, + Name_Initialize)); - Root : constant Node_Id := Root_Scenario; + -- To qualify, the subprogram must denote a source procedure with + -- name Adjust, Finalize, or Initialize where the sole formal is + -- controlled. - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + if Comes_From_Source (Subp_Id) + and then Ekind (Subp_Id) = E_Procedure + and then Chars (Subp_Id) = Subp_Nam + then + Formal_Id := First_Formal (Subp_Id); - begin - -- Nothing to do when the instantiation is ABE-safe - -- - -- generic - -- package Gen is - -- ... - -- end Gen; - -- - -- package body Gen is - -- ... - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- package Inst is new Gen (ABE); -- safe instantiation - -- ... + return + Present (Formal_Id) + and then Is_Controlled (Etype (Formal_Id)) + and then No (Next_Formal (Formal_Id)); + end if; - if Is_Safe_Instantiation (Inst, Gen_Attrs) then - return; + return False; + end Is_Controlled_Proc; - -- The instantiation and the generic body are both in the main unit + --------------------------------------- + -- Is_Default_Initial_Condition_Proc -- + --------------------------------------- - elsif Present (Gen_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) - then - -- If the root scenario appears prior to the generic body, then this - -- is a possible ABE with respect to the root scenario. - -- - -- generic - -- package Gen is - -- ... - -- end Gen; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- package Inst is new Gen; -- instantiation site - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- - -- package body Gen is -- generic body - -- ... - -- end Gen; - -- - -- Y : ... := A; -- root scenario - -- - -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but - -- not for Y. Installing an unconditional ABE raise prior to the - -- instance site would be wrong as it will fail for Y as well, but in - -- Y's case the instantiation of Gen is never an ABE. + function Is_Default_Initial_Condition_Proc + (Id : Entity_Id) return Boolean + is + begin + -- To qualify, the entity must denote a Default_Initial_Condition + -- procedure. - if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then + return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); + end Is_Default_Initial_Condition_Proc; - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + ----------------------- + -- Is_Finalizer_Proc -- + ----------------------- - if State.Suppress_Warnings then - null; + function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a _Finalizer procedure - -- Do not emit any ABE diagnostics when the instantiation occurs - -- in partial finalization context because this leads to unwanted - -- noise. + return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; + end Is_Finalizer_Proc; - elsif State.Within_Partial_Finalization then - null; + ------------------------------- + -- Is_Initial_Condition_Proc -- + ------------------------------- - -- ABE diagnostics are emitted only in the static model because - -- there is a well-defined order to visiting scenarios. Without - -- this order diagnostics appear jumbled and result in unwanted - -- noise. + function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an Initial_Condition procedure - elsif Static_Elaboration_Checks then - Error_Msg_NE - ("??cannot instantiate & before body seen", Inst, Gen_Id); - Error_Msg_N ("\Program_Error may be raised at run time", Inst); + return + Ekind (Id) = E_Procedure + and then Is_Initial_Condition_Procedure (Id); + end Is_Initial_Condition_Proc; - Output_Active_Scenarios (Inst); - end if; + -------------------- + -- Is_Initialized -- + -------------------- - -- Install a conditional run-time ABE check to verify that the - -- generic body has been elaborated prior to the instantiation. + function Is_Initialized (Obj_Decl : Node_Id) return Boolean is + begin + -- To qualify, the object declaration must have an expression - if Check_OK then - Install_ABE_Check - (N => Inst, - Ins_Nod => Exp_Inst, - Target_Id => Gen_Attrs.Spec_Id, - Target_Decl => Gen_Attrs.Spec_Decl, - Target_Body => Gen_Attrs.Body_Decl); + return + Present (Expression (Obj_Decl)) + or else Has_Init_Expression (Obj_Decl); + end Is_Initialized; - -- Update the state of the Processing phase to indicate that - -- no implicit Elaborate[_All] pragmas must be generated from - -- this point on. - -- - -- generic - -- package Gen is - -- ... - -- end Gen; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- <ABE check> - -- declare Inst is new Gen; - -- ... - -- end A; - -- - -- X : ... := A; - -- - -- package body Gen is - -- begin - -- External.Subp; -- imparts Elaborate_All - -- end Gen; - -- - -- If Some_Condition is True, then the ABE check will fail at - -- runtime and the call to External.Subp will never take place, - -- rendering the implicit Elaborate_All useless. - -- - -- If Some_Condition is False, then the call to External.Subp - -- will never take place, rendering the implicit Elaborate_All - -- useless. + ----------------------- + -- Is_Invariant_Proc -- + ----------------------- - New_State.Suppress_Implicit_Pragmas := True; - end if; - end if; + function Is_Invariant_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote the "full" invariant procedure - -- Otherwise the generic body is not available in this compilation or it - -- resides in an external unit. Install a run-time ABE check to verify - -- that the generic body has been elaborated prior to the instantiation - -- when the dynamic model is in effect. + return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); + end Is_Invariant_Proc; - elsif Dynamic_Elaboration_Checks and then Check_OK then - Install_ABE_Check - (N => Inst, - Ins_Nod => Exp_Inst, - Id => Gen_Attrs.Unit_Id); - end if; + --------------------------------------- + -- Is_Non_Library_Level_Encapsulator -- + --------------------------------------- - -- Ensure that the unit with the generic body is elaborated prior to - -- the main unit. No implicit pragma is generated if the instantiation - -- has elaboration checks suppressed. This behaviour parallels that of - -- the old ABE mechanism. + function Is_Non_Library_Level_Encapsulator + (N : Node_Id) return Boolean + is + begin + case Nkind (N) is + when N_Abstract_Subprogram_Declaration + | N_Aspect_Specification + | N_Component_Declaration + | N_Entry_Body + | N_Entry_Declaration + | N_Expression_Function + | N_Formal_Abstract_Subprogram_Declaration + | N_Formal_Concrete_Subprogram_Declaration + | N_Formal_Object_Declaration + | N_Formal_Package_Declaration + | N_Formal_Type_Declaration + | N_Generic_Association + | N_Implicit_Label_Declaration + | N_Incomplete_Type_Declaration + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Protected_Body + | N_Protected_Type_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Subprogram_Body + | N_Subprogram_Declaration + | N_Task_Body + | N_Task_Type_Declaration + => + return True; - if Inst_Attrs.Elab_Checks_OK then - Ensure_Prior_Elaboration - (N => Inst, - Unit_Id => Gen_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate, - State => New_State); - end if; - end Process_Conditional_ABE_Instantiation_Ada; + when others => + return Is_Generic_Declaration_Or_Body (N); + end case; + end Is_Non_Library_Level_Encapsulator; - ------------------------------------------------- - -- Process_Conditional_ABE_Instantiation_SPARK -- - ------------------------------------------------- + ------------------------------- + -- Is_Partial_Invariant_Proc -- + ------------------------------- - procedure Process_Conditional_ABE_Instantiation_SPARK - (Inst : Node_Id; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - State : Processing_Attributes) - is - Req_Nam : Name_Id; + function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote the "partial" invariant + -- procedure. - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + return + Ekind (Id) = E_Procedure + and then Is_Partial_Invariant_Procedure (Id); + end Is_Partial_Invariant_Proc; - Check_SPARK_Model_In_Effect (Inst); + ---------------------------- + -- Is_Postconditions_Proc -- + ---------------------------- - -- A source instantiation imposes an Elaborate[_All] requirement on the - -- context of the main unit. Determine whether the context has a pragma - -- strong enough to meet the requirement. The check is orthogonal to the - -- ABE ramifications of the instantiation. + function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a _Postconditions procedure - -- IMPORTANT: This check must be performed only when -gnatd.v (enforce - -- SPARK elaboration rules in SPARK code) is active because the static - -- model can ensure the prior elaboration of the unit which contains a - -- body by installing an implicit Elaborate[_All] pragma. + return + Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; + end Is_Postconditions_Proc; - if Debug_Flag_Dot_V then - if Nkind (Inst) = N_Package_Instantiation then - Req_Nam := Name_Elaborate_All; - else - Req_Nam := Name_Elaborate; - end if; + --------------------------- + -- Is_Preelaborated_Unit -- + --------------------------- - Meet_Elaboration_Requirement - (N => Inst, - Target_Id => Gen_Id, - Req_Nam => Req_Nam); + function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is + begin + return + Is_Preelaborated (Id) + or else Is_Pure (Id) + or else Is_Remote_Call_Interface (Id) + or else Is_Remote_Types (Id) + or else Is_Shared_Passive (Id); + end Is_Preelaborated_Unit; + + ------------------------ + -- Is_Protected_Entry -- + ------------------------ + + function Is_Protected_Entry (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an entry defined in a protected + -- type. - -- Otherwise ensure that the unit with the target body is elaborated - -- prior to the main unit. + return + Is_Entry (Id) + and then Is_Protected_Type (Non_Private_View (Scope (Id))); + end Is_Protected_Entry; - else - Ensure_Prior_Elaboration - (N => Inst, - Unit_Id => Gen_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate, - State => State); - end if; - end Process_Conditional_ABE_Instantiation_SPARK; + ----------------------- + -- Is_Protected_Subp -- + ----------------------- - ------------------------------------------------- - -- Process_Conditional_ABE_Variable_Assignment -- - ------------------------------------------------- + function Is_Protected_Subp (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a subprogram defined within a + -- protected type. - procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id) is - Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (Asmt)); - Prag : constant Node_Id := SPARK_Pragma (Var_Id); + return + Ekind_In (Id, E_Function, E_Procedure) + and then Is_Protected_Type (Non_Private_View (Scope (Id))); + end Is_Protected_Subp; - SPARK_Rules_On : Boolean; - -- This flag is set when the SPARK rules are in effect + ---------------------------- + -- Is_Protected_Body_Subp -- + ---------------------------- - begin - -- The SPARK rules are in effect when both the assignment and the - -- variable are subject to SPARK_Mode On. + function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a subprogram with attribute + -- Protected_Subprogram set. - SPARK_Rules_On := - Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On - and then Is_SPARK_Mode_On_Node (Asmt); + return + Ekind_In (Id, E_Function, E_Procedure) + and then Present (Protected_Subprogram (Id)); + end Is_Protected_Body_Subp; - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + ----------------- + -- Is_Scenario -- + ----------------- - if Elab_Info_Messages then - Elab_Msg_NE - (Msg => "assignment to & during elaboration", - N => Asmt, - Id => Var_Id, - Info_Msg => True, - In_SPARK => SPARK_Rules_On); - end if; + function Is_Scenario (N : Node_Id) return Boolean is + begin + case Nkind (N) is + when N_Assignment_Statement + | N_Attribute_Reference + | N_Call_Marker + | N_Entry_Call_Statement + | N_Expanded_Name + | N_Function_Call + | N_Function_Instantiation + | N_Identifier + | N_Package_Instantiation + | N_Procedure_Call_Statement + | N_Procedure_Instantiation + | N_Requeue_Statement + => + return True; - -- The SPARK rules are in effect. These rules are applied regardless of - -- whether -gnatd.v (enforce SPARK elaboration rules in SPARK code) is - -- in effect because the static model cannot ensure safe assignment of - -- variables. + when others => + return False; + end case; + end Is_Scenario; - if SPARK_Rules_On then - Process_Conditional_ABE_Variable_Assignment_SPARK - (Asmt => Asmt, - Var_Id => Var_Id); + ------------------------------ + -- Is_SPARK_Semantic_Target -- + ------------------------------ - -- Otherwise the Ada rules are in effect + function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Default_Initial_Condition_Proc (Id) + or else Is_Initial_Condition_Proc (Id); + end Is_SPARK_Semantic_Target; - else - Process_Conditional_ABE_Variable_Assignment_Ada - (Asmt => Asmt, - Var_Id => Var_Id); - end if; - end Process_Conditional_ABE_Variable_Assignment; + ------------------------ + -- Is_Subprogram_Inst -- + ------------------------ - ----------------------------------------------------- - -- Process_Conditional_ABE_Variable_Assignment_Ada -- - ----------------------------------------------------- + function Is_Subprogram_Inst (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a function or a procedure which + -- is hidden within an anonymous package, and is a generic instance. - procedure Process_Conditional_ABE_Variable_Assignment_Ada - (Asmt : Node_Id; - Var_Id : Entity_Id) - is - Var_Decl : constant Node_Id := Declaration_Node (Var_Id); - Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); + return + Ekind_In (Id, E_Function, E_Procedure) + and then Is_Hidden (Id) + and then Is_Generic_Instance (Id); + end Is_Subprogram_Inst; - begin - -- Emit a warning when an uninitialized variable declared in a package - -- spec without a pragma Elaborate_Body is initialized by elaboration - -- code within the corresponding body. + ------------------------------ + -- Is_Suitable_Access_Taken -- + ------------------------------ - if Is_Elaboration_Warnings_OK_Id (Var_Id) - and then not Is_Initialized (Var_Decl) - and then not Has_Pragma_Elaborate_Body (Spec_Id) - then - Error_Msg_NE - ("??variable & can be accessed by clients before this " - & "initialization", Asmt, Var_Id); + function Is_Suitable_Access_Taken (N : Node_Id) return Boolean is + Nam : Name_Id; + Pref : Node_Id; + Subp_Id : Entity_Id; - Error_Msg_NE - ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " - & "initialization", Asmt, Spec_Id); + begin + -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect - Output_Active_Scenarios (Asmt); + if Debug_Flag_Dot_UU then + return False; - -- Generate an implicit Elaborate_Body in the spec + -- Nothing to do when the scenario is not an attribute reference - Set_Elaborate_Body_Desirable (Spec_Id); - end if; - end Process_Conditional_ABE_Variable_Assignment_Ada; + elsif Nkind (N) /= N_Attribute_Reference then + return False; - ------------------------------------------------------- - -- Process_Conditional_ABE_Variable_Assignment_SPARK -- - ------------------------------------------------------- + -- Nothing to do for internally-generated attributes because they are + -- assumed to be ABE safe. - procedure Process_Conditional_ABE_Variable_Assignment_SPARK - (Asmt : Node_Id; - Var_Id : Entity_Id) - is - Var_Decl : constant Node_Id := Declaration_Node (Var_Id); - Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); + elsif not Comes_From_Source (N) then + return False; + end if; - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + Nam := Attribute_Name (N); + Pref := Prefix (N); - Check_SPARK_Model_In_Effect (Asmt); + -- Sanitize the prefix of the attribute - -- Emit an error when an initialized variable declared in a package spec - -- without pragma Elaborate_Body is further modified by elaboration code - -- within the corresponding body. + if not Is_Entity_Name (Pref) then + return False; - if Is_Elaboration_Warnings_OK_Id (Var_Id) - and then Is_Initialized (Var_Decl) - and then not Has_Pragma_Elaborate_Body (Spec_Id) - then - Error_Msg_NE - ("variable & modified by elaboration code in package body", - Asmt, Var_Id); + elsif No (Entity (Pref)) then + return False; + end if; - Error_Msg_NE - ("\add pragma ""Elaborate_Body"" to spec & to ensure full " - & "initialization", Asmt, Spec_Id); + Subp_Id := Entity (Pref); - Output_Active_Scenarios (Asmt); - end if; - end Process_Conditional_ABE_Variable_Assignment_SPARK; + if not Is_Subprogram_Or_Entry (Subp_Id) then + return False; + end if; - ------------------------------------------------ - -- Process_Conditional_ABE_Variable_Reference -- - ------------------------------------------------ + -- Traverse a possible chain of renamings to obtain the original + -- entry or subprogram which the prefix may rename. - procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id) is - Var_Attrs : Variable_Attributes; - Var_Id : Entity_Id; + Subp_Id := Get_Renamed_Entity (Subp_Id); - begin - Extract_Variable_Reference_Attributes - (Ref => Ref, - Var_Id => Var_Id, - Attrs => Var_Attrs); - - if Is_Read (Ref) then - Process_Conditional_ABE_Variable_Reference_Read - (Ref => Ref, - Var_Id => Var_Id, - Attrs => Var_Attrs); - end if; - end Process_Conditional_ABE_Variable_Reference; + -- To qualify, the attribute must meet the following prerequisites: - ----------------------------------------------------- - -- Process_Conditional_ABE_Variable_Reference_Read -- - ----------------------------------------------------- + return - procedure Process_Conditional_ABE_Variable_Reference_Read - (Ref : Node_Id; - Var_Id : Entity_Id; - Attrs : Variable_Attributes) - is - begin - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + -- The prefix must denote a source entry, operator, or subprogram + -- which is not imported. - if Elab_Info_Messages then - Elab_Msg_NE - (Msg => "read of variable & during elaboration", - N => Ref, - Id => Var_Id, - Info_Msg => True, - In_SPARK => True); - end if; + Comes_From_Source (Subp_Id) + and then Is_Subprogram_Or_Entry (Subp_Id) + and then not Is_Bodiless_Subprogram (Subp_Id) - -- Nothing to do when the variable appears within the main unit because - -- diagnostics on reads are relevant only for external variables. + -- The attribute name must be one of the 'Access forms. Note that + -- 'Unchecked_Access cannot apply to a subprogram. - if Is_Same_Unit (Attrs.Unit_Id, Cunit_Entity (Main_Unit)) then - null; + and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); + end Is_Suitable_Access_Taken; - -- Nothing to do when the variable is already initialized. Note that the - -- variable may be further modified by the external unit. + ---------------------- + -- Is_Suitable_Call -- + ---------------------- - elsif Is_Initialized (Declaration_Node (Var_Id)) then - null; + function Is_Suitable_Call (N : Node_Id) return Boolean is + begin + -- Entry and subprogram calls are intentionally ignored because they + -- may undergo expansion depending on the compilation mode, previous + -- errors, generic context, etc. Call markers play the role of calls + -- and provide a uniform foundation for ABE processing. - -- Nothing to do when the external unit guarantees the initialization of - -- the variable by means of pragma Elaborate_Body. + return Nkind (N) = N_Call_Marker; + end Is_Suitable_Call; - elsif Has_Pragma_Elaborate_Body (Attrs.Unit_Id) then - null; + ------------------------------- + -- Is_Suitable_Instantiation -- + ------------------------------- - -- A variable read imposes an Elaborate requirement on the context of - -- the main unit. Determine whether the context has a pragma strong - -- enough to meet the requirement. + function Is_Suitable_Instantiation (N : Node_Id) return Boolean is + Inst : constant Node_Id := Scenario (N); - else - Meet_Elaboration_Requirement - (N => Ref, - Target_Id => Var_Id, - Req_Nam => Name_Elaborate); - end if; - end Process_Conditional_ABE_Variable_Reference_Read; + begin + -- To qualify, the instantiation must come from source - ----------------------------- - -- Process_Conditional_ABE -- - ----------------------------- + return + Comes_From_Source (Inst) + and then Nkind (Inst) in N_Generic_Instantiation; + end Is_Suitable_Instantiation; - -- NOTE: The body of this routine is intentionally out of order because it - -- invokes an instantiated subprogram (Process_Conditional_ABE_Activation). - -- Placing the body in alphabetical order will result in a guaranteed ABE. + ------------------------------------ + -- Is_Suitable_SPARK_Derived_Type -- + ------------------------------------ - procedure Process_Conditional_ABE - (N : Node_Id; - State : Processing_Attributes := Initial_State) - is - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; + function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is + Prag : Node_Id; + Typ : Entity_Id; - begin - -- Add the current scenario to the stack of active scenarios + begin + -- To qualify, the type declaration must denote a derived tagged type + -- with primitive operations, subject to pragma SPARK_Mode On. - Push_Active_Scenario (N); + if Nkind (N) = N_Full_Type_Declaration + and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition + then + Typ := Defining_Entity (N); + Prag := SPARK_Pragma (Typ); - -- 'Access + return + Is_Tagged_Type (Typ) + and then Has_Primitive_Operations (Typ) + and then Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On; + end if; - if Is_Suitable_Access (N) then - Process_Conditional_ABE_Access - (Attr => N, - State => State); + return False; + end Is_Suitable_SPARK_Derived_Type; - -- Activations and calls + ------------------------------------- + -- Is_Suitable_SPARK_Instantiation -- + ------------------------------------- - elsif Is_Suitable_Call (N) then + function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is + Inst : constant Node_Id := Scenario (N); - -- In general, only calls found within the main unit are processed - -- because the ALI information supplied to binde is for the main - -- unit only. However, to preserve the consistency of the tree and - -- ensure proper serialization of internal names, external calls - -- also receive corresponding call markers (see Build_Call_Marker). - -- Regardless of the reason, external calls must not be processed. + Gen_Id : Entity_Id; + Prag : Node_Id; - if In_Main_Context (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); + begin + -- To qualify, both the instantiation and the generic must be subject + -- to SPARK_Mode On. - if Is_Activation_Proc (Target_Id) then - Process_Conditional_ABE_Activation - (Call => N, - Call_Attrs => Call_Attrs, - State => State); + if Is_Suitable_Instantiation (N) then + Gen_Id := Instantiated_Generic (Inst); + Prag := SPARK_Pragma (Gen_Id); - else - Process_Conditional_ABE_Call - (Call => N, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - State => State); - end if; + return + Is_SPARK_Mode_On_Node (Inst) + and then Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On; end if; - -- Instantiations + return False; + end Is_Suitable_SPARK_Instantiation; - elsif Is_Suitable_Instantiation (N) then - Process_Conditional_ABE_Instantiation - (Exp_Inst => N, - State => State); + -------------------------------------------- + -- Is_Suitable_SPARK_Refined_State_Pragma -- + -------------------------------------------- - -- Variable assignments + function Is_Suitable_SPARK_Refined_State_Pragma + (N : Node_Id) return Boolean + is + begin + -- To qualfy, the pragma must denote Refined_State - elsif Is_Suitable_Variable_Assignment (N) then - Process_Conditional_ABE_Variable_Assignment (N); + return + Nkind (N) = N_Pragma + and then Pragma_Name (N) = Name_Refined_State; + end Is_Suitable_SPARK_Refined_State_Pragma; + + ------------------------------------- + -- Is_Suitable_Variable_Assignment -- + ------------------------------------- + + function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is + N_Unit : Node_Id; + N_Unit_Id : Entity_Id; + Nam : Node_Id; + Var_Decl : Node_Id; + Var_Id : Entity_Id; + Var_Unit : Node_Id; + Var_Unit_Id : Entity_Id; - -- Variable references + begin + -- Nothing to do when the scenario is not an assignment - elsif Is_Suitable_Variable_Reference (N) then + if Nkind (N) /= N_Assignment_Statement then + return False; - -- In general, only variable references found within the main unit - -- are processed because the ALI information supplied to binde is for - -- the main unit only. However, to preserve the consistency of the - -- tree and ensure proper serialization of internal names, external - -- variable references also receive corresponding variable reference - -- markers (see Build_Varaible_Reference_Marker). Regardless of the - -- reason, external variable references must not be processed. + -- Nothing to do for internally-generated assignments because they + -- are assumed to be ABE safe. - if In_Main_Context (N) then - Process_Conditional_ABE_Variable_Reference (N); - end if; - end if; + elsif not Comes_From_Source (N) then + return False; - -- Remove the current scenario from the stack of active scenarios once - -- all ABE diagnostics and checks have been performed. + -- Assignments are ignored in GNAT mode on the assumption that + -- they are ABE-safe. This behaviour parallels that of the old + -- ABE mechanism. - Pop_Active_Scenario (N); - end Process_Conditional_ABE; + elsif GNAT_Mode then + return False; + end if; - -------------------------------------------- - -- Process_Guaranteed_ABE_Activation_Impl -- - -------------------------------------------- + Nam := Assignment_Target (N); - procedure Process_Guaranteed_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - State : Processing_Attributes) - is - pragma Unreferenced (State); + -- Sanitize the left hand side of the assignment - Check_OK : constant Boolean := - not Is_Ignored_Ghost_Entity (Obj_Id) - and then not Task_Attrs.Ghost_Mode_Ignore - and then Is_Elaboration_Checks_OK_Id (Obj_Id) - and then Task_Attrs.Elab_Checks_OK; - -- A run-time ABE check may be installed only when the object and the - -- task type have active elaboration checks, and both are not ignored - -- Ghost constructs. + if not Is_Entity_Name (Nam) then + return False; - begin - -- Nothing to do when the root scenario appears at the declaration - -- level and the task is in the same unit, but outside this context. - -- - -- task type Task_Typ; -- task declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- T : Task_Typ; - -- begin - -- <activation call> -- activation site - -- end; - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- task body Task_Typ is - -- ... - -- end Task_Typ; - -- - -- In the example above, the context of X is the declarative list of - -- Proc. The "elaboration" of X may reach the activation of T whose body - -- is defined outside of X's context. The task body is relevant only - -- when Proc is invoked, but this happens only in "normal" elaboration, - -- therefore the task body must not be considered if this is not the - -- case. + elsif No (Entity (Nam)) then + return False; + end if; - -- Performance note: parent traversal + Var_Id := Entity (Nam); - if Is_Up_Level_Target (Task_Attrs.Task_Decl) then - return; + -- Sanitize the variable - -- Nothing to do when the activation is ABE-safe - -- - -- generic - -- package Gen is - -- task type Task_Typ; - -- end Gen; - -- - -- package body Gen is - -- task body Task_Typ is - -- begin - -- ... - -- end Task_Typ; - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- package Nested is - -- package Inst is new Gen; - -- T : Inst.Task_Typ; - -- end Nested; -- safe activation - -- ... - - elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then - return; + if Var_Id = Any_Id then + return False; - -- An activation call leads to a guaranteed ABE when the activation - -- call and the task appear within the same context ignoring library - -- levels, and the body of the task has not been seen yet or appears - -- after the activation call. - -- - -- procedure Guaranteed_ABE is - -- task type Task_Typ; - -- - -- package Nested is - -- T : Task_Typ; - -- <activation call> -- guaranteed ABE - -- end Nested; - -- - -- task body Task_Typ is - -- ... - -- end Task_Typ; - -- ... + elsif Ekind (Var_Id) /= E_Variable then + return False; + end if; - -- Performance note: parent traversal + Var_Decl := Declaration_Node (Var_Id); - elsif Is_Guaranteed_ABE - (N => Call, - Target_Decl => Task_Attrs.Task_Decl, - Target_Body => Task_Attrs.Body_Decl) - then - if Call_Attrs.Elab_Warnings_OK then - Error_Msg_Sloc := Sloc (Call); - Error_Msg_N - ("??task & will be activated # before elaboration of its body", - Obj_Id); - Error_Msg_N ("\Program_Error will be raised at run time", Obj_Id); + if Nkind (Var_Decl) /= N_Object_Declaration then + return False; end if; - -- Mark the activation call as a guaranteed ABE + N_Unit_Id := Find_Top_Unit (N); + N_Unit := Unit_Declaration_Node (N_Unit_Id); - Set_Is_Known_Guaranteed_ABE (Call); + Var_Unit_Id := Find_Top_Unit (Var_Decl); + Var_Unit := Unit_Declaration_Node (Var_Unit_Id); - -- Install a run-time ABE failue because this activation call will - -- always result in an ABE. + -- To qualify, the assignment must meet the following prerequisites: - if Check_OK then - Install_ABE_Failure - (N => Call, - Ins_Nod => Call); - end if; - end if; - end Process_Guaranteed_ABE_Activation_Impl; + return + Comes_From_Source (Var_Id) - procedure Process_Guaranteed_ABE_Activation is - new Process_Activation_Generic (Process_Guaranteed_ABE_Activation_Impl); + -- The variable must be declared in the spec of compilation unit + -- U. - --------------------------------- - -- Process_Guaranteed_ABE_Call -- - --------------------------------- + and then Nkind (Var_Unit) = N_Package_Declaration + and then Find_Enclosing_Level (Var_Decl) = Library_Spec_Level - procedure Process_Guaranteed_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id) - is - Target_Attrs : Target_Attributes; + -- The assignment must occur in the body of compilation unit U - begin - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); + and then Nkind (N_Unit) = N_Package_Body + and then Present (Corresponding_Body (Var_Unit)) + and then Corresponding_Body (Var_Unit) = N_Unit_Id; + end Is_Suitable_Variable_Assignment; - -- Nothing to do when the root scenario appears at the declaration level - -- and the target is in the same unit, but outside this context. - -- - -- function B ...; -- target declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- function B ... is - -- ... - -- end B; - -- - -- In the example above, the context of X is the declarative region of - -- Proc. The "elaboration" of X may eventually reach B which is defined - -- outside of X's context. B is relevant only when Proc is invoked, but - -- this happens only by means of "normal" elaboration, therefore B must - -- not be considered if this is not the case. + ------------------------------------ + -- Is_Suitable_Variable_Reference -- + ------------------------------------ - -- Performance note: parent traversal + function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is + begin + -- Expanded names and identifiers are intentionally ignored because + -- they be folded, optimized away, etc. Variable references markers + -- play the role of variable references and provide a uniform + -- foundation for ABE processing. - if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then - return; + return Nkind (N) = N_Variable_Reference_Marker; + end Is_Suitable_Variable_Reference; - -- Nothing to do when the call is ABE-safe - -- - -- generic - -- function Gen ...; - -- - -- function Gen ... is - -- begin - -- ... - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- function Inst is new Gen; - -- X : ... := Inst; -- safe call - -- ... + ------------------- + -- Is_Task_Entry -- + ------------------- - elsif Is_Safe_Call (Call, Target_Attrs) then - return; + function Is_Task_Entry (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an entry defined in a task type - -- A call leads to a guaranteed ABE when the call and the target appear - -- within the same context ignoring library levels, and the body of the - -- target has not been seen yet or appears after the call. - -- - -- procedure Guaranteed_ABE is - -- function Func ...; - -- - -- package Nested is - -- Obj : ... := Func; -- guaranteed ABE - -- end Nested; - -- - -- function Func ... is - -- ... - -- end Func; - -- ... + return + Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); + end Is_Task_Entry; - -- Performance note: parent traversal + ------------------------ + -- Is_Up_Level_Target -- + ------------------------ - elsif Is_Guaranteed_ABE - (N => Call, - Target_Decl => Target_Attrs.Spec_Decl, - Target_Body => Target_Attrs.Body_Decl) - then - if Call_Attrs.Elab_Warnings_OK then - Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id); - Error_Msg_N ("\Program_Error will be raised at run time", Call); - end if; + function Is_Up_Level_Target + (Targ_Decl : Node_Id; + In_State : Processing_In_State) return Boolean + is + Root : constant Node_Id := Root_Scenario; + Root_Rep : constant Scenario_Rep_Id := + Scenario_Representation_Of (Root, In_State); - -- Mark the call as a guarnateed ABE + begin + -- The root appears within the declaratons of a block statement, + -- entry body, subprogram body, or task body ignoring enclosing + -- packages. The root is always within the main unit. - Set_Is_Known_Guaranteed_ABE (Call); + if not In_State.Suppress_Up_Level_Targets + and then Level (Root_Rep) = Declaration_Level + then + -- The target is within the main unit. It acts as an up-level + -- target when it appears within a context which encloses the + -- root. + -- + -- package body Main_Unit is + -- function Func ...; -- target + -- + -- procedure Proc is + -- X : ... := Func; -- root scenario - -- Install a run-time ABE failure because the call will always result - -- in an ABE. The failure is installed when both the call and target - -- have enabled elaboration checks, and both are not ignored Ghost - -- constructs. + if In_Extended_Main_Code_Unit (Targ_Decl) then + return not In_Same_Context (Root, Targ_Decl, Nested_OK => True); - if Call_Attrs.Elab_Checks_OK - and then Target_Attrs.Elab_Checks_OK - and then not Call_Attrs.Ghost_Mode_Ignore - and then not Target_Attrs.Ghost_Mode_Ignore - then - Install_ABE_Failure - (N => Call, - Ins_Nod => Call); + -- Otherwise the target is external to the main unit which makes + -- it an up-level target. + + else + return True; + end if; end if; - end if; - end Process_Guaranteed_ABE_Call; - ------------------------------------------ - -- Process_Guaranteed_ABE_Instantiation -- - ------------------------------------------ + return False; + end Is_Up_Level_Target; + end Semantics; - procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id) is - Gen_Attrs : Target_Attributes; - Gen_Id : Entity_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; + --------------------- + -- SPARK_Processor -- + --------------------- - begin - Extract_Instantiation_Attributes - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + package body SPARK_Processor is - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + ----------------------- + -- Local subprograms -- + ----------------------- - -- Nothing to do when the root scenario appears at the declaration level - -- and the generic is in the same unit, but outside this context. - -- - -- generic - -- procedure Gen is ...; -- generic declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- procedure I is new Gen; -- instantiation site - -- ... - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- procedure Gen is - -- ... - -- end Gen; - -- - -- In the example above, the context of X is the declarative region of - -- Proc. The "elaboration" of X may eventually reach Gen which appears - -- outside of X's context. Gen is relevant only when Proc is invoked, - -- but this happens only by means of "normal" elaboration, therefore - -- Gen must not be considered if this is not the case. + procedure Process_SPARK_Derived_Type + (Typ_Decl : Node_Id; + Typ_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_SPARK_Derived_Type); + -- Verify that the freeze node of a derived type denoted by declaration + -- Typ_Decl is within the early call region of each overriding primitive + -- body that belongs to the derived type (SPARK RM 7.7(8)). Typ_Rep is + -- the representation of the type. In_State denotes the current state of + -- the Processing phase. + + procedure Process_SPARK_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_SPARK_Instantiation); + -- Verify that instanciation Inst does not precede the generic body it + -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the + -- instantiation. In_State is the current state of the Processing phase. + + procedure Process_SPARK_Refined_State_Pragma + (Prag : Node_Id; + Prag_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_SPARK_Refined_State_Pragma); + -- Verify that each constituent of Refined_State pragma Prag which + -- belongs to abstract state mentioned in pragma Initializes has prior + -- elaboration with respect to the main unit (SPARK RM 7.7.1(7)). + -- Prag_Rep is the representation of the pragma. In_State denotes the + -- current state of the Processing phase. + + procedure Process_SPARK_Scenario + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_SPARK_Scenario); + -- Top-level dispatcher for verifying SPARK scenarios which are not + -- always executable during elaboration but still need elaboration- + -- related checks. In_State is the current state of the Processing + -- phase. + + --------------------------------- + -- Check_SPARK_Model_In_Effect -- + --------------------------------- + + SPARK_Model_Warning_Posted : Boolean := False; + -- This flag prevents the same SPARK model-related warning from being + -- emitted multiple times. + + procedure Check_SPARK_Model_In_Effect is + Spec_Id : constant Entity_Id := + Unique_Entity (Cunit_Entity (Main_Unit)); - -- Performance note: parent traversal + begin + -- Do not emit the warning multiple times as this creates useless + -- noise. - if Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then - return; + if SPARK_Model_Warning_Posted then + null; - -- Nothing to do when the instantiation is ABE-safe - -- - -- generic - -- package Gen is - -- ... - -- end Gen; - -- - -- package body Gen is - -- ... - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- package Inst is new Gen (ABE); -- safe instantiation - -- ... + -- SPARK rule verification requires the "strict" static model - elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then - return; + elsif Static_Elaboration_Checks + and not Relaxed_Elaboration_Checks + then + null; - -- An instantiation leads to a guaranteed ABE when the instantiation and - -- the generic appear within the same context ignoring library levels, - -- and the body of the generic has not been seen yet or appears after - -- the instantiation. - -- - -- procedure Guaranteed_ABE is - -- generic - -- procedure Gen; - -- - -- package Nested is - -- procedure Inst is new Gen; -- guaranteed ABE - -- end Nested; - -- - -- procedure Gen is - -- ... - -- end Gen; - -- ... + -- Any other combination of models does not guarantee the absence of + -- ABE problems for SPARK rule verification purposes. Note that there + -- is no need to check for the presence of the legacy ABE mechanism + -- because the legacy code has its own dedicated processing for SPARK + -- rules. - -- Performance note: parent traversal + else + SPARK_Model_Warning_Posted := True; - elsif Is_Guaranteed_ABE - (N => Inst, - Target_Decl => Gen_Attrs.Spec_Decl, - Target_Body => Gen_Attrs.Body_Decl) - then - if Inst_Attrs.Elab_Warnings_OK then - Error_Msg_NE - ("??cannot instantiate & before body seen", Inst, Gen_Id); - Error_Msg_N ("\Program_Error will be raised at run time", Inst); + Error_Msg_N + ("??SPARK elaboration checks require static elaboration model", + Spec_Id); + + if Dynamic_Elaboration_Checks then + Error_Msg_N + ("\dynamic elaboration model is in effect", Spec_Id); + + else + pragma Assert (Relaxed_Elaboration_Checks); + Error_Msg_N + ("\relaxed elaboration model is in effect", Spec_Id); + end if; end if; + end Check_SPARK_Model_In_Effect; - -- Mark the instantiation as a guarantee ABE. This automatically - -- suppresses the instantiation of the generic body. + --------------------------- + -- Check_SPARK_Scenarios -- + --------------------------- - Set_Is_Known_Guaranteed_ABE (Inst); + procedure Check_SPARK_Scenarios is + Iter : NE_Set.Iterator; + N : Node_Id; - -- Install a run-time ABE failure because the instantiation will - -- always result in an ABE. The failure is installed when both the - -- instance and the generic have enabled elaboration checks, and both - -- are not ignored Ghost constructs. + begin + Iter := Iterate_SPARK_Scenarios; + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - if Inst_Attrs.Elab_Checks_OK - and then Gen_Attrs.Elab_Checks_OK - and then not Inst_Attrs.Ghost_Mode_Ignore - and then not Gen_Attrs.Ghost_Mode_Ignore - then - Install_ABE_Failure - (N => Inst, - Ins_Nod => Exp_Inst); - end if; - end if; - end Process_Guaranteed_ABE_Instantiation; + Process_SPARK_Scenario + (N => N, + In_State => SPARK_State); + end loop; + end Check_SPARK_Scenarios; - ---------------------------- - -- Process_Guaranteed_ABE -- - ---------------------------- + -------------------------------- + -- Process_SPARK_Derived_Type -- + -------------------------------- - -- NOTE: The body of this routine is intentionally out of order because it - -- invokes an instantiated subprogram (Process_Guaranteed_ABE_Activation). - -- Placing the body in alphabetical order will result in a guaranteed ABE. + procedure Process_SPARK_Derived_Type + (Typ_Decl : Node_Id; + Typ_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (In_State); + + Typ : constant Entity_Id := Target (Typ_Rep); + + Stop_Check : exception; + -- This exception is raised when the freeze node violates the + -- placement rules. + + procedure Check_Overriding_Primitive + (Prim : Entity_Id; + FNode : Node_Id); + pragma Inline (Check_Overriding_Primitive); + -- Verify that freeze node FNode is within the early call region of + -- overriding primitive Prim's body. + + function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; + pragma Inline (Freeze_Node_Location); + -- Return a more accurate source location associated with freeze node + -- FNode. + + function Precedes_Source_Construct (N : Node_Id) return Boolean; + pragma Inline (Precedes_Source_Construct); + -- Determine whether arbitrary node N appears prior to some source + -- construct. + + procedure Suggest_Elaborate_Body + (N : Node_Id; + Body_Decl : Node_Id; + Error_Nod : Node_Id); + pragma Inline (Suggest_Elaborate_Body); + -- Suggest the use of pragma Elaborate_Body when the pragma will + -- allow for node N to appear within the early call region of + -- subprogram body Body_Decl. The suggestion is attached to + -- Error_Nod as a continuation error. + + -------------------------------- + -- Check_Overriding_Primitive -- + -------------------------------- + + procedure Check_Overriding_Primitive + (Prim : Entity_Id; + FNode : Node_Id) + is + Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); + Body_Decl : Node_Id; + Body_Id : Entity_Id; + Region : Node_Id; - procedure Process_Guaranteed_ABE (N : Node_Id) is - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; + begin + -- Nothing to do for predefined primitives because they are + -- artifacts of tagged type expansion and cannot override source + -- primitives. - begin - -- Add the current scenario to the stack of active scenarios + if Is_Predefined_Dispatching_Operation (Prim) then + return; + end if; - Push_Active_Scenario (N); + Body_Id := Corresponding_Body (Prim_Decl); - -- Only calls, instantiations, and task activations may result in a - -- guaranteed ABE. + -- Nothing to do when the primitive does not have a corresponding + -- body. This can happen when the unit with the bodies is not the + -- main unit subjected to ABE checks. - if Is_Suitable_Call (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); + if No (Body_Id) then + return; - if Is_Activation_Proc (Target_Id) then - Process_Guaranteed_ABE_Activation - (Call => N, - Call_Attrs => Call_Attrs, - State => Initial_State); + -- The primitive overrides a parent or progenitor primitive - else - Process_Guaranteed_ABE_Call - (Call => N, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id); - end if; + elsif Present (Overridden_Operation (Prim)) then - elsif Is_Suitable_Instantiation (N) then - Process_Guaranteed_ABE_Instantiation (N); - end if; + -- Nothing to do when overriding an interface primitive happens + -- by inheriting a non-interface primitive as the check would + -- be done on the parent primitive. - -- Remove the current scenario from the stack of active scenarios once - -- all ABE diagnostics and checks have been performed. + if Present (Alias (Prim)) then + return; + end if; - Pop_Active_Scenario (N); - end Process_Guaranteed_ABE; + -- Nothing to do when the primitive is not overriding. The body of + -- such a primitive cannot be targeted by a dispatching call which + -- is executable during elaboration, and cannot cause an ABE. - -------------------------- - -- Push_Active_Scenario -- - -------------------------- + else + return; + end if; - procedure Push_Active_Scenario (N : Node_Id) is - begin - Scenario_Stack.Append (N); - end Push_Active_Scenario; + Body_Decl := Unit_Declaration_Node (Body_Id); + Region := Find_Early_Call_Region (Body_Decl); - --------------------------------- - -- Record_Elaboration_Scenario -- - --------------------------------- + -- The freeze node appears prior to the early call region of the + -- primitive body. - procedure Record_Elaboration_Scenario (N : Node_Id) is - Level : Enclosing_Level_Kind; + -- IMPORTANT: This check must always be performed even when + -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not + -- specified because the static model cannot guarantee the absence + -- of ABEs in the presence of dispatching calls. - Any_Level_OK : Boolean; - -- This flag is set when a particular scenario is allowed to appear at - -- any level. + if Earlier_In_Extended_Unit (FNode, Region) then + Error_Msg_Node_2 := Prim; + Error_Msg_NE + ("first freezing point of type & must appear within early " + & "call region of primitive body & (SPARK RM 7.7(8))", + Typ_Decl, Typ); - Declaration_Level_OK : Boolean; - -- This flag is set when a particular scenario is allowed to appear at - -- the declaration level. + Error_Msg_Sloc := Sloc (Region); + Error_Msg_N ("\region starts #", Typ_Decl); - Library_Level_OK : Boolean; - -- This flag is set when a particular scenario is allowed to appear at - -- the library level. + Error_Msg_Sloc := Sloc (Body_Decl); + Error_Msg_N ("\region ends #", Typ_Decl); - begin - -- Assume that the scenario cannot appear on any level + Error_Msg_Sloc := Freeze_Node_Location (FNode); + Error_Msg_N ("\first freezing point #", Typ_Decl); - Any_Level_OK := False; - Declaration_Level_OK := False; - Library_Level_OK := False; + -- If applicable, suggest the use of pragma Elaborate_Body in + -- the associated package spec. - -- Nothing to do when switch -gnatH (legacy elaboration checking mode - -- enabled) is in effect because the legacy ABE mechanism does not need - -- to carry out this action. + Suggest_Elaborate_Body + (N => FNode, + Body_Decl => Body_Decl, + Error_Nod => Typ_Decl); - if Legacy_Elaboration_Checks then - return; + raise Stop_Check; + end if; + end Check_Overriding_Primitive; - -- Nothing to do for ASIS because ABE checks and diagnostics are not - -- performed in this mode. + -------------------------- + -- Freeze_Node_Location -- + -------------------------- - elsif ASIS_Mode then - return; + function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is + Context : constant Node_Id := Parent (FNode); + Loc : constant Source_Ptr := Sloc (FNode); - -- Nothing to do when the scenario is being preanalyzed + Prv_Decls : List_Id; + Vis_Decls : List_Id; - elsif Preanalysis_Active then - return; - end if; + begin + -- In general, the source location of the freeze node is as close + -- as possible to the real freeze point, except when the freeze + -- node is at the "bottom" of a package spec. - -- Ensure that a library-level call does not appear in a preelaborated - -- unit. The check must come before ignoring scenarios within external - -- units or inside generics because calls in those context must also be - -- verified. + if Nkind (Context) = N_Package_Specification then + Prv_Decls := Private_Declarations (Context); + Vis_Decls := Visible_Declarations (Context); - if Is_Suitable_Call (N) then - Check_Preelaborated_Call (N); - end if; + -- The freeze node appears in the private declarations of the + -- package. - -- Nothing to do when the scenario does not appear within the main unit + if Present (Prv_Decls) + and then List_Containing (FNode) = Prv_Decls + then + null; - if not In_Main_Context (N) then - return; + -- The freeze node appears in the visible declarations of the + -- package and there are no private declarations. - -- Scenarios within a generic unit are never considered because generics - -- cannot be elaborated. + elsif Present (Vis_Decls) + and then List_Containing (FNode) = Vis_Decls + and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) + then + null; - elsif Inside_A_Generic then - return; + -- Otherwise the freeze node is not in the "last" declarative + -- list of the package. Use the existing source location of the + -- freeze node. - -- Scenarios which do not fall in one of the elaboration categories - -- listed below are not considered. The categories are: + else + return Loc; + end if; - -- 'Access for entries, operators, and subprograms - -- Assignments to variables - -- Calls (includes task activation) - -- Derived types - -- Instantiations - -- Pragma Refined_State - -- Reads of variables + -- The freeze node appears at the "bottom" of the package when + -- it is in the "last" declarative list and is either the last + -- in the list or is followed by internal constructs only. In + -- that case the more appropriate source location is that of + -- the package end label. - elsif Is_Suitable_Access (N) then - Library_Level_OK := True; + if not Precedes_Source_Construct (FNode) then + return Sloc (End_Label (Context)); + end if; + end if; - -- Signal any enclosing local exception handlers that the 'Access may - -- raise Program_Error due to a failed ABE check when switch -gnatd.o - -- (conservative elaboration order for indirect calls) is in effect. - -- Marking the exception handlers ensures proper expansion by both - -- the front and back end restriction when No_Exception_Propagation - -- is in effect. + return Loc; + end Freeze_Node_Location; - if Debug_Flag_Dot_O then - Possible_Local_Raise (N, Standard_Program_Error); - end if; + ------------------------------- + -- Precedes_Source_Construct -- + ------------------------------- - elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then - Declaration_Level_OK := True; - Library_Level_OK := True; + function Precedes_Source_Construct (N : Node_Id) return Boolean is + Decl : Node_Id; - -- Signal any enclosing local exception handlers that the call or - -- instantiation may raise Program_Error due to a failed ABE check. - -- Marking the exception handlers ensures proper expansion by both - -- the front and back end restriction when No_Exception_Propagation - -- is in effect. + begin + Decl := Next (N); + while Present (Decl) loop + if Comes_From_Source (Decl) then + return True; - Possible_Local_Raise (N, Standard_Program_Error); + -- A generated body for a source expression function is treated + -- as a source construct. - elsif Is_Suitable_SPARK_Derived_Type (N) then - Any_Level_OK := True; + elsif Nkind (Decl) = N_Subprogram_Body + and then Was_Expression_Function (Decl) + and then Comes_From_Source (Original_Node (Decl)) + then + return True; + end if; - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Library_Level_OK := True; + Next (Decl); + end loop; - elsif Is_Suitable_Variable_Assignment (N) - or else Is_Suitable_Variable_Reference (N) - then - Library_Level_OK := True; + return False; + end Precedes_Source_Construct; - -- Otherwise the input does not denote a suitable scenario + ---------------------------- + -- Suggest_Elaborate_Body -- + ---------------------------- - else - return; - end if; + procedure Suggest_Elaborate_Body + (N : Node_Id; + Body_Decl : Node_Id; + Error_Nod : Node_Id) + is + Unit_Id : constant Node_Id := Unit (Cunit (Main_Unit)); + Region : Node_Id; - -- The static model imposes additional restrictions on the placement of - -- scenarios. In contrast, the dynamic model assumes that every scenario - -- will be elaborated or invoked at some point. + begin + -- The suggestion applies only when the subprogram body resides in + -- a compilation package body, and a pragma Elaborate_Body would + -- allow for the node to appear in the early call region of the + -- subprogram body. This implies that all code from the subprogram + -- body up to the node is preelaborable. - if Static_Elaboration_Checks then + if Nkind (Unit_Id) = N_Package_Body then - -- Certain scenarios are allowed to appear at any level. This check - -- is performed here in order to save on a parent traversal. + -- Find the start of the early call region again assuming that + -- the package spec has pragma Elaborate_Body. Note that the + -- internal data structures are intentionally not updated + -- because this is a speculative search. - if Any_Level_OK then - null; + Region := + Find_Early_Call_Region + (Body_Decl => Body_Decl, + Assume_Elab_Body => True, + Skip_Memoization => True); - -- Otherwise the scenario must appear at a specific level + -- If the node appears within the early call region, assuming + -- that the package spec carries pragma Elaborate_Body, then it + -- is safe to suggest the pragma. - else - -- Performance note: parent traversal + if Earlier_In_Extended_Unit (Region, N) then + Error_Msg_Name_1 := Name_Elaborate_Body; + Error_Msg_NE + ("\consider adding pragma % in spec of unit &", + Error_Nod, Defining_Entity (Unit_Id)); + end if; + end if; + end Suggest_Elaborate_Body; - Level := Find_Enclosing_Level (N); + -- Local variables - -- Declaration-level scenario + FNode : constant Node_Id := Freeze_Node (Typ); + Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); - if Declaration_Level_OK and then Level = Declaration_Level then - null; + Prim_Elmt : Elmt_Id; - -- Library-level or instantiation scenario + -- Start of processing for Process_SPARK_Derived_Type - elsif Library_Level_OK - and then Level in Library_Or_Instantiation_Level - then - null; + begin + -- A type should have its freeze node set by the time SPARK scenarios + -- are being verified. - -- Otherwise the scenario does not appear at the proper level and - -- cannot possibly act as a top-level scenario. + pragma Assert (Present (FNode)); - else - return; - end if; + -- Verify that the freeze node of the derived type is within the + -- early call region of each overriding primitive body + -- (SPARK RM 7.7(8)). + + if Present (Prims) then + Prim_Elmt := First_Elmt (Prims); + while Present (Prim_Elmt) loop + Check_Overriding_Primitive + (Prim => Node (Prim_Elmt), + FNode => FNode); + + Next_Elmt (Prim_Elmt); + end loop; end if; - end if; - -- Derived types subject to SPARK_Mode On require elaboration-related - -- checks even though the type may not be declared within elaboration - -- code. The types are recorded in a separate table which is examined - -- during the Processing phase. Note that the checks must be delayed - -- because the bodies of overriding primitives are not available yet. + exception + when Stop_Check => + null; + end Process_SPARK_Derived_Type; - if Is_Suitable_SPARK_Derived_Type (N) then - Record_SPARK_Elaboration_Scenario (N); + --------------------------------- + -- Process_SPARK_Instantiation -- + --------------------------------- - -- Nothing left to do for derived types + procedure Process_SPARK_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + Gen_Id : constant Entity_Id := Target (Inst_Rep); + Gen_Rep : constant Target_Rep_Id := + Target_Representation_Of (Gen_Id, In_State); + Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); - return; + begin + -- The instantiation and the generic body are both in the main unit - -- Instantiations of generics both subject to SPARK_Mode On require - -- elaboration-related checks even though the instantiations may not - -- appear within elaboration code. The instantiations are recored in - -- a separate table which is examined during the Procesing phase. Note - -- that the checks must be delayed because it is not known yet whether - -- the generic unit has a body or not. + if Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) - -- IMPORTANT: A SPARK instantiation is also a normal instantiation which - -- is subject to common conditional and guaranteed ABE checks. + -- If the instantiation appears prior to the generic body, then the + -- instantiation is illegal (SPARK RM 7.7(6)). - elsif Is_Suitable_SPARK_Instantiation (N) then - Record_SPARK_Elaboration_Scenario (N); + -- IMPORTANT: This check must always be performed even when + -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not + -- specified because the rule prevents use-before-declaration of + -- objects that may precede the generic body. - -- External constituents that refine abstract states which appear in - -- pragma Initializes require elaboration-related checks even though - -- a Refined_State pragma lacks any elaboration semantic. + and then Earlier_In_Extended_Unit (Inst, Body_Decl) + then + Error_Msg_NE + ("cannot instantiate & before body seen", Inst, Gen_Id); + end if; + end Process_SPARK_Instantiation; - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Record_SPARK_Elaboration_Scenario (N); + ---------------------------- + -- Process_SPARK_Scenario -- + ---------------------------- - -- Nothing left to do for pragma Refined_State + procedure Process_SPARK_Scenario + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); - return; - end if; + begin + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - -- Perform early detection of guaranteed ABEs in order to suppress the - -- instantiation of generic bodies as gigi cannot handle certain types - -- of premature instantiations. + Check_SPARK_Model_In_Effect; - Process_Guaranteed_ABE (N); + -- Add the current scenario to the stack of active scenarios - -- At this point all checks have been performed. Record the scenario for - -- later processing by the ABE phase. + Push_Active_Scenario (Scen); - Top_Level_Scenarios.Append (N); - Set_Is_Recorded_Top_Level_Scenario (N); - end Record_Elaboration_Scenario; + -- Derived type - --------------------------------------- - -- Record_SPARK_Elaboration_Scenario -- - --------------------------------------- + if Is_Suitable_SPARK_Derived_Type (Scen) then + Process_SPARK_Derived_Type + (Typ_Decl => Scen, + Typ_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - procedure Record_SPARK_Elaboration_Scenario (N : Node_Id) is - begin - SPARK_Scenarios.Append (N); - Set_Is_Recorded_SPARK_Scenario (N); - end Record_SPARK_Elaboration_Scenario; + -- Instantiation - ----------------------------------- - -- Recorded_SPARK_Scenarios_Hash -- - ----------------------------------- + elsif Is_Suitable_SPARK_Instantiation (Scen) then + Process_SPARK_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - function Recorded_SPARK_Scenarios_Hash - (Key : Node_Id) return Recorded_SPARK_Scenarios_Index - is - begin - return - Recorded_SPARK_Scenarios_Index (Key mod Recorded_SPARK_Scenarios_Max); - end Recorded_SPARK_Scenarios_Hash; + -- Refined_State pragma - --------------------------------------- - -- Recorded_Top_Level_Scenarios_Hash -- - --------------------------------------- + elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then + Process_SPARK_Refined_State_Pragma + (Prag => Scen, + Prag_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); + end if; - function Recorded_Top_Level_Scenarios_Hash - (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index - is - begin - return - Recorded_Top_Level_Scenarios_Index - (Key mod Recorded_Top_Level_Scenarios_Max); - end Recorded_Top_Level_Scenarios_Hash; + -- Remove the current scenario from the stack of active scenarios + -- once all ABE diagnostics and checks have been performed. - -------------------------- - -- Reset_Visited_Bodies -- - -------------------------- + Pop_Active_Scenario (Scen); + end Process_SPARK_Scenario; - procedure Reset_Visited_Bodies is - begin - if Visited_Bodies_In_Use then - Visited_Bodies_In_Use := False; - Visited_Bodies.Reset; - end if; - end Reset_Visited_Bodies; + ---------------------------------------- + -- Process_SPARK_Refined_State_Pragma -- + ---------------------------------------- - ------------------- - -- Root_Scenario -- - ------------------- + procedure Process_SPARK_Refined_State_Pragma + (Prag : Node_Id; + Prag_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Prag_Rep); - function Root_Scenario return Node_Id is - package Stack renames Scenario_Stack; + procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); + pragma Inline (Check_SPARK_Constituent); + -- Ensure that a single constituent Constit_Id is elaborated prior to + -- the main unit. - begin - -- Ensure that the scenario stack has at least one active scenario in - -- it. The one at the bottom (index First) is the root scenario. + procedure Check_SPARK_Constituents (Constits : Elist_Id); + pragma Inline (Check_SPARK_Constituents); + -- Ensure that all constituents found in list Constits are elaborated + -- prior to the main unit. - pragma Assert (Stack.Last >= Stack.First); - return Stack.Table (Stack.First); - end Root_Scenario; + procedure Check_SPARK_Initialized_State (State : Node_Id); + pragma Inline (Check_SPARK_Initialized_State); + -- Ensure that the constituents of single abstract state State are + -- elaborated prior to the main unit. - --------------------------- - -- Set_Early_Call_Region -- - --------------------------- + procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); + pragma Inline (Check_SPARK_Initialized_States); + -- Ensure that the constituents of all abstract states which appear + -- in the Initializes pragma of package Pack_Id are elaborated prior + -- to the main unit. - procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is - begin - pragma Assert (Ekind_In (Body_Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure, - E_Subprogram_Body)); + ----------------------------- + -- Check_SPARK_Constituent -- + ----------------------------- - Early_Call_Regions_In_Use := True; - Early_Call_Regions.Set (Body_Id, Start); - end Set_Early_Call_Region; + procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is + SM_Prag : Node_Id; - ---------------------------- - -- Set_Elaboration_Status -- - ---------------------------- + begin + -- Nothing to do for "null" constituents - procedure Set_Elaboration_Status - (Unit_Id : Entity_Id; - Val : Elaboration_Attributes) - is - begin - Elaboration_Statuses_In_Use := True; - Elaboration_Statuses.Set (Unit_Id, Val); - end Set_Elaboration_Status; + if Nkind (Constit_Id) = N_Null then + return; - ------------------------------------ - -- Set_Is_Recorded_SPARK_Scenario -- - ------------------------------------ + -- Nothing to do for illegal constituents - procedure Set_Is_Recorded_SPARK_Scenario - (N : Node_Id; - Val : Boolean := True) - is - begin - Recorded_SPARK_Scenarios_In_Use := True; - Recorded_SPARK_Scenarios.Set (N, Val); - end Set_Is_Recorded_SPARK_Scenario; + elsif Error_Posted (Constit_Id) then + return; + end if; - ---------------------------------------- - -- Set_Is_Recorded_Top_Level_Scenario -- - ---------------------------------------- + SM_Prag := SPARK_Pragma (Constit_Id); - procedure Set_Is_Recorded_Top_Level_Scenario - (N : Node_Id; - Val : Boolean := True) - is - begin - Recorded_Top_Level_Scenarios_In_Use := True; - Recorded_Top_Level_Scenarios.Set (N, Val); - end Set_Is_Recorded_Top_Level_Scenario; + -- The check applies only when the constituent is subject to + -- pragma SPARK_Mode On. - ------------------------- - -- Set_Is_Visited_Body -- - ------------------------- + if Present (SM_Prag) + and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On + then + -- An external constituent of an abstract state which appears + -- in the Initializes pragma of a package spec imposes an + -- Elaborate requirement on the context of the main unit. + -- Determine whether the context has a pragma strong enough to + -- meet the requirement. + + -- IMPORTANT: This check is performed only when -gnatd.v + -- (enforce SPARK elaboration rules in SPARK code) is in effect + -- because the static model can ensure the prior elaboration of + -- the unit which contains a constituent by installing implicit + -- Elaborate pragma. + + if Debug_Flag_Dot_V then + Meet_Elaboration_Requirement + (N => Prag, + Targ_Id => Constit_Id, + Req_Nam => Name_Elaborate, + In_State => In_State); + + -- Otherwise ensure that the unit with the external constituent + -- is elaborated prior to the main unit. - procedure Set_Is_Visited_Body (Subp_Body : Node_Id) is - begin - Visited_Bodies_In_Use := True; - Visited_Bodies.Set (Subp_Body, True); - end Set_Is_Visited_Body; + else + Ensure_Prior_Elaboration + (N => Prag, + Unit_Id => Find_Top_Unit (Constit_Id), + Prag_Nam => Name_Elaborate, + In_State => In_State); + end if; + end if; + end Check_SPARK_Constituent; - ------------------------------- - -- Static_Elaboration_Checks -- - ------------------------------- + ------------------------------ + -- Check_SPARK_Constituents -- + ------------------------------ - function Static_Elaboration_Checks return Boolean is - begin - return not Dynamic_Elaboration_Checks; - end Static_Elaboration_Checks; + procedure Check_SPARK_Constituents (Constits : Elist_Id) is + Constit_Elmt : Elmt_Id; - ------------------- - -- Traverse_Body -- - ------------------- + begin + if Present (Constits) then + Constit_Elmt := First_Elmt (Constits); + while Present (Constit_Elmt) loop + Check_SPARK_Constituent (Node (Constit_Elmt)); + Next_Elmt (Constit_Elmt); + end loop; + end if; + end Check_SPARK_Constituents; - procedure Traverse_Body (N : Node_Id; State : Processing_Attributes) is - procedure Find_And_Process_Nested_Scenarios; - pragma Inline (Find_And_Process_Nested_Scenarios); - -- Examine the declarations and statements of subprogram body N for - -- suitable scenarios. + ----------------------------------- + -- Check_SPARK_Initialized_State -- + ----------------------------------- - --------------------------------------- - -- Find_And_Process_Nested_Scenarios -- - --------------------------------------- + procedure Check_SPARK_Initialized_State (State : Node_Id) is + SM_Prag : Node_Id; + State_Id : Entity_Id; - procedure Find_And_Process_Nested_Scenarios is - function Is_Potential_Scenario - (Nod : Node_Id) return Traverse_Result; - -- Determine whether arbitrary node Nod denotes a suitable scenario. - -- If it does, save it in the Nested_Scenarios list of the subprogram - -- body, and process it. + begin + -- Nothing to do for "null" initialization items - procedure Traverse_List (List : List_Id); - pragma Inline (Traverse_List); - -- Invoke Traverse_Potential_Scenarios on each node in list List + if Nkind (State) = N_Null then + return; - procedure Traverse_Potential_Scenarios is - new Traverse_Proc (Is_Potential_Scenario); + -- Nothing to do for illegal states - --------------------------- - -- Is_Potential_Scenario -- - --------------------------- + elsif Error_Posted (State) then + return; + end if; - function Is_Potential_Scenario - (Nod : Node_Id) return Traverse_Result - is - begin - -- Special cases + State_Id := Entity_Of (State); - -- Skip constructs which do not have elaboration of their own and - -- need to be elaborated by other means such as invocation, task - -- activation, etc. + -- Sanitize the state - if Is_Non_Library_Level_Encapsulator (Nod) then - return Skip; + if No (State_Id) then + return; - -- Terminate the traversal of a task body when encountering an - -- accept or select statement, and - -- - -- * Entry calls during elaboration are not allowed. In this - -- case the accept or select statement will cause the task - -- to block at elaboration time because there are no entry - -- calls to unblock it. - -- - -- or - -- - -- * Switch -gnatd_a (stop elaboration checks on accept or - -- select statement) is in effect. + elsif Error_Posted (State_Id) then + return; - elsif (Debug_Flag_Underscore_A - or else Restriction_Active - (No_Entry_Calls_In_Elaboration_Code)) - and then Nkind_In (Original_Node (Nod), N_Accept_Statement, - N_Selective_Accept) - then - return Abandon; + elsif Ekind (State_Id) /= E_Abstract_State then + return; + end if; - -- Terminate the traversal of a task body when encountering a - -- suspension call, and - -- - -- * Entry calls during elaboration are not allowed. In this - -- case the suspension call emulates an entry call and will - -- cause the task to block at elaboration time. - -- - -- or - -- - -- * Switch -gnatd_s (stop elaboration checks on synchronous - -- suspension) is in effect. - -- - -- Note that the guard should not be checking the state of flag - -- Within_Task_Body because only suspension calls which appear - -- immediately within the statements of the task are supported. - -- Flag Within_Task_Body carries over to deeper levels of the - -- traversal. + -- The check is performed only when the abstract state is subject + -- to SPARK_Mode On. - elsif (Debug_Flag_Underscore_S - or else Restriction_Active - (No_Entry_Calls_In_Elaboration_Code)) - and then Is_Synchronous_Suspension_Call (Nod) - and then In_Task_Body (Nod) + SM_Prag := SPARK_Pragma (State_Id); + + if Present (SM_Prag) + and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On then - return Abandon; + Check_SPARK_Constituents (Refinement_Constituents (State_Id)); + end if; + end Check_SPARK_Initialized_State; - -- Certain nodes carry semantic lists which act as repositories - -- until expansion transforms the node and relocates the contents. - -- Examine these lists in case expansion is disabled. + ------------------------------------ + -- Check_SPARK_Initialized_States -- + ------------------------------------ - elsif Nkind_In (Nod, N_And_Then, N_Or_Else) then - Traverse_List (Actions (Nod)); + procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is + Init_Prag : constant Node_Id := + Get_Pragma (Pack_Id, Pragma_Initializes); - elsif Nkind_In (Nod, N_Elsif_Part, N_Iteration_Scheme) then - Traverse_List (Condition_Actions (Nod)); + Init : Node_Id; + Inits : Node_Id; - elsif Nkind (Nod) = N_If_Expression then - Traverse_List (Then_Actions (Nod)); - Traverse_List (Else_Actions (Nod)); + begin + if Present (Init_Prag) then + Inits := Expression (Get_Argument (Init_Prag, Pack_Id)); - elsif Nkind_In (Nod, N_Component_Association, - N_Iterated_Component_Association) - then - Traverse_List (Loop_Actions (Nod)); + -- Avoid processing a "null" initialization list. The only + -- other alternative is an aggregate. - -- General case + if Nkind (Inits) = N_Aggregate then - elsif Is_Suitable_Scenario (Nod) then - Process_Conditional_ABE - (N => Nod, - State => State); - end if; + -- The initialization items appear in list form: + -- + -- (state1, state2) - return OK; - end Is_Potential_Scenario; + if Present (Expressions (Inits)) then + Init := First (Expressions (Inits)); + while Present (Init) loop + Check_SPARK_Initialized_State (Init); + Next (Init); + end loop; + end if; - ------------------- - -- Traverse_List -- - ------------------- + -- The initialization items appear in associated form: + -- + -- (state1 => item1, + -- state2 => (item2, item3)) + + if Present (Component_Associations (Inits)) then + Init := First (Component_Associations (Inits)); + while Present (Init) loop + Check_SPARK_Initialized_State (Init); + Next (Init); + end loop; + end if; + end if; + end if; + end Check_SPARK_Initialized_States; - procedure Traverse_List (List : List_Id) is - Item : Node_Id; + -- Local variables - begin - Item := First (List); - while Present (Item) loop - Traverse_Potential_Scenarios (Item); - Next (Item); - end loop; - end Traverse_List; + Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (Prag); - -- Start of processing for Find_And_Process_Nested_Scenarios + -- Start of processing for Process_SPARK_Refined_State_Pragma begin - -- Examine the declarations for suitable scenarios + -- Pragma Refined_State must be associated with a package body - Traverse_List (Declarations (N)); + pragma Assert + (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); - -- Examine the handled sequence of statements. This also includes any - -- exceptions handlers. + -- Verify that each external contitunent of an abstract state + -- mentioned in pragma Initializes is properly elaborated. - Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); - end Find_And_Process_Nested_Scenarios; + Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); + end Process_SPARK_Refined_State_Pragma; + end SPARK_Processor; - -- Start of processing for Traverse_Body + ------------------------------- + -- Spec_And_Body_From_Entity -- + ------------------------------- + procedure Spec_And_Body_From_Entity + (Id : Node_Id; + Spec_Decl : out Node_Id; + Body_Decl : out Node_Id) + is begin - -- Nothing to do when there is no body + Spec_And_Body_From_Node + (N => Unit_Declaration_Node (Id), + Spec_Decl => Spec_Decl, + Body_Decl => Body_Decl); + end Spec_And_Body_From_Entity; - if No (N) then - return; + ----------------------------- + -- Spec_And_Body_From_Node -- + ----------------------------- - elsif Nkind (N) /= N_Subprogram_Body then - return; - end if; + procedure Spec_And_Body_From_Node + (N : Node_Id; + Spec_Decl : out Node_Id; + Body_Decl : out Node_Id) + is + Body_Id : Entity_Id; + Spec_Id : Entity_Id; - -- Nothing to do if the body was already traversed during the processing - -- of the same top-level scenario. + begin + -- Assume that the construct lacks spec and body - if Is_Visited_Body (N) then - return; + Body_Decl := Empty; + Spec_Decl := Empty; - -- Otherwise mark the body as traversed + -- Bodies - else - Set_Is_Visited_Body (N); + if Nkind_In (N, N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) + then + Spec_Id := Corresponding_Spec (N); + + -- The body completes a previous declaration + + if Present (Spec_Id) then + Spec_Decl := Unit_Declaration_Node (Spec_Id); + + -- Otherwise the body acts as the initial declaration, and is both a + -- spec and body. There is no need to look for an optional body. + + else + Body_Decl := N; + Spec_Decl := N; + return; + end if; + + -- Declarations + + elsif Nkind_In (N, N_Entry_Declaration, + N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Protected_Type_Declaration, + N_Subprogram_Declaration, + N_Task_Type_Declaration) + then + Spec_Decl := N; + + -- Expression function + + elsif Nkind (N) = N_Expression_Function then + Spec_Id := Corresponding_Spec (N); + pragma Assert (Present (Spec_Id)); + + Spec_Decl := Unit_Declaration_Node (Spec_Id); + + -- Instantiations + + elsif Nkind (N) in N_Generic_Instantiation then + Spec_Decl := Instance_Spec (N); + pragma Assert (Present (Spec_Decl)); + + -- Stubs + + elsif Nkind (N) in N_Body_Stub then + Spec_Id := Corresponding_Spec_Of_Stub (N); + + -- The stub completes a previous declaration + + if Present (Spec_Id) then + Spec_Decl := Unit_Declaration_Node (Spec_Id); + + -- Otherwise the stub acts as a spec + + else + Spec_Decl := N; + end if; end if; - -- Examine the declarations and statements of the subprogram body for - -- suitable scenarios, save and process them accordingly. + -- Obtain an optional or mandatory body + + if Present (Spec_Decl) then + Body_Id := Corresponding_Body (Spec_Decl); - Find_And_Process_Nested_Scenarios; - end Traverse_Body; + if Present (Body_Id) then + Body_Decl := Unit_Declaration_Node (Body_Id); + end if; + end if; + end Spec_And_Body_From_Node; + + ------------------------------- + -- Static_Elaboration_Checks -- + ------------------------------- + + function Static_Elaboration_Checks return Boolean is + begin + return not Dynamic_Elaboration_Checks; + end Static_Elaboration_Checks; ----------------- -- Unit_Entity -- @@ -11256,82 +15699,6 @@ package body Sem_Elab is --------------------------------- procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is - procedure Update_SPARK_Scenario; - pragma Inline (Update_SPARK_Scenario); - -- Update the contents of table SPARK_Scenarios if Old_N is recorded - -- there. - - procedure Update_Top_Level_Scenario; - pragma Inline (Update_Top_Level_Scenario); - -- Update the contexts of table Top_Level_Scenarios if Old_N is recorded - -- there. - - --------------------------- - -- Update_SPARK_Scenario -- - --------------------------- - - procedure Update_SPARK_Scenario is - package Scenarios renames SPARK_Scenarios; - - begin - if Is_Recorded_SPARK_Scenario (Old_N) then - - -- Performance note: list traversal - - for Index in Scenarios.First .. Scenarios.Last loop - if Scenarios.Table (Index) = Old_N then - Scenarios.Table (Index) := New_N; - - -- The old SPARK scenario is no longer recorded, but the new - -- one is. - - Set_Is_Recorded_Top_Level_Scenario (Old_N, False); - Set_Is_Recorded_Top_Level_Scenario (New_N); - return; - end if; - end loop; - - -- A recorded SPARK scenario must be in the table of recorded - -- SPARK scenarios. - - pragma Assert (False); - end if; - end Update_SPARK_Scenario; - - ------------------------------- - -- Update_Top_Level_Scenario -- - ------------------------------- - - procedure Update_Top_Level_Scenario is - package Scenarios renames Top_Level_Scenarios; - - begin - if Is_Recorded_Top_Level_Scenario (Old_N) then - - -- Performance note: list traversal - - for Index in Scenarios.First .. Scenarios.Last loop - if Scenarios.Table (Index) = Old_N then - Scenarios.Table (Index) := New_N; - - -- The old top-level scenario is no longer recorded, but the - -- new one is. - - Set_Is_Recorded_Top_Level_Scenario (Old_N, False); - Set_Is_Recorded_Top_Level_Scenario (New_N); - return; - end if; - end loop; - - -- A recorded top-level scenario must be in the table of recorded - -- top-level scenarios. - - pragma Assert (False); - end if; - end Update_Top_Level_Scenario; - - -- Start of processing for Update_Elaboration_Requirement - begin -- Nothing to do when the old and new scenarios are one and the same @@ -11344,20 +15711,10 @@ package body Sem_Elab is -- is inserted at the proper place in the tree. elsif Is_Scenario (Old_N) then - Update_SPARK_Scenario; - Update_Top_Level_Scenario; + Replace_Scenario (Old_N, New_N); end if; end Update_Elaboration_Scenario; - ------------------------- - -- Visited_Bodies_Hash -- - ------------------------- - - function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index is - begin - return Visited_Bodies_Index (Key mod Visited_Bodies_Max); - end Visited_Bodies_Hash; - --------------------------------------------------------------------------- -- -- -- L E G A C Y A C C E S S B E F O R E E L A B O R A T I O N -- diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads index 5d47957..f47d525 100644 --- a/gcc/ada/sem_elab.ads +++ b/gcc/ada/sem_elab.ads @@ -30,25 +30,9 @@ with Types; use Types; package Sem_Elab is - procedure Build_Call_Marker (N : Node_Id); - -- Create a call marker for call or requeue statement N and record it for - -- later processing by the ABE mechanism. - - procedure Build_Variable_Reference_Marker - (N : Node_Id; - Read : Boolean; - Write : Boolean); - -- Create a variable reference marker for arbitrary node N if it mentions a - -- variable, and record it for later processing by the ABE mechanism. Flag - -- Read should be set when the reference denotes a read. Flag Write should - -- be set when the reference denotes a write. - - procedure Check_Elaboration_Scenarios; - -- Examine each scenario recorded during analysis/resolution and apply the - -- Ada or SPARK elaboration rules taking into account the model in effect. - -- This processing detects and diagnoses ABE issues, installs conditional - -- ABE checks or guaranteed ABE failures, and ensures the elaboration of - -- units. + ----------- + -- Types -- + ----------- -- The following type classifies the various enclosing levels used in ABE -- diagnostics. @@ -64,9 +48,9 @@ package Sem_Elab is -- package Nested is -- enclosing package ignored -- X ... -- at declaration level - Generic_Package_Spec, - Generic_Package_Body, - -- A construct is at the "generic library level" when it appears in a + Generic_Spec_Level, + Generic_Body_Level, + -- A construct is at the "generic level" when it appears in a -- generic package library unit, ignoring enclosing packages. Example: -- generic @@ -74,14 +58,14 @@ package Sem_Elab is -- package Nested is -- enclosing package ignored -- X ... -- at generic library level - Instantiation, + Instantiation_Level, -- A construct is at the "instantiation library level" when it appears -- in a library unit which is also an instantiation. Example: -- package Inst is new Gen; -- at instantiation level - Package_Spec, - Package_Body, + Library_Spec_Level, + Library_Body_Level, -- A construct is at the "library level" when it appears in a package -- library unit, ignoring enclosing packages. Example: @@ -93,26 +77,46 @@ package Sem_Elab is -- This value is used to indicate that none of the levels above are in -- effect. - subtype Any_Library_Level is Enclosing_Level_Kind range - Generic_Package_Spec .. - Package_Body; - - subtype Generic_Library_Level is Enclosing_Level_Kind range - Generic_Package_Spec .. - Generic_Package_Body; + subtype Generic_Level is Enclosing_Level_Kind range + Generic_Spec_Level .. + Generic_Body_Level; subtype Library_Level is Enclosing_Level_Kind range - Package_Spec .. - Package_Body; + Library_Spec_Level .. + Library_Body_Level; subtype Library_Or_Instantiation_Level is Enclosing_Level_Kind range - Instantiation .. - Package_Body; + Instantiation_Level .. + Library_Body_Level; + + procedure Build_Call_Marker (N : Node_Id); + pragma Inline (Build_Call_Marker); + -- Create a call marker for call or requeue statement N and record it for + -- later processing by the ABE mechanism. + + procedure Build_Variable_Reference_Marker + (N : Node_Id; + Read : Boolean; + Write : Boolean); + pragma Inline (Build_Variable_Reference_Marker); + -- Create a variable reference marker for arbitrary node N if it mentions a + -- variable, and record it for later processing by the ABE mechanism. Flag + -- Read should be set when the reference denotes a read. Flag Write should + -- be set when the reference denotes a write. + + procedure Check_Elaboration_Scenarios; + -- Examine each scenario recorded during analysis/resolution and apply the + -- Ada or SPARK elaboration rules taking into account the model in effect. + -- This processing detects and diagnoses ABE issues, installs conditional + -- ABE checks or guaranteed ABE failures, and ensures the elaboration of + -- units. function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind; + pragma Inline (Find_Enclosing_Level); -- Determine the enclosing level of arbitrary node N procedure Initialize; + pragma Inline (Initialize); -- Initialize the internal structures of this unit procedure Kill_Elaboration_Scenario (N : Node_Id); @@ -121,9 +125,10 @@ package Sem_Elab is -- dead code. procedure Record_Elaboration_Scenario (N : Node_Id); + pragma Inline (Record_Elaboration_Scenario); -- Determine whether atribtray node N denotes a scenario which requires - -- ABE diagnostics or runtime checks. If this is the case, store N into - -- a table for later processing. + -- ABE diagnostics or runtime checks. If this is the case, store N for + -- later processing. --------------------------------------------------------------------------- -- -- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 520650b..b499dbd 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9861,6 +9861,17 @@ package body Sem_Prag is -- Start of processing for Process_Inline begin + -- An inlined subprogram may grant access to its private enclosing + -- context depending on the placement of its body. From elaboration + -- point of view, the flow of execution may enter this private + -- context, and then reach an external unit, thus producing a + -- dependency on that external unit. For such a path to be properly + -- discovered and encoded in the ALI file of the main unit, let the + -- ABE mechanism process the body of the main unit, and encode all + -- relevant invocation constructs and the relations between them. + + Mark_Save_Invocation_Graph_Of_Body; + Check_No_Identifiers; Check_At_Least_N_Arguments (1); @@ -12219,7 +12230,7 @@ package body Sem_Prag is Check_Ghost_Synchronous; -- Option Part_Of without an encapsulating state is - -- illegal (SPARK RM 7.1.4(9)). + -- illegal (SPARK RM 7.1.4(8)). elsif Chars (Opt) = Name_Part_Of then SPARK_Msg_N @@ -19349,20 +19360,25 @@ package body Sem_Prag is ----------------------- -- pragma Machine_Attribute ( - -- [Entity =>] LOCAL_NAME, - -- [Attribute_Name =>] static_string_EXPRESSION - -- [, [Info =>] static_EXPRESSION] ); + -- [Entity =>] LOCAL_NAME, + -- [Attribute_Name =>] static_string_EXPRESSION + -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] ); when Pragma_Machine_Attribute => Machine_Attribute : declare + Arg : Node_Id; Def_Id : Entity_Id; begin GNAT_Pragma; Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info)); - if Arg_Count = 3 then + if Arg_Count >= 3 then Check_Optional_Identifier (Arg3, Name_Info); - Check_Arg_Is_OK_Static_Expression (Arg3); + Arg := Arg3; + while Present (Arg) loop + Check_Arg_Is_OK_Static_Expression (Arg); + Arg := Next (Arg); + end loop; else Check_Arg_Count (2); end if; @@ -25603,6 +25619,12 @@ package body Sem_Prag is Ent := Underlying_Type (Ent); end if; + -- The pragma applies to entities with addresses + + if Is_Type (Ent) then + Error_Pragma ("pragma applies to objects and subprograms"); + end if; + -- The only processing required is to link this item on to the -- list of rep items for the given entity. This is accomplished -- by the call to Rep_Item_Too_Late (when no error is detected diff --git a/gcc/ada/sem_spark.adb b/gcc/ada/sem_spark.adb index cfa6df8..b4e816e 100644 --- a/gcc/ada/sem_spark.adb +++ b/gcc/ada/sem_spark.adb @@ -42,9 +42,9 @@ with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; package body Sem_SPARK is - ------------------------------------------------- - -- Handling of Permissions Associated to Paths -- - ------------------------------------------------- + --------------------------------------------------- + -- Handling of Permissions Associated with Paths -- + --------------------------------------------------- package Permissions is Elaboration_Context_Max : constant := 1009; @@ -52,16 +52,44 @@ package body Sem_SPARK is type Elaboration_Context_Index is range 0 .. Elaboration_Context_Max - 1; - function Elaboration_Context_Hash (Key : Entity_Id) - return Elaboration_Context_Index; - -- Function to hash any node of the AST + function Elaboration_Context_Hash + (Key : Entity_Id) return Elaboration_Context_Index; + -- The hash function + + -- Permission type associated with paths. These are related to but not + -- the same as the states associated with names used in SPARK RM 3.10: + -- Unrestricted, Observed, Borrowed, Moved. When ownership rules lead to + -- a state change for a name, this may correspond to multiple permission + -- changes for the paths corresponding to the name, its prefixes, and + -- its extensions. For example, when an object is assigned to, the + -- corresponding name gets into state Moved, while the path for the name + -- gets permission Write_Only as well as every prefix of the name, and + -- every suffix gets permission No_Access. + + type Perm_Kind_Option is + (None, + -- Special value used when no permission is passed around + + No_Access, + -- The path cannot be accessed for reading or writing. This is the + -- case for the path of a name in the Borrowed state. + + Read_Only, + -- The path can only be accessed for reading. This is the case for + -- the path of a name in the Observed state. + + Read_Write, + -- The path can be accessed for both reading and writing. This is the + -- case for the path of a name in the Unrestricted state. + + Write_Only + -- The path can only be accessed for writing. This is the case for + -- the path of a name in the Moved state. + ); - type Perm_Kind is (Borrowed, Observed, Unrestricted, Moved); - -- Permission type associated with paths. The Moved permission is - -- equivalent to the Unrestricted one (same permissions). The Moved is - -- however used to mark the RHS after a move (which still unrestricted). - -- This way, we may generate warnings when manipulating the RHS - -- afterwads since it is set to Null after the assignment. + subtype Perm_Kind is Perm_Kind_Option range No_Access .. Write_Only; + subtype Read_Perm is Perm_Kind range Read_Only .. Read_Write; + subtype Write_Perm is Perm_Kind range Read_Write .. Write_Only; type Perm_Tree_Wrapper; @@ -83,34 +111,39 @@ package body Sem_SPARK is package Perm_Tree_Maps is new Simple_HTable (Header_Num => Elaboration_Context_Index, - Key => Node_Id, + Key => Entity_Id, Element => Perm_Tree_Access, No_Element => null, Hash => Elaboration_Context_Hash, Equal => "="); - -- The instantation of a hash table, with keys being nodes and values - -- being pointers to trees. This is used to reference easily all - -- extensions of a Record_Component node (that can have name x, y, ...). + -- The instantation of a hash table, with keys being entities and values + -- being pointers to permission trees. This is used to define global + -- environment permissions (entities in that case are stand-alone + -- objects or formal parameters), as well as the permissions for the + -- extensions of a Record_Component node (entities in that case are + -- record components). -- The definition of permission trees. This is a tree, which has a - -- permission at each node, and depending on the type of the node, - -- can have zero, one, or more children pointed to by an access to tree. + -- permission at each node, and depending on the type of the node, can + -- have zero, one, or more children reached through an access to tree. type Perm_Tree (Kind : Path_Kind := Entire_Object) is record Permission : Perm_Kind; -- Permission at this level in the path Is_Node_Deep : Boolean; - -- Whether this node is of a deep type, to be used when moving the - -- path. + -- Whether this node is of a "deep" type, i.e. an access type or a + -- composite type containing access type subcomponents. This + -- corresponds to both "observing" and "owning" types in SPARK RM + -- 3.10. To be used when moving the path. case Kind is -- An entire object is either a leaf (an object which cannot be -- extended further in a path) or a subtree in folded form (which -- could later be unfolded further in another kind of node). The -- field Children_Permission specifies a permission for every - -- extension of that node if that permission is different from - -- the node's permission. + -- extension of that node if that permission is different from the + -- node's permission. when Entire_Object => Children_Permission : Perm_Kind; @@ -121,20 +154,17 @@ package body Sem_SPARK is when Reference => Get_All : Perm_Tree_Access; - -- Unfolded path of array type. The permission of the elements is + -- Unfolded path of array type. The permission of elements is -- given in Get_Elem. when Array_Component => Get_Elem : Perm_Tree_Access; - -- Unfolded path of record type. The permission of the regular - -- components is given in Component. The permission of unknown - -- components (for objects of tagged type) is given in - -- Other_Components. + -- Unfolded path of record type. The permission of the components + -- is given in Component. when Record_Component => Component : Perm_Tree_Maps.Instance; - Other_Components : Perm_Tree_Access; end case; end record; @@ -144,9 +174,8 @@ package body Sem_SPARK is -- We use this wrapper in order to have unconstrained discriminants type Perm_Env is new Perm_Tree_Maps.Instance; - -- The definition of a permission environment for the analysis. This - -- is just a hash table of permission trees, each of them rooted with - -- an Identifier/Expanded_Name. + -- The definition of a permission environment for the analysis. This is + -- just a hash table from entities to permission trees. type Perm_Env_Access is access Perm_Env; -- Access to permission environments @@ -166,20 +195,17 @@ package body Sem_SPARK is -- The type defining the hash table saving the environments at the entry -- of each loop. - package Boolean_Variables_Maps is new Simple_HTable + package Variable_Maps is new Simple_HTable (Header_Num => Elaboration_Context_Index, Key => Entity_Id, - Element => Boolean, - No_Element => False, + Element => Node_Id, + No_Element => Empty, Hash => Elaboration_Context_Hash, Equal => "="); - -- These maps allow tracking the variables that have been declared but - -- never used anywhere in the source code. Especially, we do not raise - -- an error if the variable stays write-only and is declared at package - -- level, because there is no risk that the variable has been moved, - -- because it has never been used. - type Initialization_Map is new Boolean_Variables_Maps.Instance; + type Variable_Mapping is new Variable_Maps.Instance; + -- Mapping from variables to nodes denoting paths that are observed or + -- borrowed by the variable. -------------------- -- Simple Getters -- @@ -195,7 +221,6 @@ package body Sem_SPARK is function Get_Elem (T : Perm_Tree_Access) return Perm_Tree_Access; function Is_Node_Deep (T : Perm_Tree_Access) return Boolean; function Kind (T : Perm_Tree_Access) return Path_Kind; - function Other_Components (T : Perm_Tree_Access) return Perm_Tree_Access; function Permission (T : Perm_Tree_Access) return Perm_Kind; ----------------------- @@ -204,25 +229,24 @@ package body Sem_SPARK is procedure Copy_Env (From : Perm_Env; - To : in out Perm_Env); + To : in out Perm_Env); -- Procedure to copy a permission environment - procedure Copy_Init_Map - (From : Initialization_Map; - To : in out Initialization_Map); - -- Procedure to copy an initialization map + procedure Move_Env (From, To : in out Perm_Env); + -- Procedure to move a permission environment. It frees To, moves From + -- in To and sets From to Nil. + + procedure Move_Variable_Mapping (From, To : in out Variable_Mapping); + -- Move a variable mapping, freeing memory as needed and resetting the + -- source mapping. - procedure Copy_Tree - (From : Perm_Tree_Access; - To : Perm_Tree_Access); + procedure Copy_Tree (From, To : Perm_Tree_Access); -- Procedure to copy a permission tree - procedure Free_Env - (PE : in out Perm_Env); + procedure Free_Env (PE : in out Perm_Env); -- Procedure to free a permission environment - procedure Free_Perm_Tree - (PT : in out Perm_Tree_Access); + procedure Free_Tree (PT : in out Perm_Tree_Access); -- Procedure to free a permission tree -------------------- @@ -230,8 +254,10 @@ package body Sem_SPARK is -------------------- procedure Perm_Mismatch - (Exp_Perm, Act_Perm : Perm_Kind; - N : Node_Id); + (N : Node_Id; + Exp_Perm : Perm_Kind; + Act_Perm : Perm_Kind; + Forbidden_Perm : Boolean := False); -- Issues a continuation error message about a mismatch between a -- desired permission Exp_Perm and a permission obtained Act_Perm. N -- is the node on which the error is reported. @@ -253,9 +279,7 @@ package body Sem_SPARK is -- Component -- --------------- - function Component - (T : Perm_Tree_Access) - return Perm_Tree_Maps.Instance + function Component (T : Perm_Tree_Access) return Perm_Tree_Maps.Instance is begin return T.all.Tree.Component; @@ -271,7 +295,7 @@ package body Sem_SPARK is Son : Perm_Tree_Access; begin - Reset (To); + Free_Env (To); Key_From := Get_First_Key (From); while Key_From.Present loop Comp_From := Get (From, Key_From.K); @@ -285,34 +309,18 @@ package body Sem_SPARK is end loop; end Copy_Env; - ------------------- - -- Copy_Init_Map -- - ------------------- - - procedure Copy_Init_Map - (From : Initialization_Map; - To : in out Initialization_Map) - is - Comp_From : Boolean; - Key_From : Boolean_Variables_Maps.Key_Option; - - begin - Reset (To); - Key_From := Get_First_Key (From); - while Key_From.Present loop - Comp_From := Get (From, Key_From.K); - Set (To, Key_From.K, Comp_From); - Key_From := Get_Next_Key (From); - end loop; - end Copy_Init_Map; - --------------- -- Copy_Tree -- --------------- - procedure Copy_Tree (From : Perm_Tree_Access; To : Perm_Tree_Access) is + procedure Copy_Tree (From, To : Perm_Tree_Access) is begin + -- Copy the direct components of the tree + To.all := From.all; + + -- Now reallocate access components for a deep copy of the tree + case Kind (From) is when Entire_Object => null; @@ -332,12 +340,9 @@ package body Sem_SPARK is Son : Perm_Tree_Access; Hash_Table : Perm_Tree_Maps.Instance; begin - -- We put a new hash table, so that it gets dealiased from the - -- Component (From) hash table. + -- We put a new hash table, so that it gets dealiased from + -- the Component (From) hash table. To.all.Tree.Component := Hash_Table; - To.all.Tree.Other_Components := - new Perm_Tree_Wrapper'(Other_Components (From).all); - Copy_Tree (Other_Components (From), Other_Components (To)); Key_From := Perm_Tree_Maps.Get_First_Key (Component (From)); @@ -354,7 +359,6 @@ package body Sem_SPARK is end loop; end; end case; - end Copy_Tree; ------------------------------ @@ -377,16 +381,18 @@ package body Sem_SPARK is begin CompO := Get_First (PE); while CompO /= null loop - Free_Perm_Tree (CompO); + Free_Tree (CompO); CompO := Get_Next (PE); end loop; + + Reset (PE); end Free_Env; - -------------------- - -- Free_Perm_Tree -- - -------------------- + --------------- + -- Free_Tree -- + --------------- - procedure Free_Perm_Tree (PT : in out Perm_Tree_Access) is + procedure Free_Tree (PT : in out Perm_Tree_Access) is procedure Free_Perm_Tree_Dealloc is new Ada.Unchecked_Deallocation (Perm_Tree_Wrapper, Perm_Tree_Access); @@ -395,33 +401,32 @@ package body Sem_SPARK is begin case Kind (PT) is when Entire_Object => - Free_Perm_Tree_Dealloc (PT); + null; when Reference => - Free_Perm_Tree (PT.all.Tree.Get_All); - Free_Perm_Tree_Dealloc (PT); + Free_Tree (PT.all.Tree.Get_All); when Array_Component => - Free_Perm_Tree (PT.all.Tree.Get_Elem); + Free_Tree (PT.all.Tree.Get_Elem); when Record_Component => declare Comp : Perm_Tree_Access; begin - Free_Perm_Tree (PT.all.Tree.Other_Components); Comp := Perm_Tree_Maps.Get_First (Component (PT)); while Comp /= null loop -- Free every Component subtree - Free_Perm_Tree (Comp); + Free_Tree (Comp); Comp := Perm_Tree_Maps.Get_Next (Component (PT)); end loop; end; - Free_Perm_Tree_Dealloc (PT); end case; - end Free_Perm_Tree; + + Free_Perm_Tree_Dealloc (PT); + end Free_Tree; ------------- -- Get_All -- @@ -459,17 +464,27 @@ package body Sem_SPARK is return T.all.Tree.Kind; end Kind; - ---------------------- - -- Other_Components -- - ---------------------- + -------------- + -- Move_Env -- + -------------- - function Other_Components - (T : Perm_Tree_Access) - return Perm_Tree_Access - is + procedure Move_Env (From, To : in out Perm_Env) is begin - return T.all.Tree.Other_Components; - end Other_Components; + Free_Env (To); + To := From; + From := Perm_Env (Perm_Tree_Maps.Nil); + end Move_Env; + + --------------------------- + -- Move_Variable_Mapping -- + --------------------------- + + procedure Move_Variable_Mapping (From, To : in out Variable_Mapping) is + begin + Reset (To); + To := From; + From := Variable_Mapping (Variable_Maps.Nil); + end Move_Variable_Mapping; ---------------- -- Permission -- @@ -484,11 +499,27 @@ package body Sem_SPARK is -- Perm_Mismatch -- ------------------- - procedure Perm_Mismatch (Exp_Perm, Act_Perm : Perm_Kind; N : Node_Id) is + procedure Perm_Mismatch + (N : Node_Id; + Exp_Perm : Perm_Kind; + Act_Perm : Perm_Kind; + Forbidden_Perm : Boolean := False) + is begin - Error_Msg_N ("\expected state `" - & Perm_Kind'Image (Exp_Perm) & "` at least, got `" - & Perm_Kind'Image (Act_Perm) & "`", N); + if Forbidden_Perm then + if Exp_Perm = Act_Perm then + Error_Msg_N ("\got forbidden state `" + & Perm_Kind'Image (Exp_Perm), N); + else + Error_Msg_N ("\forbidden state `" + & Perm_Kind'Image (Exp_Perm) & "`, got `" + & Perm_Kind'Image (Act_Perm) & "`", N); + end if; + else + Error_Msg_N ("\expected state `" + & Perm_Kind'Image (Exp_Perm) & "` at least, got `" + & Perm_Kind'Image (Act_Perm) & "`", N); + end if; end Perm_Mismatch; end Permissions; @@ -499,8 +530,9 @@ package body Sem_SPARK is -- Analysis modes for AST traversal -- -------------------------------------- - -- The different modes for analysis. This allows to checking whether a path - -- found in the code should be moved, borrowed, or observed. + -- The different modes for analysis. This allows checking whether a path + -- has the right permission, and also updating permissions when a path is + -- moved, borrowed, or observed. type Checking_Mode is @@ -508,31 +540,32 @@ package body Sem_SPARK is -- Default mode Move, - -- Regular moving semantics. Checks that paths have Unrestricted - -- permission. After moving a path, the permission of both it and - -- its extensions are set to Unrestricted. + -- Move semantics. Checks that paths have Read_Write permission. After + -- moving a path, its permission and the permission of its prefixes are + -- set to Write_Only, while the permission of its extensions is set to + -- No_Access. Assign, -- Used for the target of an assignment, or an actual parameter with - -- mode OUT. Checks that paths have Unrestricted permission. After - -- assigning to a path, its permission is set to Unrestricted. + -- mode OUT. Checks that paths have Write_Perm permission. After + -- assigning to a path, its permission and the permission of its + -- extensions are set to Read_Write. The permission of its prefixes may + -- be normalized from Write_Only to Read_Write depending on other + -- permissions in the tree (a prefix gets permission Read_Write when all + -- its extensions become Read_Write). Borrow, - -- Used for the source of an assignement when initializes a stand alone - -- object of anonymous type, constant, or IN parameter and also OUT - -- or IN OUT composite object. - -- In the borrowed state, the access object is completely "dead". + -- Borrow semantics. Checks that paths have Read_Write permission. After + -- borrowing a path, its permission and the permission of its prefixes + -- and extensions are set to No_Access. Observe - -- Used for actual IN parameters of a scalar type. Checks that paths - -- have Read_Perm permission. After checking a path, its permission - -- is set to Observed. - -- - -- Also used for formal IN parameters - + -- Observe semantics. Checks that paths have Read_Perm permission. After + -- observing a path, its permission and the permission of its prefixes + -- and extensions are set to Read_Only. ); - type Result_Kind is (Folded, Unfolded, Function_Call); + type Result_Kind is (Folded, Unfolded); -- The type declaration to discriminate in the Perm_Or_Tree type -- The result type of the function Get_Perm_Or_Tree. This returns either a @@ -542,72 +575,125 @@ package body Sem_SPARK is type Perm_Or_Tree (R : Result_Kind) is record case R is - when Folded => Found_Permission : Perm_Kind; - when Unfolded => Tree_Access : Perm_Tree_Access; - when Function_Call => null; + when Folded => Found_Permission : Perm_Kind; + when Unfolded => Tree_Access : Perm_Tree_Access; end case; end record; + type Error_Status is (OK, Error); + ----------------------- -- Local subprograms -- ----------------------- - -- Checking proceduress for safe pointer usage. These procedures traverse - -- the AST, check nodes for correct permissions according to SPARK RM - -- 6.4.2, and update permissions depending on the node kind. + function "<=" (P1, P2 : Perm_Kind) return Boolean; + function ">=" (P1, P2 : Perm_Kind) return Boolean; + function Glb (P1, P2 : Perm_Kind) return Perm_Kind; + function Lub (P1, P2 : Perm_Kind) return Perm_Kind; + + procedure Check_Assignment (Target : Node_Or_Entity_Id; Expr : Node_Id); + -- Handle assignment as part of an assignment statement or an object + -- declaration. procedure Check_Call_Statement (Call : Node_Id); procedure Check_Callable_Body (Body_N : Node_Id); - -- We are not in End_Of_Callee mode, hence we will save the environment - -- and start from a new one. We will add in the environment all formal - -- parameters as well as global used during the subprogram, with the - -- appropriate permissions (unrestricted for borrowed and moved, observed - -- for observed names). + -- Entry point for the analysis of a subprogram or entry body procedure Check_Declaration (Decl : Node_Id); - procedure Check_Expression (Expr : Node_Id); + procedure Check_Expression (Expr : Node_Id; Mode : Checking_Mode); + pragma Precondition (Nkind_In (Expr, N_Index_Or_Discriminant_Constraint, + N_Range_Constraint, + N_Subtype_Indication) + or else Nkind (Expr) in N_Subexpr); - procedure Check_Globals (N : Node_Id); - -- This procedure takes a global pragma and checks it + procedure Check_Globals (Subp : Entity_Id); + -- This procedure takes a subprogram called and checks the permission of + -- globals. + + -- Checking proceduress for safe pointer usage. These procedures traverse + -- the AST, check nodes for correct permissions according to SPARK RM 3.10, + -- and update permissions depending on the node kind. The main procedure + -- Check_Node is mutually recursive with the specialized procedures that + -- follow. procedure Check_List (L : List_Id); -- Calls Check_Node on each element of the list - procedure Check_Loop_Statement (Loop_N : Node_Id); + procedure Check_Loop_Statement (Stmt : Node_Id); procedure Check_Node (N : Node_Id); - -- Main traversal procedure to check safe pointer usage. This procedure is - -- mutually recursive with the specialized procedures that follow. + -- Main traversal procedure to check safe pointer usage procedure Check_Package_Body (Pack : Node_Id); - procedure Check_Param_In (Formal : Entity_Id; Actual : Node_Id); - -- This procedure takes a formal and an actual parameter and checks the - -- permission of every in-mode parameter. This includes Observing and - -- Borrowing. + procedure Check_Package_Spec (Pack : Node_Id); + + procedure Check_Parameter_Or_Global + (Expr : Node_Id; + Typ : Entity_Id; + Kind : Formal_Kind; + Subp : Entity_Id; + Global_Var : Boolean); + -- Check the permission of every actual parameter or global + + procedure Check_Pragma (Prag : Node_Id); - procedure Check_Param_Out (Formal : Entity_Id; Actual : Node_Id); - -- This procedure takes a formal and an actual parameter and checks the - -- state of every out-mode and in out-mode parameter. This includes - -- Moving and Borrowing. + procedure Check_Source_Of_Borrow_Or_Observe + (Expr : Node_Id; + Status : out Error_Status); procedure Check_Statement (Stmt : Node_Id); - function Get_Perm (N : Node_Id) return Perm_Kind; + procedure Check_Type (Typ : Entity_Id); + -- Check that type Typ is either not deep, or that it is an observing or + -- owning type according to SPARK RM 3.10 + + function Get_Observed_Or_Borrowed_Expr (Expr : Node_Id) return Node_Id; + pragma Precondition (Is_Path_Expression (Expr)); + -- Return the expression being borrowed/observed when borrowing or + -- observing Expr. If Expr is a call to a traversal function, this is + -- the first actual, otherwise it is Expr. + + function Get_Perm (N : Node_Or_Entity_Id) return Perm_Kind; -- The function that takes a name as input and returns a permission - -- associated to it. + -- associated with it. function Get_Perm_Or_Tree (N : Node_Id) return Perm_Or_Tree; - -- This function gets a Node_Id and looks recursively to find the - -- appropriate subtree for that Node_Id. If the tree is folded on - -- that node, then it returns the permission given at the right level. + pragma Precondition (Is_Path_Expression (N)); + -- This function gets a node and looks recursively to find the appropriate + -- subtree for that node. If the tree is folded on that node, then it + -- returns the permission given at the right level. function Get_Perm_Tree (N : Node_Id) return Perm_Tree_Access; - -- This function gets a Node_Id and looks recursively to find the - -- appropriate subtree for that Node_Id. If the tree is folded, then - -- it unrolls the tree up to the appropriate level. + pragma Precondition (Is_Path_Expression (N)); + -- This function gets a node and looks recursively to find the appropriate + -- subtree for that node. If the tree is folded, then it unrolls the tree + -- up to the appropriate level. + + function Get_Root_Object + (Expr : Node_Id; + Through_Traversal : Boolean := True) return Entity_Id; + pragma Precondition (Is_Path_Expression (Expr)); + -- Return the root of the path expression Expr, or Empty for an allocator, + -- NULL, or a function call. Through_Traversal is True if it should follow + -- through calls to traversal functions. + + generic + with procedure Handle_Parameter_Or_Global + (Expr : Node_Id; + Formal_Typ : Entity_Id; + Param_Mode : Formal_Kind; + Subp : Entity_Id; + Global_Var : Boolean); + procedure Handle_Globals (Subp : Entity_Id); + -- Handling of globals is factored in a generic instantiated below + + function Has_Array_Component (Expr : Node_Id) return Boolean; + pragma Precondition (Is_Path_Expression (Expr)); + -- This function gets a node and looks recursively to determine whether the + -- given path has any array component. procedure Hp (P : Perm_Env); -- A procedure that outputs the hash table. This function is used only in @@ -619,18 +705,38 @@ package body Sem_SPARK is -- A procedure that is called when deep globals or aliased globals are used -- without any global aspect. - function Is_Deep (E : Entity_Id) return Boolean; + function Is_Deep (Typ : Entity_Id) return Boolean; -- A function that can tell if a type is deep or not. Returns true if the -- type passed as argument is deep. + function Is_Path_Expression (Expr : Node_Id) return Boolean; + -- Return whether Expr corresponds to a path + + function Is_Prefix_Or_Almost (Pref, Expr : Node_Id) return Boolean; + -- Determine if the candidate Prefix is indeed a prefix of Expr, or almost + -- a prefix, in the sense that they could still refer to overlapping memory + -- locations. + + function Is_Traversal_Function (E : Entity_Id) return Boolean; + + function Is_Traversal_Function_Call (Expr : Node_Id) return Boolean; + + function Loop_Of_Exit (N : Node_Id) return Entity_Id; + -- A function that takes an exit statement node and returns the entity of + -- the loop that this statement is exiting from. + + procedure Merge_Env (Source : in out Perm_Env; Target : in out Perm_Env); + -- Merge Target and Source into Target, and then deallocate the Source + procedure Perm_Error - (N : Node_Id; - Perm : Perm_Kind; - Found_Perm : Perm_Kind); + (N : Node_Id; + Perm : Perm_Kind; + Found_Perm : Perm_Kind; + Forbidden_Perm : Boolean := False); -- A procedure that is called when the permissions found contradict the - -- rules established by the RM. This function is called with the node, its - -- entity and the permission that was expected, and adds an error message - -- with the appropriate values. + -- rules established by the RM. This function is called with the node and + -- the permission that was expected, and issues an error message with the + -- appropriate values. procedure Perm_Error_Subprogram_End (E : Entity_Id; @@ -638,50 +744,69 @@ package body Sem_SPARK is Perm : Perm_Kind; Found_Perm : Perm_Kind); -- A procedure that is called when the permissions found contradict the - -- rules established by the RM at the end of subprograms. This function - -- is called with the node, its entity, the node of the returning function - -- and the permission that was expected, and adds an error message with the + -- rules established by the RM at the end of subprograms. This function is + -- called with the node, the node of the returning function, and the + -- permission that was expected, and adds an error message with the -- appropriate values. - procedure Process_Path (N : Node_Id); - - procedure Return_Declarations (L : List_Id); - -- Check correct permissions on every declared object at the end of a - -- callee. Used at the end of the body of a callable entity. Checks that - -- paths of all borrowed formal parameters and global have Unrestricted - -- permission. + procedure Process_Path (Expr : Node_Id; Mode : Checking_Mode); + pragma Precondition (Is_Path_Expression (Expr)); + -- Check correct permission for the path in the checking mode Mode, and + -- update permissions of the path and its prefixes/extensions. procedure Return_Globals (Subp : Entity_Id); -- Takes a subprogram as input, and checks that all borrowed global items - -- of the subprogram indeed have RW permission at the end of the subprogram - -- execution. - - procedure Return_The_Global - (Id : Entity_Id; - Mode : Formal_Kind; - Subp : Entity_Id); - -- Auxiliary procedure to Return_Globals - -- There is no need to return parameters because they will be reassigned - -- their state once the subprogram returns. Local variables that have - -- borrowed, observed, or moved an actual parameter go out of the scope. + -- of the subprogram indeed have Read_Write permission at the end of the + -- subprogram execution. + + procedure Return_Parameter_Or_Global + (Id : Entity_Id; + Typ : Entity_Id; + Kind : Formal_Kind; + Subp : Entity_Id; + Global_Var : Boolean); + -- Auxiliary procedure to Return_Parameters and Return_Globals + + procedure Return_Parameters (Subp : Entity_Id); + -- Takes a subprogram as input, and checks that all out parameters of the + -- subprogram indeed have Read_Write permission at the end of the + -- subprogram execution. procedure Set_Perm_Extensions (T : Perm_Tree_Access; P : Perm_Kind); -- This procedure takes an access to a permission tree and modifies the -- tree so that any strict extensions of the given tree become of the -- access specified by parameter P. - function Set_Perm_Prefixes_Borrow (N : Node_Id) return Perm_Tree_Access; - -- This function modifies the permissions of a given node_id in the - -- permission environment as well as in all the prefixes of the path, - -- given that the path is borrowed with mode out. + procedure Set_Perm_Extensions_Move (T : Perm_Tree_Access; E : Entity_Id); + -- Set permissions to + -- No for any extension with more .all + -- W for any deep extension with same number of .all + -- RW for any shallow extension with same number of .all function Set_Perm_Prefixes - (N : Node_Id; - New_Perm : Perm_Kind) - return Perm_Tree_Access; - -- This function sets the permissions of a given node_id in the - -- permission environment as well as in all the prefixes of the path - -- to the one given in parameter (P). + (N : Node_Id; + Perm : Perm_Kind_Option) return Perm_Tree_Access; + pragma Precondition (Is_Path_Expression (N)); + -- This function modifies the permissions of a given node in the permission + -- environment as well as all the prefixes of the path, to the new + -- permission Perm. The general rule here is that everybody updates the + -- permission of the subtree they are returning. + + procedure Set_Perm_Prefixes_Assign (N : Node_Id); + pragma Precondition (Is_Path_Expression (N)); + -- This procedure takes a name as an input and sets in the permission + -- tree the given permission to the given name. The general rule here is + -- that everybody updates the permission of the subtree it is returning. + -- The permission of the assigned path has been set to RW by the caller. + -- + -- Case where we have to normalize a tree after the correct permissions + -- have been assigned already. We look for the right subtree at the given + -- path, actualize its permissions, and then call the normalization on its + -- parent. + -- + -- Example: We assign x.y and x.z, and then Set_Perm_Prefixes_Assign will + -- change the permission of x to RW because all of its components have + -- permission RW. procedure Setup_Globals (Subp : Entity_Id); -- Takes a subprogram as input, and sets up the environment by adding @@ -689,7 +814,9 @@ package body Sem_SPARK is procedure Setup_Parameter_Or_Global (Id : Entity_Id; - Mode : Formal_Kind; + Typ : Entity_Id; + Kind : Formal_Kind; + Subp : Entity_Id; Global_Var : Boolean); -- Auxiliary procedure to Setup_Parameters and Setup_Globals @@ -697,15 +824,6 @@ package body Sem_SPARK is -- Takes a subprogram as input, and sets up the environment by adding -- formal parameters with appropriate permissions. - function Has_Ownership_Aspect_True - (N : Node_Id; - Msg : String) - return Boolean; - -- Takes a node as an input, and finds out whether it has ownership aspect - -- True or False. This function is recursive whenever the node has a - -- composite type. Access-to-objects have ownership aspect False if they - -- have a general access type. - ---------------------- -- Global Variables -- ---------------------- @@ -717,11 +835,13 @@ package body Sem_SPARK is -- scope. The analysis ensures at each point that this variables contains -- a valid permission environment with all bindings in scope. - Current_Checking_Mode : Checking_Mode := Read; - -- The current analysis mode. This global variable indicates at each point - -- of the analysis whether the node being analyzed is moved, borrowed, - -- assigned, read, ... The full list of possible values can be found in - -- the declaration of type Checking_Mode. + Inside_Procedure_Call : Boolean := False; + -- Set while checking the actual parameters of a procedure or entry call + + Inside_Elaboration : Boolean := False; + -- Set during package spec/body elaboration, during which move and local + -- observe/borrow are not allowed. As a result, no other checking is needed + -- during elaboration. Current_Loops_Envs : Env_Backups; -- This variable contains saves of permission environments at each loop the @@ -737,378 +857,486 @@ package body Sem_SPARK is -- restrictive than the saved environment at the beginning of the loop, and -- the permission environment after the loop is equal to the accumulator. - Current_Initialization_Map : Initialization_Map; - -- This variable contains a map that binds each variable of the analyzed - -- source code to a boolean that becomes true whenever the variable is used - -- after declaration. Hence we can exclude from analysis variables that - -- are just declared and never accessed, typically at package declaration. + Current_Borrowers : Variable_Mapping; + -- Mapping from borrowers to the path borrowed - -------------------------- - -- Check_Call_Statement -- - -------------------------- + Current_Observers : Variable_Mapping; + -- Mapping from observers to the path observed - procedure Check_Call_Statement (Call : Node_Id) is - Saved_Env : Perm_Env; + -------------------- + -- Handle_Globals -- + -------------------- - procedure Iterate_Call_In is new - Iterate_Call_Parameters (Check_Param_In); - procedure Iterate_Call_Out is new - Iterate_Call_Parameters (Check_Param_Out); + -- Generic procedure is defined first so that instantiations can be defined + -- anywhere afterwards. - begin - -- Save environment, so that the modifications done by analyzing the - -- parameters are not kept at the end of the call. - - Copy_Env (Current_Perm_Env, Saved_Env); - - -- We first check the globals then parameters to handle the - -- No_Parameter_Aliasing Restriction. An out or in-out global is - -- considered as borrowing while a parameter with the same mode is - -- a move. This order disallow passing a part of a variable to a - -- subprogram if it is referenced as a global by the callable (when - -- writable). - -- For paremeters, we fisrt check in parameters and then the out ones. - -- This is to avoid Observing or Borrowing objects that are already - -- moved. This order is not mandatory but allows to catch runtime - -- errors like null pointer dereferencement at the analysis time. - - Current_Checking_Mode := Read; - Check_Globals (Get_Pragma (Get_Called_Entity (Call), Pragma_Global)); - Iterate_Call_In (Call); - Iterate_Call_Out (Call); - - -- Restore environment, because after borrowing/observing actual - -- parameters, they get their permission reverted to the ones before - -- the call. - - Free_Env (Current_Perm_Env); - Copy_Env (Saved_Env, Current_Perm_Env); - Free_Env (Saved_Env); - end Check_Call_Statement; + procedure Handle_Globals (Subp : Entity_Id) is - ------------------------- - -- Check_Callable_Body -- - ------------------------- + -- Local subprograms - procedure Check_Callable_Body (Body_N : Node_Id) is + procedure Handle_Globals_From_List + (First_Item : Node_Id; + Kind : Formal_Kind); + -- Handle global items from the list starting at Item + + procedure Handle_Globals_Of_Mode (Global_Mode : Name_Id); + -- Handle global items for the mode Global_Mode + + ------------------------------ + -- Handle_Globals_From_List -- + ------------------------------ + + procedure Handle_Globals_From_List + (First_Item : Node_Id; + Kind : Formal_Kind) + is + Item : Node_Id := First_Item; + E : Entity_Id; + + begin + while Present (Item) loop + E := Entity (Item); + + -- Ignore abstract states, which play no role in pointer aliasing - Mode_Before : constant Checking_Mode := Current_Checking_Mode; - Saved_Env : Perm_Env; - Saved_Init_Map : Initialization_Map; - New_Env : Perm_Env; - Body_Id : constant Entity_Id := Defining_Entity (Body_N); - Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); + if Ekind (E) = E_Abstract_State then + null; + else + Handle_Parameter_Or_Global (Expr => Item, + Formal_Typ => Etype (Item), + Param_Mode => Kind, + Subp => Subp, + Global_Var => True); + end if; + + Next_Global (Item); + end loop; + end Handle_Globals_From_List; + + ---------------------------- + -- Handle_Globals_Of_Mode -- + ---------------------------- + + procedure Handle_Globals_Of_Mode (Global_Mode : Name_Id) is + Kind : Formal_Kind; + + begin + case Global_Mode is + when Name_Input + | Name_Proof_In + => + Kind := E_In_Parameter; + + when Name_Output => + Kind := E_Out_Parameter; + + when Name_In_Out => + Kind := E_In_Out_Parameter; + + when others => + raise Program_Error; + end case; + + -- Check both global items from Global and Refined_Global pragmas + + Handle_Globals_From_List (First_Global (Subp, Global_Mode), Kind); + Handle_Globals_From_List + (First_Global (Subp, Global_Mode, Refined => True), Kind); + end Handle_Globals_Of_Mode; + + -- Start of processing for Handle_Globals begin - -- Check if SPARK pragma is not set to Off + Handle_Globals_Of_Mode (Name_Proof_In); + Handle_Globals_Of_Mode (Name_Input); + Handle_Globals_Of_Mode (Name_Output); + Handle_Globals_Of_Mode (Name_In_Out); + end Handle_Globals; - if Present (SPARK_Pragma (Defining_Entity (Body_N))) then - if Get_SPARK_Mode_From_Annotation - (SPARK_Pragma (Defining_Entity (Body_N, False))) /= Opt.On - then - return; - end if; - else - return; - end if; + ---------- + -- "<=" -- + ---------- - -- Save environment and put a new one in place + function "<=" (P1, P2 : Perm_Kind) return Boolean is + begin + return P2 >= P1; + end "<="; - Copy_Env (Current_Perm_Env, Saved_Env); + ---------- + -- ">=" -- + ---------- - -- Save initialization map + function ">=" (P1, P2 : Perm_Kind) return Boolean is + begin + case P2 is + when No_Access => return True; + when Read_Only => return P1 in Read_Perm; + when Write_Only => return P1 in Write_Perm; + when Read_Write => return P1 = Read_Write; + end case; + end ">="; - Copy_Init_Map (Current_Initialization_Map, Saved_Init_Map); - Current_Checking_Mode := Read; - Current_Perm_Env := New_Env; + ---------------------- + -- Check_Assignment -- + ---------------------- - -- Add formals and globals to the environment with adequate permissions + procedure Check_Assignment (Target : Node_Or_Entity_Id; Expr : Node_Id) is - if Is_Subprogram_Or_Entry (Spec_Id) then - Setup_Parameters (Spec_Id); - Setup_Globals (Spec_Id); - end if; + -- Local subprograms - -- Analyze the body of the function + procedure Handle_Borrow + (Var : Entity_Id; + Expr : Node_Id; + Is_Decl : Boolean); + -- Update map of current borrowers - Check_List (Declarations (Body_N)); - Check_Node (Handled_Statement_Sequence (Body_N)); + procedure Handle_Observe + (Var : Entity_Id; + Expr : Node_Id; + Is_Decl : Boolean); + -- Update map of current observers - -- Check the read-write permissions of borrowed parameters/globals + ------------------- + -- Handle_Borrow -- + ------------------- - if Ekind_In (Spec_Id, E_Procedure, E_Entry) - and then not No_Return (Spec_Id) - then - Return_Globals (Spec_Id); - end if; + procedure Handle_Borrow + (Var : Entity_Id; + Expr : Node_Id; + Is_Decl : Boolean) + is + Borrowed : constant Node_Id := Get_Observed_Or_Borrowed_Expr (Expr); - -- Free the environments + begin + -- SPARK RM 3.10(8): If the type of the target is an anonymous + -- access-to-variable type (an owning access type), the source shall + -- be an owning access object [..] whose root object is the target + -- object itself. - Free_Env (Current_Perm_Env); - Copy_Env (Saved_Env, Current_Perm_Env); - Free_Env (Saved_Env); + -- ??? In fact we could be slightly more permissive in allowing even + -- a call to a traversal function of the right form. - -- Restore initialization map + if not Is_Decl + and then (Is_Traversal_Function_Call (Expr) + or else Get_Root_Object (Borrowed) /= Var) + then + Error_Msg_NE + ("source of assignment must have & as root (SPARK RM 3.10(8)))", + Expr, Var); + return; + end if; - Copy_Init_Map (Saved_Init_Map, Current_Initialization_Map); - Reset (Saved_Init_Map); + Set (Current_Borrowers, Var, Borrowed); + end Handle_Borrow; - -- The assignment of all out parameters will be done by caller + -------------------- + -- Handle_Observe -- + -------------------- - Current_Checking_Mode := Mode_Before; - end Check_Callable_Body; + procedure Handle_Observe + (Var : Entity_Id; + Expr : Node_Id; + Is_Decl : Boolean) + is + Observed : constant Node_Id := Get_Observed_Or_Borrowed_Expr (Expr); - ----------------------- - -- Check_Declaration -- - ----------------------- + begin + -- ??? We are currently using the same restriction for observers + -- as for borrowers. To be seen if the SPARK RM current rule really + -- allows more uses. - procedure Check_Declaration (Decl : Node_Id) is - Target_Ent : constant Entity_Id := Defining_Identifier (Decl); - Target_Typ : Node_Id renames Etype (Target_Ent); + if not Is_Decl + and then (Is_Traversal_Function_Call (Expr) + or else Get_Root_Object (Observed) /= Var) + then + Error_Msg_NE + ("source of assignment must have & as root (SPARK RM 3.10(8)))", + Expr, Var); + return; + end if; - Target_View_Typ : Entity_Id; + Set (Current_Observers, Var, Observed); + end Handle_Observe; - Check : Boolean := True; - begin - if Present (Full_View (Target_Typ)) then - Target_View_Typ := Full_View (Target_Typ); - else - Target_View_Typ := Target_Typ; - end if; + -- Local variables - case N_Declaration'(Nkind (Decl)) is - when N_Full_Type_Declaration => - if not Has_Ownership_Aspect_True (Target_Ent, "type declaration") - then - Check := False; - end if; + Target_Typ : constant Node_Id := Etype (Target); + Is_Decl : constant Boolean := Nkind (Target) = N_Defining_Identifier; + Target_Root : Entity_Id; + Expr_Root : Entity_Id; + Perm : Perm_Kind; + Status : Error_Status; - -- ??? What about component declarations with defaults. + -- Start of processing for Check_Assignment - when N_Object_Declaration => - if (Is_Access_Type (Target_View_Typ) - or else Is_Deep (Target_Typ)) - and then not Has_Ownership_Aspect_True - (Target_Ent, "Object declaration ") - then - Check := False; - end if; + begin + Check_Type (Target_Typ); - if Is_Anonymous_Access_Type (Target_View_Typ) - and then not Present (Expression (Decl)) - then + if Is_Anonymous_Access_Type (Target_Typ) then + Check_Source_Of_Borrow_Or_Observe (Expr, Status); - -- ??? Check the case of default value (AI) - -- ??? How an anonymous access type can be with default exp? + if Status /= OK then + return; + end if; - Error_Msg_NE ("? object declaration & has OAF (Anonymous " - & "access-to-object with no initialization)", - Decl, Target_Ent); + if Is_Decl then + Target_Root := Target; + else + Target_Root := Get_Root_Object (Target); + end if; - -- If it it an initialization + Expr_Root := Get_Root_Object (Expr); - elsif Present (Expression (Decl)) and Check then + -- SPARK RM 3.10(8): For an assignment statement where + -- the target is a stand-alone object of an anonymous + -- access-to-object type - -- Find out the operation to be done on the right-hand side + pragma Assert (Present (Target_Root)); - -- Initializing object, access type + -- If the type of the target is an anonymous + -- access-to-constant type (an observing access type), the + -- source shall be an owning access object denoted by a name + -- that is not in the Moved state, and whose root object + -- is not in the Moved state and is not declared at a + -- statically deeper accessibility level than that of + -- the target object. - if Is_Access_Type (Target_View_Typ) then + if Is_Access_Constant (Target_Typ) then + Perm := Get_Perm (Expr); - -- Initializing object, constant access type + if Perm = No_Access then + Perm_Error (Expr, No_Access, No_Access, + Forbidden_Perm => True); + return; + end if; - if Is_Constant_Object (Target_Ent) then + Perm := Get_Perm (Expr_Root); - -- Initializing object, constant access to variable type + if Perm = No_Access then + Perm_Error (Expr, No_Access, No_Access, + Forbidden_Perm => True); + return; + end if; - if not Is_Access_Constant (Target_View_Typ) then - Current_Checking_Mode := Borrow; + -- ??? check accessibility level - -- Initializing object, constant access to constant type + -- If the type of the target is an anonymous + -- access-to-variable type (an owning access type), the + -- source shall be an owning access object denoted by a + -- name that is in the Unrestricted state, and whose root + -- object is the target object itself. - -- Initializing object, - -- constant access to constant anonymous type. + Check_Expression (Expr, Observe); + Handle_Observe (Target_Root, Expr, Is_Decl); - elsif Is_Anonymous_Access_Type (Target_View_Typ) then + else + Perm := Get_Perm (Expr); - -- This is an object declaration so the target - -- of the assignement is a stand-alone object. + if Perm /= Read_Write then + Perm_Error (Expr, Read_Write, Perm); + return; + end if; - Current_Checking_Mode := Observe; + if not Is_Decl then + if not Is_Entity_Name (Target) then + Error_Msg_N + ("target of borrow must be stand-alone variable", + Target); + return; - -- Initializing object, constant access to constant - -- named type. + elsif Target_Root /= Expr_Root then + Error_Msg_NE + ("source of borrow must be variable &", + Expr, Target); + return; + end if; + end if; - else - -- If named then it is a general access type - -- Hence, Has_Ownership_Aspec_True is False. + Check_Expression (Expr, Borrow); + Handle_Borrow (Target_Root, Expr, Is_Decl); + end if; - raise Program_Error; - end if; + elsif Is_Deep (Target_Typ) then - -- Initializing object, variable access type + if Is_Path_Expression (Expr) then + Check_Expression (Expr, Move); + + else + Error_Msg_N ("expression not allowed as source of move", Expr); + return; + end if; - else - -- Initializing object, variable access to variable type + else + Check_Expression (Expr, Read); + end if; + end Check_Assignment; - if not Is_Access_Constant (Target_View_Typ) then + -------------------------- + -- Check_Call_Statement -- + -------------------------- - -- Initializing object, variable named access to - -- variable type. + procedure Check_Call_Statement (Call : Node_Id) is - if not Is_Anonymous_Access_Type (Target_View_Typ) then - Current_Checking_Mode := Move; + Subp : constant Entity_Id := Get_Called_Entity (Call); - -- Initializing object, variable anonymous access to - -- variable type. + -- Local subprograms - else - -- This is an object declaration so the target - -- object of the assignement is a stand-alone - -- object. + procedure Check_Param (Formal : Entity_Id; Actual : Node_Id); + -- Check the permission of every actual parameter - Current_Checking_Mode := Borrow; - end if; + procedure Update_Param (Formal : Entity_Id; Actual : Node_Id); + -- Update the permission of OUT actual parameters - -- Initializing object, variable access to constant type + ----------------- + -- Check_Param -- + ----------------- - else - -- Initializing object, - -- variable named access to constant type. + procedure Check_Param (Formal : Entity_Id; Actual : Node_Id) is + begin + Check_Parameter_Or_Global + (Expr => Actual, + Typ => Underlying_Type (Etype (Formal)), + Kind => Ekind (Formal), + Subp => Subp, + Global_Var => False); + end Check_Param; - if not Is_Anonymous_Access_Type (Target_View_Typ) then - Error_Msg_N ("assignment not allowed, Ownership " - & "Aspect False (Anonymous Access " - & "Object)", Decl); - Check := False; + ------------------ + -- Update_Param -- + ------------------ - -- Initializing object, - -- variable anonymous access to constant type. + procedure Update_Param (Formal : Entity_Id; Actual : Node_Id) is + Mode : constant Entity_Kind := Ekind (Formal); - else - -- This is an object declaration so the target - -- of the assignement is a stand-alone object. + begin + case Formal_Kind'(Mode) is + when E_Out_Parameter => + Check_Expression (Actual, Assign); - Current_Checking_Mode := Observe; - end if; - end if; - end if; + when others => + null; + end case; + end Update_Param; - -- Initializing object, composite (deep) type + procedure Check_Params is new + Iterate_Call_Parameters (Check_Param); - elsif Is_Deep (Target_Typ) then + procedure Update_Params is new + Iterate_Call_Parameters (Update_Param); - -- Initializing object, constant composite type + -- Start of processing for Check_Call_Statement - if Is_Constant_Object (Target_Ent) then - Current_Checking_Mode := Observe; + begin + Inside_Procedure_Call := True; + Check_Params (Call); + Check_Globals (Get_Called_Entity (Call)); - -- Initializing object, variable composite type + Inside_Procedure_Call := False; + Update_Params (Call); + end Check_Call_Statement; - else + ------------------------- + -- Check_Callable_Body -- + ------------------------- - -- Initializing object, variable anonymous composite type + procedure Check_Callable_Body (Body_N : Node_Id) is + Save_In_Elab : constant Boolean := Inside_Elaboration; + Body_Id : constant Entity_Id := Defining_Entity (Body_N); + Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); + Prag : constant Node_Id := SPARK_Pragma (Body_Id); - if Nkind (Object_Definition (Decl)) = - N_Constrained_Array_Definition + Saved_Env : Perm_Env; + Saved_Borrowers : Variable_Mapping; + Saved_Observers : Variable_Mapping; - -- An N_Constrained_Array_Definition is an anonymous - -- array (to be checked). Record types are always - -- named and are considered in the else part. + begin + -- Only SPARK bodies are analyzed - then - declare - Com_Ty : constant Node_Id := - Component_Type (Etype (Target_Typ)); - begin + if No (Prag) + or else Get_SPARK_Mode_From_Annotation (Prag) /= Opt.On + then + return; + end if; - if Is_Access_Type (Com_Ty) then + Inside_Elaboration := False; - -- If components are of anonymous type + -- Save environment and put a new one in place - if Is_Anonymous_Access_Type (Com_Ty) then - if Is_Access_Constant (Com_Ty) then - Current_Checking_Mode := Observe; + Move_Env (Current_Perm_Env, Saved_Env); + Move_Variable_Mapping (Current_Borrowers, Saved_Borrowers); + Move_Variable_Mapping (Current_Observers, Saved_Observers); - else - Current_Checking_Mode := Borrow; - end if; + -- Add formals and globals to the environment with adequate permissions - else - Current_Checking_Mode := Move; - end if; + if Is_Subprogram_Or_Entry (Spec_Id) then + Setup_Parameters (Spec_Id); + Setup_Globals (Spec_Id); + end if; - elsif Is_Deep (Com_Ty) then + -- Analyze the body of the subprogram - -- This is certainly named so it is a move + Check_List (Declarations (Body_N)); + Check_Node (Handled_Statement_Sequence (Body_N)); - Current_Checking_Mode := Move; - end if; - end; + -- Check the read-write permissions of borrowed parameters/globals - else - Current_Checking_Mode := Move; - end if; - end if; + if Ekind_In (Spec_Id, E_Procedure, E_Entry) + and then not No_Return (Spec_Id) + then + Return_Parameters (Spec_Id); + Return_Globals (Spec_Id); + end if; - end if; - end if; + -- Restore the saved environment and free the current one - if Check then - Check_Node (Expression (Decl)); - end if; + Move_Env (Saved_Env, Current_Perm_Env); + Move_Variable_Mapping (Saved_Borrowers, Current_Borrowers); + Move_Variable_Mapping (Saved_Observers, Current_Observers); - -- If lhs is not a pointer, we still give it the unrestricted - -- state which is useless but not harmful. + Inside_Elaboration := Save_In_Elab; + end Check_Callable_Body; - declare - Elem : Perm_Tree_Access; - Deep : constant Boolean := Is_Deep (Target_Typ); + ----------------------- + -- Check_Declaration -- + ----------------------- - begin - -- Note that all declared variables are set to the unrestricted - -- state. - -- - -- If variables are not initialized: - -- unrestricted to every declared object. - -- Exp: - -- R : Rec - -- S : Rec := (...) - -- R := S - -- The assignement R := S is not allowed in the new rules - -- if R is not unrestricted. - -- - -- If variables are initialized: - -- If it is a move, then the target is unrestricted - -- If it is a borrow, then the target is unrestricted - -- If it is an observe, then the target should be observed - - if Current_Checking_Mode = Observe then - Elem := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Deep, - Permission => Observed, - Children_Permission => Observed)); - else - Elem := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Deep, - Permission => Unrestricted, - Children_Permission => Unrestricted)); - end if; + procedure Check_Declaration (Decl : Node_Id) is + Target : constant Entity_Id := Defining_Identifier (Decl); + Target_Typ : constant Node_Id := Etype (Target); + Expr : Node_Id; - -- Create new tree for defining identifier + begin + case N_Declaration'(Nkind (Decl)) is + when N_Full_Type_Declaration => + Check_Type (Target); - Set (Current_Perm_Env, - Unique_Entity (Defining_Identifier (Decl)), - Elem); - pragma Assert (Get_First (Current_Perm_Env) /= null); - end; + -- ??? What about component declarations with defaults. when N_Subtype_Declaration => - Check_Node (Subtype_Indication (Decl)); + Check_Expression (Subtype_Indication (Decl), Read); + + when N_Object_Declaration => + Check_Type (Target_Typ); + + Expr := Expression (Decl); + if Present (Expr) then + Check_Assignment (Target => Target, + Expr => Expr); + end if; + + if Is_Deep (Target_Typ) then + declare + Tree : constant Perm_Tree_Access := + new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => True, + Permission => Read_Write, + Children_Permission => Read_Write)); + begin + Set (Current_Perm_Env, Target, Tree); + end; + end if; when N_Iterator_Specification => null; @@ -1147,318 +1375,401 @@ package body Sem_SPARK is -- Check_Expression -- ---------------------- - procedure Check_Expression (Expr : Node_Id) is - Mode_Before : constant Checking_Mode := Current_Checking_Mode; - begin - case N_Subexpr'(Nkind (Expr)) is - when N_Procedure_Call_Statement - | N_Function_Call - => - Check_Call_Statement (Expr); + procedure Check_Expression (Expr : Node_Id; Mode : Checking_Mode) is - when N_Identifier - | N_Expanded_Name - => - -- Check if identifier is pointing to nothing (On/Off/...) + -- Local subprograms - if not Present (Entity (Expr)) then - return; - end if; + function Is_Type_Name (Expr : Node_Id) return Boolean; + -- Detect when a path expression is in fact a type name - -- Do not analyze things that are not of object Kind + procedure Read_Expression (Expr : Node_Id); + -- Most subexpressions are only analyzed in Read mode. This is a + -- specialized version of Check_Expression for that case. - if Ekind (Entity (Expr)) not in Object_Kind then - return; - end if; + procedure Read_Expression_List (L : List_Id); + -- Call Read_Expression on every expression in the list L - -- Consider as ident + procedure Read_Indexes (Expr : Node_Id); + pragma Precondition (Is_Path_Expression (Expr)); + -- When processing a path, the index expressions and function call + -- arguments occurring on the path should be analyzed in Read mode. - Process_Path (Expr); + ------------------ + -- Is_Type_Name -- + ------------------ - -- Switch to read mode and then check the readability of each operand + function Is_Type_Name (Expr : Node_Id) return Boolean is + begin + return Nkind_In (Expr, N_Expanded_Name, N_Identifier) + and then Is_Type (Entity (Expr)); + end Is_Type_Name; - when N_Binary_Op => - Current_Checking_Mode := Read; - Check_Node (Left_Opnd (Expr)); - Check_Node (Right_Opnd (Expr)); + --------------------- + -- Read_Expression -- + --------------------- - -- Switch to read mode and then check the readability of each operand + procedure Read_Expression (Expr : Node_Id) is + begin + Check_Expression (Expr, Read); + end Read_Expression; - when N_Op_Abs - | N_Op_Minus - | N_Op_Not - | N_Op_Plus - => - Current_Checking_Mode := Read; - Check_Node (Right_Opnd (Expr)); + -------------------------- + -- Read_Expression_List -- + -------------------------- - -- Forbid all deep expressions for Attribute ??? - -- What about generics? (formal parameters). + procedure Read_Expression_List (L : List_Id) is + N : Node_Id; + begin + N := First (L); + while Present (N) loop + Read_Expression (N); + Next (N); + end loop; + end Read_Expression_List; - when N_Attribute_Reference => - case Attribute_Name (Expr) is - when Name_Access => - Error_Msg_N ("access attribute not allowed", Expr); + ------------------ + -- Read_Indexes -- + ------------------ - when Name_Last - | Name_First - => - Current_Checking_Mode := Read; - Check_Node (Prefix (Expr)); + procedure Read_Indexes (Expr : Node_Id) is - when Name_Min => - Current_Checking_Mode := Read; - Check_Node (Prefix (Expr)); + -- Local subprograms - when Name_Image => - Check_List (Expressions (Expr)); + procedure Read_Param (Formal : Entity_Id; Actual : Node_Id); - when Name_Img => - Check_Node (Prefix (Expr)); + ---------------- + -- Read_Param -- + ---------------- - when Name_SPARK_Mode => - null; + procedure Read_Param (Formal : Entity_Id; Actual : Node_Id) is + pragma Unreferenced (Formal); + begin + Read_Expression (Actual); + end Read_Param; - when Name_Value => - Current_Checking_Mode := Read; - Check_Node (Prefix (Expr)); + procedure Read_Params is new Iterate_Call_Parameters (Read_Param); - when Name_Update => - Check_List (Expressions (Expr)); - Check_Node (Prefix (Expr)); + -- Start of processing for Read_Indexes - when Name_Pred - | Name_Succ - => - Check_List (Expressions (Expr)); - Check_Node (Prefix (Expr)); - - when Name_Length => - Current_Checking_Mode := Read; - Check_Node (Prefix (Expr)); - - -- Any Attribute referring to the underlying memory is ignored - -- in the analysis. This means that taking the address of a - -- variable makes a silent alias that is not rejected by the - -- analysis. - - when Name_Address - | Name_Alignment - | Name_Component_Size - | Name_First_Bit - | Name_Last_Bit - | Name_Size - | Name_Position - => - null; + begin + case N_Subexpr'(Nkind (Expr)) is + when N_Identifier + | N_Expanded_Name + | N_Null + => + null; - -- Attributes referring to types (get values from types), hence - -- no need to check either for borrows or any loans. + when N_Explicit_Dereference + | N_Selected_Component + => + Read_Indexes (Prefix (Expr)); - when Name_Base - | Name_Val - => - null; - -- Other attributes that fall out of the scope of the analysis + when N_Indexed_Component => + Read_Indexes (Prefix (Expr)); + Read_Expression_List (Expressions (Expr)); - when others => - null; - end case; + when N_Slice => + Read_Indexes (Prefix (Expr)); + Read_Expression (Discrete_Range (Expr)); - when N_In => - Current_Checking_Mode := Read; - Check_Node (Left_Opnd (Expr)); - Check_Node (Right_Opnd (Expr)); + when N_Allocator => + Read_Expression (Expression (Expr)); - when N_Not_In => - Current_Checking_Mode := Read; - Check_Node (Left_Opnd (Expr)); - Check_Node (Right_Opnd (Expr)); + when N_Function_Call => + Read_Params (Expr); + Check_Globals (Get_Called_Entity (Expr)); - -- Switch to read mode and then check the readability of each operand + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => + Read_Indexes (Expression (Expr)); - when N_And_Then - | N_Or_Else - => - Current_Checking_Mode := Read; - Check_Node (Left_Opnd (Expr)); - Check_Node (Right_Opnd (Expr)); + when others => + raise Program_Error; + end case; + end Read_Indexes; - -- Check the arguments of the call + -- Start of processing for Check_Expression - when N_Explicit_Dereference => - Process_Path (Expr); + begin + if Is_Type_Name (Expr) then + return; - -- Copy environment, run on each branch, and then merge + elsif Is_Path_Expression (Expr) then + Read_Indexes (Expr); + Process_Path (Expr, Mode); + return; + end if; - when N_If_Expression => - declare - Saved_Env : Perm_Env; + -- Expressions that are not path expressions should only be analyzed in + -- Read mode. - -- Accumulator for the different branches + pragma Assert (Mode = Read); - New_Env : Perm_Env; - Elmt : Node_Id := First (Expressions (Expr)); + -- Special handling for nodes that may contain evaluated expressions in + -- the form of constraints. + case Nkind (Expr) is + when N_Index_Or_Discriminant_Constraint => + declare + Assn : Node_Id := First (Constraints (Expr)); begin - Current_Checking_Mode := Read; - Check_Node (Elmt); - Current_Checking_Mode := Mode_Before; + while Present (Assn) loop + case Nkind (Assn) is + when N_Discriminant_Association => + Read_Expression (Expression (Assn)); - -- Save environment + when others => + Read_Expression (Assn); + end case; - Copy_Env (Current_Perm_Env, Saved_Env); + Next (Assn); + end loop; + end; + return; - -- Here we have the original env in saved, current with a fresh - -- copy, and new aliased. + when N_Range_Constraint => + Read_Expression (Range_Expression (Expr)); + return; - -- THEN PART + when N_Subtype_Indication => + if Present (Constraint (Expr)) then + Read_Expression (Constraint (Expr)); + end if; + return; - Next (Elmt); - Check_Node (Elmt); + when others => + null; + end case; - -- Here the new_environment contains curr env after then block + -- At this point Expr can only be a subexpression - -- ELSE part - -- Restore environment before if - Copy_Env (Current_Perm_Env, New_Env); - Free_Env (Current_Perm_Env); - Copy_Env (Saved_Env, Current_Perm_Env); + case N_Subexpr'(Nkind (Expr)) is - -- Here new environment contains the environment after then and - -- current the fresh copy of old one. + when N_Binary_Op + | N_Membership_Test + | N_Short_Circuit + => + Read_Expression (Left_Opnd (Expr)); + Read_Expression (Right_Opnd (Expr)); - Next (Elmt); - Check_Node (Elmt); + when N_Unary_Op => + Read_Expression (Right_Opnd (Expr)); - -- CLEANUP + when N_Attribute_Reference => + declare + Aname : constant Name_Id := Attribute_Name (Expr); + Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); + Pref : constant Node_Id := Prefix (Expr); + Args : constant List_Id := Expressions (Expr); - Copy_Env (New_Env, Current_Perm_Env); - Free_Env (New_Env); - Free_Env (Saved_Env); - end; + begin + case Attr_Id is + + -- The following attributes take either no arguments, or + -- arguments that do not refer to evaluated expressions + -- (like Length or Loop_Entry), hence only the prefix + -- needs to be read. + + when Attribute_Address + | Attribute_Alignment + | Attribute_Callable + | Attribute_Component_Size + | Attribute_Constrained + | Attribute_First + | Attribute_First_Bit + | Attribute_Last + | Attribute_Last_Bit + | Attribute_Length + | Attribute_Loop_Entry + | Attribute_Object_Size + | Attribute_Position + | Attribute_Size + | Attribute_Terminated + | Attribute_Valid + | Attribute_Value_Size + => + Read_Expression (Pref); + + -- The following attributes take a type name as prefix, + -- hence only the arguments need to be read. + + when Attribute_Ceiling + | Attribute_Floor + | Attribute_Max + | Attribute_Min + | Attribute_Mod + | Attribute_Pos + | Attribute_Pred + | Attribute_Remainder + | Attribute_Rounding + | Attribute_Succ + | Attribute_Truncation + | Attribute_Val + | Attribute_Value + => + Read_Expression_List (Args); - when N_Indexed_Component => - Process_Path (Expr); + -- Attributes Image and Img either take a type name as + -- prefix with an expression in argument, or the expression + -- directly as prefix. Adapt to each case. - -- Analyze the expression that is getting qualified + when Attribute_Image + | Attribute_Img + => + if No (Args) then + Read_Expression (Pref); + else + Read_Expression_List (Args); + end if; - when N_Qualified_Expression => - Check_Node (Expression (Expr)); + -- Attribute Update takes expressions as both prefix and + -- arguments, so both need to be read. - when N_Quantified_Expression => - declare - Saved_Env : Perm_Env; + when Attribute_Update => + Read_Expression (Pref); + Read_Expression_List (Args); - begin - Copy_Env (Current_Perm_Env, Saved_Env); - Current_Checking_Mode := Read; - Check_Node (Iterator_Specification (Expr)); - Check_Node (Loop_Parameter_Specification (Expr)); + -- Attribute Modulus does not reference the evaluated + -- expression, so it can be ignored for this analysis. - Check_Node (Condition (Expr)); - Free_Env (Current_Perm_Env); - Copy_Env (Saved_Env, Current_Perm_Env); - Free_Env (Saved_Env); + when Attribute_Modulus => + null; + + -- Postconditions should not be analyzed + + when Attribute_Old + | Attribute_Result + => + raise Program_Error; + + when others => + Error_Msg_Name_1 := Aname; + Error_Msg_N ("attribute % not allowed in SPARK", Expr); + end case; end; - -- Analyze the list of associations in the aggregate - when N_Aggregate => - Check_List (Expressions (Expr)); - Check_List (Component_Associations (Expr)); + when N_Range => + Read_Expression (Low_Bound (Expr)); + Read_Expression (High_Bound (Expr)); - when N_Allocator => - Check_Node (Expression (Expr)); + when N_If_Expression => + Read_Expression_List (Expressions (Expr)); when N_Case_Expression => declare - Saved_Env : Perm_Env; - - -- Accumulator for the different branches - - New_Env : Perm_Env; - Elmt : Node_Id := First (Alternatives (Expr)); + Cases : constant List_Id := Alternatives (Expr); + Cur_Case : Node_Id := First (Cases); begin - Current_Checking_Mode := Read; - Check_Node (Expression (Expr)); - Current_Checking_Mode := Mode_Before; + while Present (Cur_Case) loop + Read_Expression (Expression (Cur_Case)); + Next (Cur_Case); + end loop; - -- Save environment + Read_Expression (Expression (Expr)); + end; - Copy_Env (Current_Perm_Env, Saved_Env); + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => + Read_Expression (Expression (Expr)); - -- Here we have the original env in saved, current with a fresh - -- copy, and new aliased. + when N_Quantified_Expression => + declare + For_In_Spec : constant Node_Id := + Loop_Parameter_Specification (Expr); + For_Of_Spec : constant Node_Id := + Iterator_Specification (Expr); + For_Of_Spec_Typ : Node_Id; - -- First alternative + begin + if Present (For_In_Spec) then + Read_Expression (Discrete_Subtype_Definition (For_In_Spec)); + else + Read_Expression (Name (For_Of_Spec)); + For_Of_Spec_Typ := Subtype_Indication (For_Of_Spec); + if Present (For_Of_Spec_Typ) then + Read_Expression (For_Of_Spec_Typ); + end if; + end if; - Check_Node (Elmt); - Next (Elmt); - Copy_Env (Current_Perm_Env, New_Env); - Free_Env (Current_Perm_Env); + Read_Expression (Condition (Expr)); + end; - -- Other alternatives + when N_Aggregate => + declare + Assocs : constant List_Id := Component_Associations (Expr); + Assoc : Node_Id := First (Assocs); + CL : List_Id; + Choice : Node_Id; - while Present (Elmt) loop + begin + while Present (Assoc) loop + + -- An array aggregate with a single component association + -- may have a nonstatic choice expression that needs to be + -- analyzed. This can only occur for a single choice that + -- is not the OTHERS one. + + if Is_Array_Type (Etype (Expr)) then + CL := Choices (Assoc); + if List_Length (CL) = 1 then + Choice := First (CL); + if Nkind (Choice) /= N_Others_Choice then + Read_Expression (Choice); + end if; + end if; + end if; - -- Restore environment + -- The expression in the component association also needs to + -- be analyzed. - Copy_Env (Saved_Env, Current_Perm_Env); - Check_Node (Elmt); - Next (Elmt); + Read_Expression (Expression (Assoc)); + Next (Assoc); end loop; - -- CLEANUP - Copy_Env (Saved_Env, Current_Perm_Env); - Free_Env (New_Env); - Free_Env (Saved_Env); + Read_Expression_List (Expressions (Expr)); end; - -- Analyze the list of associates in the aggregate as well as the - -- ancestor part. when N_Extension_Aggregate => - Check_Node (Ancestor_Part (Expr)); - Check_List (Expressions (Expr)); - - when N_Range => - Check_Node (Low_Bound (Expr)); - Check_Node (High_Bound (Expr)); - - -- We arrived at a path. Process it. - - when N_Selected_Component => - Process_Path (Expr); + Read_Expression (Ancestor_Part (Expr)); + Read_Expression_List (Expressions (Expr)); - when N_Slice => - Process_Path (Expr); - - when N_Type_Conversion => - Check_Node (Expression (Expr)); + when N_Character_Literal + | N_Numeric_Or_String_Literal + | N_Operator_Symbol + | N_Raise_Expression + | N_Raise_xxx_Error + => + null; - when N_Unchecked_Type_Conversion => - Check_Node (Expression (Expr)); + when N_Delta_Aggregate + | N_Target_Name + => + Error_Msg_N ("unsupported construct in SPARK", Expr); - -- Checking should not be called directly on these nodes + -- Procedure calls are handled in Check_Node - when N_Target_Name => + when N_Procedure_Call_Statement => raise Program_Error; - -- Unsupported constructs in SPARK - - when N_Delta_Aggregate => - Error_Msg_N ("unsupported construct in SPARK", Expr); - - -- Ignored constructs for pointer checking + -- Path expressions are handled before this point - when N_Character_Literal + when N_Allocator + | N_Expanded_Name + | N_Explicit_Dereference + | N_Function_Call + | N_Identifier + | N_Indexed_Component | N_Null - | N_Numeric_Or_String_Literal - | N_Operator_Symbol - | N_Raise_Expression - | N_Raise_xxx_Error + | N_Selected_Component + | N_Slice => - null; + raise Program_Error; + -- The following nodes are never generated in GNATprove mode when N_Expression_With_Actions @@ -1469,171 +1780,344 @@ package body Sem_SPARK is end case; end Check_Expression; - ------------------- - -- Check_Globals -- - ------------------- + ---------------- + -- Check_List -- + ---------------- - procedure Check_Globals (N : Node_Id) is + procedure Check_List (L : List_Id) is + N : Node_Id; begin - if Nkind (N) = N_Empty then - return; - end if; + N := First (L); + while Present (N) loop + Check_Node (N); + Next (N); + end loop; + end Check_List; - declare - pragma Assert (List_Length (Pragma_Argument_Associations (N)) = 1); - PAA : constant Node_Id := First (Pragma_Argument_Associations (N)); - pragma Assert (Nkind (PAA) = N_Pragma_Argument_Association); - Row : Node_Id; - The_Mode : Name_Id; - RHS : Node_Id; - - procedure Process (Mode : Name_Id; The_Global : Entity_Id); - procedure Process (Mode : Name_Id; The_Global : Node_Id) is - Ident_Elt : constant Entity_Id := - Unique_Entity (Entity (The_Global)); - Mode_Before : constant Checking_Mode := Current_Checking_Mode; + -------------------------- + -- Check_Loop_Statement -- + -------------------------- + procedure Check_Loop_Statement (Stmt : Node_Id) is + + -- Local Subprograms + + procedure Check_Is_Less_Restrictive_Env + (Exiting_Env : Perm_Env; + Entry_Env : Perm_Env); + -- This procedure checks that the Exiting_Env environment is less + -- restrictive than the Entry_Env environment. + + procedure Check_Is_Less_Restrictive_Tree + (New_Tree : Perm_Tree_Access; + Orig_Tree : Perm_Tree_Access; + E : Entity_Id); + -- Auxiliary procedure to check that the tree New_Tree is less + -- restrictive than the tree Orig_Tree for the entity E. + + procedure Perm_Error_Loop_Exit + (E : Entity_Id; + Loop_Id : Node_Id; + Perm : Perm_Kind; + Found_Perm : Perm_Kind); + -- A procedure that is called when the permissions found contradict + -- the rules established by the RM at the exit of loops. This function + -- is called with the entity, the node of the enclosing loop, the + -- permission that was expected, and the permission found, and issues + -- an appropriate error message. + + ----------------------------------- + -- Check_Is_Less_Restrictive_Env -- + ----------------------------------- + + procedure Check_Is_Less_Restrictive_Env + (Exiting_Env : Perm_Env; + Entry_Env : Perm_Env) + is + Comp_Entry : Perm_Tree_Maps.Key_Option; + Iter_Entry, Iter_Exit : Perm_Tree_Access; + + begin + Comp_Entry := Get_First_Key (Entry_Env); + while Comp_Entry.Present loop + Iter_Entry := Get (Entry_Env, Comp_Entry.K); + pragma Assert (Iter_Entry /= null); + Iter_Exit := Get (Exiting_Env, Comp_Entry.K); + pragma Assert (Iter_Exit /= null); + Check_Is_Less_Restrictive_Tree + (New_Tree => Iter_Exit, + Orig_Tree => Iter_Entry, + E => Comp_Entry.K); + Comp_Entry := Get_Next_Key (Entry_Env); + end loop; + end Check_Is_Less_Restrictive_Env; + + ------------------------------------ + -- Check_Is_Less_Restrictive_Tree -- + ------------------------------------ + + procedure Check_Is_Less_Restrictive_Tree + (New_Tree : Perm_Tree_Access; + Orig_Tree : Perm_Tree_Access; + E : Entity_Id) + is + -- Local subprograms + + procedure Check_Is_Less_Restrictive_Tree_Than + (Tree : Perm_Tree_Access; + Perm : Perm_Kind; + E : Entity_Id); + -- Auxiliary procedure to check that the tree N is less restrictive + -- than the given permission P. + + procedure Check_Is_More_Restrictive_Tree_Than + (Tree : Perm_Tree_Access; + Perm : Perm_Kind; + E : Entity_Id); + -- Auxiliary procedure to check that the tree N is more restrictive + -- than the given permission P. + + ----------------------------------------- + -- Check_Is_Less_Restrictive_Tree_Than -- + ----------------------------------------- + + procedure Check_Is_Less_Restrictive_Tree_Than + (Tree : Perm_Tree_Access; + Perm : Perm_Kind; + E : Entity_Id) + is begin - if Ekind (Ident_Elt) = E_Abstract_State then - return; + if not (Permission (Tree) >= Perm) then + Perm_Error_Loop_Exit + (E, Stmt, Permission (Tree), Perm); end if; - case Mode is - when Name_Input - | Name_Proof_In - => - Current_Checking_Mode := Observe; - Check_Node (The_Global); - when Name_Output - | Name_In_Out - => - -- ??? Borrow not Move? - Current_Checking_Mode := Borrow; - Check_Node (The_Global); + case Kind (Tree) is + when Entire_Object => + if not (Children_Permission (Tree) >= Perm) then + Perm_Error_Loop_Exit + (E, Stmt, Children_Permission (Tree), Perm); - when others => - raise Program_Error; + end if; + + when Reference => + Check_Is_Less_Restrictive_Tree_Than + (Get_All (Tree), Perm, E); + + when Array_Component => + Check_Is_Less_Restrictive_Tree_Than + (Get_Elem (Tree), Perm, E); + + when Record_Component => + declare + Comp : Perm_Tree_Access; + begin + Comp := Perm_Tree_Maps.Get_First (Component (Tree)); + while Comp /= null loop + Check_Is_Less_Restrictive_Tree_Than (Comp, Perm, E); + Comp := + Perm_Tree_Maps.Get_Next (Component (Tree)); + end loop; + end; end case; - Current_Checking_Mode := Mode_Before; - end Process; + end Check_Is_Less_Restrictive_Tree_Than; - begin - if Nkind (Expression (PAA)) = N_Null then + ----------------------------------------- + -- Check_Is_More_Restrictive_Tree_Than -- + ----------------------------------------- - -- global => null - -- No globals, nothing to do + procedure Check_Is_More_Restrictive_Tree_Than + (Tree : Perm_Tree_Access; + Perm : Perm_Kind; + E : Entity_Id) + is + begin + if not (Perm >= Permission (Tree)) then + Perm_Error_Loop_Exit + (E, Stmt, Permission (Tree), Perm); + end if; - return; + case Kind (Tree) is + when Entire_Object => + if not (Perm >= Children_Permission (Tree)) then + Perm_Error_Loop_Exit + (E, Stmt, Children_Permission (Tree), Perm); + end if; - elsif Nkind_In (Expression (PAA), N_Identifier, N_Expanded_Name) then + when Reference => + Check_Is_More_Restrictive_Tree_Than + (Get_All (Tree), Perm, E); - -- global => foo - -- A single input + when Array_Component => + Check_Is_More_Restrictive_Tree_Than + (Get_Elem (Tree), Perm, E); - Process (Name_Input, Expression (PAA)); + when Record_Component => + declare + Comp : Perm_Tree_Access; + begin + Comp := Perm_Tree_Maps.Get_First (Component (Tree)); + while Comp /= null loop + Check_Is_More_Restrictive_Tree_Than (Comp, Perm, E); + Comp := + Perm_Tree_Maps.Get_Next (Component (Tree)); + end loop; + end; + end case; + end Check_Is_More_Restrictive_Tree_Than; - elsif Nkind (Expression (PAA)) = N_Aggregate - and then Expressions (Expression (PAA)) /= No_List - then - -- global => (foo, bar) - -- Inputs - - RHS := First (Expressions (Expression (PAA))); - while Present (RHS) loop - case Nkind (RHS) is - when N_Identifier - | N_Expanded_Name - => - Process (Name_Input, RHS); + -- Start of processing for Check_Is_Less_Restrictive_Tree - when N_Numeric_Or_String_Literal => - Process (Name_Input, Original_Node (RHS)); + begin + if not (Permission (New_Tree) <= Permission (Orig_Tree)) then + Perm_Error_Loop_Exit + (E => E, + Loop_Id => Stmt, + Perm => Permission (New_Tree), + Found_Perm => Permission (Orig_Tree)); + end if; - when others => - raise Program_Error; + case Kind (New_Tree) is + + -- Potentially folded tree. We check the other tree Orig_Tree to + -- check whether it is folded or not. If folded we just compare + -- their Permission and Children_Permission, if not, then we + -- look at the Children_Permission of the folded tree against + -- the unfolded tree Orig_Tree. + + when Entire_Object => + case Kind (Orig_Tree) is + when Entire_Object => + if not (Children_Permission (New_Tree) <= + Children_Permission (Orig_Tree)) + then + Perm_Error_Loop_Exit + (E, Stmt, + Children_Permission (New_Tree), + Children_Permission (Orig_Tree)); + end if; + + when Reference => + Check_Is_More_Restrictive_Tree_Than + (Get_All (Orig_Tree), Children_Permission (New_Tree), E); + + when Array_Component => + Check_Is_More_Restrictive_Tree_Than + (Get_Elem (Orig_Tree), Children_Permission (New_Tree), E); + + when Record_Component => + declare + Comp : Perm_Tree_Access; + begin + Comp := Perm_Tree_Maps.Get_First + (Component (Orig_Tree)); + while Comp /= null loop + Check_Is_More_Restrictive_Tree_Than + (Comp, Children_Permission (New_Tree), E); + Comp := Perm_Tree_Maps.Get_Next + (Component (Orig_Tree)); + end loop; + end; end case; - RHS := Next (RHS); - end loop; - elsif Nkind (Expression (PAA)) = N_Aggregate - and then Component_Associations (Expression (PAA)) /= No_List - then - -- global => (mode => foo, - -- mode => (bar, baz)) - -- A mixture of things + when Reference => + case Kind (Orig_Tree) is + when Entire_Object => + Check_Is_Less_Restrictive_Tree_Than + (Get_All (New_Tree), Children_Permission (Orig_Tree), E); - declare - CA : constant List_Id := - Component_Associations (Expression (PAA)); - begin - Row := First (CA); - while Present (Row) loop - pragma Assert (List_Length (Choices (Row)) = 1); - The_Mode := Chars (First (Choices (Row))); - RHS := Expression (Row); - - case Nkind (RHS) is - when N_Aggregate => - RHS := First (Expressions (RHS)); - while Present (RHS) loop - case Nkind (RHS) is - when N_Numeric_Or_String_Literal => - Process (The_Mode, Original_Node (RHS)); - - when others => - Process (The_Mode, RHS); - end case; - RHS := Next (RHS); - end loop; + when Reference => + Check_Is_Less_Restrictive_Tree + (Get_All (New_Tree), Get_All (Orig_Tree), E); - when N_Identifier - | N_Expanded_Name - => - Process (The_Mode, RHS); + when others => + raise Program_Error; + end case; - when N_Null => - null; + when Array_Component => + case Kind (Orig_Tree) is + when Entire_Object => + Check_Is_Less_Restrictive_Tree_Than + (Get_Elem (New_Tree), Children_Permission (Orig_Tree), E); - when N_Numeric_Or_String_Literal => - Process (The_Mode, Original_Node (RHS)); + when Array_Component => + Check_Is_Less_Restrictive_Tree + (Get_Elem (New_Tree), Get_Elem (Orig_Tree), E); - when others => - raise Program_Error; - end case; - Row := Next (Row); - end loop; - end; + when others => + raise Program_Error; + end case; - else - raise Program_Error; - end if; - end; - end Check_Globals; + when Record_Component => + declare + CompN : Perm_Tree_Access; + begin + CompN := + Perm_Tree_Maps.Get_First (Component (New_Tree)); + case Kind (Orig_Tree) is + when Entire_Object => + while CompN /= null loop + Check_Is_Less_Restrictive_Tree_Than + (CompN, Children_Permission (Orig_Tree), E); + + CompN := + Perm_Tree_Maps.Get_Next (Component (New_Tree)); + end loop; - ---------------- - -- Check_List -- - ---------------- + when Record_Component => + declare - procedure Check_List (L : List_Id) is - N : Node_Id; - begin - N := First (L); - while Present (N) loop - Check_Node (N); - Next (N); - end loop; - end Check_List; + KeyO : Perm_Tree_Maps.Key_Option; + CompO : Perm_Tree_Access; + begin + KeyO := Perm_Tree_Maps.Get_First_Key + (Component (Orig_Tree)); + while KeyO.Present loop + pragma Assert (CompO /= null); + + Check_Is_Less_Restrictive_Tree (CompN, CompO, E); + + KeyO := Perm_Tree_Maps.Get_Next_Key + (Component (Orig_Tree)); + CompN := Perm_Tree_Maps.Get + (Component (New_Tree), KeyO.K); + CompO := Perm_Tree_Maps.Get + (Component (Orig_Tree), KeyO.K); + end loop; + end; - -------------------------- - -- Check_Loop_Statement -- - -------------------------- + when others => + raise Program_Error; + end case; + end; + end case; + end Check_Is_Less_Restrictive_Tree; - procedure Check_Loop_Statement (Loop_N : Node_Id) is + -------------------------- + -- Perm_Error_Loop_Exit -- + -------------------------- + + procedure Perm_Error_Loop_Exit + (E : Entity_Id; + Loop_Id : Node_Id; + Perm : Perm_Kind; + Found_Perm : Perm_Kind) + is + begin + Error_Msg_Node_2 := Loop_Id; + Error_Msg_N ("insufficient permission for & when exiting loop &", E); + Perm_Mismatch (Exp_Perm => Perm, + Act_Perm => Found_Perm, + N => Loop_Id); + end Perm_Error_Loop_Exit; -- Local variables - Loop_Name : constant Entity_Id := Entity (Identifier (Loop_N)); + Loop_Name : constant Entity_Id := Entity (Identifier (Stmt)); Loop_Env : constant Perm_Env_Access := new Perm_Env; + Scheme : constant Node_Id := Iteration_Scheme (Stmt); + + -- Start of processing for Check_Loop_Statement begin -- Save environment prior to the loop @@ -1650,7 +2134,7 @@ package body Sem_SPARK is -- Otherwise, the loop exit environment remains empty until it is -- populated by analyzing exit statements. - if Present (Iteration_Scheme (Loop_N)) then + if Present (Iteration_Scheme (Stmt)) then declare Exit_Env : constant Perm_Env_Access := new Perm_Env; @@ -1662,8 +2146,41 @@ package body Sem_SPARK is -- Analyze loop - Check_Node (Iteration_Scheme (Loop_N)); - Check_List (Statements (Loop_N)); + if Present (Scheme) then + + -- Case of a WHILE loop + + if Present (Condition (Scheme)) then + Check_Expression (Condition (Scheme), Read); + + -- Case of a FOR loop + + else + declare + Param_Spec : constant Node_Id := + Loop_Parameter_Specification (Scheme); + Iter_Spec : constant Node_Id := Iterator_Specification (Scheme); + begin + if Present (Param_Spec) then + Check_Expression + (Discrete_Subtype_Definition (Param_Spec), Read); + else + Check_Expression (Name (Iter_Spec), Read); + if Present (Subtype_Indication (Iter_Spec)) then + Check_Expression (Subtype_Indication (Iter_Spec), Read); + end if; + end if; + end; + end if; + end if; + + Check_List (Statements (Stmt)); + + -- Check that environment gets less restrictive at end of loop + + Check_Is_Less_Restrictive_Env + (Exiting_Env => Current_Perm_Env, + Entry_Env => Loop_Env.all); -- Set environment to the one for exiting the loop @@ -1697,24 +2214,20 @@ package body Sem_SPARK is ---------------- procedure Check_Node (N : Node_Id) is - Mode_Before : constant Checking_Mode := Current_Checking_Mode; begin case Nkind (N) is when N_Declaration => Check_Declaration (N); - when N_Subexpr => - Check_Expression (N); - - when N_Subtype_Indication => - Check_Node (Constraint (N)); - when N_Body_Stub => Check_Node (Get_Body_From_Stub (N)); when N_Statement_Other_Than_Procedure_Call => Check_Statement (N); + when N_Procedure_Call_Statement => + Check_Call_Statement (N); + when N_Package_Body => Check_Package_Body (N); @@ -1728,124 +2241,13 @@ package body Sem_SPARK is Check_List (Declarations (N)); when N_Package_Declaration => - declare - Spec : constant Node_Id := Specification (N); - - begin - Current_Checking_Mode := Read; - Check_List (Visible_Declarations (Spec)); - Check_List (Private_Declarations (Spec)); - - Return_Declarations (Visible_Declarations (Spec)); - Return_Declarations (Private_Declarations (Spec)); - end; - - when N_Iteration_Scheme => - Current_Checking_Mode := Read; - Check_Node (Condition (N)); - Check_Node (Iterator_Specification (N)); - Check_Node (Loop_Parameter_Specification (N)); - - when N_Case_Expression_Alternative => - Current_Checking_Mode := Read; - Check_List (Discrete_Choices (N)); - Current_Checking_Mode := Mode_Before; - Check_Node (Expression (N)); - - when N_Case_Statement_Alternative => - Current_Checking_Mode := Read; - Check_List (Discrete_Choices (N)); - Current_Checking_Mode := Mode_Before; - Check_List (Statements (N)); - - when N_Component_Association => - Check_Node (Expression (N)); + Check_Package_Spec (N); when N_Handled_Sequence_Of_Statements => Check_List (Statements (N)); - when N_Parameter_Association => - Check_Node (Explicit_Actual_Parameter (N)); - - when N_Range_Constraint => - Check_Node (Range_Expression (N)); - - when N_Index_Or_Discriminant_Constraint => - Check_List (Constraints (N)); - - -- Checking should not be called directly on these nodes - - when N_Abortable_Part - | N_Accept_Alternative - | N_Access_Definition - | N_Access_Function_Definition - | N_Access_Procedure_Definition - | N_Access_To_Object_Definition - | N_Aspect_Specification - | N_Compilation_Unit - | N_Compilation_Unit_Aux - | N_Component_Clause - | N_Component_Definition - | N_Component_List - | N_Constrained_Array_Definition - | N_Contract - | N_Decimal_Fixed_Point_Definition - | N_Defining_Character_Literal - | N_Defining_Identifier - | N_Defining_Operator_Symbol - | N_Defining_Program_Unit_Name - | N_Delay_Alternative - | N_Derived_Type_Definition - | N_Designator - | N_Discriminant_Specification - | N_Elsif_Part - | N_Entry_Body_Formal_Part - | N_Enumeration_Type_Definition - | N_Entry_Call_Alternative - | N_Entry_Index_Specification - | N_Error - | N_Exception_Handler - | N_Floating_Point_Definition - | N_Formal_Decimal_Fixed_Point_Definition - | N_Formal_Derived_Type_Definition - | N_Formal_Discrete_Type_Definition - | N_Formal_Floating_Point_Definition - | N_Formal_Incomplete_Type_Definition - | N_Formal_Modular_Type_Definition - | N_Formal_Ordinary_Fixed_Point_Definition - | N_Formal_Private_Type_Definition - | N_Formal_Signed_Integer_Type_Definition - | N_Generic_Association - | N_Mod_Clause - | N_Modular_Type_Definition - | N_Ordinary_Fixed_Point_Definition - | N_Package_Specification - | N_Parameter_Specification - | N_Pragma_Argument_Association - | N_Protected_Definition - | N_Push_Pop_xxx_Label - | N_Real_Range_Specification - | N_Record_Definition - | N_SCIL_Dispatch_Table_Tag_Init - | N_SCIL_Dispatching_Call - | N_SCIL_Membership_Test - | N_Signed_Integer_Type_Definition - | N_Subunit - | N_Task_Definition - | N_Terminate_Alternative - | N_Triggering_Alternative - | N_Unconstrained_Array_Definition - | N_Unused_At_Start - | N_Unused_At_End - | N_Variant - | N_Variant_Part - => - raise Program_Error; - - -- Unsupported constructs in SPARK - - when N_Iterated_Component_Association => - Error_Msg_N ("unsupported construct in SPARK", N); + when N_Pragma => + Check_Pragma (N); -- Ignored constructs for pointer checking @@ -1877,7 +2279,6 @@ package body Sem_SPARK is | N_Others_Choice | N_Package_Instantiation | N_Package_Renaming_Declaration - | N_Pragma | N_Procedure_Instantiation | N_Record_Representation_Clause | N_Subprogram_Declaration @@ -1890,19 +2291,16 @@ package body Sem_SPARK is | N_Variable_Reference_Marker | N_Discriminant_Association - -- ??? check whether we should do sth special for - -- N_Discriminant_Association, or maybe raise a program error. + -- ??? check whether we should do something special for + -- N_Discriminant_Association, or maybe raise Program_Error. => null; - -- The following nodes are rewritten by semantic analysis - when N_Single_Protected_Declaration - | N_Single_Task_Declaration - => + -- Checking should not be called directly on these nodes + + when others => raise Program_Error; end case; - - Current_Checking_Mode := Mode_Before; end Check_Node; ------------------------ @@ -1910,179 +2308,207 @@ package body Sem_SPARK is ------------------------ procedure Check_Package_Body (Pack : Node_Id) is - Saved_Env : Perm_Env; - CorSp : Node_Id; + Save_In_Elab : constant Boolean := Inside_Elaboration; + Spec : constant Node_Id := + Package_Specification (Corresponding_Spec (Pack)); + Prag : constant Node_Id := SPARK_Pragma (Defining_Entity (Pack)); + Saved_Env : Perm_Env; begin - if Present (SPARK_Pragma (Defining_Entity (Pack, False))) then - if Get_SPARK_Mode_From_Annotation - (SPARK_Pragma (Defining_Entity (Pack))) /= Opt.On - then - return; - end if; - else + -- Only SPARK bodies are analyzed + + if No (Prag) + or else Get_SPARK_Mode_From_Annotation (Prag) /= Opt.On + then return; end if; - CorSp := Parent (Corresponding_Spec (Pack)); - while Nkind (CorSp) /= N_Package_Specification loop - CorSp := Parent (CorSp); - end loop; + Inside_Elaboration := True; + + -- Save environment and put a new one in place - Check_List (Visible_Declarations (CorSp)); + Move_Env (Current_Perm_Env, Saved_Env); - -- Save environment + -- Reanalyze package spec to have its variables in the environment - Copy_Env (Current_Perm_Env, Saved_Env); - Check_List (Private_Declarations (CorSp)); + Check_List (Visible_Declarations (Spec)); + Check_List (Private_Declarations (Spec)); - -- Set mode to Read, and then analyze declarations and statements + -- Check declarations and statements in the special mode for elaboration - Current_Checking_Mode := Read; Check_List (Declarations (Pack)); Check_Node (Handled_Statement_Sequence (Pack)); - -- Check RW for every stateful variable (i.e. in declarations) - - Return_Declarations (Private_Declarations (CorSp)); - Return_Declarations (Visible_Declarations (CorSp)); - Return_Declarations (Declarations (Pack)); + -- Restore the saved environment and free the current one - -- Restore previous environment (i.e. delete every nonvisible - -- declaration) from environment. + Move_Env (Saved_Env, Current_Perm_Env); - Free_Env (Current_Perm_Env); - Copy_Env (Saved_Env, Current_Perm_Env); + Inside_Elaboration := Save_In_Elab; end Check_Package_Body; - -------------------- - -- Check_Param_In -- - -------------------- + ------------------------ + -- Check_Package_Spec -- + ------------------------ + + procedure Check_Package_Spec (Pack : Node_Id) is + Save_In_Elab : constant Boolean := Inside_Elaboration; + Spec : constant Node_Id := Specification (Pack); + Saved_Env : Perm_Env; - procedure Check_Param_In (Formal : Entity_Id; Actual : Node_Id) is - Mode : constant Entity_Kind := Ekind (Formal); - Mode_Before : constant Checking_Mode := Current_Checking_Mode; begin - case Formal_Kind'(Mode) is + Inside_Elaboration := True; - -- Formal IN parameter + -- Save environment and put a new one in place - when E_In_Parameter => + Move_Env (Current_Perm_Env, Saved_Env); - -- Formal IN parameter, access type + -- Check declarations in the special mode for elaboration - if Is_Access_Type (Etype (Formal)) then + Check_List (Visible_Declarations (Spec)); + Check_List (Private_Declarations (Spec)); - -- Formal IN parameter, access to variable type + -- Restore the saved environment and free the current one - if not Is_Access_Constant (Etype (Formal)) then + Move_Env (Saved_Env, Current_Perm_Env); - -- Formal IN parameter, named/anonymous access-to-variable - -- type. - -- - -- In SPARK, IN access-to-variable is an observe operation - -- for a function, and a borrow operation for a procedure. + Inside_Elaboration := Save_In_Elab; + end Check_Package_Spec; - if Ekind (Scope (Formal)) = E_Function then - Current_Checking_Mode := Observe; - Check_Node (Actual); - else - Current_Checking_Mode := Borrow; - Check_Node (Actual); - end if; + ------------------------------- + -- Check_Parameter_Or_Global -- + ------------------------------- - -- Formal IN parameter, access-to-constant type - -- Formal IN parameter, access-to-named-constant type + procedure Check_Parameter_Or_Global + (Expr : Node_Id; + Typ : Entity_Id; + Kind : Formal_Kind; + Subp : Entity_Id; + Global_Var : Boolean) + is + Mode : Checking_Mode; + Status : Error_Status; + + begin + if not Global_Var + and then Is_Anonymous_Access_Type (Typ) + then + Check_Source_Of_Borrow_Or_Observe (Expr, Status); - elsif not Is_Anonymous_Access_Type (Etype (Formal)) then - Error_Msg_N ("assignment not allowed, Ownership Aspect" - & " False (Named general access type)", - Formal); + if Status /= OK then + return; + end if; + end if; - -- Formal IN parameter, access to anonymous constant type + case Kind is + when E_In_Parameter => - else - Current_Checking_Mode := Observe; - Check_Node (Actual); - end if; + -- Inputs of functions have R permission only - -- Formal IN parameter, composite type + if Ekind (Subp) = E_Function then + Mode := Read; - elsif Is_Deep (Etype (Formal)) then + -- Input global variables have R permission only - -- Composite formal types should be named - -- Formal IN parameter, composite named type + elsif Global_Var then + Mode := Read; - Current_Checking_Mode := Observe; - Check_Node (Actual); - end if; + -- Anonymous access to constant is an observe - when E_Out_Parameter - | E_In_Out_Parameter - => - null; - end case; + elsif Is_Anonymous_Access_Type (Typ) + and then Is_Access_Constant (Typ) + then + Mode := Observe; - Current_Checking_Mode := Mode_Before; - end Check_Param_In; + -- Other access types are a borrow - ---------------------- - -- Check_Param_Out -- - ---------------------- + elsif Is_Access_Type (Typ) then + Mode := Borrow; - procedure Check_Param_Out (Formal : Entity_Id; Actual : Node_Id) is - Mode : constant Entity_Kind := Ekind (Formal); - Mode_Before : constant Checking_Mode := Current_Checking_Mode; + -- Deep types other than access types define an observe - begin - case Formal_Kind'(Mode) is + elsif Is_Deep (Typ) then + Mode := Observe; - -- Formal OUT/IN OUT parameter + -- Otherwise the variable is read - when E_Out_Parameter - | E_In_Out_Parameter - => + else + Mode := Read; + end if; - -- Formal OUT/IN OUT parameter, access type + when E_Out_Parameter => + Mode := Assign; - if Is_Access_Type (Etype (Formal)) then + when E_In_Out_Parameter => + Mode := Move; + end case; - -- Formal OUT/IN OUT parameter, access to variable type + Check_Expression (Expr, Mode); + end Check_Parameter_Or_Global; - if not Is_Access_Constant (Etype (Formal)) then + procedure Check_Globals_Inst is + new Handle_Globals (Check_Parameter_Or_Global); - -- Cannot have anonymous out access parameter - -- Formal out/in out parameter, access to named variable - -- type. + procedure Check_Globals (Subp : Entity_Id) renames Check_Globals_Inst; - Current_Checking_Mode := Move; - Check_Node (Actual); + ------------------ + -- Check_Pragma -- + ------------------ - -- Formal out/in out parameter, access to constant type + procedure Check_Pragma (Prag : Node_Id) is + Prag_Id : constant Pragma_Id := Get_Pragma_Id (Prag); + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Prag)); + Arg2 : Node_Id; - else - Error_Msg_N ("assignment not allowed, Ownership Aspect False" - & " (Named general access type)", Formal); + begin + if Present (Arg1) then + Arg2 := Next (Arg1); + end if; - end if; + case Prag_Id is + when Pragma_Check => + declare + Expr : constant Node_Id := Expression (Arg2); + begin + Check_Expression (Expr, Read); + end; - -- Formal out/in out parameter, composite type + -- There is no need to check contracts, as these can only access + -- inputs and outputs of the subprogram. Inputs are checked + -- independently for R permission. Outputs are checked + -- independently to have RW permission on exit. - elsif Is_Deep (Etype (Formal)) then + when Pragma_Contract_Cases + | Pragma_Postcondition + | Pragma_Precondition + | Pragma_Refined_Post + => + null; - -- Composite formal types should be named - -- Formal out/in out Parameter, Composite Named type. + -- The same holds for the initial condition after package + -- elaboration, for the different reason that library-level + -- variables can only be left in RW state after elaboration. - Current_Checking_Mode := Borrow; - Check_Node (Actual); - end if; + when Pragma_Initial_Condition => + null; - when E_In_Parameter => + -- These pragmas should have been rewritten and/or removed in + -- GNATprove mode. + + when Pragma_Assert + | Pragma_Assert_And_Cut + | Pragma_Assume + | Pragma_Compile_Time_Error + | Pragma_Compile_Time_Warning + | Pragma_Debug + | Pragma_Loop_Invariant + => + raise Program_Error; + + when others => null; end case; - - Current_Checking_Mode := Mode_Before; - end Check_Param_Out; + end Check_Pragma; ------------------------- -- Check_Safe_Pointers -- @@ -2121,19 +2547,18 @@ package body Sem_SPARK is Reset (Current_Loops_Envs); Reset (Current_Loops_Accumulators); Reset (Current_Perm_Env); - Reset (Current_Initialization_Map); end Initialize; -- Local variables Prag : Node_Id; - -- SPARK_Mode pragma in application -- Start of processing for Check_Safe_Pointers begin Initialize; + case Nkind (N) is when N_Compilation_Unit => Check_Safe_Pointers (Unit (N)); @@ -2143,10 +2568,9 @@ package body Sem_SPARK is | N_Subprogram_Body => Prag := SPARK_Pragma (Defining_Entity (N)); + if Present (Prag) then - if Get_SPARK_Mode_From_Annotation (Prag) = Opt.Off then - return; - else + if Get_SPARK_Mode_From_Annotation (Prag) = Opt.On then Check_Node (N); end if; @@ -2163,428 +2587,361 @@ package body Sem_SPARK is end case; end Check_Safe_Pointers; - --------------------- - -- Check_Statement -- - --------------------- + --------------------------------------- + -- Check_Source_Of_Borrow_Or_Observe -- + --------------------------------------- - procedure Check_Statement (Stmt : Node_Id) is - Mode_Before : constant Checking_Mode := Current_Checking_Mode; - State_N : Perm_Kind; - Check : Boolean := True; - St_Name : Node_Id; - Ty_St_Name : Node_Id; + procedure Check_Source_Of_Borrow_Or_Observe + (Expr : Node_Id; + Status : out Error_Status) + is + Root : Entity_Id; - function Get_Root (Comp_Stmt : Node_Id) return Node_Id; - -- Return the root of the name given as input + begin + if Is_Path_Expression (Expr) then + Root := Get_Root_Object (Expr); + else + Root := Empty; + end if; - function Get_Root (Comp_Stmt : Node_Id) return Node_Id is - begin - case Nkind (Comp_Stmt) is - when N_Identifier - | N_Expanded_Name - => return Comp_Stmt; + Status := OK; - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Get_Root (Expression (Comp_Stmt)); + -- SPARK RM 3.10(3): If the target of an assignment operation is an + -- object of an anonymous access-to-object type (including copy-in for + -- a parameter), then the source shall be a name denoting a part of a + -- stand-alone object, a part of a parameter, or a call to a traversal + -- function. - when N_Parameter_Specification => - return Get_Root (Defining_Identifier (Comp_Stmt)); + if No (Root) then + if Nkind (Expr) = N_Function_Call then + Error_Msg_N + ("incorrect borrow or observe (SPARK RM 3.10(3))", Expr); + Error_Msg_N + ("\function called must be a traversal function", Expr); + else + Error_Msg_N + ("incorrect borrow or observe (SPARK RM 3.10(3))", Expr); + Error_Msg_N + ("\expression must be part of stand-alone object or parameter", + Expr); + end if; - when N_Selected_Component - | N_Indexed_Component - | N_Slice - | N_Explicit_Dereference - => - return Get_Root (Prefix (Comp_Stmt)); + Status := Error; + end if; + end Check_Source_Of_Borrow_Or_Observe; - when others => - raise Program_Error; - end case; - end Get_Root; + --------------------- + -- Check_Statement -- + --------------------- + procedure Check_Statement (Stmt : Node_Id) is begin case N_Statement_Other_Than_Procedure_Call'(Nkind (Stmt)) is + + -- An entry call is handled like other calls + when N_Entry_Call_Statement => Check_Call_Statement (Stmt); - -- Move right-hand side first, and then assign left-hand side + -- An assignment may correspond to a move, a borrow, or an observe when N_Assignment_Statement => + declare + Target : constant Node_Id := Name (Stmt); + begin + Check_Assignment (Target => Target, + Expr => Expression (Stmt)); - St_Name := Name (Stmt); - Ty_St_Name := Etype (Name (Stmt)); - - -- Check that is not a *general* access type - - if Has_Ownership_Aspect_True (St_Name, "assigning to") then - - -- Assigning to access type - - if Is_Access_Type (Ty_St_Name) then - - -- Assigning to access to variable type - - if not Is_Access_Constant (Ty_St_Name) then - - -- Assigning to named access to variable type - - if not Is_Anonymous_Access_Type (Ty_St_Name) then - Current_Checking_Mode := Move; - - -- Assigning to anonymous access to variable type - - else - -- Target /= source root - - if Nkind_In (Expression (Stmt), N_Allocator, N_Null) - or else Entity (St_Name) /= - Entity (Get_Root (Expression (Stmt))) - then - Error_Msg_N ("assignment not allowed, anonymous " - & "access Object with Different Root", - Stmt); - Check := False; - - -- Target = source root - - else - -- Here we do nothing on the source nor on the - -- target. However, we check the the legality rule: - -- "The source shall be an owning access object - -- denoted by a name that is not in the observed - -- state". - - State_N := Get_Perm (Expression (Stmt)); - if State_N = Observed then - Error_Msg_N ("assignment not allowed, Anonymous " - & "access object with the same root" - & " but source Observed", Stmt); - Check := False; - end if; - end if; - end if; - - -- else access-to-constant - - -- Assigning to anonymous access-to-constant type - - elsif Is_Anonymous_Access_Type (Ty_St_Name) then - - -- ??? Check the follwing condition. We may have to - -- add that the root is in the observed state too. - - State_N := Get_Perm (Expression (Stmt)); - if State_N /= Observed then - Error_Msg_N ("assignment not allowed, anonymous " - & "access-to-constant object not in " - & "the observed state)", Stmt); - Check := False; - - else - Error_Msg_N ("?here check accessibility level cited in" - & " the second legality rule of assign", - Stmt); - Check := False; - end if; - - -- Assigning to named access-to-constant type: - -- This case should have been detected when checking - -- Has_Onwership_Aspect_True (Name (Stmt), "msg"). - - else - raise Program_Error; - end if; - - -- Assigning to composite (deep) type. - - elsif Is_Deep (Ty_St_Name) then - if Ekind_In (Ty_St_Name, - E_Record_Type, - E_Record_Subtype) - then - declare - Elmt : Entity_Id := - First_Component_Or_Discriminant (Ty_St_Name); - - begin - while Present (Elmt) loop - if Is_Anonymous_Access_Type (Etype (Elmt)) or - Ekind (Elmt) = E_General_Access_Type - then - Error_Msg_N ("assignment not allowed, Ownership " - & "Aspect False (Components have " - & "Ownership Aspect False)", Stmt); - Check := False; - exit; - end if; - - Next_Component_Or_Discriminant (Elmt); - end loop; - end; - - -- Record types are always named so this is a move - - if Check then - Current_Checking_Mode := Move; - end if; - - elsif Ekind_In (Ty_St_Name, - E_Array_Type, - E_Array_Subtype) - and then Check - then - Current_Checking_Mode := Move; - end if; - - -- Now handle legality rules of using a borrowed, observed, - -- or moved name as a prefix in an assignment. - - else - if Nkind_In (St_Name, - N_Attribute_Reference, - N_Expanded_Name, - N_Explicit_Dereference, - N_Indexed_Component, - N_Reference, - N_Selected_Component, - N_Slice) - then - - if Is_Access_Type (Etype (Prefix (St_Name))) or - Is_Deep (Etype (Prefix (St_Name))) - then - - -- We set the Check variable to True so that we can - -- Check_Node of the expression and the name first - -- under the assumption of Current_Checking_Mode = - -- Read => nothing to be done for the RHS if the - -- following check on the expression fails, and - -- Current_Checking_Mode := Assign => the name should - -- not be borrowed or observed so that we can use it - -- as a prefix in the target of an assignement. - -- - -- Note that we do not need to check the OA here - -- because we are allowed to read and write "through" - -- an object of OAF (example: traversing a DS). - - Check := True; - end if; - end if; - - if Nkind_In (Expression (Stmt), - N_Attribute_Reference, - N_Expanded_Name, - N_Explicit_Dereference, - N_Indexed_Component, - N_Reference, - N_Selected_Component, - N_Slice) - then + -- ??? We need a rule that forbids targets of assignment for + -- which the path is not known, for example when there is a + -- function call involved (which includes calls to traversal + -- functions). Otherwise there is no way to update the + -- corresponding path permission. - if Is_Access_Type (Etype (Prefix (Expression (Stmt)))) - or else Is_Deep (Etype (Prefix (Expression (Stmt)))) - then - Current_Checking_Mode := Observe; - Check := True; - end if; - end if; + if No (Get_Root_Object + (Target, Through_Traversal => False)) + then + Error_Msg_N ("illegal target for assignment", Target); + return; end if; - if Check then - Check_Node (Expression (Stmt)); - Current_Checking_Mode := Assign; - Check_Node (St_Name); - end if; - end if; + Check_Expression (Target, Assign); + end; when N_Block_Statement => - declare - Saved_Env : Perm_Env; - begin - -- Save environment - - Copy_Env (Current_Perm_Env, Saved_Env); + Check_List (Declarations (Stmt)); + Check_Node (Handled_Statement_Sequence (Stmt)); - -- Analyze declarations and Handled_Statement_Sequences + -- Remove local borrowers and observers - Current_Checking_Mode := Read; - Check_List (Declarations (Stmt)); - Check_Node (Handled_Statement_Sequence (Stmt)); - - -- Restore environment + declare + Decl : Node_Id := First (Declarations (Stmt)); + Var : Entity_Id; + begin + while Present (Decl) loop + if Nkind (Decl) = N_Object_Declaration then + Var := Defining_Identifier (Decl); + Remove (Current_Borrowers, Var); + Remove (Current_Observers, Var); + end if; - Free_Env (Current_Perm_Env); - Copy_Env (Saved_Env, Current_Perm_Env); + Next (Decl); + end loop; end; when N_Case_Statement => declare + Alt : Node_Id; Saved_Env : Perm_Env; - - -- Accumulator for the different branches - - New_Env : Perm_Env; - Elmt : Node_Id := First (Alternatives (Stmt)); + -- Copy of environment for analysis of the different cases + New_Env : Perm_Env; + -- Accumulator for the different cases begin - Current_Checking_Mode := Read; - Check_Node (Expression (Stmt)); - Current_Checking_Mode := Mode_Before; + Check_Expression (Expression (Stmt), Read); -- Save environment Copy_Env (Current_Perm_Env, Saved_Env); - -- Here we have the original env in saved, current with a fresh - -- copy, and new aliased. - -- First alternative - Check_Node (Elmt); - Next (Elmt); - Copy_Env (Current_Perm_Env, New_Env); - Free_Env (Current_Perm_Env); + Alt := First (Alternatives (Stmt)); + Check_List (Statements (Alt)); + Next (Alt); + + -- Cleanup + + Move_Env (Current_Perm_Env, New_Env); -- Other alternatives - while Present (Elmt) loop + while Present (Alt) loop -- Restore environment Copy_Env (Saved_Env, Current_Perm_Env); - Check_Node (Elmt); - Next (Elmt); + + -- Next alternative + + Check_List (Statements (Alt)); + Next (Alt); + + -- Merge Current_Perm_Env into New_Env + + Merge_Env (Source => Current_Perm_Env, Target => New_Env); end loop; - Copy_Env (Saved_Env, Current_Perm_Env); - Free_Env (New_Env); + Move_Env (New_Env, Current_Perm_Env); Free_Env (Saved_Env); end; - when N_Delay_Relative_Statement => - Check_Node (Expression (Stmt)); - - when N_Delay_Until_Statement => - Check_Node (Expression (Stmt)); + when N_Delay_Relative_Statement + | N_Delay_Until_Statement + => + Check_Expression (Expression (Stmt), Read); when N_Loop_Statement => Check_Loop_Statement (Stmt); - -- If deep type expression, then move, else read - when N_Simple_Return_Statement => - case Nkind (Expression (Stmt)) is - when N_Empty => + declare + Subp : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (Stmt)); + Expr : constant Node_Id := Expression (Stmt); + begin + if Present (Expression (Stmt)) then declare - -- ??? This does not take into account the fact that - -- a simple return inside an extended return statement - -- applies to the extended return statement. - Subp : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (Stmt)); + Return_Typ : constant Entity_Id := + Etype (Expression (Stmt)); + begin - Return_Globals (Subp); - end; + -- SPARK RM 3.10(5): A return statement that applies + -- to a traversal function that has an anonymous + -- access-to-constant (respectively, access-to-variable) + -- result type, shall return either the literal null + -- or an access object denoted by a direct or indirect + -- observer (respectively, borrower) of the traversed + -- parameter. + + if Is_Anonymous_Access_Type (Return_Typ) then + pragma Assert (Is_Traversal_Function (Subp)); + + if Nkind (Expr) /= N_Null then + declare + Expr_Root : constant Entity_Id := + Get_Root_Object (Expr); + Param : constant Entity_Id := + First_Formal (Subp); + begin + if Param /= Expr_Root then + Error_Msg_NE + ("returned value must be rooted in " + & "traversed parameter & " + & "(SPARK RM 3.10(5))", + Stmt, Param); + end if; + end; + end if; - when others => - if Is_Deep (Etype (Expression (Stmt))) then - Current_Checking_Mode := Move; - else - Check := False; - end if; + -- Move expression to caller - if Check then - Check_Node (Expression (Stmt)); - end if; - end case; + elsif Is_Deep (Return_Typ) then + + if Is_Path_Expression (Expr) then + Check_Expression (Expr, Move); + + else + Error_Msg_N + ("expression not allowed as source of move", + Expr); + return; + end if; + + else + Check_Expression (Expr, Read); + end if; + + if Ekind_In (Subp, E_Procedure, E_Entry) + and then not No_Return (Subp) + then + Return_Parameters (Subp); + Return_Globals (Subp); + end if; + end; + end if; + end; when N_Extended_Return_Statement => - Check_List (Return_Object_Declarations (Stmt)); - Check_Node (Handled_Statement_Sequence (Stmt)); - Return_Declarations (Return_Object_Declarations (Stmt)); declare - -- ??? This does not take into account the fact that a simple - -- return inside an extended return statement applies to the - -- extended return statement. - Subp : constant Entity_Id := + Subp : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (Stmt)); + Decls : constant List_Id := Return_Object_Declarations (Stmt); + Decl : constant Node_Id := Last (Decls); + Obj : constant Entity_Id := Defining_Identifier (Decl); + Perm : Perm_Kind; begin - Return_Globals (Subp); + -- SPARK RM 3.10(5): return statement of traversal function + + if Is_Traversal_Function (Subp) then + Error_Msg_N + ("extended return cannot apply to a traversal function", + Stmt); + end if; + + Check_List (Return_Object_Declarations (Stmt)); + Check_Node (Handled_Statement_Sequence (Stmt)); + + Perm := Get_Perm (Obj); + + if Perm /= Read_Write then + Perm_Error (Decl, Read_Write, Perm); + end if; + + if Ekind_In (Subp, E_Procedure, E_Entry) + and then not No_Return (Subp) + then + Return_Parameters (Subp); + Return_Globals (Subp); + end if; end; - -- Nothing to do when exiting a loop. No merge needed + -- On loop exit, merge the current permission environment with the + -- accumulator for the given loop. when N_Exit_Statement => - null; + declare + Loop_Name : constant Entity_Id := Loop_Of_Exit (Stmt); + Saved_Accumulator : constant Perm_Env_Access := + Get (Current_Loops_Accumulators, Loop_Name); + Environment_Copy : constant Perm_Env_Access := + new Perm_Env; + begin + Copy_Env (Current_Perm_Env, Environment_Copy.all); - -- Copy environment, run on each branch + if Saved_Accumulator = null then + Set (Current_Loops_Accumulators, + Loop_Name, Environment_Copy); + else + Merge_Env (Source => Environment_Copy.all, + Target => Saved_Accumulator.all); + -- ??? Either free Environment_Copy, or change the type + -- of loop accumulators to directly store permission + -- environments. + end if; + end; + + -- On branches, analyze each branch independently on a fresh copy of + -- the permission environment, then merge the resulting permission + -- environments. when N_If_Statement => declare Saved_Env : Perm_Env; - + New_Env : Perm_Env; -- Accumulator for the different branches - New_Env : Perm_Env; - begin - Check_Node (Condition (Stmt)); + Check_Expression (Condition (Stmt), Read); -- Save environment Copy_Env (Current_Perm_Env, Saved_Env); - -- Here we have the original env in saved, current with a fresh - -- copy. - - -- THEN PART + -- THEN branch Check_List (Then_Statements (Stmt)); - Copy_Env (Current_Perm_Env, New_Env); - Free_Env (Current_Perm_Env); + Move_Env (Current_Perm_Env, New_Env); - -- Here the new_environment contains curr env after then block - - -- ELSIF part + -- ELSIF branches declare - Elmt : Node_Id; - + Branch : Node_Id; begin - Elmt := First (Elsif_Parts (Stmt)); - while Present (Elmt) loop + Branch := First (Elsif_Parts (Stmt)); + while Present (Branch) loop - -- Transfer into accumulator, and restore from save + -- Restore current permission environment Copy_Env (Saved_Env, Current_Perm_Env); - Check_Node (Condition (Elmt)); - Check_List (Then_Statements (Stmt)); - Next (Elmt); + Check_Expression (Condition (Branch), Read); + Check_List (Then_Statements (Branch)); + + -- Merge current permission environment + + Merge_Env (Source => Current_Perm_Env, Target => New_Env); + Next (Branch); end loop; end; - -- ELSE part + -- ELSE branch - -- Restore environment before if + -- Restore current permission environment Copy_Env (Saved_Env, Current_Perm_Env); - - -- Here new environment contains the environment after then and - -- current the fresh copy of old one. - Check_List (Else_Statements (Stmt)); - -- CLEANUP + -- Merge current permission environment - Copy_Env (Saved_Env, Current_Perm_Env); + Merge_Env (Source => Current_Perm_Env, Target => New_Env); + + -- Cleanup - Free_Env (New_Env); + Move_Env (New_Env, Current_Perm_Env); Free_Env (Saved_Env); end; + -- We should ideally ignore the branch after raising an exception, + -- so that it is not taken into account in merges. For now, just + -- propagate the current environment. + + when N_Raise_Statement => + null; + + when N_Null_Statement => + null; + -- Unsupported constructs in SPARK when N_Abort_Statement @@ -2599,13 +2956,6 @@ package body Sem_SPARK is => Error_Msg_N ("unsupported construct in SPARK", Stmt); - -- Ignored constructs for pointer checking - - when N_Null_Statement - | N_Raise_Statement - => - null; - -- The following nodes are never generated in GNATprove mode when N_Compound_Statement @@ -2615,28 +2965,149 @@ package body Sem_SPARK is end case; end Check_Statement; + ---------------- + -- Check_Type -- + ---------------- + + procedure Check_Type (Typ : Entity_Id) is + Check_Typ : constant Entity_Id := Underlying_Type (Typ); + + begin + case Type_Kind'(Ekind (Check_Typ)) is + when Access_Kind => + case Access_Kind'(Ekind (Underlying_Type (Check_Typ))) is + when E_Access_Type + | E_Anonymous_Access_Type + => + null; + when E_Access_Subtype => + Check_Type (Base_Type (Check_Typ)); + when E_Access_Attribute_Type => + Error_Msg_N ("access attribute not allowed in SPARK", + Check_Typ); + when E_Allocator_Type => + Error_Msg_N ("missing type resolution", Check_Typ); + when E_General_Access_Type => + Error_Msg_NE + ("general access type & not allowed in SPARK", + Check_Typ, Check_Typ); + when Access_Subprogram_Kind => + Error_Msg_NE + ("access to subprogram type & not allowed in SPARK", + Check_Typ, Check_Typ); + end case; + + when E_Array_Type + | E_Array_Subtype + => + Check_Type (Component_Type (Check_Typ)); + + when Record_Kind => + if Is_Deep (Check_Typ) + and then (Is_Tagged_Type (Check_Typ) + or else Is_Class_Wide_Type (Check_Typ)) + then + Error_Msg_NE + ("tagged type & cannot be owning in SPARK", + Check_Typ, Check_Typ); + + else + declare + Comp : Entity_Id; + begin + Comp := First_Component_Or_Discriminant (Check_Typ); + while Present (Comp) loop + Check_Type (Etype (Comp)); + Next_Component_Or_Discriminant (Comp); + end loop; + end; + end if; + + when Scalar_Kind + | E_String_Literal_Subtype + | Protected_Kind + | Task_Kind + | Incomplete_Kind + | E_Exception_Type + | E_Subprogram_Type + => + null; + + -- The following should not arise as underlying types + + when E_Private_Type + | E_Private_Subtype + | E_Limited_Private_Type + | E_Limited_Private_Subtype + => + raise Program_Error; + end case; + end Check_Type; + + ----------------------------------- + -- Get_Observed_Or_Borrowed_Expr -- + ----------------------------------- + + function Get_Observed_Or_Borrowed_Expr (Expr : Node_Id) return Node_Id is + begin + if Is_Traversal_Function_Call (Expr) then + return First_Actual (Expr); + else + return Expr; + end if; + end Get_Observed_Or_Borrowed_Expr; + -------------- -- Get_Perm -- -------------- - function Get_Perm (N : Node_Id) return Perm_Kind is - Tree_Or_Perm : constant Perm_Or_Tree := Get_Perm_Or_Tree (N); - + function Get_Perm (N : Node_Or_Entity_Id) return Perm_Kind is begin - case Tree_Or_Perm.R is - when Folded => - return Tree_Or_Perm.Found_Permission; + -- Special case for the object declared in an extended return statement - when Unfolded => - pragma Assert (Tree_Or_Perm.Tree_Access /= null); - return Permission (Tree_Or_Perm.Tree_Access); + if Nkind (N) = N_Defining_Identifier then + declare + C : constant Perm_Tree_Access := + Get (Current_Perm_Env, Unique_Entity (N)); + begin + pragma Assert (C /= null); + return Permission (C); + end; - -- We encoutered a function call, hence the memory area is fresh, - -- which means that the association permission is RW. + -- The expression is a call to a traversal function - when Function_Call => - return Unrestricted; - end case; + elsif Is_Traversal_Function_Call (N) then + declare + Callee : constant Entity_Id := Get_Called_Entity (N); + begin + if Is_Access_Constant (Etype (Callee)) then + return Read_Only; + else + return Read_Write; + end if; + end; + + -- The expression is directly rooted in an object + + elsif Present (Get_Root_Object (N, Through_Traversal => False)) then + declare + Tree_Or_Perm : constant Perm_Or_Tree := Get_Perm_Or_Tree (N); + begin + case Tree_Or_Perm.R is + when Folded => + return Tree_Or_Perm.Found_Permission; + + when Unfolded => + pragma Assert (Tree_Or_Perm.Tree_Access /= null); + return Permission (Tree_Or_Perm.Tree_Access); + end case; + end; + + -- The expression is a function call, an allocation, or null + + else + return Read_Write; + end if; end Get_Perm; ---------------------- @@ -2647,625 +3118,801 @@ package body Sem_SPARK is begin case Nkind (N) is - -- Base identifier. Normally those are the roots of the trees stored - -- in the permission environment. - - when N_Defining_Identifier => - raise Program_Error; - - when N_Identifier - | N_Expanded_Name + when N_Expanded_Name + | N_Identifier => declare - P : constant Entity_Id := Entity (N); C : constant Perm_Tree_Access := - Get (Current_Perm_Env, Unique_Entity (P)); + Get (Current_Perm_Env, Unique_Entity (Entity (N))); + begin + pragma Assert (C /= null); + return (R => Unfolded, Tree_Access => C); + end; + -- For a non-terminal path, we get the permission tree of its + -- prefix, and then get the subtree associated with the extension, + -- if unfolded. If folded, we return the permission associated with + -- children. + + when N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + | N_Slice + => + declare + C : constant Perm_Or_Tree := Get_Perm_Or_Tree (Prefix (N)); begin - -- Setting the initialization map to True, so that this - -- variable cannot be ignored anymore when looking at end - -- of elaboration of package. + case C.R is - Set (Current_Initialization_Map, Unique_Entity (P), True); - if C = null then - -- No null possible here, there are no parents for the path. - -- This means we are using a global variable without adding - -- it in environment with a global aspect. + -- Some earlier prefix was already folded, return the + -- permission found. - Illegal_Global_Usage (N); + when Folded => + return C; - else - return (R => Unfolded, Tree_Access => C); - end if; + when Unfolded => + case Kind (C.Tree_Access) is + + -- If the prefix tree is already folded, return the + -- children permission. + + when Entire_Object => + return (R => Folded, + Found_Permission => + Children_Permission (C.Tree_Access)); + + when Reference => + pragma Assert (Nkind (N) = N_Explicit_Dereference); + return (R => Unfolded, + Tree_Access => Get_All (C.Tree_Access)); + + when Record_Component => + pragma Assert (Nkind (N) = N_Selected_Component); + declare + Comp : constant Entity_Id := + Entity (Selector_Name (N)); + D : constant Perm_Tree_Access := + Perm_Tree_Maps.Get + (Component (C.Tree_Access), Comp); + begin + pragma Assert (D /= null); + return (R => Unfolded, + Tree_Access => D); + end; + + when Array_Component => + pragma Assert (Nkind (N) = N_Indexed_Component + or else + Nkind (N) = N_Slice); + pragma Assert (Get_Elem (C.Tree_Access) /= null); + return (R => Unfolded, + Tree_Access => Get_Elem (C.Tree_Access)); + end case; + end case; end; - when N_Type_Conversion + when N_Qualified_Expression + | N_Type_Conversion | N_Unchecked_Type_Conversion - | N_Qualified_Expression => return Get_Perm_Or_Tree (Expression (N)); - -- Happening when we try to get the permission of a variable that - -- is a formal parameter. We get instead the defining identifier - -- associated with the parameter (which is the one that has been - -- stored for indexing). - - when N_Parameter_Specification => - return Get_Perm_Or_Tree (Defining_Identifier (N)); - - -- We get the permission tree of its prefix, and then get either the - -- subtree associated with that specific selection, or if we have a - -- leaf that folds its children, we take the children's permission - -- and return it using the discriminant Folded. + when others => + raise Program_Error; + end case; + end Get_Perm_Or_Tree; - when N_Selected_Component => - declare - C : constant Perm_Or_Tree := Get_Perm_Or_Tree (Prefix (N)); + ------------------- + -- Get_Perm_Tree -- + ------------------- - begin - case C.R is - when Folded - | Function_Call - => - return C; + function Get_Perm_Tree (N : Node_Id) return Perm_Tree_Access is + begin + return Set_Perm_Prefixes (N, None); + end Get_Perm_Tree; - when Unfolded => - pragma Assert (C.Tree_Access /= null); - pragma Assert (Kind (C.Tree_Access) = Entire_Object - or else - Kind (C.Tree_Access) = Record_Component); - - if Kind (C.Tree_Access) = Record_Component then - declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); - Selected_C : constant Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C.Tree_Access), Selected_Component); - - begin - if Selected_C = null then - return (R => Unfolded, - Tree_Access => - Other_Components (C.Tree_Access)); + --------------------- + -- Get_Root_Object -- + --------------------- - else - return (R => Unfolded, - Tree_Access => Selected_C); - end if; - end; + function Get_Root_Object + (Expr : Node_Id; + Through_Traversal : Boolean := True) return Entity_Id + is + begin + case Nkind (Expr) is + when N_Expanded_Name + | N_Identifier + => + return Entity (Expr); - elsif Kind (C.Tree_Access) = Entire_Object then - return (R => Folded, - Found_Permission => - Children_Permission (C.Tree_Access)); + when N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + | N_Slice + => + return Get_Root_Object (Prefix (Expr), Through_Traversal); - else - raise Program_Error; - end if; - end case; - end; - -- We get the permission tree of its prefix, and then get either the - -- subtree associated with that specific selection, or if we have a - -- leaf that folds its children, we take the children's permission - -- and return it using the discriminant Folded. + -- There is no root object for an allocator or NULL - when N_Indexed_Component - | N_Slice + when N_Allocator + | N_Null => - declare - C : constant Perm_Or_Tree := Get_Perm_Or_Tree (Prefix (N)); + return Empty; - begin - case C.R is - when Folded - | Function_Call - => - return C; + -- In the case of a call to a traversal function, the root object is + -- the root of the traversed parameter. Otherwise there is no root + -- object. - when Unfolded => - pragma Assert (C.Tree_Access /= null); - pragma Assert (Kind (C.Tree_Access) = Entire_Object - or else - Kind (C.Tree_Access) = Array_Component); + when N_Function_Call => + if Through_Traversal + and then Is_Traversal_Function_Call (Expr) + then + return Get_Root_Object (First_Actual (Expr), Through_Traversal); + else + return Empty; + end if; - if Kind (C.Tree_Access) = Array_Component then - pragma Assert (Get_Elem (C.Tree_Access) /= null); - return (R => Unfolded, - Tree_Access => Get_Elem (C.Tree_Access)); + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => + return Get_Root_Object (Expression (Expr), Through_Traversal); - elsif Kind (C.Tree_Access) = Entire_Object then - return (R => Folded, Found_Permission => - Children_Permission (C.Tree_Access)); + when others => + raise Program_Error; + end case; + end Get_Root_Object; - else - raise Program_Error; - end if; - end case; - end; - -- We get the permission tree of its prefix, and then get either the - -- subtree associated with that specific selection, or if we have a - -- leaf that folds its children, we take the children's permission - -- and return it using the discriminant Folded. + --------- + -- Glb -- + --------- - when N_Explicit_Dereference => - declare - C : constant Perm_Or_Tree := Get_Perm_Or_Tree (Prefix (N)); + function Glb (P1, P2 : Perm_Kind) return Perm_Kind + is + begin + case P1 is + when No_Access => + return No_Access; + + when Read_Only => + case P2 is + when No_Access + | Write_Only + => + return No_Access; - begin - case C.R is - when Folded - | Function_Call - => - return C; + when Read_Perm => + return Read_Only; + end case; - when Unfolded => - pragma Assert (C.Tree_Access /= null); - pragma Assert (Kind (C.Tree_Access) = Entire_Object - or else - Kind (C.Tree_Access) = Reference); + when Write_Only => + case P2 is + when No_Access + | Read_Only + => + return No_Access; - if Kind (C.Tree_Access) = Reference then - if Get_All (C.Tree_Access) = null then + when Write_Perm => + return Write_Only; + end case; - -- Hash_Table_Error + when Read_Write => + return P2; + end case; + end Glb; - raise Program_Error; + ------------------------- + -- Has_Array_Component -- + ------------------------- - else - return - (R => Unfolded, - Tree_Access => Get_All (C.Tree_Access)); - end if; + function Has_Array_Component (Expr : Node_Id) return Boolean is + begin + case Nkind (Expr) is + when N_Expanded_Name + | N_Identifier + => + return False; - elsif Kind (C.Tree_Access) = Entire_Object then - return (R => Folded, Found_Permission => - Children_Permission (C.Tree_Access)); + when N_Explicit_Dereference + | N_Selected_Component + => + return Has_Array_Component (Prefix (Expr)); - else - raise Program_Error; - end if; - end case; - end; - -- The name contains a function call, hence the given path is always - -- new. We do not have to check for anything. + when N_Indexed_Component + | N_Slice + => + return True; - when N_Function_Call => - return (R => Function_Call); + when N_Allocator + | N_Null + | N_Function_Call + => + return False; + + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => + return Has_Array_Component (Expression (Expr)); when others => raise Program_Error; end case; - end Get_Perm_Or_Tree; + end Has_Array_Component; - ------------------- - -- Get_Perm_Tree -- - ------------------- + -------- + -- Hp -- + -------- + + procedure Hp (P : Perm_Env) is + Elem : Perm_Tree_Maps.Key_Option; - function Get_Perm_Tree (N : Node_Id) return Perm_Tree_Access is begin - case Nkind (N) is + Elem := Get_First_Key (P); + while Elem.Present loop + Print_Node_Briefly (Elem.K); + Elem := Get_Next_Key (P); + end loop; + end Hp; - -- Base identifier. Normally those are the roots of the trees stored - -- in the permission environment. + -------------------------- + -- Illegal_Global_Usage -- + -------------------------- - when N_Defining_Identifier => - raise Program_Error; + procedure Illegal_Global_Usage (N : Node_Or_Entity_Id) is + begin + Error_Msg_NE ("cannot use global variable & of deep type", N, N); + Error_Msg_N ("\without prior declaration in a Global aspect", N); + Errout.Finalize (Last_Call => True); + Errout.Output_Messages; + Exit_Program (E_Errors); + end Illegal_Global_Usage; - when N_Identifier - | N_Expanded_Name + ------------- + -- Is_Deep -- + ------------- + + function Is_Deep (Typ : Entity_Id) return Boolean is + begin + case Type_Kind'(Ekind (Underlying_Type (Typ))) is + when Access_Kind => + return True; + + when E_Array_Type + | E_Array_Subtype => - declare - P : constant Node_Id := Entity (N); - C : constant Perm_Tree_Access := - Get (Current_Perm_Env, Unique_Entity (P)); + return Is_Deep (Component_Type (Typ)); + when Record_Kind => + declare + Comp : Entity_Id; begin - -- Setting the initialization map to True, so that this - -- variable cannot be ignored anymore when looking at end - -- of elaboration of package. + Comp := First_Component_Or_Discriminant (Typ); + while Present (Comp) loop + if Is_Deep (Etype (Comp)) then + return True; + end if; + Next_Component_Or_Discriminant (Comp); + end loop; + end; + return False; - Set (Current_Initialization_Map, Unique_Entity (P), True); - if C = null then - -- No null possible here, there are no parents for the path. - -- This means we are using a global variable without adding - -- it in environment with a global aspect. + when Scalar_Kind + | E_String_Literal_Subtype + | Protected_Kind + | Task_Kind + | Incomplete_Kind + | E_Exception_Type + | E_Subprogram_Type + => + return False; - Illegal_Global_Usage (N); + -- The following should not arise as underlying types - else - return C; - end if; - end; + when E_Private_Type + | E_Private_Subtype + | E_Limited_Private_Type + | E_Limited_Private_Subtype + => + raise Program_Error; + end case; + end Is_Deep; - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression + ------------------------ + -- Is_Path_Expression -- + ------------------------ + + function Is_Path_Expression (Expr : Node_Id) return Boolean is + begin + case Nkind (Expr) is + when N_Expanded_Name + | N_Explicit_Dereference + | N_Identifier + | N_Indexed_Component + | N_Selected_Component + | N_Slice => - return Get_Perm_Tree (Expression (N)); + return True; - when N_Parameter_Specification => - return Get_Perm_Tree (Defining_Identifier (N)); + -- Special value NULL corresponds to an empty path - -- We get the permission tree of its prefix, and then get either the - -- subtree associated with that specific selection, or if we have a - -- leaf that folds its children, we unroll it in one step. + when N_Null => + return True; - when N_Selected_Component => - declare - C : constant Perm_Tree_Access := Get_Perm_Tree (Prefix (N)); + -- Object returned by a allocator or function call corresponds to + -- a path. - begin - if C = null then + when N_Allocator + | N_Function_Call + => + return True; - -- If null then it means we went through a function call + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => + return Is_Path_Expression (Expression (Expr)); - return null; - end if; + when others => + return False; + end case; + end Is_Path_Expression; - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Record_Component); + ------------------------- + -- Is_Prefix_Or_Almost -- + ------------------------- - if Kind (C) = Record_Component then + function Is_Prefix_Or_Almost (Pref, Expr : Node_Id) return Boolean is - -- The tree is unfolded. We just return the subtree. + type Expr_Array is array (Positive range <>) of Node_Id; + -- Sequence of expressions that make up a path - declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); - Selected_C : constant Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); + function Get_Expr_Array (Expr : Node_Id) return Expr_Array; + pragma Precondition (Is_Path_Expression (Expr)); + -- Return the sequence of expressions that make up a path - begin - if Selected_C = null then - return Other_Components (C); - end if; - return Selected_C; - end; + -------------------- + -- Get_Expr_Array -- + -------------------- - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace the node with - -- Record_Component. + function Get_Expr_Array (Expr : Node_Id) return Expr_Array is + begin + case Nkind (Expr) is + when N_Expanded_Name + | N_Identifier + => + return Expr_Array'(1 => Expr); - Elem : Node_Id; + when N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + | N_Slice + => + return Get_Expr_Array (Prefix (Expr)) & Expr; - -- Create the unrolled nodes + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => + return Get_Expr_Array (Expression (Expr)); - Son : Perm_Tree_Access; + when others => + raise Program_Error; + end case; + end Get_Expr_Array; - Child_Perm : constant Perm_Kind := - Children_Permission (C); + -- Local variables - begin - -- We change the current node from Entire_Object to - -- Record_Component with same permission and an empty - -- hash table as component list. + Prefix_Path : constant Expr_Array := Get_Expr_Array (Pref); + Expr_Path : constant Expr_Array := Get_Expr_Array (Expr); - C.all.Tree := - (Kind => Record_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), - Component => Perm_Tree_Maps.Nil, - Other_Components => - new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - -- Is_Node_Deep is true, to be conservative - Is_Node_Deep => True, - Permission => Child_Perm, - Children_Permission => Child_Perm) - ) - ); - - -- We fill the hash table with all sons of the record, - -- with basic Entire_Objects nodes. - - Elem := First_Component_Or_Discriminant - (Etype (Prefix (N))); - - while Present (Elem) loop - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => Child_Perm, - Children_Permission => Child_Perm)); + Prefix_Root : constant Node_Id := Prefix_Path (1); + Expr_Root : constant Node_Id := Expr_Path (1); - Perm_Tree_Maps.Set - (C.all.Tree.Component, Elem, Son); - Next_Component_Or_Discriminant (Elem); - end loop; - -- we return the tree to the sons, so that the recursion - -- can continue. + Common_Len : constant Positive := + Positive'Min (Prefix_Path'Length, Expr_Path'Length); - declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); + -- Start of processing for Is_Prefix_Or_Almost - Selected_C : constant Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); + begin + if Entity (Prefix_Root) /= Entity (Expr_Root) then + return False; + end if; - begin - pragma Assert (Selected_C /= null); - return Selected_C; - end; - end; - else + for J in 2 .. Common_Len loop + declare + Prefix_Elt : constant Node_Id := Prefix_Path (J); + Expr_Elt : constant Node_Id := Expr_Path (J); + begin + case Nkind (Prefix_Elt) is + when N_Explicit_Dereference => + if Nkind (Expr_Elt) /= N_Explicit_Dereference then + return False; + end if; + + when N_Selected_Component => + if Nkind (Expr_Elt) /= N_Selected_Component + or else Entity (Selector_Name (Prefix_Elt)) + /= Entity (Selector_Name (Expr_Elt)) + then + return False; + end if; + + when N_Indexed_Component + | N_Slice + => + if not Nkind_In (Expr_Elt, N_Indexed_Component, N_Slice) then + return False; + end if; + + when others => raise Program_Error; - end if; - end; - -- We set the permission tree of its prefix, and then we extract from - -- the returned pointer the subtree. If folded, we unroll the tree at - -- one step. + end case; + end; + end loop; - when N_Indexed_Component - | N_Slice - => - declare - C : constant Perm_Tree_Access := Get_Perm_Tree (Prefix (N)); + -- If the expression path is longer than the prefix one, then at this + -- point the prefix property holds. - begin - if C = null then - -- If null then we went through a function call + if Expr_Path'Length > Prefix_Path'Length then + return True; - return null; - end if; - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Array_Component); + -- Otherwise check if none of the remaining path elements in the + -- candidate prefix involve a dereference. - if Kind (C) = Array_Component then + else + for J in Common_Len + 1 .. Prefix_Path'Length loop + if Nkind (Prefix_Path (J)) = N_Explicit_Dereference then + return False; + end if; + end loop; - -- The tree is unfolded. We just return the elem subtree + return True; + end if; + end Is_Prefix_Or_Almost; - pragma Assert (Get_Elem (C) = null); - return Get_Elem (C); + --------------------------- + -- Is_Traversal_Function -- + --------------------------- - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace node with Array_Component. + function Is_Traversal_Function (E : Entity_Id) return Boolean is + begin + return Ekind (E) = E_Function - Son : Perm_Tree_Access; + -- A function is said to be a traversal function if the result type of + -- the function is an anonymous access-to-object type, - begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Children_Permission (C), - Children_Permission => Children_Permission (C))); + and then Is_Anonymous_Access_Type (Etype (E)) - -- We change the current node from Entire_Object - -- to Array_Component with same permission and the - -- previously defined son. + -- the function has at least one formal parameter, - C.all.Tree := (Kind => Array_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), - Get_Elem => Son); - return Get_Elem (C); - end; - else - raise Program_Error; - end if; - end; - -- We get the permission tree of its prefix, and then get either the - -- subtree associated with that specific selection, or if we have a - -- leaf that folds its children, we unroll the tree. + and then Present (First_Formal (E)) - when N_Explicit_Dereference => - declare - C : Perm_Tree_Access; + -- and the function's first parameter is of an access type. - begin - C := Get_Perm_Tree (Prefix (N)); + and then Is_Access_Type (Etype (First_Formal (E))); + end Is_Traversal_Function; - if C = null then + -------------------------------- + -- Is_Traversal_Function_Call -- + -------------------------------- - -- If null, we went through a function call + function Is_Traversal_Function_Call (Expr : Node_Id) return Boolean is + begin + return Nkind (Expr) = N_Function_Call + and then Present (Get_Called_Entity (Expr)) + and then Is_Traversal_Function (Get_Called_Entity (Expr)); + end Is_Traversal_Function_Call; - return null; - end if; + ------------------ + -- Loop_Of_Exit -- + ------------------ - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Reference); + function Loop_Of_Exit (N : Node_Id) return Entity_Id is + Nam : Node_Id := Name (N); + Stmt : Node_Id := N; + begin + if No (Nam) then + while Present (Stmt) loop + Stmt := Parent (Stmt); + if Nkind (Stmt) = N_Loop_Statement then + Nam := Identifier (Stmt); + exit; + end if; + end loop; + end if; + return Entity (Nam); + end Loop_Of_Exit; - if Kind (C) = Reference then + --------- + -- Lub -- + --------- - -- The tree is unfolded. We return the elem subtree + function Lub (P1, P2 : Perm_Kind) return Perm_Kind is + begin + case P1 is + when No_Access => + return P2; + + when Read_Only => + case P2 is + when No_Access + | Read_Only + => + return Read_Only; - if Get_All (C) = null then + when Write_Perm => + return Read_Write; + end case; - -- Hash_Table_Error + when Write_Only => + case P2 is + when No_Access + | Write_Only + => + return Write_Only; - raise Program_Error; - end if; - return Get_All (C); + when Read_Perm => + return Read_Write; + end case; - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace the node with Reference. + when Read_Write => + return Read_Write; + end case; + end Lub; - Son : Perm_Tree_Access; + --------------- + -- Merge_Env -- + --------------- - begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (N)), - Permission => Children_Permission (C), - Children_Permission => Children_Permission (C))); + procedure Merge_Env (Source : in out Perm_Env; Target : in out Perm_Env) is - -- We change the current node from Entire_Object to - -- Reference with same permission and the previous son. + -- Local subprograms - pragma Assert (Is_Node_Deep (C)); - C.all.Tree := (Kind => Reference, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), - Get_All => Son); - return Get_All (C); - end; - else - raise Program_Error; - end if; - end; - -- No permission tree for function calls + procedure Apply_Glb_Tree + (A : Perm_Tree_Access; + P : Perm_Kind); - when N_Function_Call => - return null; + procedure Merge_Trees + (Target : Perm_Tree_Access; + Source : Perm_Tree_Access); - when others => - raise Program_Error; - end case; - end Get_Perm_Tree; + -------------------- + -- Apply_Glb_Tree -- + -------------------- - -------- - -- Hp -- - -------- + procedure Apply_Glb_Tree + (A : Perm_Tree_Access; + P : Perm_Kind) + is + begin + A.all.Tree.Permission := Glb (Permission (A), P); - procedure Hp (P : Perm_Env) is - Elem : Perm_Tree_Maps.Key_Option; + case Kind (A) is + when Entire_Object => + A.all.Tree.Children_Permission := + Glb (Children_Permission (A), P); - begin - Elem := Get_First_Key (P); - while Elem.Present loop - Print_Node_Briefly (Elem.K); - Elem := Get_Next_Key (P); - end loop; - end Hp; + when Reference => + Apply_Glb_Tree (Get_All (A), P); - -------------------------- - -- Illegal_Global_Usage -- - -------------------------- + when Array_Component => + Apply_Glb_Tree (Get_Elem (A), P); - procedure Illegal_Global_Usage (N : Node_Or_Entity_Id) is - begin - Error_Msg_NE ("cannot use global variable & of deep type", N, N); - Error_Msg_N ("\without prior declaration in a Global aspect", N); - Errout.Finalize (Last_Call => True); - Errout.Output_Messages; - Exit_Program (E_Errors); - end Illegal_Global_Usage; + when Record_Component => + declare + Comp : Perm_Tree_Access; + begin + Comp := Perm_Tree_Maps.Get_First (Component (A)); + while Comp /= null loop + Apply_Glb_Tree (Comp, P); + Comp := Perm_Tree_Maps.Get_Next (Component (A)); + end loop; + end; + end case; + end Apply_Glb_Tree; - ------------- - -- Is_Deep -- - ------------- + ----------------- + -- Merge_Trees -- + ----------------- - function Is_Deep (E : Entity_Id) return Boolean is - function Is_Private_Entity_Mode_Off (E : Entity_Id) return Boolean; - function Is_Private_Entity_Mode_Off (E : Entity_Id) return Boolean is - Decl : Node_Id; - Pack_Decl : Node_Id; + procedure Merge_Trees + (Target : Perm_Tree_Access; + Source : Perm_Tree_Access) + is + Perm : constant Perm_Kind := + Glb (Permission (Target), Permission (Source)); begin - if Is_Itype (E) then - Decl := Associated_Node_For_Itype (E); - else - Decl := Parent (E); - end if; + pragma Assert (Is_Node_Deep (Target) = Is_Node_Deep (Source)); + Target.all.Tree.Permission := Perm; - Pack_Decl := Parent (Parent (Decl)); + case Kind (Target) is + when Entire_Object => + declare + Child_Perm : constant Perm_Kind := + Children_Permission (Target); - if Nkind (Pack_Decl) /= N_Package_Declaration then - return False; - end if; + begin + case Kind (Source) is + when Entire_Object => + Target.all.Tree.Children_Permission := + Glb (Child_Perm, Children_Permission (Source)); + + when Reference => + Copy_Tree (Source, Target); + Target.all.Tree.Permission := Perm; + Apply_Glb_Tree (Get_All (Target), Child_Perm); + + when Array_Component => + Copy_Tree (Source, Target); + Target.all.Tree.Permission := Perm; + Apply_Glb_Tree (Get_Elem (Target), Child_Perm); + + when Record_Component => + Copy_Tree (Source, Target); + Target.all.Tree.Permission := Perm; + declare + Comp : Perm_Tree_Access; - return - Present (SPARK_Aux_Pragma (Defining_Entity (Pack_Decl))) - and then Get_SPARK_Mode_From_Annotation - (SPARK_Aux_Pragma (Defining_Entity (Pack_Decl))) = Off; - end Is_Private_Entity_Mode_Off; + begin + Comp := + Perm_Tree_Maps.Get_First (Component (Target)); + while Comp /= null loop + -- Apply glb tree on every component subtree + + Apply_Glb_Tree (Comp, Child_Perm); + Comp := Perm_Tree_Maps.Get_Next + (Component (Target)); + end loop; + end; + end case; + end; - begin - pragma Assert (Is_Type (E)); - case Ekind (E) is - when Scalar_Kind => - return False; + when Reference => + case Kind (Source) is + when Entire_Object => + Apply_Glb_Tree (Get_All (Target), + Children_Permission (Source)); - when Access_Kind => - return True; + when Reference => + Merge_Trees (Get_All (Target), Get_All (Source)); - -- Just check the depth of its component type + when others => + raise Program_Error; - when E_Array_Type - | E_Array_Subtype - => - return Is_Deep (Component_Type (E)); + end case; - when E_String_Literal_Subtype => - return False; + when Array_Component => + case Kind (Source) is + when Entire_Object => + Apply_Glb_Tree (Get_Elem (Target), + Children_Permission (Source)); - -- Per RM 8.11 for class-wide types + when Array_Component => + Merge_Trees (Get_Elem (Target), Get_Elem (Source)); - when E_Class_Wide_Subtype - | E_Class_Wide_Type - => - return True; + when others => + raise Program_Error; - -- ??? What about hidden components + end case; - when E_Record_Type - | E_Record_Subtype - => - declare - Elmt : Entity_Id; + when Record_Component => + case Kind (Source) is + when Entire_Object => + declare + Child_Perm : constant Perm_Kind := + Children_Permission (Source); - begin - Elmt := First_Component_Or_Discriminant (E); - while Present (Elmt) loop - if Is_Deep (Etype (Elmt)) then - return True; - else - Next_Component_Or_Discriminant (Elmt); - end if; - end loop; - return False; - end; + Comp : Perm_Tree_Access; - when Private_Kind => - if Is_Private_Entity_Mode_Off (E) then - return False; - else - if Present (Full_View (E)) then - return Is_Deep (Full_View (E)); - else - return True; - end if; - end if; + begin + Comp := Perm_Tree_Maps.Get_First + (Component (Target)); + while Comp /= null loop + -- Apply glb tree on every component subtree + + Apply_Glb_Tree (Comp, Child_Perm); + Comp := + Perm_Tree_Maps.Get_Next (Component (Target)); + end loop; + end; - when E_Incomplete_Type - | E_Incomplete_Subtype - => - return True; + when Record_Component => + declare + Key_Source : Perm_Tree_Maps.Key_Option; + CompTarget : Perm_Tree_Access; + CompSource : Perm_Tree_Access; - -- No problem with synchronized types + begin + Key_Source := Perm_Tree_Maps.Get_First_Key + (Component (Source)); - when E_Protected_Type - | E_Protected_Subtype - | E_Task_Subtype - | E_Task_Type - => - return False; + while Key_Source.Present loop + CompSource := Perm_Tree_Maps.Get + (Component (Source), Key_Source.K); + CompTarget := Perm_Tree_Maps.Get + (Component (Target), Key_Source.K); - when E_Exception_Type => - return False; + pragma Assert (CompSource /= null); + Merge_Trees (CompTarget, CompSource); - when others => - raise Program_Error; - end case; - end Is_Deep; + Key_Source := Perm_Tree_Maps.Get_Next_Key + (Component (Source)); + end loop; + end; + + when others => + raise Program_Error; + end case; + end case; + end Merge_Trees; + + -- Local variables + + CompTarget : Perm_Tree_Access; + CompSource : Perm_Tree_Access; + KeyTarget : Perm_Tree_Maps.Key_Option; + + -- Start of processing for Merge_Env + + begin + KeyTarget := Get_First_Key (Target); + -- Iterate over every tree of the environment in the target, and merge + -- it with the source if there is such a similar one that exists. If + -- there is none, then skip. + while KeyTarget.Present loop + + CompSource := Get (Source, KeyTarget.K); + CompTarget := Get (Target, KeyTarget.K); + + pragma Assert (CompTarget /= null); + + if CompSource /= null then + Merge_Trees (CompTarget, CompSource); + Remove (Source, KeyTarget.K); + end if; + + KeyTarget := Get_Next_Key (Target); + end loop; + + -- Iterate over every tree of the environment of the source. And merge + -- again. If there is not any tree of the target then just copy the tree + -- from source to target. + declare + KeySource : Perm_Tree_Maps.Key_Option; + begin + KeySource := Get_First_Key (Source); + while KeySource.Present loop + + CompSource := Get (Source, KeySource.K); + CompTarget := Get (Target, KeySource.K); + + if CompTarget = null then + CompTarget := new Perm_Tree_Wrapper'(CompSource.all); + Copy_Tree (CompSource, CompTarget); + Set (Target, KeySource.K, CompTarget); + else + Merge_Trees (CompTarget, CompSource); + end if; + + KeySource := Get_Next_Key (Source); + end loop; + end; + + Free_Env (Source); + end Merge_Env; ---------------- -- Perm_Error -- ---------------- procedure Perm_Error - (N : Node_Id; - Perm : Perm_Kind; - Found_Perm : Perm_Kind) + (N : Node_Id; + Perm : Perm_Kind; + Found_Perm : Perm_Kind; + Forbidden_Perm : Boolean := False) is procedure Set_Root_Object (Path : Node_Id; @@ -3328,7 +3975,7 @@ package body Sem_SPARK is Error_Msg_NE ("insufficient permission for &", N, Root); end if; - Perm_Mismatch (Perm, Found_Perm, N); + Perm_Mismatch (N, Perm, Found_Perm, Forbidden_Perm); end Perm_Error; ------------------------------- @@ -3345,364 +3992,441 @@ package body Sem_SPARK is Error_Msg_Node_2 := Subp; Error_Msg_NE ("insufficient permission for & when returning from &", Subp, E); - Perm_Mismatch (Perm, Found_Perm, Subp); + Perm_Mismatch (Subp, Perm, Found_Perm); end Perm_Error_Subprogram_End; ------------------ -- Process_Path -- ------------------ - procedure Process_Path (N : Node_Id) is - Root : constant Entity_Id := Get_Enclosing_Object (N); - State_N : Perm_Kind; + procedure Process_Path (Expr : Node_Id; Mode : Checking_Mode) is + + procedure Check_Not_Borrowed (Expr : Node_Id; Root : Entity_Id); + -- Check expression Expr originating in Root was not borrowed + + procedure Check_Not_Observed (Expr : Node_Id; Root : Entity_Id); + -- Check expression Expr originating in Root was not observed + + ------------------------ + -- Check_Not_Borrowed -- + ------------------------ + + procedure Check_Not_Borrowed (Expr : Node_Id; Root : Entity_Id) is + begin + -- An expression without root object cannot be borrowed + + if No (Root) then + return; + end if; + + -- Otherwise, try to match the expression with one of the borrowed + -- expressions. + + declare + Key : Variable_Maps.Key_Option := + Get_First_Key (Current_Borrowers); + Var : Entity_Id; + Borrowed : Node_Id; + + begin + while Key.Present loop + Var := Key.K; + Borrowed := Get (Current_Borrowers, Var); + + if Is_Prefix_Or_Almost (Pref => Borrowed, Expr => Expr) then + Error_Msg_Sloc := Sloc (Borrowed); + Error_Msg_N ("expression was borrowed #", Expr); + end if; + + Key := Get_Next_Key (Current_Borrowers); + end loop; + end; + end Check_Not_Borrowed; + + ------------------------ + -- Check_Not_Observed -- + ------------------------ + + procedure Check_Not_Observed (Expr : Node_Id; Root : Entity_Id) is + begin + -- An expression without root object cannot be observed + + if No (Root) then + return; + end if; + + -- Otherwise, try to match the expression with one of the observed + -- expressions. + + declare + Key : Variable_Maps.Key_Option := + Get_First_Key (Current_Observers); + Var : Entity_Id; + Observed : Node_Id; + + begin + while Key.Present loop + Var := Key.K; + Observed := Get (Current_Observers, Var); + + if Is_Prefix_Or_Almost (Pref => Observed, Expr => Expr) then + Error_Msg_Sloc := Sloc (Observed); + Error_Msg_N ("expression was observed #", Expr); + end if; + + Key := Get_Next_Key (Current_Observers); + end loop; + end; + end Check_Not_Observed; + + -- Local variables + + Expr_Type : constant Entity_Id := Etype (Expr); + Root : Entity_Id := Get_Root_Object (Expr); + Perm : Perm_Kind_Option; + + -- Start of processing for Process_Path + begin - -- We ignore if yielding to synchronized + -- Nothing to do if the root type is not deep, or the path is not rooted + -- in an object. - if Present (Root) - and then Is_Synchronized_Object (Root) + if not Present (Root) + or else not Is_Deep (Etype (Root)) then return; end if; - State_N := Get_Perm (N); + -- Identify the root type for the path - case Current_Checking_Mode is + Root := Unique_Entity (Root); - -- Check permission R, do nothing + -- Except during elaboration, the root object should have been declared + -- and entered into the current permission environment. - when Read => + if not Inside_Elaboration + and then Get (Current_Perm_Env, Root) = null + then + Illegal_Global_Usage (Expr); + end if; - -- This condition should be removed when removing the read - -- checking mode. + -- During elaboration, only the validity of operations is checked, no + -- need to compute the permission of Expr. - return; + if Inside_Elaboration then + Perm := None; + else + Perm := Get_Perm (Expr); + end if; - when Move => + -- Check permissions + + case Mode is + + when Read => - -- The rhs object in an assignment statement (including copy in - -- and copy back) should be in the Unrestricted or Moved state. - -- Otherwise the move is not allowed. - -- This applies to both stand-alone and composite objects. - -- If the state of the source is Moved, then a warning message - -- is prompt to make the user aware of reading a nullified - -- object. + -- No checking needed during elaboration - if State_N /= Unrestricted and State_N /= Moved then - Perm_Error (N, Unrestricted, State_N); + if Inside_Elaboration then return; end if; - -- In the AI, after moving a path nothing to do since the rhs - -- object was in the Unrestricted state and it shall be - -- refreshed to Unrestricted. The object should be nullified - -- however. To avoid moving again a name that has already been - -- moved, in this implementation we set the state of the moved - -- object to "Moved". This shall be used to prompt a warning - -- when manipulating a null pointer and also to implement - -- the no aliasing parameter restriction. - - if State_N = Moved then - Error_Msg_N ("?the source or one of its extensions has" - & " already been moved", N); + -- Check path is readable + + if Perm not in Read_Perm then + Perm_Error (Expr, Read_Only, Perm); + return; end if; - declare - -- Set state to Moved to the path and any of its prefixes + when Move => - Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes (N, Moved); + -- Forbidden on deep path during elaboration, otherwise no + -- checking needed. - begin - if Tree = null then + if Inside_Elaboration then + if Is_Deep (Expr_Type) + and then not Inside_Procedure_Call + and then Present (Get_Root_Object (Expr)) + then + Error_Msg_N ("illegal move during elaboration", Expr); + end if; - -- We went through a function call, no permission to - -- modify. + return; + end if; - return; + -- For deep path, check RW permission, otherwise R permission + + if not Is_Deep (Expr_Type) then + if Perm not in Read_Perm then + Perm_Error (Expr, Read_Only, Perm); end if; + return; + end if; - -- Set state to Moved on any strict extension of the path + -- SPARK RM 3.10(1): At the point of a move operation the state of + -- the source object (if any) shall be Unrestricted. - Set_Perm_Extensions (Tree, Moved); - end; + if Perm /= Read_Write then + Perm_Error (Expr, Read_Write, Perm); + return; + end if; when Assign => - -- The lhs object in an assignment statement (including copy in - -- and copy back) should be in the Unrestricted state. - -- Otherwise the move is not allowed. - -- This applies to both stand-alone and composite objects. + -- No checking needed during elaboration - if State_N /= Unrestricted and State_N /= Moved then - Perm_Error (N, Unrestricted, State_N); + if Inside_Elaboration then return; end if; - -- After assigning to a path nothing to do since it was in the - -- Unrestricted state and it would be refreshed to - -- Unrestricted. + -- For assignment, check W permission + + if Perm not in Write_Perm then + Perm_Error (Expr, Write_Only, Perm); + return; + end if; when Borrow => - -- Borrowing is only allowed on Unrestricted objects. + -- Forbidden during elaboration - if State_N /= Unrestricted and State_N /= Moved then - Perm_Error (N, Unrestricted, State_N); - end if; + if Inside_Elaboration then + if not Inside_Procedure_Call then + Error_Msg_N ("illegal borrow during elaboration", Expr); + end if; - if State_N = Moved then - Error_Msg_N ("?the source or one of its extensions has" - & " already been moved", N); + return; end if; - declare - -- Set state to Borrowed to the path and any of its prefixes + -- For borrowing, check RW permission - Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes (N, Borrowed); + if Perm /= Read_Write then + Perm_Error (Expr, Read_Write, Perm); + return; + end if; - begin - if Tree = null then + when Observe => - -- We went through a function call, no permission to - -- modify. + -- Forbidden during elaboration - return; + if Inside_Elaboration then + if not Inside_Procedure_Call then + Error_Msg_N ("illegal observe during elaboration", Expr); end if; - -- Set state to Borrowed on any strict extension of the path + return; + end if; - Set_Perm_Extensions (Tree, Borrowed); - end; + -- For borrowing, check R permission - when Observe => - if State_N /= Unrestricted - and then State_N /= Observed - then - Perm_Error (N, Observed, State_N); + if Perm not in Read_Perm then + Perm_Error (Expr, Read_Only, Perm); + return; end if; + end case; - declare - -- Set permission to Observed on the path and any of its - -- prefixes if it is of a deep type. Actually, some operation - -- like reading from an object of access type is considered as - -- observe while it should not affect the permissions of - -- the considered tree. + -- Check path was not borrowed - Tree : Perm_Tree_Access; + Check_Not_Borrowed (Expr, Root); - begin - if Is_Deep (Etype (N)) then - Tree := Set_Perm_Prefixes (N, Observed); - else - Tree := null; - end if; + -- For modes that require W permission, check path was not observed - if Tree = null then + case Mode is + when Read | Observe => + null; + when Assign | Move | Borrow => + Check_Not_Observed (Expr, Root); + end case; - -- We went through a function call, no permission to - -- modify. + -- Do not update permission environment when handling calls - return; - end if; + if Inside_Procedure_Call then + return; + end if; - -- Set permissions to No on any strict extension of the path + -- Update the permissions - Set_Perm_Extensions (Tree, Observed); - end; - end case; - end Process_Path; + case Mode is - ------------------------- - -- Return_Declarations -- - ------------------------- + when Read => + null; - procedure Return_Declarations (L : List_Id) is - procedure Return_Declaration (Decl : Node_Id); - -- Check correct permissions for every declared object + when Move => - ------------------------ - -- Return_Declaration -- - ------------------------ + -- SPARK RM 3.10(1): After a move operation, the state of the + -- source object (if any) becomes Moved. - procedure Return_Declaration (Decl : Node_Id) is - begin - if Nkind (Decl) = N_Object_Declaration then + if Present (Get_Root_Object (Expr)) then + declare + Tree : constant Perm_Tree_Access := + Set_Perm_Prefixes (Expr, Write_Only); + begin + pragma Assert (Tree /= null); + Set_Perm_Extensions_Move (Tree, Etype (Expr)); + end; + end if; - -- Check RW for object declared, unless the object has never been - -- initialized. + when Assign => + + -- If there is no root object, or the tree has an array component, + -- then the permissions do not get modified by the assignment. - if Get (Current_Initialization_Map, - Unique_Entity (Defining_Identifier (Decl))) = False + if No (Get_Root_Object (Expr)) + or else Has_Array_Component (Expr) then return; end if; - declare - Elem : constant Perm_Tree_Access := - Get (Current_Perm_Env, - Unique_Entity (Defining_Identifier (Decl))); + -- Set permission RW for the path and its extensions + declare + Tree : constant Perm_Tree_Access := Get_Perm_Tree (Expr); begin - if Elem = null then + Tree.all.Tree.Permission := Read_Write; + Set_Perm_Extensions (Tree, Read_Write); - -- Here we are on a declaration. Hence it should have been - -- added in the environment when analyzing this node with - -- mode Read. Hence it is not possible to find a null - -- pointer here. - - -- Hash_Table_Error - - raise Program_Error; - end if; + -- Normalize the permission tree - if Permission (Elem) /= Unrestricted then - Perm_Error (Decl, Unrestricted, Permission (Elem)); - end if; + Set_Perm_Prefixes_Assign (Expr); end; - end if; - end Return_Declaration; - -- Local Variables - - N : Node_Id; - -- Start of processing for Return_Declarations + -- Borrowing and observing of paths is handled by the variables + -- Current_Borrowers and Current_Observers. - begin - N := First (L); - while Present (N) loop - Return_Declaration (N); - Next (N); - end loop; - end Return_Declarations; + when Borrow | Observe => + null; + end case; + end Process_Path; -------------------- -- Return_Globals -- -------------------- procedure Return_Globals (Subp : Entity_Id) is - procedure Return_Globals_From_List - (First_Item : Node_Id; - Kind : Formal_Kind); - -- Return global items from the list starting at Item - procedure Return_Globals_Of_Mode (Global_Mode : Name_Id); - -- Return global items for the mode Global_Mode + procedure Return_Global + (Expr : Node_Id; + Typ : Entity_Id; + Kind : Formal_Kind; + Subp : Entity_Id; + Global_Var : Boolean); + -- Proxy procedure to return globals, to adjust for the type of first + -- parameter expected by Return_Parameter_Or_Global. - ------------------------------ - -- Return_Globals_From_List -- - ------------------------------ + ------------------- + -- Return_Global -- + ------------------- - procedure Return_Globals_From_List - (First_Item : Node_Id; - Kind : Formal_Kind) + procedure Return_Global + (Expr : Node_Id; + Typ : Entity_Id; + Kind : Formal_Kind; + Subp : Entity_Id; + Global_Var : Boolean) is - Item : Node_Id := First_Item; - E : Entity_Id; - begin - while Present (Item) loop - E := Entity (Item); + Return_Parameter_Or_Global + (Id => Entity (Expr), + Typ => Typ, + Kind => Kind, + Subp => Subp, + Global_Var => Global_Var); + end Return_Global; - -- Ignore abstract states, which play no role in pointer aliasing - - if Ekind (E) = E_Abstract_State then - null; - else - Return_The_Global (E, Kind, Subp); - end if; - Next_Global (Item); - end loop; - end Return_Globals_From_List; - - ---------------------------- - -- Return_Globals_Of_Mode -- - ---------------------------- - - procedure Return_Globals_Of_Mode (Global_Mode : Name_Id) is - Kind : Formal_Kind; - - begin - case Global_Mode is - when Name_Input - | Name_Proof_In - => - Kind := E_In_Parameter; - when Name_Output => - Kind := E_Out_Parameter; - when Name_In_Out => - Kind := E_In_Out_Parameter; - when others => - raise Program_Error; - end case; - - -- Return both global items from Global and Refined_Global pragmas - - Return_Globals_From_List (First_Global (Subp, Global_Mode), Kind); - Return_Globals_From_List - (First_Global (Subp, Global_Mode, Refined => True), Kind); - end Return_Globals_Of_Mode; + procedure Return_Globals_Inst is new Handle_Globals (Return_Global); -- Start of processing for Return_Globals begin - Return_Globals_Of_Mode (Name_Proof_In); - Return_Globals_Of_Mode (Name_Input); - Return_Globals_Of_Mode (Name_Output); - Return_Globals_Of_Mode (Name_In_Out); + Return_Globals_Inst (Subp); end Return_Globals; -------------------------------- -- Return_Parameter_Or_Global -- -------------------------------- - procedure Return_The_Global - (Id : Entity_Id; - Mode : Formal_Kind; - Subp : Entity_Id) + procedure Return_Parameter_Or_Global + (Id : Entity_Id; + Typ : Entity_Id; + Kind : Formal_Kind; + Subp : Entity_Id; + Global_Var : Boolean) is - Elem : constant Perm_Tree_Access := Get (Current_Perm_Env, Id); - pragma Assert (Elem /= null); - begin - -- Observed IN parameters and globals need not return a permission to - -- the caller. + -- Shallow parameters and globals need not be considered + + if not Is_Deep (Typ) then + return; - if Mode = E_In_Parameter + elsif Kind = E_In_Parameter then - -- Check this for read-only globals. + -- Input global variables are observed only - then - if Permission (Elem) /= Unrestricted - and then Permission (Elem) /= Observed + if Global_Var then + return; + + -- Anonymous access to constant is an observe + + elsif Is_Anonymous_Access_Type (Typ) + and then Is_Access_Constant (Typ) then - Perm_Error_Subprogram_End - (E => Id, - Subp => Subp, - Perm => Observed, - Found_Perm => Permission (Elem)); + return; + + -- Deep types other than access types define an observe + + elsif not Is_Access_Type (Typ) then + return; end if; + end if; - -- All globals of mode out or in/out should return with mode - -- Unrestricted. + -- All other parameters and globals should return with mode RW to the + -- caller. - else - if Permission (Elem) /= Unrestricted then + declare + Tree : constant Perm_Tree_Access := Get (Current_Perm_Env, Id); + begin + if Permission (Tree) /= Read_Write then Perm_Error_Subprogram_End (E => Id, Subp => Subp, - Perm => Unrestricted, - Found_Perm => Permission (Elem)); + Perm => Read_Write, + Found_Perm => Permission (Tree)); end if; - end if; - end Return_The_Global; + end; + end Return_Parameter_Or_Global; + + ----------------------- + -- Return_Parameters -- + ----------------------- + + procedure Return_Parameters (Subp : Entity_Id) is + Formal : Entity_Id; + begin + Formal := First_Formal (Subp); + while Present (Formal) loop + Return_Parameter_Or_Global + (Id => Formal, + Typ => Underlying_Type (Etype (Formal)), + Kind => Ekind (Formal), + Subp => Subp, + Global_Var => False); + Next_Formal (Formal); + end loop; + end Return_Parameters; ------------------------- -- Set_Perm_Extensions -- ------------------------- procedure Set_Perm_Extensions (T : Perm_Tree_Access; P : Perm_Kind) is + procedure Free_Perm_Tree_Children (T : Perm_Tree_Access); + -- Free the permission tree of children if any, prio to replacing T + + ----------------------------- + -- Free_Perm_Tree_Children -- + ----------------------------- + procedure Free_Perm_Tree_Children (T : Perm_Tree_Access) is begin case Kind (T) is @@ -3710,740 +4434,474 @@ package body Sem_SPARK is null; when Reference => - Free_Perm_Tree (T.all.Tree.Get_All); + Free_Tree (T.all.Tree.Get_All); when Array_Component => - Free_Perm_Tree (T.all.Tree.Get_Elem); - - -- Free every Component subtree + Free_Tree (T.all.Tree.Get_Elem); when Record_Component => declare - Comp : Perm_Tree_Access; + Hashtbl : Perm_Tree_Maps.Instance := Component (T); + Comp : Perm_Tree_Access; begin - Comp := Perm_Tree_Maps.Get_First (Component (T)); + Comp := Perm_Tree_Maps.Get_First (Hashtbl); while Comp /= null loop - Free_Perm_Tree (Comp); - Comp := Perm_Tree_Maps.Get_Next (Component (T)); + Free_Tree (Comp); + Comp := Perm_Tree_Maps.Get_Next (Hashtbl); end loop; - Free_Perm_Tree (T.all.Tree.Other_Components); + Perm_Tree_Maps.Reset (Hashtbl); end; end case; end Free_Perm_Tree_Children; - Son : constant Perm_Tree := - Perm_Tree' - (Kind => Entire_Object, - Is_Node_Deep => Is_Node_Deep (T), - Permission => Permission (T), - Children_Permission => P); + -- Start of processing for Set_Perm_Extensions begin Free_Perm_Tree_Children (T); - T.all.Tree := Son; + T.all.Tree := Perm_Tree'(Kind => Entire_Object, + Is_Node_Deep => Is_Node_Deep (T), + Permission => Permission (T), + Children_Permission => P); end Set_Perm_Extensions; ------------------------------ - -- Set_Perm_Prefixes -- + -- Set_Perm_Extensions_Move -- ------------------------------ - function Set_Perm_Prefixes - (N : Node_Id; - New_Perm : Perm_Kind) - return Perm_Tree_Access + procedure Set_Perm_Extensions_Move + (T : Perm_Tree_Access; + E : Entity_Id) is begin + -- Shallow extensions are set to RW - case Nkind (N) is - - when N_Identifier - | N_Expanded_Name - | N_Defining_Identifier - => - if Nkind (N) = N_Defining_Identifier - and then New_Perm = Borrowed - then - raise Program_Error; - end if; - - declare - P : Node_Id; - C : Perm_Tree_Access; - - begin - if Nkind (N) = N_Defining_Identifier then - P := N; - else - P := Entity (N); - end if; - - C := Get (Current_Perm_Env, Unique_Entity (P)); - pragma Assert (C /= null); - - -- Setting the initialization map to True, so that this - -- variable cannot be ignored anymore when looking at end - -- of elaboration of package. - - Set (Current_Initialization_Map, Unique_Entity (P), True); - if New_Perm = Observed - and then C = null - then - - -- No null possible here, there are no parents for the path. - -- This means we are using a global variable without adding - -- it in environment with a global aspect. - - Illegal_Global_Usage (N); - end if; - - C.all.Tree.Permission := New_Perm; - return C; - end; - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Set_Perm_Prefixes (Expression (N), New_Perm); - - when N_Parameter_Specification => - raise Program_Error; - - -- We set the permission tree of its prefix, and then we extract - -- our subtree from the returned pointer and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree - -- in one step. - - when N_Selected_Component => - declare - C : constant Perm_Tree_Access := - Set_Perm_Prefixes (Prefix (N), New_Perm); - - begin - if C = null then + if not Is_Node_Deep (T) then + Set_Perm_Extensions (T, Read_Write); + return; + end if; - -- We went through a function call, do nothing + -- Deep extensions are set to W before .all and NO afterwards - return null; - end if; + T.all.Tree.Permission := Write_Only; - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Record_Component); + case T.all.Tree.Kind is - if Kind (C) = Record_Component then - -- The tree is unfolded. We just modify the permission and - -- return the record subtree. + -- For a folded tree of composite type, unfold the tree for better + -- precision. + when Entire_Object => + case Ekind (E) is + when E_Array_Type + | E_Array_Subtype + => declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); - - Selected_C : Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); - + C : constant Perm_Tree_Access := + new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => Is_Node_Deep (T), + Permission => Read_Write, + Children_Permission => Read_Write)); begin - if Selected_C = null then - Selected_C := Other_Components (C); - end if; - - pragma Assert (Selected_C /= null); - Selected_C.all.Tree.Permission := New_Perm; - return Selected_C; + Set_Perm_Extensions_Move (C, Component_Type (E)); + T.all.Tree := (Kind => Array_Component, + Is_Node_Deep => Is_Node_Deep (T), + Permission => Write_Only, + Get_Elem => C); end; - elsif Kind (C) = Entire_Object then + when Record_Kind => declare - -- Expand the tree. Replace the node with - -- Record_Component. - - Elem : Node_Id; - - -- Create an empty hash table - + C : Perm_Tree_Access; + Comp : Entity_Id; Hashtbl : Perm_Tree_Maps.Instance; - -- We create the unrolled nodes, that will all have same - -- permission than parent. - - Son : Perm_Tree_Access; - Children_Perm : constant Perm_Kind := - Children_Permission (C); - begin - -- We change the current node from Entire_Object to - -- Record_Component with same permission and an empty - -- hash table as component list. - - C.all.Tree := - (Kind => Record_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), - Component => Hashtbl, - Other_Components => - new Perm_Tree_Wrapper' + Comp := First_Component_Or_Discriminant (E); + while Present (Comp) loop + C := new Perm_Tree_Wrapper' (Tree => - (Kind => Entire_Object, - Is_Node_Deep => True, - Permission => Children_Perm, - Children_Permission => Children_Perm) - )); + (Kind => Entire_Object, + Is_Node_Deep => Is_Deep (Etype (Comp)), + Permission => Read_Write, + Children_Permission => Read_Write)); + Set_Perm_Extensions_Move (C, Etype (Comp)); + Perm_Tree_Maps.Set (Hashtbl, Comp, C); + Next_Component_Or_Discriminant (Comp); + end loop; - -- We fill the hash table with all sons of the record, - -- with basic Entire_Objects nodes. + T.all.Tree := + (Kind => Record_Component, + Is_Node_Deep => Is_Node_Deep (T), + Permission => Write_Only, + Component => Hashtbl); + end; - Elem := First_Component_Or_Discriminant - (Etype (Prefix (N))); + -- Otherwise, extensions are set to NO - while Present (Elem) loop - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => Children_Perm, - Children_Permission => Children_Perm)); + when others => + Set_Perm_Extensions (T, No_Access); + end case; - Perm_Tree_Maps.Set (C.all.Tree.Component, Elem, Son); - Next_Component_Or_Discriminant (Elem); - end loop; - -- Now we set the right field to Borrowed, and then we - -- return the tree to the sons, so that the recursion can - -- continue. + when Reference => + Set_Perm_Extensions (T, No_Access); - declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); - Selected_C : Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); + when Array_Component => + Set_Perm_Extensions_Move (Get_Elem (T), Component_Type (E)); - begin - if Selected_C = null then - Selected_C := Other_Components (C); - end if; + when Record_Component => + declare + C : Perm_Tree_Access; + Comp : Entity_Id; - pragma Assert (Selected_C /= null); - Selected_C.all.Tree.Permission := New_Perm; - return Selected_C; - end; - end; - else - raise Program_Error; - end if; + begin + Comp := First_Component_Or_Discriminant (E); + while Present (Comp) loop + C := Perm_Tree_Maps.Get (Component (T), Comp); + pragma Assert (C /= null); + Set_Perm_Extensions_Move (C, Etype (Comp)); + Next_Component_Or_Discriminant (Comp); + end loop; end; + end case; + end Set_Perm_Extensions_Move; - -- We set the permission tree of its prefix, and then we extract - -- from the returned pointer the subtree and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree in - -- one step. + ----------------------- + -- Set_Perm_Prefixes -- + ----------------------- - when N_Indexed_Component - | N_Slice + function Set_Perm_Prefixes + (N : Node_Id; + Perm : Perm_Kind_Option) return Perm_Tree_Access + is + begin + case Nkind (N) is + when N_Expanded_Name + | N_Identifier => declare - C : constant Perm_Tree_Access := - Set_Perm_Prefixes (Prefix (N), New_Perm); + E : constant Entity_Id := Unique_Entity (Entity (N)); + C : constant Perm_Tree_Access := Get (Current_Perm_Env, E); + pragma Assert (C /= null); begin - if C = null then - - -- We went through a function call, do nothing - - return null; + if Perm /= None then + C.all.Tree.Permission := Glb (Perm, Permission (C)); end if; - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Array_Component); - - if Kind (C) = Array_Component then - - -- The tree is unfolded. We just modify the permission and - -- return the elem subtree. - - pragma Assert (Get_Elem (C) /= null); - C.all.Tree.Get_Elem.all.Tree.Permission := New_Perm; - return Get_Elem (C); - - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace node with Array_Component. - - Son : Perm_Tree_Access; - - begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Node_Deep (C), - Permission => New_Perm, - Children_Permission => Children_Permission (C))); - - -- Children_Permission => Children_Permission (C) - -- this line should be checked maybe New_Perm - -- instead of Children_Permission (C) - - -- We change the current node from Entire_Object - -- to Array_Component with same permission and the - -- previously defined son. - - C.all.Tree := (Kind => Array_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => New_Perm, - Get_Elem => Son); - return Get_Elem (C); - end; - else - raise Program_Error; - end if; + return C; end; - -- We set the permission tree of its prefix, and then we extract - -- from the returned pointer the subtree and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree - -- at one step. + -- For a non-terminal path, we set the permission tree of its prefix, + -- and then we extract from the returned pointer the subtree and + -- assign an adequate permission to it, if unfolded. If folded, + -- we unroll the tree one level. when N_Explicit_Dereference => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes (Prefix (N), New_Perm); - - begin - if C = null then - - -- We went through a function call. Do nothing. - - return null; - end if; - + Set_Perm_Prefixes (Prefix (N), Perm); + pragma Assert (C /= null); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Reference); + begin + -- The tree is already unfolded. Replace the permission of the + -- dereference. if Kind (C) = Reference then + declare + D : constant Perm_Tree_Access := Get_All (C); + pragma Assert (D /= null); - -- The tree is unfolded. We just modify the permission and - -- return the elem subtree. - - pragma Assert (Get_All (C) /= null); - C.all.Tree.Get_All.all.Tree.Permission := New_Perm; - return Get_All (C); + begin + if Perm /= None then + D.all.Tree.Permission := Glb (Perm, Permission (D)); + end if; - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace the node with Reference. + return D; + end; - Son : Perm_Tree_Access; + -- The tree is folded. Expand it. + else + declare + pragma Assert (Kind (C) = Entire_Object); + + Child_P : constant Perm_Kind := Children_Permission (C); + D : constant Perm_Tree_Access := + new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => Is_Deep (Etype (N)), + Permission => Child_P, + Children_Permission => Child_P)); begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (N)), - Permission => New_Perm, - Children_Permission => Children_Permission (C))); - - -- We change the current node from Entire_Object to - -- Reference with Borrowed and the previous son. + if Perm /= None then + D.all.Tree.Permission := Perm; + end if; - pragma Assert (Is_Node_Deep (C)); C.all.Tree := (Kind => Reference, Is_Node_Deep => Is_Node_Deep (C), - Permission => New_Perm, - Get_All => Son); - return Get_All (C); + Permission => Permission (C), + Get_All => D); + return D; end; - - else - raise Program_Error; end if; end; - when N_Function_Call => - return null; - - when others => - raise Program_Error; - end case; - end Set_Perm_Prefixes; - - ------------------------------ - -- Set_Perm_Prefixes_Borrow -- - ------------------------------ - - function Set_Perm_Prefixes_Borrow (N : Node_Id) return Perm_Tree_Access - is - begin - pragma Assert (Current_Checking_Mode = Borrow); - case Nkind (N) is - - when N_Identifier - | N_Expanded_Name - => - declare - P : constant Node_Id := Entity (N); - C : constant Perm_Tree_Access := - Get (Current_Perm_Env, Unique_Entity (P)); - pragma Assert (C /= null); - - begin - -- Setting the initialization map to True, so that this - -- variable cannot be ignored anymore when looking at end - -- of elaboration of package. - - Set (Current_Initialization_Map, Unique_Entity (P), True); - C.all.Tree.Permission := Borrowed; - return C; - end; - - when N_Type_Conversion - | N_Unchecked_Type_Conversion - | N_Qualified_Expression - => - return Set_Perm_Prefixes_Borrow (Expression (N)); - - when N_Parameter_Specification - | N_Defining_Identifier - => - raise Program_Error; - - -- We set the permission tree of its prefix, and then we extract - -- our subtree from the returned pointer and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree - -- in one step. - when N_Selected_Component => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow (Prefix (N)); - - begin - if C = null then - - -- We went through a function call, do nothing - - return null; - end if; - - -- The permission of the returned node should be No - - pragma Assert (Permission (C) = Borrowed); + Set_Perm_Prefixes (Prefix (N), Perm); + pragma Assert (C /= null); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Record_Component); + begin + -- The tree is already unfolded. Replace the permission of the + -- component. if Kind (C) = Record_Component then - - -- The tree is unfolded. We just modify the permission and - -- return the record subtree. - declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); - Selected_C : Perm_Tree_Access := - Perm_Tree_Maps.Get - (Component (C), Selected_Component); + Comp : constant Entity_Id := Entity (Selector_Name (N)); + D : constant Perm_Tree_Access := + Perm_Tree_Maps.Get (Component (C), Comp); + pragma Assert (D /= null); begin - if Selected_C = null then - Selected_C := Other_Components (C); + if Perm /= None then + D.all.Tree.Permission := Glb (Perm, Permission (D)); end if; - pragma Assert (Selected_C /= null); - Selected_C.all.Tree.Permission := Borrowed; - return Selected_C; + return D; end; - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace the node with - -- Record_Component. - - Elem : Node_Id; + -- The tree is folded. Expand it. - -- Create an empty hash table + else + declare + pragma Assert (Kind (C) = Entire_Object); + D : Perm_Tree_Access; + D_This : Perm_Tree_Access; + Comp : Node_Id; + P : Perm_Kind; + Child_P : constant Perm_Kind := Children_Permission (C); Hashtbl : Perm_Tree_Maps.Instance; - - -- We create the unrolled nodes, that will all have same - -- permission than parent. - - Son : Perm_Tree_Access; - ChildrenPerm : constant Perm_Kind := - Children_Permission (C); + -- Create an empty hash table begin - -- We change the current node from Entire_Object to - -- Record_Component with same permission and an empty - -- hash table as component list. - - C.all.Tree := - (Kind => Record_Component, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Permission (C), - Component => Hashtbl, - Other_Components => - new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => True, - Permission => ChildrenPerm, - Children_Permission => ChildrenPerm) - )); - - -- We fill the hash table with all sons of the record, - -- with basic Entire_Objects nodes. + Comp := + First_Component_Or_Discriminant (Etype (Prefix (N))); - Elem := First_Component_Or_Discriminant - (Etype (Prefix (N))); + while Present (Comp) loop + if Perm /= None + and then Comp = Entity (Selector_Name (N)) + then + P := Perm; + else + P := Child_P; + end if; - while Present (Elem) loop - Son := new Perm_Tree_Wrapper' + D := new Perm_Tree_Wrapper' (Tree => (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (Elem)), - Permission => ChildrenPerm, - Children_Permission => ChildrenPerm)); - Perm_Tree_Maps.Set (C.all.Tree.Component, Elem, Son); - Next_Component_Or_Discriminant (Elem); - end loop; + Is_Node_Deep => Is_Deep (Etype (Comp)), + Permission => P, + Children_Permission => Child_P)); + Perm_Tree_Maps.Set (Hashtbl, Comp, D); - -- Now we set the right field to Borrowed, and then we - -- return the tree to the sons, so that the recursion can - -- continue. - - declare - Selected_Component : constant Entity_Id := - Entity (Selector_Name (N)); - Selected_C : Perm_Tree_Access := Perm_Tree_Maps.Get - (Component (C), Selected_Component); + -- Store the tree to return for this component - begin - if Selected_C = null then - Selected_C := Other_Components (C); + if Comp = Entity (Selector_Name (N)) then + D_This := D; end if; - pragma Assert (Selected_C /= null); - Selected_C.all.Tree.Permission := Borrowed; - return Selected_C; - end; - end; + Next_Component_Or_Discriminant (Comp); + end loop; - else - raise Program_Error; + C.all.Tree := (Kind => Record_Component, + Is_Node_Deep => Is_Node_Deep (C), + Permission => Permission (C), + Component => Hashtbl); + return D_This; + end; end if; end; - -- We set the permission tree of its prefix, and then we extract - -- from the returned pointer the subtree and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree in - -- one step. - when N_Indexed_Component | N_Slice => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow (Prefix (N)); - - begin - if C = null then - - -- We went through a function call, do nothing - - return null; - end if; - - pragma Assert (Permission (C) = Borrowed); + Set_Perm_Prefixes (Prefix (N), Perm); + pragma Assert (C /= null); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Array_Component); + begin + -- The tree is already unfolded. Replace the permission of the + -- component. if Kind (C) = Array_Component then + declare + D : constant Perm_Tree_Access := Get_Elem (C); + pragma Assert (D /= null); - -- The tree is unfolded. We just modify the permission and - -- return the elem subtree. - - pragma Assert (Get_Elem (C) /= null); - C.all.Tree.Get_Elem.all.Tree.Permission := Borrowed; - return Get_Elem (C); + begin + if Perm /= None then + D.all.Tree.Permission := Glb (Perm, Permission (D)); + end if; - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace node with Array_Component. + return D; + end; - Son : Perm_Tree_Access; + -- The tree is folded. Expand it. + else + declare + pragma Assert (Kind (C) = Entire_Object); + + Child_P : constant Perm_Kind := Children_Permission (C); + D : constant Perm_Tree_Access := + new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => Is_Node_Deep (C), + Permission => Child_P, + Children_Permission => Child_P)); begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Borrowed, - Children_Permission => Children_Permission (C))); - - -- We change the current node from Entire_Object - -- to Array_Component with same permission and the - -- previously defined son. + if Perm /= None then + D.all.Tree.Permission := Perm; + end if; C.all.Tree := (Kind => Array_Component, Is_Node_Deep => Is_Node_Deep (C), - Permission => Borrowed, - Get_Elem => Son); - return Get_Elem (C); + Permission => Permission (C), + Get_Elem => D); + return D; end; - - else - raise Program_Error; end if; end; - -- We set the permission tree of its prefix, and then we extract - -- from the returned pointer the subtree and assign an adequate - -- permission to it, if unfolded. If folded, we unroll the tree - -- at one step. - - when N_Explicit_Dereference => - declare - C : constant Perm_Tree_Access := - Set_Perm_Prefixes_Borrow (Prefix (N)); + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => + return Set_Perm_Prefixes (Expression (N), Perm); - begin - if C = null then + when others => + raise Program_Error; + end case; + end Set_Perm_Prefixes; - -- We went through a function call. Do nothing. + ------------------------------ + -- Set_Perm_Prefixes_Assign -- + ------------------------------ - return null; - end if; + procedure Set_Perm_Prefixes_Assign (N : Node_Id) is + C : constant Perm_Tree_Access := Get_Perm_Tree (N); - -- The permission of the returned node should be No + begin + case Kind (C) is + when Entire_Object => + pragma Assert (Children_Permission (C) = Read_Write); + C.all.Tree.Permission := Read_Write; - pragma Assert (Permission (C) = Borrowed); - pragma Assert (Kind (C) = Entire_Object - or else Kind (C) = Reference); + when Reference => + C.all.Tree.Permission := + Lub (Permission (C), Permission (Get_All (C))); - if Kind (C) = Reference then + when Array_Component => + null; - -- The tree is unfolded. We just modify the permission and - -- return the elem subtree. + when Record_Component => + declare + Comp : Perm_Tree_Access; + Perm : Perm_Kind := Read_Write; - pragma Assert (Get_All (C) /= null); - C.all.Tree.Get_All.all.Tree.Permission := Borrowed; - return Get_All (C); + begin + -- We take the Glb of all the descendants, and then update the + -- permission of the node with it. - elsif Kind (C) = Entire_Object then - declare - -- Expand the tree. Replace the node with Reference. + Comp := Perm_Tree_Maps.Get_First (Component (C)); + while Comp /= null loop + Perm := Glb (Perm, Permission (Comp)); + Comp := Perm_Tree_Maps.Get_Next (Component (C)); + end loop; - Son : Perm_Tree_Access; + C.all.Tree.Permission := Lub (Permission (C), Perm); + end; + end case; - begin - Son := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (N)), - Permission => Borrowed, - Children_Permission => Children_Permission (C))); + case Nkind (N) is - -- We change the current node from Entire_Object to - -- Reference with Borrowed and the previous son. + -- Base identifier end recursion - pragma Assert (Is_Node_Deep (C)); - C.all.Tree := (Kind => Reference, - Is_Node_Deep => Is_Node_Deep (C), - Permission => Borrowed, - Get_All => Son); - return Get_All (C); - end; + when N_Expanded_Name + | N_Identifier + => + null; - else - raise Program_Error; - end if; - end; + when N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + | N_Slice + => + Set_Perm_Prefixes_Assign (Prefix (N)); - when N_Function_Call => - return null; + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => + Set_Perm_Prefixes_Assign (Expression (N)); when others => raise Program_Error; end case; - end Set_Perm_Prefixes_Borrow; + end Set_Perm_Prefixes_Assign; ------------------- -- Setup_Globals -- ------------------- procedure Setup_Globals (Subp : Entity_Id) is - procedure Setup_Globals_From_List - (First_Item : Node_Id; - Kind : Formal_Kind); - -- Set up global items from the list starting at Item - procedure Setup_Globals_Of_Mode (Global_Mode : Name_Id); - -- Set up global items for the mode Global_Mode + procedure Setup_Global + (Expr : Node_Id; + Typ : Entity_Id; + Kind : Formal_Kind; + Subp : Entity_Id; + Global_Var : Boolean); + -- Proxy procedure to set up globals, to adjust for the type of first + -- parameter expected by Setup_Parameter_Or_Global. - ----------------------------- - -- Setup_Globals_From_List -- - ----------------------------- + ------------------ + -- Setup_Global -- + ------------------ - procedure Setup_Globals_From_List - (First_Item : Node_Id; - Kind : Formal_Kind) + procedure Setup_Global + (Expr : Node_Id; + Typ : Entity_Id; + Kind : Formal_Kind; + Subp : Entity_Id; + Global_Var : Boolean) is - Item : Node_Id := First_Item; - E : Entity_Id; - - begin - while Present (Item) loop - E := Entity (Item); - - -- Ignore abstract states, which play no role in pointer aliasing - - if Ekind (E) = E_Abstract_State then - null; - else - Setup_Parameter_Or_Global (E, Kind, Global_Var => True); - end if; - Next_Global (Item); - end loop; - end Setup_Globals_From_List; - - --------------------------- - -- Setup_Globals_Of_Mode -- - --------------------------- - - procedure Setup_Globals_Of_Mode (Global_Mode : Name_Id) is - Kind : Formal_Kind; - begin - case Global_Mode is - when Name_Input - | Name_Proof_In - => - Kind := E_In_Parameter; - - when Name_Output => - Kind := E_Out_Parameter; - - when Name_In_Out => - Kind := E_In_Out_Parameter; - - when others => - raise Program_Error; - end case; - - -- Set up both global items from Global and Refined_Global pragmas + Setup_Parameter_Or_Global + (Id => Entity (Expr), + Typ => Typ, + Kind => Kind, + Subp => Subp, + Global_Var => Global_Var); + end Setup_Global; - Setup_Globals_From_List (First_Global (Subp, Global_Mode), Kind); - Setup_Globals_From_List - (First_Global (Subp, Global_Mode, Refined => True), Kind); - end Setup_Globals_Of_Mode; + procedure Setup_Globals_Inst is new Handle_Globals (Setup_Global); -- Start of processing for Setup_Globals begin - Setup_Globals_Of_Mode (Name_Proof_In); - Setup_Globals_Of_Mode (Name_Input); - Setup_Globals_Of_Mode (Name_Output); - Setup_Globals_Of_Mode (Name_In_Out); + Setup_Globals_Inst (Subp); end Setup_Globals; ------------------------------- @@ -4452,178 +4910,110 @@ package body Sem_SPARK is procedure Setup_Parameter_Or_Global (Id : Entity_Id; - Mode : Formal_Kind; + Typ : Entity_Id; + Kind : Formal_Kind; + Subp : Entity_Id; Global_Var : Boolean) is - Elem : Perm_Tree_Access; - View_Typ : Entity_Id; + Perm : Perm_Kind_Option; begin - if Present (Full_View (Etype (Id))) then - View_Typ := Full_View (Etype (Id)); - else - View_Typ := Etype (Id); - end if; + case Kind is + when E_In_Parameter => - Elem := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (Id)), - Permission => Unrestricted, - Children_Permission => Unrestricted)); + -- Shallow parameters and globals need not be considered - case Mode is + if not Is_Deep (Typ) then + Perm := None; - -- All out and in out parameters are considered to be unrestricted. - -- They are whether borrowed or moved. Ada Rules would restrict - -- these permissions further. For example an in parameter cannot - -- be written. + -- Inputs of functions have R permission only - -- In the following we deal with in parameters that can be observed. - -- We only consider the observing cases. + elsif Ekind (Subp) = E_Function then + Perm := Read_Only; - when E_In_Parameter => + -- Input global variables have R permission only - -- Handling global variables as IN parameters here. - -- Remove the following condition once it's decided how globals - -- should be considered. ??? - -- - -- In SPARK, IN access-to-variable is an observe operation for - -- a function, and a borrow operation for a procedure. - - if not Global_Var then - if (Is_Access_Type (View_Typ) - and then Is_Access_Constant (View_Typ) - and then Is_Anonymous_Access_Type (View_Typ)) - or else - (Is_Access_Type (View_Typ) - and then Ekind (Scope (Id)) = E_Function) - or else - (not Is_Access_Type (View_Typ) - and then Is_Deep (View_Typ) - and then not Is_Anonymous_Access_Type (View_Typ)) - then - Elem.all.Tree.Permission := Observed; - Elem.all.Tree.Children_Permission := Observed; + elsif Global_Var then + Perm := Read_Only; - else - Elem.all.Tree.Permission := Unrestricted; - Elem.all.Tree.Children_Permission := Unrestricted; - end if; + -- Anonymous access to constant is an observe + + elsif Is_Anonymous_Access_Type (Typ) + and then Is_Access_Constant (Typ) + then + Perm := Read_Only; + + -- Other access types are a borrow + + elsif Is_Access_Type (Typ) then + Perm := Read_Write; + + -- Deep types other than access types define an observe else - Elem.all.Tree.Permission := Observed; - Elem.all.Tree.Children_Permission := Observed; + Perm := Read_Only; end if; - -- When out or in/out formal or global parameters, we set them to - -- the Unrestricted state. "We want to be able to assume that all - -- relevant writable globals are unrestricted when a subprogram - -- starts executing". Formal parameters of mode out or in/out - -- are whether Borrowers or the targets of a move operation: - -- they start theirs lives in the subprogram as Unrestricted. + when E_Out_Parameter + | E_In_Out_Parameter + => + -- Shallow parameters and globals need not be considered + + if not Is_Deep (Typ) then + Perm := None; - when others => - Elem.all.Tree.Permission := Unrestricted; - Elem.all.Tree.Children_Permission := Unrestricted; + -- Functions cannot have outputs in SPARK + + elsif Ekind (Subp) = E_Function then + if Kind = E_Out_Parameter then + Error_Msg_N ("function with OUT parameter is not " + & "allowed in SPARK", Id); + else + Error_Msg_N ("function with `IN OUT` parameter is not " + & "allowed in SPARK", Id); + end if; + + return; + + -- Deep types define a borrow or a move + + else + Perm := Read_Write; + end if; end case; - Set (Current_Perm_Env, Id, Elem); + if Perm /= None then + declare + Tree : constant Perm_Tree_Access := + new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => Is_Deep (Etype (Id)), + Permission => Perm, + Children_Permission => Perm)); + begin + Set (Current_Perm_Env, Id, Tree); + end; + end if; end Setup_Parameter_Or_Global; ---------------------- -- Setup_Parameters -- ---------------------- - procedure Setup_Parameters (Subp : Entity_Id) is Formal : Entity_Id; + procedure Setup_Parameters (Subp : Entity_Id) is + Formal : Entity_Id; begin Formal := First_Formal (Subp); while Present (Formal) loop Setup_Parameter_Or_Global - (Formal, Ekind (Formal), Global_Var => False); + (Id => Formal, + Typ => Underlying_Type (Etype (Formal)), + Kind => Ekind (Formal), + Subp => Subp, + Global_Var => False); Next_Formal (Formal); end loop; end Setup_Parameters; - ------------------------------- - -- Has_Ownership_Aspect_True -- - ------------------------------- - - function Has_Ownership_Aspect_True - (N : Entity_Id; - Msg : String) - return Boolean - is - begin - case Ekind (Etype (N)) is - when Access_Kind => - if Ekind (Etype (N)) = E_General_Access_Type then - Error_Msg_NE (Msg & " & not allowed " & - "(Named General Access type)", N, N); - return False; - - else - return True; - end if; - - when E_Array_Type - | E_Array_Subtype - => - declare - Com_Ty : constant Node_Id := Component_Type (Etype (N)); - Ret : Boolean := Has_Ownership_Aspect_True (Com_Ty, ""); - - begin - if Nkind (Parent (N)) = N_Full_Type_Declaration and - Is_Anonymous_Access_Type (Com_Ty) - then - Ret := False; - end if; - - if not Ret then - Error_Msg_NE (Msg & " & not allowed " - & "(Components of Named General Access type or" - & " Anonymous type)", N, N); - end if; - return Ret; - end; - - -- ??? What about hidden components - - when E_Record_Type - | E_Record_Subtype - => - declare - Elmt : Entity_Id; - Elmt_T_Perm : Boolean := True; - Elmt_Perm, Elmt_Anonym : Boolean; - - begin - Elmt := First_Component_Or_Discriminant (Etype (N)); - while Present (Elmt) loop - Elmt_Perm := Has_Ownership_Aspect_True (Elmt, - "type of component"); - Elmt_Anonym := Is_Anonymous_Access_Type (Etype (Elmt)); - if Elmt_Anonym then - Error_Msg_NE - ("type of component & not allowed" - & " (Components of Anonymous type)", Elmt, Elmt); - end if; - Elmt_T_Perm := Elmt_T_Perm and Elmt_Perm and not Elmt_Anonym; - Next_Component_Or_Discriminant (Elmt); - end loop; - if not Elmt_T_Perm then - Error_Msg_NE - (Msg & " & not allowed (One or " - & "more components have Ownership Aspect False)", - N, N); - end if; - return Elmt_T_Perm; - end; - - when others => - return True; - end case; - - end Has_Ownership_Aspect_True; end Sem_SPARK; diff --git a/gcc/ada/sem_spark.ads b/gcc/ada/sem_spark.ads index e83b661..ee4126a 100644 --- a/gcc/ada/sem_spark.ads +++ b/gcc/ada/sem_spark.ads @@ -23,9 +23,9 @@ -- -- ------------------------------------------------------------------------------ --- This package implements an anti-aliasing analysis for access types. The --- rules that are enforced are defined in the anti-aliasing section of the --- SPARK RM 6.4.2 +-- This package implements an ownership analysis for access types. The rules +-- that are enforced are defined in section 3.10 of the SPARK Reference +-- Manual. -- -- Check_Safe_Pointers is called by Gnat1drv, when GNATprove mode is -- activated. It does an analysis of the source code, looking for code that is @@ -138,6 +138,6 @@ package Sem_SPARK is procedure Check_Safe_Pointers (N : Node_Id); -- The entry point of this package. It analyzes a node and reports errors - -- when there are violations of aliasing rules. + -- when there are violations of ownership rules. end Sem_SPARK; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 16c6711..77eefdc 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6721,33 +6721,26 @@ package body Sem_Util is -- Enclosing_Generic_Body -- ---------------------------- - function Enclosing_Generic_Body - (N : Node_Id) return Node_Id - is - P : Node_Id; - Decl : Node_Id; - Spec : Node_Id; + function Enclosing_Generic_Body (N : Node_Id) return Node_Id is + Par : Node_Id; + Spec_Id : Entity_Id; begin - P := Parent (N); - while Present (P) loop - if Nkind (P) = N_Package_Body - or else Nkind (P) = N_Subprogram_Body - then - Spec := Corresponding_Spec (P); - - if Present (Spec) then - Decl := Unit_Declaration_Node (Spec); + Par := Parent (N); + while Present (Par) loop + if Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then + Spec_Id := Corresponding_Spec (Par); - if Nkind (Decl) = N_Generic_Package_Declaration - or else Nkind (Decl) = N_Generic_Subprogram_Declaration - then - return P; - end if; + if Present (Spec_Id) + and then Nkind_In (Unit_Declaration_Node (Spec_Id), + N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration) + then + return Par; end if; end if; - P := Parent (P); + Par := Parent (Par); end loop; return Empty; @@ -6757,38 +6750,34 @@ package body Sem_Util is -- Enclosing_Generic_Unit -- ---------------------------- - function Enclosing_Generic_Unit - (N : Node_Id) return Node_Id - is - P : Node_Id; - Decl : Node_Id; - Spec : Node_Id; + function Enclosing_Generic_Unit (N : Node_Id) return Node_Id is + Par : Node_Id; + Spec_Decl : Node_Id; + Spec_Id : Entity_Id; begin - P := Parent (N); - while Present (P) loop - if Nkind (P) = N_Generic_Package_Declaration - or else Nkind (P) = N_Generic_Subprogram_Declaration + Par := Parent (N); + while Present (Par) loop + if Nkind_In (Par, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration) then - return P; + return Par; - elsif Nkind (P) = N_Package_Body - or else Nkind (P) = N_Subprogram_Body - then - Spec := Corresponding_Spec (P); + elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then + Spec_Id := Corresponding_Spec (Par); - if Present (Spec) then - Decl := Unit_Declaration_Node (Spec); + if Present (Spec_Id) then + Spec_Decl := Unit_Declaration_Node (Spec_Id); - if Nkind (Decl) = N_Generic_Package_Declaration - or else Nkind (Decl) = N_Generic_Subprogram_Declaration + if Nkind_In (Spec_Decl, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration) then - return Decl; + return Spec_Decl; end if; end if; end if; - P := Parent (P); + Par := Parent (Par); end loop; return Empty; @@ -7579,6 +7568,18 @@ package body Sem_Util is end loop; end Examine_Array_Bounds; + ------------------- + -- Exceptions_OK -- + ------------------- + + function Exceptions_OK return Boolean is + begin + return + not (Restriction_Active (No_Exception_Handlers) or else + Restriction_Active (No_Exception_Propagation) or else + Restriction_Active (No_Exceptions)); + end Exceptions_OK; + -------------------------- -- Explain_Limited_Type -- -------------------------- @@ -9201,12 +9202,12 @@ package body Sem_Util is Next_Entity (Func); end loop; - -- If not found, no way to resolve remaining primitives. + -- If not found, no way to resolve remaining primitives if Cursor = Any_Type then Error_Msg_N - ("primitive operation for Iterable type must appear " - & "in the same list of declarations as the type", Aspect); + ("primitive operation for Iterable type must appear in the same " + & "list of declarations as the type", Aspect); end if; return Cursor; @@ -10737,7 +10738,7 @@ package body Sem_Util is -- Asynch_Writers Effective_Writes -- -- Note that both forms of External have higher precedence than - -- Synchronous (SPARK RM 7.1.4(10)). + -- Synchronous (SPARK RM 7.1.4(9)). elsif Has_Synchronous then return Nam_In (Property, Name_Async_Readers, Name_Async_Writers); @@ -18900,6 +18901,44 @@ package body Sem_Util is end if; end Mark_Elaboration_Attributes; + ---------------------------------------- + -- Mark_Save_Invocation_Graph_Of_Body -- + ---------------------------------------- + + procedure Mark_Save_Invocation_Graph_Of_Body is + Main : constant Node_Id := Cunit (Main_Unit); + Main_Unit : constant Node_Id := Unit (Main); + Aux_Id : Entity_Id; + + begin + Set_Save_Invocation_Graph_Of_Body (Main); + + -- Assume that the main unit does not have a complimentary unit + + Aux_Id := Empty; + + -- Obtain the complimentary unit of the main unit + + if Nkind_In (Main_Unit, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Subprogram_Declaration) + then + Aux_Id := Corresponding_Body (Main_Unit); + + elsif Nkind_In (Main_Unit, N_Package_Body, + N_Subprogram_Body, + N_Subprogram_Renaming_Declaration) + then + Aux_Id := Corresponding_Spec (Main_Unit); + end if; + + if Present (Aux_Id) then + Set_Save_Invocation_Graph_Of_Body + (Parent (Unit_Declaration_Node (Aux_Id))); + end if; + end Mark_Save_Invocation_Graph_Of_Body; + ---------------------------------- -- Matching_Static_Array_Bounds -- ---------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 4e4d4ba..3f8d2e7 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -708,6 +708,10 @@ package Sem_Util is -- If no suitable entity is available, return Empty. This routine carries -- out actions that are tied to SPARK semantics. + function Exceptions_OK return Boolean; + -- Determine whether exceptions are allowed to be caught, propagated, or + -- raised. + procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id); -- This procedure is called after issuing a message complaining about an -- inappropriate use of limited type T. If useful, it adds additional @@ -2182,6 +2186,10 @@ package Sem_Util is -- Modes - Save the Ghost and SPARK modes in effect (if applicable) -- Warnings - Save the status of Elab_Warnings + procedure Mark_Save_Invocation_Graph_Of_Body; + -- Notify the body of the main unit that the invocation constructs and + -- relations expressed within it must be recorded by the ABE mechanism. + function Matching_Static_Array_Bounds (L_Typ : Node_Id; R_Typ : Node_Id) return Boolean; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index dda94d2..7e13aa5 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -632,9 +632,16 @@ package body Sem_Warn is Expression := Condition (Iter); - -- For iteration, do not process, since loop will always terminate - - elsif Present (Loop_Parameter_Specification (Iter)) then + -- For Loop_Parameter_Specification, do not process, since loop + -- will always terminate. For Iterator_Specification, also do not + -- process. Either it will always terminate (e.g. "for X of + -- Some_Array ..."), or we can't tell if it's going to terminate + -- without looking at the iterator, so any warning here would be + -- noise. + + elsif Present (Loop_Parameter_Specification (Iter)) + or else Present (Iterator_Specification (Iter)) + then return; end if; end if; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 2464b97..d24938c 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1913,7 +1913,8 @@ package body Sinfo is or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); return Flag1 (N); end Is_Elaboration_Checks_OK_Node; @@ -1932,12 +1933,15 @@ package body Sinfo is or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Call_Marker or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Identifier or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); return Flag3 (N); end Is_Elaboration_Warnings_OK_Node; @@ -2130,7 +2134,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Variable_Reference_Marker); - return Flag1 (N); + return Flag4 (N); end Is_Read; function Is_Source_Call @@ -2156,7 +2160,8 @@ package body Sinfo is or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); return Flag2 (N); end Is_SPARK_Mode_On_Node; @@ -2216,7 +2221,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Variable_Reference_Marker); - return Flag2 (N); + return Flag5 (N); end Is_Write; function Iteration_Scheme @@ -3091,6 +3096,14 @@ package body Sinfo is return Flag18 (N); end Rounded_Result; + function Save_Invocation_Graph_Of_Body + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return Flag1 (N); + end Save_Invocation_Graph_Of_Body; + function SCIL_Controlling_Tag (N : Node_Id) return Node_Id is begin @@ -5387,7 +5400,8 @@ package body Sinfo is or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); Set_Flag1 (N, Val); end Set_Is_Elaboration_Checks_OK_Node; @@ -5406,12 +5420,15 @@ package body Sinfo is or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Call_Marker or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Identifier or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); Set_Flag3 (N, Val); end Set_Is_Elaboration_Warnings_OK_Node; @@ -5604,7 +5621,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Variable_Reference_Marker); - Set_Flag1 (N, Val); + Set_Flag4 (N, Val); end Set_Is_Read; procedure Set_Is_Source_Call @@ -5630,7 +5647,8 @@ package body Sinfo is or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); Set_Flag2 (N, Val); end Set_Is_SPARK_Mode_On_Node; @@ -5692,7 +5710,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Variable_Reference_Marker); - Set_Flag2 (N, Val); + Set_Flag5 (N, Val); end Set_Is_Write; procedure Set_Iteration_Scheme @@ -6567,6 +6585,14 @@ package body Sinfo is Set_Flag18 (N, Val); end Set_Rounded_Result; + procedure Set_Save_Invocation_Graph_Of_Body + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_Flag1 (N, Val); + end Set_Save_Invocation_Graph_Of_Body; + procedure Set_SCIL_Controlling_Tag (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index b0f992b..b1e57bf 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1762,6 +1762,7 @@ package Sinfo is -- procedure call statement -- procedure instantiation -- requeue statement + -- variable reference marker -- -- Set when the node appears within a context which allows the generation -- of run-time ABE checks. This flag detemines whether the ABE Processing @@ -1778,12 +1779,15 @@ package Sinfo is -- attribute reference -- call marker -- entry call statement + -- expanded name -- function call -- function instantiation + -- identifier -- package instantiation -- procedure call statement -- procedure instantiation -- requeue statement + -- variable reference marker -- -- Set when the node appears within a context where elaboration warnings -- are enabled. This flag determines whether the ABE processing phase @@ -1941,7 +1945,7 @@ package Sinfo is -- the resolution of accidental overloading of binary or unary operators -- which may occur in instances. - -- Is_Read (Flag1-Sem) + -- Is_Read (Flag4-Sem) -- Present in variable reference markers. Set when the original variable -- reference constitues a read of the variable. @@ -1950,13 +1954,25 @@ package Sinfo is -- source. -- Is_SPARK_Mode_On_Node (Flag2-Sem) - -- Present in nodes which represent an elaboration scenario. Those are - -- assignment statement, attribute reference, call marker, entry call - -- statement, expanded name, function call, identifier, instantiation, - -- procedure call statement, and requeue statement nodes. Set when the - -- node appears within a context subject to SPARK_Mode On. This flag - -- determines when the SPARK model of elaboration be activated by the - -- ABE Processing phase. + -- Present in the following nodes: + -- + -- assignment statement + -- attribute reference + -- call marker + -- entry call statement + -- expanded name + -- function call + -- function instantiation + -- identifier + -- package instantiation + -- procedure call statement + -- procedure instantiation + -- requeue statement + -- variable reference marker + -- + -- Set when the node appears within a context subject to SPARK_Mode On. + -- This flag determines when the SPARK model of elaboration be activated + -- by the ABE Processing phase. -- Is_Static_Coextension (Flag14-Sem) -- Present in N_Allocator nodes. Set if the allocator is a coextension @@ -1989,7 +2005,7 @@ package Sinfo is -- indicate that the construct is a task master (i.e. has declared tasks -- or declares an access to a task type). - -- Is_Write (Flag2-Sem) + -- Is_Write (Flag5-Sem) -- Present in variable reference markers. Set when the original variable -- reference constitues a write of the variable. @@ -2328,6 +2344,11 @@ package Sinfo is -- are the result of expansion of rounded fixed-point divide, conversion -- and multiplication operations. + -- Save_Invocation_Graph_Of_Body (Flag1-Sem) + -- Present in compilation unit nodes. Set when the elaboration mechanism + -- must record all invocation constructs and invocation relations within + -- the body of the compilation unit. + -- -- SCIL_Entity (Node4-Sem) -- Present in SCIL nodes. References the specific tagged type associated -- with the SCIL node (for an N_SCIL_Dispatching_Call node, this is @@ -2606,6 +2627,7 @@ package Sinfo is -- Original_Discriminant (Node2-Sem) -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem) -- Has_Private_View (Flag11-Sem) (set in generic units) -- Redundant_Use (Flag13-Sem) -- Atomic_Sync_Required (Flag14-Sem) @@ -2857,7 +2879,7 @@ package Sinfo is -- Einfo. -- Note: N_Defining_Identifier is an extended node whose fields are - -- deliberately layed out to match the layout of fields in an ordinary + -- deliberately laid out to match the layout of fields in an ordinary -- N_Identifier node allowing for easy alteration of an identifier -- node into a defining identifier node. For details, see procedure -- Sinfo.CN.Change_Identifier_To_Defining_Identifier. @@ -3204,8 +3226,8 @@ package Sinfo is -- in package Einfo. -- Note: N_Defining_Character_Literal is an extended node whose fields - -- are deliberate layed out to match the layout of fields in an ordinary - -- N_Character_Literal node allowing for easy alteration of a character + -- are deliberately laid out to match layout of fields in an ordinary + -- N_Character_Literal node, allowing for easy alteration of a character -- literal node into a defining character literal node. For details, see -- Sinfo.CN.Change_Character_Literal_To_Defining_Character_Literal. @@ -5429,7 +5451,7 @@ package Sinfo is -- in package Einfo. -- Note: N_Defining_Operator_Symbol is an extended node whose fields - -- are deliberately layed out to match the layout of fields in an + -- are deliberately laid out to match the layout of fields in an -- ordinary N_Operator_Symbol node allowing for easy alteration of -- an operator symbol node into a defining operator symbol node. -- See Sinfo.CN.Change_Operator_Symbol_To_Defining_Operator_Symbol @@ -6634,17 +6656,18 @@ package Sinfo is -- N_Compilation_Unit -- Sloc points to first token of defining unit name - -- Library_Unit (Node4-Sem) corresponding/parent spec/body -- Context_Items (List1) context items and pragmas preceding unit -- Private_Present (Flag15) set if library unit has private keyword -- Unit (Node2) library item or subunit -- Aux_Decls_Node (Node5) points to the N_Compilation_Unit_Aux node - -- Has_No_Elaboration_Code (Flag17-Sem) - -- Body_Required (Flag13-Sem) set for spec if body is required - -- Acts_As_Spec (Flag4-Sem) flag for subprogram body with no spec - -- Context_Pending (Flag16-Sem) -- First_Inlined_Subprogram (Node3-Sem) + -- Library_Unit (Node4-Sem) corresponding/parent spec/body + -- Save_Invocation_Graph_Of_Body (Flag1-Sem) + -- Acts_As_Spec (Flag4-Sem) flag for subprogram body with no spec + -- Body_Required (Flag13-Sem) set for spec if body is required -- Has_Pragma_Suppress_All (Flag14-Sem) + -- Context_Pending (Flag16-Sem) + -- Has_No_Elaboration_Code (Flag17-Sem) -- N_Compilation_Unit_Aux -- Sloc is a copy of the Sloc from the N_Compilation_Unit node @@ -8035,7 +8058,7 @@ package Sinfo is -- of this node, leaving the N_Selected_Component node used only when -- the prefix is a record or protected type. - -- The fields of the N_Expanded_Name node are layed out identically + -- The fields of the N_Expanded_Name node are laid out identically -- to those of the N_Selected_Component node, allowing conversion of -- an expanded name node to a selected component node to be done -- easily, see Sinfo.CN.Change_Selected_Component_To_Expanded_Name. @@ -8051,6 +8074,7 @@ package Sinfo is -- Associated_Node (Node4-Sem) -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem) -- Has_Private_View (Flag11-Sem) set in generic units -- Redundant_Use (Flag13-Sem) -- Atomic_Sync_Required (Flag14-Sem) @@ -8576,8 +8600,11 @@ package Sinfo is -- N_Variable_Reference_Marker -- Sloc points to Sloc of original variable reference -- Target (Node1-Sem) - -- Is_Read (Flag1-Sem) - -- Is_Write (Flag2-Sem) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem) + -- Is_Read (Flag4-Sem) + -- Is_Write (Flag5-Sem) ----------- -- Empty -- @@ -9868,7 +9895,7 @@ package Sinfo is (N : Node_Id) return Boolean; -- Flag4 function Is_Read - (N : Node_Id) return Boolean; -- Flag1 + (N : Node_Id) return Boolean; -- Flag4 function Is_Source_Call (N : Node_Id) return Boolean; -- Flag4 @@ -9895,7 +9922,7 @@ package Sinfo is (N : Node_Id) return Boolean; -- Flag5 function Is_Write - (N : Node_Id) return Boolean; -- Flag2 + (N : Node_Id) return Boolean; -- Flag5 function Iteration_Scheme (N : Node_Id) return Node_Id; -- Node2 @@ -10164,6 +10191,9 @@ package Sinfo is function Rounded_Result (N : Node_Id) return Boolean; -- Flag18 + function Save_Invocation_Graph_Of_Body + (N : Node_Id) return Boolean; -- Flag1 + function SCIL_Controlling_Tag (N : Node_Id) return Node_Id; -- Node5 @@ -10972,7 +11002,7 @@ package Sinfo is (N : Node_Id; Val : Boolean := True); -- Flag4 procedure Set_Is_Read - (N : Node_Id; Val : Boolean := True); -- Flag1 + (N : Node_Id; Val : Boolean := True); -- Flag4 procedure Set_Is_Source_Call (N : Node_Id; Val : Boolean := True); -- Flag4 @@ -10999,7 +11029,7 @@ package Sinfo is (N : Node_Id; Val : Boolean := True); -- Flag5 procedure Set_Is_Write - (N : Node_Id; Val : Boolean := True); -- Flag2 + (N : Node_Id; Val : Boolean := True); -- Flag5 procedure Set_Iteration_Scheme (N : Node_Id; Val : Node_Id); -- Node2 @@ -11268,6 +11298,9 @@ package Sinfo is procedure Set_Rounded_Result (N : Node_Id; Val : Boolean := True); -- Flag18 + procedure Set_Save_Invocation_Graph_Of_Body + (N : Node_Id; Val : Boolean := True); -- Flag1 + procedure Set_SCIL_Controlling_Tag (N : Node_Id; Val : Node_Id); -- Node5 @@ -13566,6 +13599,7 @@ package Sinfo is pragma Inline (Reverse_Present); pragma Inline (Right_Opnd); pragma Inline (Rounded_Result); + pragma Inline (Save_Invocation_Graph_Of_Body); pragma Inline (SCIL_Controlling_Tag); pragma Inline (SCIL_Entity); pragma Inline (SCIL_Tag_Value); @@ -13930,6 +13964,7 @@ package Sinfo is pragma Inline (Set_Reverse_Present); pragma Inline (Set_Right_Opnd); pragma Inline (Set_Rounded_Result); + pragma Inline (Set_Save_Invocation_Graph_Of_Body); pragma Inline (Set_SCIL_Controlling_Tag); pragma Inline (Set_SCIL_Entity); pragma Inline (Set_SCIL_Tag_Value); diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads index b1684a7..0e75389 100644 --- a/gcc/ada/style.ads +++ b/gcc/ada/style.ads @@ -125,6 +125,9 @@ package Style is -- Called with Scan_Ptr pointing to the first minus sign of a comment. -- Intended for checking any specific rules for comment placement/format. + procedure Check_Defining_Identifier_Casing + renames Style_Inst.Check_Defining_Identifier_Casing; + procedure Check_Dot_Dot renames Style_Inst.Check_Dot_Dot; -- Called after scanning out dot dot to check spacing @@ -219,4 +222,5 @@ package Style is -- lower case letters. On entry Token_Ptr points to the keyword token. -- This is not used for keywords appearing as attribute designators, -- where instead Check_Attribute_Name (True) is called. + end Style; diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index 56526d8..375664b 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -610,6 +610,31 @@ package body Styleg is end if; end Check_Comment; + -------------------------------------- + -- Check_Defining_Identifier_Casing -- + -------------------------------------- + + procedure Check_Defining_Identifier_Casing is + begin + if Style_Check_Mixed_Case_Decls then + case Determine_Token_Casing is + when All_Lower_Case + | All_Upper_Case + => + Error_Msg_SC -- CODEFIX + ("(style) bad capitalization, mixed case required"); + + -- The Unknown case is something like A_B_C, which is both all + -- caps and mixed case. + + when Mixed_Case + | Unknown + => + null; -- OK + end case; + end if; + end Check_Defining_Identifier_Casing; + ------------------- -- Check_Dot_Dot -- ------------------- diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads index d93121f..f176c02 100644 --- a/gcc/ada/styleg.ads +++ b/gcc/ada/styleg.ads @@ -91,6 +91,11 @@ package Styleg is -- Called with Scan_Ptr pointing to the first minus sign of a comment. -- Intended for checking any specific rules for comment placement/format. + procedure Check_Defining_Identifier_Casing; + -- The current token is an identifier that will be a defining + -- identifier. Check that it is mixed case, if the appropriate + -- switch is set. + procedure Check_Dot_Dot; -- Called after scanning out dot dot to check spacing diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb index 549f826..929e2d7 100644 --- a/gcc/ada/stylesw.adb +++ b/gcc/ada/stylesw.adb @@ -79,6 +79,7 @@ package body Stylesw is Style_Check_Boolean_And_Or := False; Style_Check_Comments := False; Style_Check_DOS_Line_Terminator := False; + Style_Check_Mixed_Case_Decls := False; Style_Check_End_Labels := False; Style_Check_Form_Feeds := False; Style_Check_Horizontal_Tabs := False; @@ -168,6 +169,7 @@ package body Stylesw is end if; Add ('d', Style_Check_DOS_Line_Terminator); + Add ('D', Style_Check_Mixed_Case_Decls); Add ('e', Style_Check_End_Labels); Add ('f', Style_Check_Form_Feeds); Add ('h', Style_Check_Horizontal_Tabs); @@ -336,6 +338,9 @@ package body Stylesw is when 'd' => Style_Check_DOS_Line_Terminator := True; + when 'D' => + Style_Check_Mixed_Case_Decls := True; + when 'e' => Style_Check_End_Labels := True; @@ -503,6 +508,9 @@ package body Stylesw is when 'd' => Style_Check_DOS_Line_Terminator := False; + when 'D' => + Style_Check_Mixed_Case_Decls := False; + when 'e' => Style_Check_End_Labels := False; diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads index d82fcb1..de1f92d 100644 --- a/gcc/ada/stylesw.ads +++ b/gcc/ada/stylesw.ads @@ -113,6 +113,10 @@ package Stylesw is -- the line terminator must be a single LF, without an associated CR (e.g. -- DOS line terminator sequence CR/LF not allowed). + Style_Check_Mixed_Case_Decls : Boolean := False; + -- This can be set True by using the -gnatyD switch. If it is True, then + -- declared identifiers must be in Mixed_Case. + Style_Check_End_Labels : Boolean := False; -- This can be set True by using the -gnatye switch. If it is True, then -- optional END labels must always be present. diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index 2f8831b..dc62ec2 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -51,6 +51,9 @@ package body Switch.B is -- Used for -d and -D to scan stack size including handling k/m. S is -- set to 'd' or 'D' to indicate the switch being scanned. + procedure Scan_Debug_Switches; + -- Scan out debug switches + --------------------------- -- Get_Optional_Filename -- --------------------------- @@ -114,6 +117,70 @@ package body Switch.B is return Result; end Get_Stack_Size; + ------------------------- + -- Scan_Debug_Switches -- + ------------------------- + + procedure Scan_Debug_Switches is + Dot : Boolean := False; + Underscore : Boolean := False; + + begin + while Ptr <= Max loop + C := Switch_Chars (Ptr); + + -- Binder debug flags come in the following forms: + -- + -- letter + -- . letter + -- _ letter + -- + -- digit + -- . digit + -- _ digit + -- + -- Note that the processing of switch -d aleady takes care of the + -- case where the first flag is a digit (default stack size). + + if C in '1' .. '9' or else + C in 'a' .. 'z' or else + C in 'A' .. 'Z' + then + -- . letter + -- . digit + + if Dot then + Set_Dotted_Debug_Flag (C); + Dot := False; + + -- _ letter + -- _ digit + + elsif Underscore then + Set_Underscored_Debug_Flag (C); + Underscore := False; + + -- letter + -- digit + + else + Set_Debug_Flag (C); + end if; + + elsif C = '.' then + Dot := True; + + elsif C = '_' then + Underscore := True; + + else + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + end loop; + end Scan_Debug_Switches; + -- Start of processing for Scan_Binder_Switches begin @@ -170,7 +237,6 @@ package body Switch.B is -- Processing for d switch when 'd' => - if Ptr = Max then Bad_Switch (Switch_Chars); end if; @@ -189,26 +255,7 @@ package body Switch.B is -- Case where character after -d is not digit (debug flags) else - -- Note: for the debug switch, the remaining characters in this - -- switch field must all be debug flags, since all valid switch - -- characters are also valid debug characters. This switch is - -- not documented on purpose because it is only used by the - -- implementors. - - -- Loop to scan out debug flags - - loop - C := Switch_Chars (Ptr); - - if C in 'a' .. 'z' or else C in 'A' .. 'Z' then - Set_Debug_Flag (C); - else - Bad_Switch (Switch_Chars); - end if; - - Ptr := Ptr + 1; - exit when Ptr > Max; - end loop; + Scan_Debug_Switches; end if; -- Processing for D switch @@ -294,6 +341,12 @@ package body Switch.B is Debugger_Level := 2; end if; + -- Processing for G switch + + when 'G' => + Ptr := Ptr + 1; + Generate_C_Code := True; + -- Processing for h switch when 'h' => diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 21a29bf..0fbc606 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -1066,4 +1066,3 @@ __gnat_name_case_equivalence () return 1; #endif } - diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index a1d0a2e..61e9f3d 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -1492,6 +1492,49 @@ package body Uintp is end; end UI_From_Int; + ---------------------- + -- UI_From_Integral -- + ---------------------- + + function UI_From_Integral (Input : In_T) return Uint is + begin + -- If in range of our normal conversion function, use it so we can use + -- direct access and our cache. + + if In_T'Size <= Int'Size + or else Input in In_T (Int'First) .. In_T (Int'Last) + then + return UI_From_Int (Int (Input)); + + else + -- For values of larger magnitude, compute digits into a vector and + -- call Vector_To_Uint. + + declare + Max_For_In_T : constant Int := 3 * In_T'Size / Int'Size; + Our_Base : constant In_T := In_T (Base); + Temp_Integer : In_T := Input; + -- Base is defined so that 3 Uint digits is sufficient to hold the + -- largest possible Int value. + + U : Uint; + V : UI_Vector (1 .. Max_For_In_T); + + begin + for J in reverse V'Range loop + V (J) := Int (abs (Temp_Integer rem Our_Base)); + Temp_Integer := Temp_Integer / Our_Base; + end loop; + + U := Vector_To_Uint (V, Input < 0); + Uints_Min := Uints.Last; + Udigits_Min := Udigits.Last; + + return U; + end; + end if; + end UI_From_Integral; + ------------ -- UI_GCD -- ------------ @@ -2324,50 +2367,4 @@ package body Uintp is return Uint_0; end Vector_To_Uint; - ---------------------- - -- UI_From_Integral -- - ---------------------- - - function UI_From_Integral (Input : In_T) return Uint is - U : Uint; - - begin - -- If in range of our normal conversion function, use it so we can - -- use direct access and our cache. - - if In_T'Size <= Int'Size - or else Input in In_T (Int'First) .. In_T (Int'Last) - then - return UI_From_Int (Int (Input)); - - else - -- pragma Warnings (Off); - - -- For values of larger magnitude, compute digits into a vector - -- and call Vector_To_Uint. - - declare - Max_For_In_T : constant Int := 3 * In_T'Size / Int'Size; - Our_Base : constant In_T := In_T (Base); - Temp_Integer : In_T := Input; - -- Base is defined so that 3 Uint digits is sufficient to hold the - -- largest possible Int value. - - V : UI_Vector (1 .. Max_For_In_T); - - begin - for J in reverse V'Range loop - V (J) := Int (abs (Temp_Integer rem Our_Base)); - Temp_Integer := Temp_Integer / Our_Base; - end loop; - - U := Vector_To_Uint (V, Input < 0); - Uints_Min := Uints.Last; - Udigits_Min := Udigits.Last; - return U; - end; - - -- pragma Warnings (On); - end if; - end UI_From_Integral; end Uintp; diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index a09f326..d8342ba 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -251,9 +251,9 @@ package Uintp is generic type In_T is range <>; function UI_From_Integral (Input : In_T) return Uint; - -- Likewise, but converts from any integer type. - -- Must not be applied to biased types (instantiation will provide - -- a warning if actual is a biased type). + -- Likewise, but converts from any integer type. Must not be applied to + -- biased types (instantiation will provide a warning if actual is a biased + -- type). function UI_From_CC (Input : Char_Code) return Uint; -- Converts Char_Code value to universal integer form |