From 69e6ee2f15f110f7f69554aa049a869f9d4dd556 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Wed, 3 Jul 2019 08:14:57 +0000 Subject: [PATCH] [Ada] ABE checks v3.0, foundations of Elaboration order v4.0 ------------------------ -- Elaboration checks -- ------------------------ The dynamic ABE checks model now emits the same diagnostics as those of the static ABE checks model. The ABE checks mechanism has been redesigned and refactored in the face of increasing requirements. Most of the functionality can now be toggled, thus allowing for various combinations of behavior. The combinations are defined as "initial states" and may be further altered. Scenarios and targets have been distinctly separated at the higher level, instead of directly working with nodes and entitites. Scenarios and targets now carry a representation which removes the need to constantly recompute relevant attributes, and offers a common interface for the various processors. Most processing has now been refactored into "services" which perform a single ABE-related function. ----------------------- -- Elaboration order -- ----------------------- A new elaboration order mechanism based on the use of an invocation graph to provide extra information about the flow of execution at elaboration time has been introduced. The ABE checks mechanism has been altered to encode pieces of the invocation graph in the associated ALI files of units. The new elaboration order mechanism reconstructs the full invocation graph at bind time, and coupled with the library item graph, determines the elaboration order of units. The new elaboration order mechanism is currently inaccessible. ------------ -- Source -- ------------ -- pack.ads package Pack is procedure ABE_Proc; procedure Safe_Proc; end Pack; -- pack.adb with Ada.Text_IO; use Ada.Text_IO; package body Pack is function Call_Proc (ABE : Boolean) return Integer; procedure Safe_Proc is begin Put_Line ("safe"); end Safe_Proc; function Call_Proc (ABE : Boolean) return Integer is begin if ABE then ABE_Proc; else Safe_Proc; end if; return 0; end Call_Proc; Elab_1 : constant Integer := Call_Proc (ABE => False); Elab_2 : constant Integer := Call_Proc (ABE => True); procedure ABE_Proc is begin Put_Line ("ABE"); end ABE_Proc; end Pack; -- main.adb with Pack; procedure Main is begin null; end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -f -q -gnatE main.adb $ ./main $ gnatmake -f -q -gnatE main.adb -gnatDG -gnatwL $ grep -c "safeE" pack.adb.dg pack.adb:14:10: warning: cannot call "ABE_Proc" before body seen pack.adb:14:10: warning: Program_Error may be raised at run time pack.adb:14:10: warning: body of unit "Pack" elaborated pack.adb:14:10: warning: function "Call_Proc" called at line 22 pack.adb:14:10: warning: procedure "ABE_Proc" called at line 14 pack.adb:14:10: warning: cannot call "ABE_Proc" before body seen pack.adb:14:10: warning: Program_Error may be raised at run time pack.adb:14:10: warning: body of unit "Pack" elaborated pack.adb:14:10: warning: function "Call_Proc" called at line 23 pack.adb:14:10: warning: procedure "ABE_Proc" called at line 14 safe raised PROGRAM_ERROR : pack.adb:14 access before elaboration 0 2019-07-03 Hristian Kirtchev gcc/ada/ * 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. From-SVN: r272976 --- gcc/ada/ChangeLog | 152 + gcc/ada/ali.adb | 744 +- gcc/ada/ali.ads | 316 + gcc/ada/binde.adb | 14 +- gcc/ada/binde.ads | 14 - gcc/ada/bindgen.adb | 1 - gcc/ada/bindgen.ads | 3 +- gcc/ada/bindo-augmentors.adb | 372 + gcc/ada/bindo-augmentors.ads | 62 + gcc/ada/bindo-builders.adb | 488 + gcc/ada/bindo-builders.ads | 65 + gcc/ada/bindo-diagnostics.adb | 72 + gcc/ada/bindo-diagnostics.ads | 61 + gcc/ada/bindo-elaborators.adb | 1418 ++ gcc/ada/bindo-elaborators.ads | 55 + gcc/ada/bindo-graphs.adb | 2890 ++++ gcc/ada/bindo-graphs.ads | 1248 ++ gcc/ada/bindo-units.adb | 384 + gcc/ada/bindo-units.ads | 146 + gcc/ada/bindo-validators.adb | 679 + gcc/ada/bindo-validators.ads | 95 + gcc/ada/bindo-writers.adb | 1333 ++ gcc/ada/bindo-writers.ads | 125 + gcc/ada/bindo.adb | 287 + gcc/ada/bindo.ads | 44 + gcc/ada/debug.adb | 198 +- gcc/ada/exp_util.adb | 12 - gcc/ada/exp_util.ads | 4 - gcc/ada/gcc-interface/Make-lang.in | 17 +- gcc/ada/gnatbind.adb | 16 +- gcc/ada/lib-writ.adb | 372 + gcc/ada/lib-writ.ads | 88 + gcc/ada/libgnat/g-dynhta.adb | 54 + gcc/ada/libgnat/g-dynhta.ads | 11 + gcc/ada/libgnat/g-graphs.adb | 94 +- gcc/ada/libgnat/g-graphs.ads | 69 +- gcc/ada/libgnat/g-sets.adb | 2 +- gcc/ada/namet.adb | 18 + gcc/ada/namet.ads | 8 + gcc/ada/rtsfind.ads | 2 +- gcc/ada/sem_ch12.adb | 47 +- gcc/ada/sem_ch8.adb | 12 +- gcc/ada/sem_elab.adb | 20613 ++++++++++++++++----------- gcc/ada/sem_elab.ads | 81 +- gcc/ada/sem_prag.adb | 11 + gcc/ada/sem_util.adb | 123 +- gcc/ada/sem_util.ads | 8 + gcc/ada/sinfo.adb | 46 +- gcc/ada/sinfo.ads | 75 +- gcc/ada/switch-b.adb | 89 +- 50 files changed, 24692 insertions(+), 8446 deletions(-) create mode 100644 gcc/ada/bindo-augmentors.adb create mode 100644 gcc/ada/bindo-augmentors.ads create mode 100644 gcc/ada/bindo-builders.adb create mode 100644 gcc/ada/bindo-builders.ads create mode 100644 gcc/ada/bindo-diagnostics.adb create mode 100644 gcc/ada/bindo-diagnostics.ads create mode 100644 gcc/ada/bindo-elaborators.adb create mode 100644 gcc/ada/bindo-elaborators.ads create mode 100644 gcc/ada/bindo-graphs.adb create mode 100644 gcc/ada/bindo-graphs.ads create mode 100644 gcc/ada/bindo-units.adb create mode 100644 gcc/ada/bindo-units.ads create mode 100644 gcc/ada/bindo-validators.adb create mode 100644 gcc/ada/bindo-validators.ads create mode 100644 gcc/ada/bindo-writers.adb create mode 100644 gcc/ada/bindo-writers.ads create mode 100644 gcc/ada/bindo.adb create mode 100644 gcc/ada/bindo.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4ce8d74bb70..15d40a5e399 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,155 @@ +2019-07-03 Hristian Kirtchev + + * 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 * sem_spark.adb: Add support for locally borrowing and observing diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 818e67abdf8..978fb3d73a1 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 78358574f44..79eabb173d2 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 f5bd4b8e391..d060fd88a74 100644 --- a/gcc/ada/binde.adb +++ b/gcc/ada/binde.adb @@ -23,20 +23,22 @@ -- -- ------------------------------------------------------------------------------ -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. -- diff --git a/gcc/ada/binde.ads b/gcc/ada/binde.ads index 6412d263c9c..bdea7dc7fb7 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 5cc3ea2d9af..e1355400ab0 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; diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads index 86466f498de..722cfad5b09 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 00000000000..b94ff7ab139 --- /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 is 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 statictics + + 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 no + -- 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 00000000000..0efae619924 --- /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 00000000000..33adede21d1 --- /dev/null +++ b/gcc/ada/bindo-builders.adb @@ -0,0 +1,488 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 Bindo.Units; use Bindo.Units; + +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 + + ----------------- + -- Global data -- + ----------------- + + Lib_Graph : Library_Graph := Library_Graphs.Nil; + + ----------------------- + -- Local subprograms -- + ----------------------- + + 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. + + 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 + + ------------------------- + -- 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); + + return Lib_Graph; + end Build_Library_Graph; + + ------------------------------- + -- 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; + + ------------------------- + -- 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; + 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 00000000000..39cde4ff348 --- /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 which 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 which 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 00000000000..bf11d39a942 --- /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 00000000000..3b1d01cba46 --- /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 00000000000..42b5b6d7ad8 --- /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 traching 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 traching 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 which 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 which 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 which + -- 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 which 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 00000000000..c65f593df0e --- /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 00000000000..ec99fe419e7 --- /dev/null +++ b/gcc/ada/bindo-graphs.adb @@ -0,0 +1,2890 @@ +------------------------------------------------------------------------------ +-- -- +-- 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)); + + 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 + (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.Predefined; + 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 00000000000..3f550275bdc --- /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 00000000000..04471fa8dac --- /dev/null +++ b/gcc/ada/bindo-units.adb @@ -0,0 +1,384 @@ +------------------------------------------------------------------------------ +-- -- +-- 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_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 00000000000..0c1d901035b --- /dev/null +++ b/gcc/ada/bindo-units.ads @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 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 00000000000..54d2fc6643a --- /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 00000000000..39fccc66413 --- /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 00000000000..7450c15f8f3 --- /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 00000000000..9ed598e9981 --- /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 00000000000..7d26476c86b --- /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 00000000000..39cf7a49373 --- /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/debug.adb b/gcc/ada/debug.adb index e43174cdf44..d76d93d6948 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/exp_util.adb b/gcc/ada/exp_util.adb index 6b884ef384c..420609067c9 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 -- ----------------------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index aac44336276..7cb9d2de73a 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/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 104b214a879..dd90c7b7c9a 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -320,8 +320,8 @@ GNAT_ADA_OBJS = \ 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 \ @@ -508,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 \ @@ -527,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/gnatbind.adb b/gcc/ada/gnatbind.adb index be703a98cfd..41541c3423b 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/lib-writ.adb b/gcc/ada/lib-writ.adb index 319557eaf57..ffd6a9001ea 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). @@ -433,6 +632,175 @@ package body Lib.Writ is end loop; 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 34e2480ae91..c17233a726e 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/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb index 6cb4182d979..84dcc304578 100644 --- a/gcc/ada/libgnat/g-dynhta.adb +++ b/gcc/ada/libgnat/g-dynhta.adb @@ -33,6 +33,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 -- ------------------- @@ -485,6 +513,32 @@ package body GNAT.Dynamic_HTables is 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 -- ------------ diff --git a/gcc/ada/libgnat/g-dynhta.ads b/gcc/ada/libgnat/g-dynhta.ads index 6c19f0f370e..107c4c0c1f8 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 -- ------------------- @@ -345,6 +351,11 @@ package GNAT.Dynamic_HTables is type Dynamic_Hash_Table is private; Nil : constant Dynamic_Hash_Table; + 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. diff --git a/gcc/ada/libgnat/g-graphs.adb b/gcc/ada/libgnat/g-graphs.adb index 210e08363cb..1049641ae5e 100644 --- a/gcc/ada/libgnat/g-graphs.adb +++ b/gcc/ada/libgnat/g-graphs.adb @@ -262,7 +262,7 @@ package body GNAT.Graphs is begin Ensure_Created (G); - return Get_Component_Attributes (G, Comp) /= No_Component_Attributes; + return Component_Map.Contains (G.Components, Comp); end Contains_Component; ------------------- @@ -276,7 +276,7 @@ package body GNAT.Graphs is begin Ensure_Created (G); - return Get_Edge_Attributes (G, E) /= No_Edge_Attributes; + return Edge_Map.Contains (G.All_Edges, E); end Contains_Edge; --------------------- @@ -290,7 +290,7 @@ package body GNAT.Graphs is begin Ensure_Created (G); - return Get_Vertex_Attributes (G, V) /= No_Vertex_Attributes; + return Vertex_Map.Contains (G.All_Vertices, V); end Contains_Vertex; ------------ @@ -517,7 +517,7 @@ package body GNAT.Graphs is -- Lowest visitation number On_Stack : Boolean := False; - -- Set when the library item appears in Stack + -- Set when the corresponding vertex appears on the Stack end record; No_Tarjan_Attributes : constant Tarjan_Attributes := @@ -673,11 +673,11 @@ package body GNAT.Graphs is ------------------------ procedure Associate_Vertices (Comp : Component_Id) is - Iter : Vertex_Iterator; + Iter : Component_Vertex_Iterator; V : Vertex_Id; begin - Iter := Iterate_Vertices (G, Comp); + Iter := Iterate_Component_Vertices (G, Comp); while Has_Next (Iter) loop Next (Iter, V); @@ -1150,18 +1150,18 @@ package body GNAT.Graphs is -- Has_Next -- -------------- - function Has_Next (Iter : Outgoing_Edge_Iterator) return Boolean is + function Has_Next (Iter : Component_Vertex_Iterator) return Boolean is begin - return Edge_Set.Has_Next (Edge_Set.Iterator (Iter)); + return Vertex_List.Has_Next (Vertex_List.Iterator (Iter)); end Has_Next; -------------- -- Has_Next -- -------------- - function Has_Next (Iter : Vertex_Iterator) return Boolean is + function Has_Next (Iter : Outgoing_Edge_Iterator) return Boolean is begin - return Vertex_List.Has_Next (Vertex_List.Iterator (Iter)); + return Edge_Set.Has_Next (Edge_Set.Iterator (Iter)); end Has_Next; -------------- @@ -1216,6 +1216,23 @@ package body GNAT.Graphs is 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 -- ---------------------------- @@ -1233,21 +1250,6 @@ package body GNAT.Graphs is (Edge_Set.Iterate (Get_Outgoing_Edges (G, V))); end Iterate_Outgoing_Edges; - ---------------------- - -- Iterate_Vertices -- - ---------------------- - - function Iterate_Vertices - (G : Directed_Graph; - Comp : Component_Id) return Vertex_Iterator - is - begin - Ensure_Created (G); - Ensure_Present (G, Comp); - - return Vertex_Iterator (Vertex_List.Iterate (Get_Vertices (G, Comp))); - end Iterate_Vertices; - ---------- -- Next -- ---------- @@ -1289,11 +1291,11 @@ package body GNAT.Graphs is ---------- procedure Next - (Iter : in out Outgoing_Edge_Iterator; - E : out Edge_Id) + (Iter : in out Component_Vertex_Iterator; + V : out Vertex_Id) is begin - Edge_Set.Next (Edge_Set.Iterator (Iter), E); + Vertex_List.Next (Vertex_List.Iterator (Iter), V); end Next; ---------- @@ -1301,13 +1303,28 @@ package body GNAT.Graphs is ---------- procedure Next - (Iter : in out Vertex_Iterator; - V : out Vertex_Id) + (Iter : in out Outgoing_Edge_Iterator; + E : out Edge_Id) is begin - Vertex_List.Next (Vertex_List.Iterator (Iter), V); + 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 -- -------------------------- @@ -1330,6 +1347,21 @@ package body GNAT.Graphs is 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 -- ------------------------ diff --git a/gcc/ada/libgnat/g-graphs.ads b/gcc/ada/libgnat/g-graphs.ads index 106f06c5cb3..3b655221292 100644 --- a/gcc/ada/libgnat/g-graphs.ads +++ b/gcc/ada/libgnat/g-graphs.ads @@ -45,7 +45,7 @@ package GNAT.Graphs is -- (referred to as simply "component") in a graph. type Component_Id is new Natural; - No_Component : constant Component_Id; + 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 @@ -230,12 +230,22 @@ package GNAT.Graphs is 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 @@ -329,6 +339,29 @@ package GNAT.Graphs is -- * 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. @@ -353,29 +386,6 @@ package GNAT.Graphs is -- * 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 Vertex_Iterator is private; - - function Has_Next (Iter : Vertex_Iterator) return Boolean; - -- Determine whether iterator Iter has more vertices to examine - - function Iterate_Vertices - (G : Directed_Graph; - Comp : Component_Id) return Vertex_Iterator; - -- Obtain an iterator over all vertices that comprise component Comp of - -- graph G. - - procedure Next - (Iter : in out 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. - private pragma Unreferenced (No_Edge); @@ -513,15 +523,14 @@ package GNAT.Graphs is -- 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 Outgoing_Edge_Iterator is new Edge_Set.Iterator; - type Vertex_Iterator is new Vertex_List.Iterator; + 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 - No_Component : constant Component_Id := Component_Id'First; First_Component : constant Component_Id := No_Component + 1; end GNAT.Graphs; diff --git a/gcc/ada/libgnat/g-sets.adb b/gcc/ada/libgnat/g-sets.adb index 149018165dd..b58888043ae 100644 --- a/gcc/ada/libgnat/g-sets.adb +++ b/gcc/ada/libgnat/g-sets.adb @@ -46,7 +46,7 @@ package body GNAT.Sets is Elem : Element_Type) return Boolean is begin - return Hashed_Set.Get (Hashed_Set.Dynamic_Hash_Table (S), Elem); + return Hashed_Set.Contains (Hashed_Set.Dynamic_Hash_Table (S), Elem); end Contains; ------------ diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 5f1ff906045..51c7cf46302 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -1497,6 +1497,24 @@ 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; + ------------------ -- Reinitialize -- ------------------ diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 58fbc087fc3..a788b55256f 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. diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index cd6e521fa3f..47ad8743571 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_ch12.adb b/gcc/ada/sem_ch12.adb index 24273645fa2..bf85b281020 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); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 8f2d24515b8..5f515bcf422 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -5489,8 +5489,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 +6516,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 diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index b74f88d0461..f57b3b1151a 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,615 +672,1286 @@ 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 + + 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 -- + --------- - -- The target is a protected subprogram + 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 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). + -- The following type enumerates all possible Ghost mode mode kinds - -- The following table stores the early call regions of subprogram bodies + type Extended_Ghost_Mode is + (Is_Ignored, + Is_Checked_Or_Not_Specified); - Early_Call_Regions_Max : constant := 101; + -- The following type enumerates all possible SPARK mode kinds - type Early_Call_Regions_Index is range 0 .. Early_Call_Regions_Max - 1; + type Extended_SPARK_Mode is + (Is_On, + Is_Off_Or_Not_Specified); - function Early_Call_Regions_Hash - (Key : Entity_Id) return Early_Call_Regions_Index; - -- Obtain the hash value of entity Key + -------------- + -- Builders -- + -------------- - Early_Call_Regions_In_Use : Boolean := False; - -- This flag determines whether table Early_Call_Regions contains at least - -- least one key/value pair. + 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_No_Element : constant Node_Id := Empty; + ------------------------- + -- Scenario attributes -- + ------------------------- - 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 => "="); + 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 - -- The following table stores the elaboration status of all units withed by - -- the main unit. + ----------------------- + -- Target attributes -- + ----------------------- - Elaboration_Statuses_Max : constant := 1009; + 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. - type Elaboration_Statuses_Index is range 0 .. Elaboration_Statuses_Max - 1; + 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 - function Elaboration_Statuses_Hash - (Key : Entity_Id) return Elaboration_Statuses_Index; - -- Obtain the hash value of entity Key + procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id); + pragma Inline (Disable_Elaboration_Checks); + -- Disable elaboration checks 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 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_No_Element : constant Elaboration_Attributes := - No_Elaboration_Attributes; + 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. - 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 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 - -- The following table stores a status flag for each SPARK scenario saved - -- in table SPARK_Scenarios. + function Kind (T_Id : Target_Rep_Id) return Target_Kind; + pragma Inline (Kind); + -- Obtain the nature of target T_Id - Recorded_SPARK_Scenarios_Max : constant := 127; + 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 - type Recorded_SPARK_Scenarios_Index is - range 0 .. Recorded_SPARK_Scenarios_Max - 1; + 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 - function Recorded_SPARK_Scenarios_Hash - (Key : Node_Id) return Recorded_SPARK_Scenarios_Index; - -- Obtain the hash value of Key + function Unit (T_Id : Target_Rep_Id) return Entity_Id; + pragma Inline (Unit); + -- Obtain the unit where the target is defined - Recorded_SPARK_Scenarios_In_Use : Boolean := False; - -- This flag flag determines whether table Recorded_SPARK_Scenarios - -- contains at least one key/value pair. + 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_No_Element : constant Boolean := False; + ----------------- + -- Maintenance -- + ----------------- - 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 => "="); + procedure Finalize_Internal_Representation; + pragma Inline (Finalize_Internal_Representation); + -- Finalize all internal data structures - -- The following table stores a status flag for each top-level scenario - -- recorded in table Top_Level_Scenarios. + procedure Initialize_Internal_Representation; + pragma Inline (Initialize_Internal_Representation); + -- Initialize all internal data structures - Recorded_Top_Level_Scenarios_Max : constant := 503; + end Internal_Representation; + use Internal_Representation; - type Recorded_Top_Level_Scenarios_Index is - range 0 .. Recorded_Top_Level_Scenarios_Max - 1; + -- The following package provides functionality for recording pieces of the + -- invocation graph in the ALI file of the main unit. - function Recorded_Top_Level_Scenarios_Hash - (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index; - -- Obtain the hash value of entity Key + package Invocation_Graph is - 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. + --------- + -- API -- + --------- - Recorded_Top_Level_Scenarios_No_Element : constant Boolean := False; + 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. - 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 => "="); + ----------------- + -- Maintenance -- + ----------------- - -- 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. + procedure Finalize_Invocation_Graph; + pragma Inline (Finalize_Invocation_Graph); + -- Finalize all internal data structures - 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"); + procedure Initialize_Invocation_Graph; + pragma Inline (Initialize_Invocation_Graph); + -- Initialize all internal data structures - -- The following table stores SPARK scenarios which are not necessarily - -- executable during elaboration, but still require elaboration-related - -- checks. + end Invocation_Graph; + use Invocation_Graph; - 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"); + -- The following package stores scenarios - -- 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. + package Scenario_Storage is - 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"); + --------- + -- API -- + --------- - -- 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. + procedure Add_Declaration_Scenario (N : Node_Id); + pragma Inline (Add_Declaration_Scenario); + -- Save declaration level scenario N - Visited_Bodies_Max : constant := 511; + 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. - type Visited_Bodies_Index is range 0 .. Visited_Bodies_Max - 1; + procedure Add_Library_Body_Scenario (N : Node_Id); + pragma Inline (Add_Library_Body_Scenario); + -- Save library-level body scenario N - function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index; - -- Obtain the hash value of node Key + procedure Add_Library_Spec_Scenario (N : Node_Id); + pragma Inline (Add_Library_Spec_Scenario); + -- Save library-level spec scenario N - Visited_Bodies_In_Use : Boolean := False; - -- This flag determines whether table Visited_Bodies contains at least one - -- key/value pair. + procedure Add_SPARK_Scenario (N : Node_Id); + pragma Inline (Add_SPARK_Scenario); + -- Save SPARK scenario N - Visited_Bodies_No_Element : constant Boolean := False; + procedure Delete_Scenario (N : Node_Id); + pragma Inline (Delete_Scenario); + -- Delete arbitrary scenario N - 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 Iterate_Declaration_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Declaration_Scenarios); + -- Obtain an iterator over all declaration level scenarios - ----------------------- - -- Local subprograms -- - ----------------------- + 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. - -- 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 Iterate_Library_Body_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Library_Body_Scenarios); + -- Obtain an iterator over all library level body scenarios - 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 Iterate_Library_Spec_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Library_Spec_Scenarios); + -- Obtain an iterator over all library level spec scenarios - 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. + function Iterate_SPARK_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_SPARK_Scenarios); + -- Obtain an iterator over all SPARK scenarios - 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. + procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id); + pragma Inline (Replace_Scenario); + -- Replace scenario Old_N with scenario New_N - 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 - -- encloses arbitrary node N. Return Empty if no such instance exists. + ----------------- + -- Maintenance -- + ----------------- - function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id; - pragma Inline (Find_Top_Unit); - -- Return the top unit which contains arbitrary node or entity N. The unit - -- is obtained by logically unwinding instantiations and subunits when N - -- resides within one. + procedure Finalize_Scenario_Storage; + pragma Inline (Finalize_Scenario_Storage); + -- Finalize all internal data structures - function Find_Unit_Entity (N : Node_Id) return Entity_Id; - pragma Inline (Find_Unit_Entity); - -- Return the entity of unit N + 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. + + 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_Bridge_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Bridge_Target); + -- Determine whether arbitrary entity Id denotes a bridge target + + 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. + + 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_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. + + 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 -- + ----------------------- + + 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 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 + -- encloses arbitrary node N. Return Empty if no such instance exists. + + function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id; + pragma Inline (Find_Top_Unit); + -- Return the top unit which contains arbitrary node or entity N. The unit + -- is obtained by logically unwinding instantiations and subunits when N + -- resides within one. + + function Find_Unit_Entity (N : Node_Id) return Entity_Id; + pragma Inline (Find_Unit_Entity); + -- Return the entity of unit N function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id; pragma Inline (First_Formal_Type); @@ -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,324 +2018,37 @@ 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 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_Suitable_Access (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Access); - -- 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. - - 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_Scenario (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Scenario); - -- Determine whether arbitrary node N is a suitable scenario 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_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 - - 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 (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. - - 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 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. - 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_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. - - 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. + function Scenario (N : Node_Id) return Node_Id; + pragma Inline (Scenario); + -- Return the appropriate scenario node for scenario N - 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 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. - 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. + 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 Static_Elaboration_Checks return Boolean; pragma Inline (Static_Elaboration_Checks); -- Determine whether the static model is in effect - 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. - 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 @@ -1876,3456 +2058,6767 @@ package body Sem_Elab is -- Update all relevant internal data structures when scenario Old_N is -- transformed into scenario New_N by Atree.Rewrite. - ----------------------- - -- Build_Call_Marker -- - ----------------------- - - procedure Build_Call_Marker (N : Node_Id) is - function In_External_Context - (Call : Node_Id; - Target_Attrs : Target_Attributes) 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. + ---------------------- + -- Active_Scenarios -- + ---------------------- - function In_Premature_Context (Call : Node_Id) return Boolean; - -- Determine whether call Call appears within a premature context + package body Active_Scenarios is - function Is_Bridge_Target (Id : Entity_Id) return Boolean; - pragma Inline (Is_Bridge_Target); - -- Determine whether arbitrary entity Id denotes a bridge target + ----------------------- + -- Local subprograms -- + ----------------------- - 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 - -- parameter within a source call. + 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_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean; - pragma Inline (Is_Generic_Formal_Subp); - -- Determine whether subprogram Subp_Id denotes a generic formal - -- subprogram which appears in the "prologue" of an instantiation. + 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. - ------------------------- - -- In_External_Context -- - ------------------------- + ------------------- + -- Output_Access -- + ------------------- - function In_External_Context - (Call : Node_Id; - Target_Attrs : Target_Attributes) return Boolean + procedure Output_Access_Taken + (Attr : Node_Id; + Attr_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) is - Inst : Node_Id; - Inst_Body : Node_Id; - Inst_Decl : Node_Id; + Subp_Id : constant Entity_Id := Target (Attr_Rep); begin - -- Performance note: parent traversal + 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; - Inst := Find_Enclosing_Instance (Call); + ---------------------------- + -- Output_Active_Scenario -- + ---------------------------- - -- The call appears within an instance + 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; - if Present (Inst) then + begin + -- 'Access - -- The call comes from the main unit and the target does not + if Is_Suitable_Access_Taken (Scen) then + Output_Access_Taken + (Attr => Scen, + Attr_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); - if In_Extended_Main_Code_Unit (Call) - and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl) - then - return True; + -- Call or task activation - -- Otherwise the target declaration must not appear within the - -- instance spec or body. + elsif Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - else - Extract_Instance_Attributes - (Exp_Inst => Inst, - Inst_Decl => Inst_Decl, - Inst_Body => Inst_Body); + if Kind (Scen_Rep) = Call_Scenario then + Output_Call + (Call => Scen, + Call_Rep => Scen_Rep, + Error_Nod => Error_Nod); - -- Performance note: parent traversal + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); - return not In_Subtree - (N => Target_Attrs.Spec_Decl, - Root1 => Inst_Decl, - Root2 => Inst_Body); + Output_Task_Activation + (Call => Scen, + Call_Rep => Scen_Rep, + Error_Nod => Error_Nod); end if; - end if; - - return False; - end In_External_Context; - -------------------------- - -- In_Premature_Context -- - -------------------------- + -- Instantiation - function In_Premature_Context (Call : Node_Id) return Boolean is - Par : Node_Id; + elsif Is_Suitable_Instantiation (Scen) then + Output_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); - begin - -- Climb the parent chain looking for premature contexts + -- Pragma Refined_State - Par := Parent (Call); - while Present (Par) loop + 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); - -- Aspect specifications and generic associations are premature - -- contexts because nested calls has not been relocated to their - -- final context. + -- Variable assignment - if Nkind_In (Par, N_Aspect_Specification, - N_Generic_Association) - then - return True; + elsif Is_Suitable_Variable_Assignment (Scen) then + Output_Variable_Assignment + (Asmt => Scen, + Asmt_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); - -- Prevent the search from going too far + -- Variable reference - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; + 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; - Par := Parent (Par); - end loop; + ----------------------------- + -- Output_Active_Scenarios -- + ----------------------------- - return False; - end In_Premature_Context; + procedure Output_Active_Scenarios + (Error_Nod : Node_Id; + In_State : Processing_In_State) + is + package Scenarios renames Active_Scenario_Stack; - ---------------------- - -- Is_Bridge_Target -- - ---------------------- + Header_Posted : Boolean := False; - 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 -- - --------------------------- + -- Output the contents of the active scenario stack starting from the + -- bottom, or the least recent scenario. - function Is_Default_Expression (Call : Node_Id) return Boolean is - Outer_Call : constant Node_Id := Parent (Call); - Outer_Nam : Node_Id; + for Index in Scenarios.First .. Scenarios.Last loop + if not Header_Posted then + Output_Header (Error_Nod); + Header_Posted := True; + end if; - begin - -- To qualify, the node must appear immediately within a source call - -- which invokes a source target. + Output_Active_Scenario + (N => Scenarios.Table (Index), + Error_Nod => Error_Nod, + In_State => In_State); + end loop; + end Output_Active_Scenarios; - if Nkind_In (Outer_Call, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) - and then Comes_From_Source (Outer_Call) - then - Outer_Nam := Extract_Call_Name (Outer_Call); + ----------------- + -- Output_Call -- + ----------------- - return - Is_Entity_Name (Outer_Nam) - and then Present (Entity (Outer_Nam)) - and then Is_Subprogram_Or_Entry (Entity (Outer_Nam)) - and then Comes_From_Source (Entity (Outer_Nam)); - end if; + 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. - return False; - end Is_Default_Expression; + 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. - ---------------------------- - -- Is_Generic_Formal_Subp -- - ---------------------------- + 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. - function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is - Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); - Context : constant Node_Id := Parent (Subp_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 - -- To qualify, the subprogram must rename a generic actual subprogram - -- where the enclosing context is an instantiation. + ------------------------------- + -- Output_Accept_Alternative -- + ------------------------------- - return - Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration - and then not Comes_From_Source (Subp_Decl) - and then Nkind_In (Context, N_Function_Specification, - N_Package_Specification, - N_Procedure_Specification) - and then Present (Generic_Parent (Context)); - end Is_Generic_Formal_Subp; + procedure Output_Accept_Alternative (Alt_Id : Entity_Id) is + Entry_Id : constant Entity_Id := Receiving_Entry (Alt_Id); - -- Local variables + begin + pragma Assert (Present (Entry_Id)); - Call_Attrs : Call_Attributes; - Call_Nam : Node_Id; - Marker : Node_Id; - Target_Attrs : Target_Attributes; - Target_Id : Entity_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 -- + ----------------------- + + procedure Build_Call_Marker (N : Node_Id) is + function In_External_Context + (Call : Node_Id; + Subp_Id : Entity_Id) return Boolean; + pragma Inline (In_External_Context); + -- 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_Default_Expression (Call : Node_Id) return Boolean; + pragma Inline (Is_Default_Expression); + -- Determine whether call Call acts as the expression of a defaulted + -- parameter within a source call. + + function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean; + pragma Inline (Is_Generic_Formal_Subp); + -- Determine whether subprogram Subp_Id denotes a generic formal + -- subprogram which appears in the "prologue" of an instantiation. + + ------------------------- + -- In_External_Context -- + ------------------------- + + function In_External_Context + (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_Spec : Node_Id; + + begin + Inst := Find_Enclosing_Instance (Call); + + -- The call appears within an instance + + if Present (Inst) then + + -- 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 (Spec_Decl) + then + return True; + + -- Otherwise the target declaration must not appear within the + -- instance spec or body. + + else + Spec_And_Body_From_Node + (N => Inst, + Spec_Decl => Inst_Spec, + Body_Decl => Inst_Body); + + return not In_Subtree + (N => Spec_Decl, + Root1 => Inst_Spec, + Root2 => Inst_Body); + end if; + end if; + + return False; + end In_External_Context; + + -------------------------- + -- In_Premature_Context -- + -------------------------- + + function In_Premature_Context (Call : Node_Id) return Boolean is + Par : Node_Id; + + begin + -- Climb the parent chain looking for premature contexts + + Par := Parent (Call); + while Present (Par) loop + + -- Aspect specifications and generic associations are premature + -- contexts because nested calls has not been relocated to their + -- final context. + + if Nkind_In (Par, N_Aspect_Specification, + N_Generic_Association) + then + return True; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + return False; + end In_Premature_Context; + + --------------------------- + -- Is_Default_Expression -- + --------------------------- + + function Is_Default_Expression (Call : Node_Id) return Boolean is + Outer_Call : constant Node_Id := Parent (Call); + Outer_Nam : Node_Id; + + begin + -- To qualify, the node must appear immediately within a source call + -- which invokes a source target. + + if Nkind_In (Outer_Call, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) + and then Comes_From_Source (Outer_Call) + then + Outer_Nam := Call_Name (Outer_Call); + + return + Is_Entity_Name (Outer_Nam) + and then Present (Entity (Outer_Nam)) + and then Is_Subprogram_Or_Entry (Entity (Outer_Nam)) + and then Comes_From_Source (Entity (Outer_Nam)); + end if; + + return False; + end Is_Default_Expression; + + ---------------------------- + -- Is_Generic_Formal_Subp -- + ---------------------------- + + function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is + Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); + Context : constant Node_Id := Parent (Subp_Decl); + + begin + -- To qualify, the subprogram must rename a generic actual subprogram + -- where the enclosing context is an instantiation. + + return + Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration + and then not Comes_From_Source (Subp_Decl) + and then Nkind_In (Context, N_Function_Specification, + N_Package_Specification, + N_Procedure_Specification) + and then Present (Generic_Parent (Context)); + end Is_Generic_Formal_Subp; + + -- Local variables + + Call_Nam : Node_Id; + Marker : Node_Id; + Subp_Id : Entity_Id; + + -- Start of processing for Build_Call_Marker + + 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. + + if Legacy_Elaboration_Checks then + return; + + -- Nothing to do for ASIS because ABE checks and diagnostics are not + -- performed in this mode. + + elsif ASIS_Mode then + return; + + -- Nothing to do when the call is being preanalyzed as the marker will + -- be inserted in the wrong place. + + elsif Preanalysis_Active then + return; + + -- Nothing to do when the input does not denote a call or a requeue + + elsif not Nkind_In (N, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement, + N_Requeue_Statement) + then + return; + + -- Nothing to do when the input denotes entry call or requeue statement, + -- and switch -gnatd_e (ignore entry calls and requeue statements for + -- elaboration) is in effect. + + elsif Debug_Flag_Underscore_E + 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 := Call_Name (N); + + -- Nothing to do when the call is erroneous or left in a bad state + + if not (Is_Entity_Name (Call_Nam) + and then Present (Entity (Call_Nam)) + 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 + -- elaboration) is in 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_Dot_GG + and then Is_Generic_Formal_Subp (Entity (Call_Nam)) + then + return; + + -- 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. This check must be performed with the direct target of the + -- call to avoid the side effects of mapping actuals to formals using + -- renamings. + + elsif Debug_Flag_LL + and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) + and then In_External_Context + (Call => N, + Subp_Id => Subp_Id) + then + return; + + -- Nothing to do when the call invokes an assertion pragma procedure + -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is + -- in effect. + + elsif Debug_Flag_Underscore_P + 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 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 Comes_From_Source (Subp_Id) + and then Nkind (N) = N_Function_Call + and then Is_Default_Expression (N) + then + null; + + -- The target emulates Ada semantics + + elsif Is_Ada_Semantic_Target (Subp_Id) then + null; + + -- The target acts as a link between scenarios + + elsif Is_Bridge_Target (Subp_Id) then + null; + + -- The target emulates SPARK semantics + + elsif Is_SPARK_Semantic_Target (Subp_Id) then + null; + + -- Otherwise the call is not suitable for ABE processing. This prevents + -- the generation of call markers which will never play a role in ABE + -- diagnostics. + + else + return; + end if; + + -- At this point it is known that the call will play some role in ABE + -- checks and diagnostics. Create a corresponding call marker in case + -- the original call is heavily transformed by expansion later on. + + Marker := Make_Call_Marker (Sloc (N)); + + -- Inherit the attributes of the original call + + 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, Is_Elaboration_Checks_OK_Node (N)); + + Set_Is_Elaboration_Warnings_OK_Node + (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: + + -- 1) The marker appears in the same context, in close proximity to + -- the call. + + -- + -- + + -- 2) Inserting the marker prior to the call ensures that an ABE check + -- will take effect prior to the call. + + -- + -- + -- + + -- 3) The above two properties are preserved even when the call is a + -- function which is subsequently relocated in order to capture its + -- result. Note that if the call is relocated to a new context, the + -- relocated call will receive a marker of its own. + + -- + -- + -- Temp : ... := Func_Call ...; + -- ... Temp ... + + -- The insertion must take place even when the call does not occur in + -- the main unit to keep the tree symmetric. This ensures that internal + -- name serialization is consistent in case the call marker causes the + -- tree to transform in some way. + + Insert_Action (N, Marker); + + -- The marker becomes the "corresponding" scenario for the call. Save + -- the marker for later processing by the ABE phase. + + Record_Elaboration_Scenario (Marker); + end Build_Call_Marker; + + ------------------------------------- + -- Build_Variable_Reference_Marker -- + ------------------------------------- + + procedure Build_Variable_Reference_Marker + (N : Node_Id; + Read : Boolean; + Write : Boolean) + is + function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id; + pragma Inline (Ultimate_Variable); + -- Obtain the ultimate renamed variable of variable Var_Id + + ----------------------- + -- 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_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 + -- the main unit to keep the tree symmetric. This ensures that internal + -- name serialization is consistent in case the variable marker causes + -- the tree to transform in some way. + + Insert_Action (N, Marker); + + -- The marker becomes the "corresponding" scenario for the reference. + -- Save the marker for later processing for the ABE phase. + + 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 + -- to carry out this action. + + if Legacy_Elaboration_Checks then + return; + + -- Nothing to do for ASIS because ABE checks and diagnostics are not + -- performed in this mode. + + elsif ASIS_Mode then + 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 + -- main unit. + + Install_Elaboration_Model (Unit_Entity (Cunit_Entity (Main_Unit))); + + -- Examine the context of the main unit and record all units with prior + -- elaboration with respect to it. + + Collect_Elaborated_Units; + + -- 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. + + Iter := Iterate_Declaration_Scenarios; + Check_Conditional_ABE_Scenarios (Iter); + + 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. + + 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_Installer -- + --------------------- + + package body Check_Installer is + + ----------------------- + -- Local subprograms -- + ----------------------- + + 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 + if not Check_Or_Failure_Generation_OK then + return False; + + -- 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; + + return True; + end ABE_Check_Or_Failure_OK; + + ------------------------------------ + -- Check_Or_Failure_Generation_OK -- + ------------------------------------ + + 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. + + if Serious_Errors_Detected > 0 then + return False; + + -- An ABE check or failure must not be installed when compiling for + -- GNATprove because raise statements are not supported. + + elsif GNATprove_Mode then + return False; + end if; + + return True; + end Check_Or_Failure_Generation_OK; + + -------------------- + -- Insertion_Node -- + -------------------- + + 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. + + if Nkind (N) in N_Generic_Instantiation + and then Present (Instance_Spec (N)) + then + return Instance_Spec (N); + + -- Otherwise the proper insertion node is the scenario itself + + else + return N; + end if; + end Insertion_Node; + + --------------------------------- + -- Insert_ABE_Check_Or_Failure -- + --------------------------------- + + 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); + + begin + -- Install the nearest enclosing scope of the scenario as there must + -- be something on the scope stack. + + Push_Scope (Scop_Id); + + Insert_Action (Ins_Nod, Check); + + Pop_Scope; + end Insert_ABE_Check_Or_Failure; + + -------------------------------- + -- Install_Dynamic_ABE_Checks -- + -------------------------------- + + procedure Install_Dynamic_ABE_Checks is + Iter : NE_Set.Iterator; + N : Node_Id; + + begin + if not Check_Or_Failure_Generation_OK then + return; + + -- Nothing to do if the dynamic model is not in effect + + elsif not Dynamic_Elaboration_Checks then + return; + end if; + + -- Install a conditional ABE check for each saved scenario + + Iter := Iterate_Dynamic_ABE_Check_Scenarios; + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); + + Process_Conditional_ABE + (N => N, + In_State => Dynamic_Model_State); + end loop; + end Install_Dynamic_ABE_Checks; + + -------------------------------- + -- Install_Scenario_ABE_Check -- + -------------------------------- + + procedure Install_Scenario_ABE_Check + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Scenario_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; + + -- Prevent multiple attempts to install the same ABE check + + Disable_Elaboration_Checks (Disable); + + 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; + + -- Prevent multiple attempts to install the same ABE check + + Disable_Elaboration_Checks (Disable); + + Install_Scenario_ABE_Check_Common + (N => N, + Targ_Id => Targ_Id, + Targ_Rep => Targ_Rep); + end Install_Scenario_ABE_Check; + + --------------------------------------- + -- 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; + + -- Create the declaration of the elaboration flag. The name + -- carries a unique counter in case the name is overloaded. + + Flag_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Targ_Id), 'E', -1)); + + Set_Elaboration_Entity (Targ_Id, Flag_Id); + Set_Elaboration_Entity_Required (Targ_Id); + + Push_Scope (Scope (Targ_Id)); + + -- Generate: + -- Enn : Short_Integer := 0; + + 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))); + + -- Generate: + -- Enn := 1; + + Set_Elaboration_Flag (Targ_Body, Targ_Id); + + Pop_Scope; + end Build_Elaboration_Entity; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + + -- Start for processing for Install_Scenario_ABE_Check_Common + + begin + -- Create an elaboration flag for the target when it does not have + -- one. + + Build_Elaboration_Entity; + + -- 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; + + ---------------------------------- + -- 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 + -- Nothing to do when the scenario does not require an ABE failure + + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Targ_Id, + Unit_Id => Unit (Targ_Rep)) + then + return; + end if; + + -- Prevent multiple attempts to install the same ABE check + + Disable_Elaboration_Checks (Disable); + + Install_Scenario_ABE_Failure_Common (N); + end Install_Scenario_ABE_Failure; + + ---------------------------------- + -- Install_Scenario_ABE_Failure -- + ---------------------------------- + + 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 + + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Targ_Id, + Unit_Id => Unit (Targ_Rep)) + then + return; + end if; + + -- Prevent multiple attempts to install the same ABE check + + Disable_Elaboration_Checks (Disable); + + Install_Scenario_ABE_Failure_Common (N); + end Install_Scenario_ABE_Failure; + + ----------------------------------------- + -- Install_Scenario_ABE_Failure_Common -- + ----------------------------------------- + + procedure Install_Scenario_ABE_Failure_Common (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + begin + -- Generate: + -- raise Program_Error with "access before elaboration"; + + Insert_ABE_Check_Or_Failure + (N => N, + Check => + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration)); + end Install_Scenario_ABE_Failure_Common; + + ---------------------------- + -- Install_Unit_ABE_Check -- + ---------------------------- + + 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); + + 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; + + ---------------------------- + -- Install_Unit_ABE_Check -- + ---------------------------- + + procedure Install_Unit_ABE_Check + (N : Node_Id; + Unit_Id : Entity_Id; + Disable : Target_Rep_Id) + is + Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); + + 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; + + ----------------------------------- + -- Install_Unit_ABE_Check_Common -- + ----------------------------------- + + 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); + + 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; + + ---------------------- + -- Compilation_Unit -- + ---------------------- + + function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is + Comp_Unit : Node_Id; + + begin + Comp_Unit := Parent (Unit_Id); + + -- Handle the case where a concurrent subunit is rewritten as a null + -- statement due to expansion activities. + + 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); + + -- Otherwise use the declaration node of the unit + + else + Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); + end if; + + -- 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; - -- Start of processing for Build_Call_Marker + ------------------------------- + -- Conditional_ABE_Processor -- + ------------------------------- - 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. + package body Conditional_ABE_Processor is - if Legacy_Elaboration_Checks then - return; + ----------------------- + -- Local subprograms -- + ----------------------- - -- Nothing to do for ASIS because ABE checks and diagnostics are not - -- performed in this mode. + 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; - elsif ASIS_Mode then - return; + begin + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - -- Nothing to do when the call is being preanalyzed as the marker will - -- be inserted in the wrong place. + -- Reset the traversed status of all subprogram bodies because the + -- current conditional scenario acts as a new DFS traversal root. - elsif Preanalysis_Active then - return; + Reset_Traversed_Bodies; - -- Nothing to do when the input does not denote a call or a requeue + Process_Conditional_ABE + (N => N, + In_State => Conditional_ABE_State); + end loop; + end Check_Conditional_ABE_Scenarios; - elsif not Nkind_In (N, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement, - N_Requeue_Statement) - then - return; + --------------------------------- + -- Is_Conditional_ABE_Scenario -- + --------------------------------- - -- Nothing to do when the input denotes entry call or requeue statement, - -- and switch -gnatd_e (ignore entry calls and requeue statements for - -- elaboration) is 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; - elsif Debug_Flag_Underscore_E - and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) - then - return; - end if; + ----------------------------- + -- Process_Conditional_ABE -- + ----------------------------- - Call_Nam := Extract_Call_Name (N); + procedure Process_Conditional_ABE + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); + Scen_Rep : Scenario_Rep_Id; - -- Nothing to do when the call is erroneous or left in a bad state + begin + -- Add the current scenario to the stack of active scenarios - if not (Is_Entity_Name (Call_Nam) - and then Present (Entity (Call_Nam)) - and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) - then - return; + Push_Active_Scenario (Scen); - -- Nothing to do when the call invokes a generic formal subprogram and - -- switch -gnatd.G (ignore calls through generic formal parameters for - -- elaboration) is in 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. + -- 'Access - elsif Debug_Flag_Dot_GG - and then Is_Generic_Formal_Subp (Entity (Call_Nam)) - then - return; + 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); - -- 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. + -- Call or task activation - -- Performance note: parent traversal + elsif Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - elsif In_Premature_Context (N) then - return; - end if; + -- 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. - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); + if In_Main_Context (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); + if Kind (Scen_Rep) = Call_Scenario then + Process_Conditional_ABE_Call + (Call => Scen, + Call_Rep => Scen_Rep, + In_State => In_State); - -- 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. + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); - if Debug_Flag_LL - and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) + Process_Activation + (Call => Scen, + Call_Rep => Scen_Rep, + Processor => Process_Conditional_ABE_Activation'Access, + In_State => In_State); + end if; + end if; - -- Performance note: parent traversal + -- Instantiation - and then In_External_Context - (Call => N, - Target_Attrs => Target_Attrs) - then - return; + elsif Is_Suitable_Instantiation (Scen) then + Process_Conditional_ABE_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - -- Nothing to do when the call invokes an assertion pragma procedure - -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is - -- in effect. + -- Variable assignments - elsif Debug_Flag_Underscore_P - and then Is_Assertion_Pragma_Target (Target_Id) - then - return; + 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); - -- Source calls to source targets are always considered because they - -- reflect the original call graph. + -- Variable references - elsif Target_Attrs.From_Source and then Call_Attrs.From_Source then - null; + elsif Is_Suitable_Variable_Reference (Scen) then - -- A call to a source function which acts as the default expression in - -- another call requires special detection. + -- 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. - elsif Target_Attrs.From_Source - and then Nkind (N) = N_Function_Call - and then Is_Default_Expression (N) - then - null; + 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; - -- The target emulates Ada semantics + -- Remove the current scenario from the stack of active scenarios + -- once all ABE diagnostics and checks have been performed. - elsif Is_Ada_Semantic_Target (Target_Id) then - null; + Pop_Active_Scenario (Scen); + end Process_Conditional_ABE; - -- The target acts as a link between scenarios + ------------------------------------------ + -- Process_Conditional_ABE_Access_Taken -- + ------------------------------------------ - elsif Is_Bridge_Target (Target_Id) then - null; + 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 - -- The target emulates SPARK semantics + ------------------------- + -- Build_Access_Marker -- + ------------------------- - elsif Is_SPARK_Semantic_Target (Target_Id) then - null; + function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id is + Marker : Node_Id; - -- Otherwise the call is not suitable for ABE processing. This prevents - -- the generation of call markers which will never play a role in ABE - -- diagnostics. + begin + Marker := Make_Call_Marker (Sloc (Attr)); - else - return; - end if; + -- Inherit relevant attributes from the attribute - -- At this point it is known that the call will play some role in ABE - -- checks and diagnostics. Create a corresponding call marker in case - -- the original call is heavily transformed by expansion later on. + 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); - Marker := Make_Call_Marker (Sloc (N)); + -- Partially insert the call marker into the tree by setting its + -- parent pointer. - -- Inherit the attributes of the original call + Set_Parent (Marker, Attr); - 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_Elaboration_Checks_OK_Node - (Marker, Call_Attrs.Elab_Checks_OK); - 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); + return Marker; + end Build_Access_Marker; - -- The marker is inserted prior to the original call. This placement has - -- several desirable effects: + -- Local variables - -- 1) The marker appears in the same context, in close proximity to - -- the call. + 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 - -- 2) Inserting the marker prior to the call ensures that an ABE check - -- will take effect prior to the call. + -- Start of processing for Process_Conditional_ABE_Access - -- - -- - -- + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - -- 3) The above two properties are preserved even when the call is a - -- function which is subsequently relocated in order to capture its - -- result. Note that if the call is relocated to a new context, the - -- relocated call will receive a marker of its own. + if Elab_Info_Messages + and then not New_In_State.Suppress_Info_Messages + then + Error_Msg_NE + ("info: access to & during elaboration", Attr, Subp_Id); + end if; - -- - -- - -- Temp : ... := Func_Call ...; - -- ... Temp ... + -- 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. - -- The insertion must take place even when the call does not occur in - -- the main unit to keep the tree symmetric. This ensures that internal - -- name serialization is consistent in case the call marker causes the - -- tree to transform in some way. + 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); - Insert_Action (N, Marker); + -- Do not emit any ABE diagnostics when the current or previous + -- scenario in this traversal has suppressed elaboration warnings. - -- The marker becomes the "corresponding" scenario for the call. Save - -- the marker for later processing by the ABE phase. + if New_In_State.Suppress_Warnings then + null; - Record_Elaboration_Scenario (Marker); - end Build_Call_Marker; + -- 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); - ------------------------------------- - -- Build_Variable_Reference_Marker -- - ------------------------------------- + Output_Active_Scenarios (Attr, New_In_State); + end if; - procedure Build_Variable_Reference_Marker - (N : Node_Id; - Read : Boolean; - Write : Boolean) - is - Marker : Node_Id; - Var_Attrs : Variable_Attributes; - Var_Id : Entity_Id; + -- 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) - begin - Extract_Variable_Reference_Attributes - (Ref => N, - Var_Id => Var_Id, - Attrs => Var_Attrs); + if Debug_Flag_Dot_O then + Process_Conditional_ABE + (N => Build_Access_Marker (Subp_Id), + In_State => New_In_State); - Marker := Make_Variable_Reference_Marker (Sloc (N)); + -- Otherwise ensure that the unit with the corresponding body is + -- elaborated prior to the main unit. - -- Inherit the attributes of the original variable reference + else + Ensure_Prior_Elaboration + (N => Attr, + Unit_Id => Unit (Subp_Rep), + Prag_Nam => Name_Elaborate_All, + In_State => New_In_State); + end if; + end Process_Conditional_ABE_Access_Taken; - Set_Target (Marker, Var_Id); - Set_Is_Read (Marker, Read); - Set_Is_Write (Marker, Write); + ---------------------------------------- + -- Process_Conditional_ABE_Activation -- + ---------------------------------------- - -- The marker is inserted prior to the original variable reference. The - -- insertion must take place even when the reference does not occur in - -- the main unit to keep the tree symmetric. This ensures that internal - -- name serialization is consistent in case the variable marker causes - -- the tree to transform in some way. + 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 - Insert_Action (N, Marker); + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - -- The marker becomes the "corresponding" scenario for the reference. - -- Save the marker for later processing for the ABE phase. + 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; - Record_Elaboration_Scenario (Marker); - end Build_Variable_Reference_Marker; + -- 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. - --------------------------------- - -- Check_Elaboration_Scenarios -- - --------------------------------- + if Debug_Flag_Underscore_I + and then In_External_Instance + (N => Call, + Target_Decl => Spec_Decl) + then + return; - procedure Check_Elaboration_Scenarios is - 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. + -- Nothing to do when the activation is a guaranteed ABE - if Legacy_Elaboration_Checks then - return; + elsif Is_Known_Guaranteed_ABE (Call) then + return; - -- Nothing to do for ASIS because ABE checks and diagnostics are not - -- performed in this mode. + -- 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 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 ASIS_Mode 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; + -- -- safe activation + -- end Nested; + -- ... - -- 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 - -- main unit. + elsif Is_Safe_Activation (Call, Task_Rep) then - Install_Elaboration_Model (Unit_Entity (Cunit_Entity (Main_Unit))); + -- Note that the task body must still be examined for any nested + -- scenarios. + + null; + + -- 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. - -- Examine the context of the main unit and record all units with prior - -- elaboration with respect to it. + elsif Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + then + if Earlier_In_Extended_Unit (Root, Body_Decl) then - Find_Elaborated_Units; + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - -- 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. + if New_In_State.Suppress_Warnings then + null; - for Index in Top_Level_Scenarios.First .. Top_Level_Scenarios.Last loop - Reset_Visited_Bodies; + -- Do not emit any ABE diagnostics when the activation occurs + -- in a partial finalization context because this action leads + -- to confusing noise. - Process_Conditional_ABE (Top_Level_Scenarios.Table (Index)); - end loop; + elsif New_In_State.Within_Partial_Finalization then + null; - -- Examine each SPARK scenario saved during the Recording phase which - -- is not necessarily executable during elaboration, but still requires - -- elaboration-related checks. + -- Otherwise emit the ABE disgnostic - for Index in SPARK_Scenarios.First .. SPARK_Scenarios.Last loop - Check_SPARK_Scenario (SPARK_Scenarios.Table (Index)); - end loop; - end Check_Elaboration_Scenarios; + 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); - ------------------------------ - -- Check_Preelaborated_Call -- - ------------------------------ + Output_Active_Scenarios (Obj_Id, New_In_State); + end if; - 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 + -- 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 + -- + -- 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; - ------------------------------ - -- 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. - 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); + 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; - 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. + -- 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. - 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)) + if SPARK_Mode_Of (Call_Rep) = Is_On + and then SPARK_Mode_Of (Task_Rep) = Is_On then - return False; + null; - -- Otherwise the node appears within a preelaborated context when the - -- associated unit is preelaborated. + -- Otherwise the Ada rules are in effect. Ensure that the unit with + -- the task body is elaborated prior to the main unit. else - return Is_Preelaborated_Unit (Spec_Id); + Ensure_Prior_Elaboration + (N => Call, + Unit_Id => Unit_Id, + Prag_Nam => Name_Elaborate_All, + In_State => New_In_State); end if; - end In_Preelaborated_Context; - - -- Local variables - Call_Attrs : Call_Attributes; - Level : Enclosing_Level_Kind; - Target_Id : Entity_Id; + Traverse_Conditional_ABE_Body + (N => Body_Decl, + In_State => New_In_State); + end Process_Conditional_ABE_Activation; - -- Start of processing for Check_Preelaborated_Call + ---------------------------------- + -- Process_Conditional_ABE_Call -- + ---------------------------------- - begin - Extract_Call_Attributes - (Call => Call, - Target_Id => Target_Id, - Attrs => Call_Attrs); + 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. - -- Nothing to do when the call is internally generated because it is - -- assumed that it will never violate preelaboration. + ------------------------------- + -- In_Initialization_Context -- + ------------------------------- - if not Call_Attrs.From_Source then - return; - end if; + function In_Initialization_Context (N : Node_Id) return Boolean is + Par : Node_Id; + Spec_Id : Entity_Id; - -- Performance note: parent traversal + begin + -- Climb the parent chain looking for initialization actions - Level := Find_Enclosing_Level (Call); + Par := Parent (N); + while Present (Par) loop - -- Library-level calls are always considered because they are part of - -- the associated unit's elaboration actions. + -- A block may be part of the initialization actions of a + -- default initialized object. - if Level in Library_Level then - null; + if Nkind (Par) = N_Block_Statement + and then Is_Initialization_Block (Par) + then + return True; - -- 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. + -- A subprogram body may denote an initialization routine - elsif Level = Generic_Package_Body then - null; + elsif Nkind (Par) = N_Subprogram_Body then + Spec_Id := Unique_Defining_Entity (Par); - -- Otherwise the call does not appear at the proper level and must not - -- be considered for this check. + -- The current subprogram body denotes a type init proc or + -- primitive [Deep_]Initialize. - else - return; - end if; + 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; - -- The call appears within a preelaborated unit. Emit a warning only for - -- internal uses, otherwise this is an error. + -- Prevent the search from going too far - if In_Preelaborated_Context (Call) then - Error_Msg_Warn := GNAT_Mode; - Error_Msg_N - ("< Call, + Subp_Id => Subp_Id, + Info_Msg => True, + In_SPARK => SPARK_Rules_On); end if; - Body_Id := Corresponding_Body (Prim_Decl); - - -- 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 No (Body_Id) then - return; - - -- The primitive overrides a parent or progenitor primitive - - elsif Present (Overridden_Operation (Prim)) then + -- 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. - -- 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. + if Is_Protected_Entry (Subp_Id) then + Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); - if Present (Alias (Prim)) then - return; - end if; + elsif Is_Task_Entry (Subp_Id) then + Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); - -- 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. + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. - else return; end if; - Body_Decl := Unit_Declaration_Node (Body_Id); - Region := Find_Early_Call_Region (Body_Decl); - - -- The freeze node appears prior to the early call region of the - -- primitive body. - - -- 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. - - 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); - - Error_Msg_Sloc := Sloc (Region); - Error_Msg_N ("\region starts #", Typ_Decl); + -- 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. - Error_Msg_Sloc := Sloc (Body_Decl); - Error_Msg_N ("\region ends #", Typ_Decl); - - Error_Msg_Sloc := Freeze_Node_Location (FNode); - Error_Msg_N ("\first freezing point #", Typ_Decl); + if Debug_Flag_Underscore_I + and then In_External_Instance + (N => Call, + Target_Decl => Subp_Decl) + then + return; - -- If applicable, suggest the use of pragma Elaborate_Body in the - -- associated package spec. + -- Nothing to do when the call is a guaranteed ABE - Suggest_Elaborate_Body - (N => FNode, - Body_Decl => Body_Decl, - Error_Nod => Typ_Decl); + elsif Is_Known_Guaranteed_ABE (Call) then + return; - raise Stop_Check; + -- 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; - end Check_Overriding_Primitive; - - -------------------------- - -- Freeze_Node_Location -- - -------------------------- - - function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is - Context : constant Node_Id := Parent (FNode); - Loc : constant Source_Ptr := Sloc (FNode); - Prv_Decls : List_Id; - Vis_Decls : List_Id; - - 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. + -- 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. - if Nkind (Context) = N_Package_Specification then - Prv_Decls := Private_Declarations (Context); - Vis_Decls := Visible_Declarations (Context); + 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); - -- The freeze node appears in the private declarations of the - -- package. + -- 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. - if Present (Prv_Decls) - and then List_Containing (FNode) = Prv_Decls - then - null; + New_In_State.Within_Initial_Condition := + New_In_State.Within_Initial_Condition + or else Is_Initial_Condition_Proc (Subp_Id); - -- The freeze node appears in the visible declarations of the - -- package and there are no private declarations. + -- 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 Present (Vis_Decls) - and then List_Containing (FNode) = Vis_Decls - and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) - then - null; + New_In_State.Within_Partial_Finalization := + New_In_State.Within_Partial_Finalization + or else Is_Partial_Finalization_Proc (Subp_Id); - -- Otherwise the freeze node is not in the "last" declarative list - -- of the package. Use the existing source location of the freeze - -- node. + -- 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. - else - return Loc; - end if; + 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); - -- 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. + -- Otherwise the Ada rules are in effect - if not Precedes_Source_Construct (FNode) then - return Sloc (End_Label (Context)); - end if; + 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; - return Loc; - end Freeze_Node_Location; - - ------------------------------- - -- Precedes_Source_Construct -- - ------------------------------- - - function Precedes_Source_Construct (N : Node_Id) return Boolean is - Decl : Node_Id; - - begin - Decl := Next (N); - while Present (Decl) loop - if Comes_From_Source (Decl) then - return True; - - -- A generated body for a source expression function is treated as - -- a source construct. - - 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; + -- Inspect the target body (and barried function) for other suitable + -- elaboration scenarios. - Next (Decl); - end loop; + Traverse_Conditional_ABE_Body + (N => Barrier_Body_Declaration (Subp_Rep), + In_State => New_In_State); - return False; - end Precedes_Source_Construct; + Traverse_Conditional_ABE_Body + (N => Body_Declaration (Subp_Rep), + In_State => New_In_State); + end Process_Conditional_ABE_Call; - ---------------------------- - -- Suggest_Elaborate_Body -- - ---------------------------- + -------------------------------------- + -- Process_Conditional_ABE_Call_Ada -- + -------------------------------------- - procedure Suggest_Elaborate_Body - (N : Node_Id; - Body_Decl : Node_Id; - Error_Nod : Node_Id) + 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 - Unt : constant Node_Id := Unit (Cunit (Main_Unit)); - Region : Node_Id; + 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 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 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. - if Nkind (Unt) = N_Package_Body then - - -- 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 Is_Dispatching_Call (Call_Rep) then + return; - Region := - Find_Early_Call_Region - (Body_Decl => Body_Decl, - Assume_Elab_Body => True, - Skip_Memoization => True); + -- 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 + -- ... - -- 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. + elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then + return; - 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; + -- 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. - -- Local variables + elsif Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + then + if Earlier_In_Extended_Unit (Root, Body_Decl) then - FNode : constant Node_Id := Freeze_Node (Typ); - Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - Prim_Elmt : Elmt_Id; + if New_In_State.Suppress_Warnings then + null; - -- Start of processing for Check_SPARK_Derived_Type + -- Do not emit any ABE diagnostics when the call occurs in a + -- partial finalization context because this leads to confusing + -- noise. - begin - -- A type should have its freeze node set by the time SPARK scenarios - -- are being verified. + elsif New_In_State.Within_Partial_Finalization then + null; - pragma Assert (Present (FNode)); + -- Otherwise emit the ABE diagnostic - -- 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)). + else + Error_Msg_NE + ("??cannot call & before body seen", Call, Subp_Id); + Error_Msg_N + ("\Program_Error may be raised at run time", Call); - if Present (Prims) then - Prim_Elmt := First_Elmt (Prims); - while Present (Prim_Elmt) loop - Check_Overriding_Primitive - (Prim => Node (Prim_Elmt), - FNode => FNode); + Output_Active_Scenarios (Call, New_In_State); + end if; - Next_Elmt (Prim_Elmt); - end loop; - end if; + -- 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 + -- + -- 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; - exception - when Stop_Check => - null; - end Check_SPARK_Derived_Type; + -- 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. - ------------------------------- - -- Check_SPARK_Instantiation -- - ------------------------------- + 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; - 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; + -- 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; - begin - Extract_Instantiation_Attributes - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + ---------------------------------------- + -- Process_Conditional_ABE_Call_SPARK -- + ---------------------------------------- - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + 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); - -- The instantiation and the generic body are both in the main unit + Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); + Region : Node_Id; - if Present (Gen_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) + begin + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - -- If the instantiation appears prior to the generic body, then the - -- instantiation is illegal (SPARK RM 7.7(6)). + Check_SPARK_Model_In_Effect; - -- 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. + -- The call and the target body are both in the main unit - 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; + if Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + and then Earlier_In_Extended_Unit (Call, Body_Decl) + then + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - --------------------------------- - -- Check_SPARK_Model_In_Effect -- - --------------------------------- + if In_State.Suppress_Warnings then + null; - SPARK_Model_Warning_Posted : Boolean := False; - -- This flag prevents the same SPARK model-related warning from being - -- emitted multiple times. + -- Do not emit any ABE diagnostics when the call occurs in an + -- initial condition context because this leads to incorrect + -- diagnostics. - procedure Check_SPARK_Model_In_Effect (N : Node_Id) is - begin - -- Do not emit the warning multiple times as this creates useless noise + elsif In_State.Within_Initial_Condition then + null; - if SPARK_Model_Warning_Posted then - null; + -- Do not emit any ABE diagnostics when the call occurs in a + -- partial finalization context because this leads to confusing + -- noise. - -- SPARK rule verification requires the "strict" static model + elsif In_State.Within_Partial_Finalization then + null; - elsif Static_Elaboration_Checks and not Relaxed_Elaboration_Checks 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. - -- 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. + else + Region := Find_Early_Call_Region (Body_Decl); - else - SPARK_Model_Warning_Posted := True; + 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_N - ("??SPARK elaboration checks require static elaboration model", N); + Error_Msg_Sloc := Sloc (Region); + Error_Msg_N ("\region starts #", Call); - 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; + Error_Msg_Sloc := Sloc (Body_Decl); + Error_Msg_N ("\region ends #", Call); - -------------------------- - -- Check_SPARK_Scenario -- - -------------------------- + Output_Active_Scenarios (Call, In_State); + end if; + end if; + end if; - procedure Check_SPARK_Scenario (N : Node_Id) is - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + -- 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; - Check_SPARK_Model_In_Effect (N); + -- Otherwise ensure that the unit with the target body is elaborated + -- prior to the main unit. - -- Add the current scenario to the stack of active scenarios + 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; - Push_Active_Scenario (N); + ------------------------------------------- + -- Process_Conditional_ABE_Instantiation -- + ------------------------------------------- - if Is_Suitable_SPARK_Derived_Type (N) then - Check_SPARK_Derived_Type (N); + 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); - elsif Is_Suitable_SPARK_Instantiation (N) then - Check_SPARK_Instantiation (N); + SPARK_Rules_On : constant Boolean := + SPARK_Mode_Of (Inst_Rep) = Is_On + and then SPARK_Mode_Of (Gen_Rep) = Is_On; - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Check_SPARK_Refined_State_Pragma (N); - end if; + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state - -- Remove the current scenario from the stack of active scenarios once - -- all ABE diagnostics and checks have been performed. + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - Pop_Active_Scenario (N); - end Check_SPARK_Scenario; + 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; - -------------------------------------- - -- Check_SPARK_Refined_State_Pragma -- - -------------------------------------- + -- Nothing to do when the instantiation is a guaranteed ABE - procedure Check_SPARK_Refined_State_Pragma (N : Node_Id) is + if Is_Known_Guaranteed_ABE (Inst) then + return; - -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are - -- intentionally unnested to avoid deep indentation of code. + -- 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; - 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. + -- 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. - 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. + New_In_State.Suppress_Warnings := + New_In_State.Suppress_Warnings + or else not Elaboration_Warnings_OK (Inst_Rep); - 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. + -- The SPARK rules are in effect - 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. + 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); - ----------------------------- - -- Check_SPARK_Constituent -- - ----------------------------- + -- Otherwise the Ada rules are in effect, or SPARK code is allowed to + -- violate the SPARK rules. - procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is - Prag : 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 + 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 - -- Nothing to do for "null" constituents + -- 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 + -- ... - if Nkind (Constit_Id) = N_Null then + if Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then return; - -- Nothing to do for illegal constituents + -- 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 - elsif Error_Posted (Constit_Id) then - return; - end if; + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - Prag := SPARK_Pragma (Constit_Id); + if New_In_State.Suppress_Warnings then + null; - -- The check applies only when the constituent is subject to pragma - -- SPARK_Mode On. + -- Do not emit any ABE diagnostics when the instantiation + -- occurs in partial finalization context because this leads + -- to unwanted noise. - if Present (Prag) - and then Get_SPARK_Mode_From_Annotation (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. + elsif New_In_State.Within_Partial_Finalization then + null; - -- 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. + -- Otherwise output the diagnostic - if Debug_Flag_Dot_V then - Meet_Elaboration_Requirement - (N => N, - Target_Id => Constit_Id, - Req_Nam => Name_Elaborate); + else + Error_Msg_NE + ("??cannot instantiate & before body seen", Inst, Gen_Id); + Error_Msg_N + ("\Program_Error may be raised at run time", Inst); - -- Otherwise ensure that the unit with the external constituent is - -- elaborated prior to the main unit. + Output_Active_Scenarios (Inst, New_In_State); + end if; - else - Ensure_Prior_Elaboration - (N => N, - Unit_Id => Find_Top_Unit (Constit_Id), - Prag_Nam => Name_Elaborate, - State => Initial_State); + -- 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 + -- + -- 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; - end if; - end Check_SPARK_Constituent; - - ------------------------------ - -- Check_SPARK_Constituents -- - ------------------------------ - procedure Check_SPARK_Constituents (Constits : Elist_Id) is - Constit_Elmt : Elmt_Id; + -- 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. - 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; + 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; - end Check_SPARK_Constituents; - ----------------------------------- - -- Check_SPARK_Initialized_State -- - ----------------------------------- + -- 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); - procedure Check_SPARK_Initialized_State (State : Node_Id) is - Prag : Node_Id; - State_Id : Entity_Id; + Req_Nam : Name_Id; begin - -- Nothing to do for "null" initialization items + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - if Nkind (State) = N_Null then - return; + Check_SPARK_Model_In_Effect; - -- Nothing to do for illegal states + -- 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; - elsif Error_Posted (State) then - return; - end if; + Meet_Elaboration_Requirement + (N => Inst, + Targ_Id => Gen_Id, + Req_Nam => Req_Nam, + In_State => In_State); - State_Id := Entity_Of (State); + -- Otherwise ensure that the unit with the target body is elaborated + -- prior to the main unit. - -- Sanitize the state + else + Ensure_Prior_Elaboration + (N => Inst, + Unit_Id => Unit (Gen_Rep), + Prag_Nam => Name_Elaborate, + In_State => In_State); + end if; + end Process_Conditional_ABE_Instantiation_SPARK; - if No (State_Id) then - return; + ------------------------------------------------- + -- Process_Conditional_ABE_Variable_Assignment -- + ------------------------------------------------- - elsif Error_Posted (State_Id) then - return; + procedure Process_Conditional_ABE_Variable_Assignment + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is - elsif Ekind (State_Id) /= E_Abstract_State then - return; - end if; + Var_Id : constant Entity_Id := Target (Asmt_Rep); + Var_Rep : constant Target_Rep_Id := + Target_Representation_Of (Var_Id, In_State); - -- The check is performed only when the abstract state is subject to - -- SPARK_Mode On. + SPARK_Rules_On : constant Boolean := + SPARK_Mode_Of (Asmt_Rep) = Is_On + and then SPARK_Mode_Of (Var_Rep) = Is_On; - Prag := SPARK_Pragma (State_Id); + 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 In_State.Suppress_Info_Messages then - Check_SPARK_Constituents (Refinement_Constituents (State_Id)); + Elab_Msg_NE + (Msg => "assignment to & during elaboration", + N => Asmt, + Id => Var_Id, + Info_Msg => True, + In_SPARK => SPARK_Rules_On); end if; - end Check_SPARK_Initialized_State; - ------------------------------------ - -- Check_SPARK_Initialized_States -- - ------------------------------------ - - 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; - - begin - if Present (Prag) then - Inits := Expression (Get_Argument (Prag, Pack_Id)); - - -- Avoid processing a "null" initialization list. The only other - -- alternative is an aggregate. + -- 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 Nkind (Inits) = N_Aggregate then + 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); - -- 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; - end if; + -- Otherwise the Ada rules are in effect - -- 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; + 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 Check_SPARK_Initialized_States; + 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); - -- Local variables + Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); + Unit_Id : constant Entity_Id := Unit (Var_Rep); - Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (N); + 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. - -- Start of processing for Check_SPARK_Refined_State_Pragma + 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 + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - begin - -- Pragma Refined_State must be associated with a package body + if not In_State.Suppress_Warnings then + Error_Msg_NE + ("??variable & can be accessed by clients before this " + & "initialization", Asmt, Var_Id); - pragma Assert - (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); + Error_Msg_NE + ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " + & "initialization", Asmt, Unit_Id); - -- Verify that each external contitunent of an abstract state mentioned - -- in pragma Initializes is properly elaborated. + Output_Active_Scenarios (Asmt, In_State); + end if; - Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); - end Check_SPARK_Refined_State_Pragma; + -- Generate an implicit Elaborate_Body in the spec - ---------------------- - -- Compilation_Unit -- - ---------------------- + 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); - function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is - Comp_Unit : Node_Id; + Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); + Unit_Id : constant Entity_Id := Unit (Var_Rep); - begin - Comp_Unit := Parent (Unit_Id); + begin + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - -- Handle the case where a concurrent subunit is rewritten as a null - -- statement due to expansion activities. + Check_SPARK_Model_In_Effect; - 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); + -- Do not emit any ABE diagnostics when a previous scenario in this + -- traversal has suppressed elaboration warnings. - -- Otherwise use the declaration node of the unit + if In_State.Suppress_Warnings then + null; - else - Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); - end if; + -- 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. - -- 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 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); - 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)); + Error_Msg_NE + ("\add pragma ""Elaborate_Body"" to spec & to ensure full " + & "initialization", Asmt, Unit_Id); - -- Handle the case where the compilation unit is a subunit + Output_Active_Scenarios (Asmt, In_State); + end if; + end Process_Conditional_ABE_Variable_Assignment_SPARK; - elsif Nkind (Comp_Unit) = N_Subunit then - Comp_Unit := Parent (Comp_Unit); - end if; + ------------------------------------------------ + -- Process_Conditional_ABE_Variable_Reference -- + ------------------------------------------------ - pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); + 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; - return Comp_Unit; - end Compilation_Unit; + begin + -- Nothing to do when the variable reference is not a read - ----------------------- - -- Early_Call_Region -- - ----------------------- + if not Is_Read_Reference (Ref_Rep) then + return; + end if; - 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; + Var_Rep := Target_Representation_Of (Var_Id, In_State); + Unit_Id := Unit (Var_Rep); - return Early_Call_Regions_No_Element; - end Early_Call_Region; + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - ----------------------------- - -- Early_Call_Regions_Hash -- - ----------------------------- + 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; - 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; + -- Nothing to do when the variable appears within the main unit + -- because diagnostics on reads are relevant only for external + -- variables. - ----------------- - -- Elab_Msg_NE -- - ----------------- + if Is_Same_Unit (Unit_Id, Cunit_Entity (Main_Unit)) then + null; - 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 + -- Nothing to do when the variable is already initialized. Note that + -- the variable may be further modified by the external unit. - function Suffix return String; - -- Obtain the suffix of the message + elsif Is_Initialized (Variable_Declaration (Var_Rep)) then + null; - ------------ - -- Prefix -- - ------------ + -- Nothing to do when the external unit guarantees the initialization + -- of the variable by means of pragma Elaborate_Body. - function Prefix return String is - begin - if Info_Msg then - return "info: "; - else - return ""; - end if; - end Prefix; + elsif Has_Pragma_Elaborate_Body (Unit_Id) then + null; - ------------ - -- Suffix -- - ------------ + -- 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 Suffix return String is - begin - if In_SPARK then - return " in SPARK"; else - return ""; + Meet_Elaboration_Requirement + (N => Ref, + Targ_Id => Var_Id, + Req_Nam => Name_Elaborate, + In_State => In_State); end if; - end Suffix; + end Process_Conditional_ABE_Variable_Reference; - -- Start of processing for Elab_Msg_NE + ----------------------------------- + -- 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 - Error_Msg_NE (Prefix & Msg & Suffix, N, Id); - end Elab_Msg_NE; - - ------------------------ - -- Elaboration_Status -- - ------------------------ + null; + end Destroy; - 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; + ----------------- + -- Diagnostics -- + ----------------- - return Elaboration_Statuses_No_Element; - end Elaboration_Status; + package body Diagnostics is - ------------------------------- - -- Elaboration_Statuses_Hash -- - ------------------------------- + ----------------- + -- Elab_Msg_NE -- + ----------------- - 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; + 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 - ------------------------------ - -- Ensure_Prior_Elaboration -- - ------------------------------ + function Suffix return String; + pragma Inline (Suffix); + -- Obtain the suffix of the message - 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)); + ------------ + -- Prefix -- + ------------ - -- Nothing to do when the caller has suppressed the generation of - -- implicit Elaborate[_All] pragmas. + function Prefix return String is + begin + if Info_Msg then + return "info: "; + else + return ""; + end if; + end Prefix; - if State.Suppress_Implicit_Pragmas then - return; + ------------ + -- Suffix -- + ------------ - -- 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. + function Suffix return String is + begin + if In_SPARK then + return " in SPARK"; + else + return ""; + end if; + end Suffix; - elsif State.Within_Partial_Finalization then - return; + -- Start of processing for Elab_Msg_NE - -- 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. + begin + Error_Msg_NE (Prefix & Msg & Suffix, N, Id); + end Elab_Msg_NE; - elsif Debug_Flag_Dot_Y and then State.Within_Task_Body then - return; + --------------- + -- Info_Call -- + --------------- - -- 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; + 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 - -- Suggest the use of pragma Prag_Nam when the dynamic model is in - -- effect. + procedure Info_Simple_Call; + pragma Inline (Info_Simple_Call); + -- Output information concerning the call - elsif Dynamic_Elaboration_Checks then - Ensure_Prior_Elaboration_Dynamic - (N => N, - Unit_Id => Unit_Id, - Prag_Nam => Prag_Nam); + procedure Info_Type_Actions (Action : String); + pragma Inline (Info_Type_Actions); + -- Output information concerning action Action of a type - -- Install an implicit pragma Prag_Nam when the static model is in - -- effect. + 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. - else - pragma Assert (Static_Elaboration_Checks); + ----------------------------- + -- Info_Accept_Alternative -- + ----------------------------- - Ensure_Prior_Elaboration_Static - (N => N, - Unit_Id => Unit_Id, - Prag_Nam => Prag_Nam); - end if; - end Ensure_Prior_Elaboration; + procedure Info_Accept_Alternative is + Entry_Id : constant Entity_Id := Receiving_Entry (Subp_Id); + pragma Assert (Present (Entry_Id)); - -------------------------------------- - -- Ensure_Prior_Elaboration_Dynamic -- - -------------------------------------- + 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 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. + 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)); - ------------------------- - -- Info_Missing_Pragma -- - ------------------------- + 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 - procedure Info_Missing_Pragma is begin - -- Internal units are ignored as they cause unnecessary noise + -- Do not output anything for targets defined in internal units + -- because this creates noise. - if not In_Internal_Unit (Unit_Id) then + if not In_Internal_Unit (Subp_Id) then - -- The name of the unit subjected to the elaboration pragma is - -- fully qualified to improve the clarity of the info message. + -- Accept alternative - Error_Msg_Name_1 := Prag_Nam; - Error_Msg_Qual_Level := Nat'Last; + if Is_Accept_Alternative_Proc (Subp_Id) then + Info_Accept_Alternative; - Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); - Error_Msg_Qual_Level := 0; - end if; - end Info_Missing_Pragma; + -- Adjustment - -- Local variables + elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then + Info_Type_Actions ("adjustment"); - Elab_Attrs : Elaboration_Attributes; - Level : Enclosing_Level_Kind; + -- Default_Initial_Condition - -- Start of processing for Ensure_Prior_Elaboration_Dynamic + 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"); - begin - Elab_Attrs := Elaboration_Status (Unit_Id); + -- Entries - -- Nothing to do when the unit is guaranteed prior elaboration by means - -- of a source Elaborate[_All] pragma. + elsif Is_Protected_Entry (Subp_Id) then + Info_Simple_Call; - if Present (Elab_Attrs.Source_Pragma) then - return; - end if; + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. - -- Output extra information on a missing Elaborate[_All] pragma when - -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas - -- is in effect. + elsif Is_Task_Entry (Subp_Id) then + null; - if Elab_Info_Messages then + -- Finalization - -- Performance note: parent traversal + elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then + Info_Type_Actions ("finalization"); - Level := Find_Enclosing_Level (N); + -- Calls to _Finalizer procedures must not appear in the output + -- because this creates confusing noise. - -- Declaration-level scenario + elsif Is_Finalizer_Proc (Subp_Id) then + null; - if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) - and then Level = Declaration_Level - then - null; + -- Initial_Condition - -- Library-level scenario + elsif Is_Initial_Condition_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "Initial_Condition", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "package"); - elsif Level in Library_Level then - null; + -- Initialization - -- Instantiation library-level scenario + elsif Is_Init_Proc (Subp_Id) + or else Is_TSS (Subp_Id, TSS_Deep_Initialize) + then + Info_Type_Actions ("initialization"); - elsif Level = Instantiation then - null; + -- Invariant - -- Otherwise the scenario does not appear at the proper level and - -- cannot possibly act as a top-level scenario. + elsif Is_Invariant_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "invariants", + Id => First_Formal_Type (Subp_Id), + Id_Kind => "type"); - else - return; - end if; + -- Partial invariant calls must not appear in the output because + -- this creates confusing noise. - Info_Missing_Pragma; - end if; - end Ensure_Prior_Elaboration_Dynamic; + elsif Is_Partial_Invariant_Proc (Subp_Id) then + null; - ------------------------------------- - -- Ensure_Prior_Elaboration_Static -- - ------------------------------------- + -- _Postconditions - 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. + elsif Is_Postconditions_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "postconditions", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "subprogram"); - ---------------------- - -- Find_With_Clause -- - ---------------------- + -- Subprograms must come last because some of the previous cases + -- fall under this category. - function Find_With_Clause - (Items : List_Id; - Withed_Id : Entity_Id) return Node_Id - is - Item : Node_Id; + elsif Ekind (Subp_Id) = E_Function then + Info_Simple_Call; - begin - -- Examine the context clauses looking for a suitable with. Note that - -- limited clauses do not affect the elaboration order. + elsif Ekind (Subp_Id) = E_Procedure then + Info_Simple_Call; - 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; + else + pragma Assert (False); + return; end if; + end if; + end Info_Call; - Next (Item); - end loop; - - return Empty; - end Find_With_Clause; - - -------------------------- - -- Info_Implicit_Pragma -- - -------------------------- + ------------------------ + -- Info_Instantiation -- + ------------------------ - procedure Info_Implicit_Pragma is + procedure Info_Instantiation + (Inst : Node_Id; + Gen_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is begin - -- Internal units are ignored as they cause unnecessary noise + Elab_Msg_NE + (Msg => "instantiation of & during elaboration", + N => Inst, + Id => Gen_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Instantiation; - if not In_Internal_Unit (Unit_Id) then + ----------------------------- + -- Info_Variable_Reference -- + ----------------------------- - -- The name of the unit subjected to the elaboration pragma is - -- fully qualified to improve the clarity of the info message. + 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; + end Diagnostics; - Error_Msg_Name_1 := Prag_Nam; - Error_Msg_Qual_Level := Nat'Last; + --------------------------------- + -- Early_Call_Region_Processor -- + --------------------------------- - Error_Msg_NE - ("info: implicit pragma % generated for unit &", N, Unit_Id); + package body Early_Call_Region_Processor is - Error_Msg_Qual_Level := 0; - Output_Active_Scenarios (N); - end if; - end Info_Implicit_Pragma; + --------------------- + -- Data structures -- + --------------------- - -- Local variables + -- The following map relates early call regions to subprogram bodies - 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 Destroy (N : in out Node_Id); + -- Destroy node N - Clause : Node_Id; - Elab_Attrs : Elaboration_Attributes; - Items : List_Id; + 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); - -- Start of processing for Ensure_Prior_Elaboration_Static + Early_Call_Regions_Map : ECR_Map.Dynamic_Hash_Table := ECR_Map.Nil; - begin - Elab_Attrs := Elaboration_Status (Unit_Id); + ----------------------- + -- Local subprograms -- + ----------------------- - -- Nothing to do when the unit is guaranteed prior elaboration by means - -- of a source Elaborate[_All] pragma. + 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. - if Present (Elab_Attrs.Source_Pragma) then - return; + 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. - -- Nothing to do when the unit has an existing implicit Elaborate[_All] - -- pragma installed by a previous scenario. + ------------- + -- Destroy -- + ------------- - elsif Present (Elab_Attrs.With_Clause) then + procedure Destroy (N : in out Node_Id) is + pragma Unreferenced (N); + begin + null; + end Destroy; - -- 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. + ----------------------- + -- Early_Call_Region -- + ----------------------- - if Elaborate_Desirable (Elab_Attrs.With_Clause) - and then Prag_Nam = Name_Elaborate_All - then - Set_Elaborate_All_Desirable (Elab_Attrs.With_Clause); - Set_Elaborate_Desirable (Elab_Attrs.With_Clause, False); - end if; + function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is + pragma Assert (Present (Body_Id)); + begin + return ECR_Map.Get (Early_Call_Regions_Map, Body_Id); + end Early_Call_Region; - return; - end if; + ------------------------------------------ + -- Finalize_Early_Call_Region_Processor -- + ------------------------------------------ - -- At this point it is known that the unit has no prior elaboration - -- according to pragmas and hierarchical relationships. + procedure Finalize_Early_Call_Region_Processor is + begin + ECR_Map.Destroy (Early_Call_Regions_Map); + end Finalize_Early_Call_Region_Processor; - Items := Context_Items (Main_Cunit); + ---------------------------- + -- Find_Early_Call_Region -- + ---------------------------- - if No (Items) then - Items := New_List; - Set_Context_Items (Main_Cunit, Items); - 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 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: + -- + -- + -- ... + -- <- Curr + -- <- Start + -- + -- + -- 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) + -- <- Curr (2.2) + -- begin + -- <- Curr (2.1) + -- end Nested; + -- <- 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) + -- <- Curr (2.2) + -- private + -- <- Curr (2.1) + -- end Nested; + -- <- 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) + -- <- Curr (4.1) + -- begin + -- <- 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) + -- <- 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) + -- <- Curr (6.2) + -- private + -- <- 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; - -- 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. + 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. - Clause := - Find_With_Clause - (Items => Items, - Withed_Id => Unit_Id); + -- The current construct is an encapsulator or is preelaborable - -- Generate: - -- with Id; + if Present (Curr) then - -- 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. + -- Enter encapsulators by inspecting their declarations and/or + -- statements. - if No (Clause) then - Clause := - Make_With_Clause (Loc, - Name => New_Occurrence_Of (Unit_Id, Loc)); + if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then + Enter_Handled_Body (Curr); - Set_Implicit_With (Clause); - Set_Library_Unit (Clause, Unit_Cunit); + elsif Nkind (Curr) = N_Package_Declaration then + Enter_Package_Declaration (Curr); - Append_To (Items, Clause); - end if; + -- Early call regions have a property which can be exploited to + -- optimize the algorithm. + -- + -- + -- + -- ... + -- + -- + -- + -- 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. - -- Mark the with clause depending on the pragma required + 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); - if Prag_Nam = Name_Elaborate then - Set_Elaborate_Desirable (Clause); - else - Set_Elaborate_All_Desirable (Clause); - end if; + raise ECR_Found; - -- The implicit Elaborate[_All] ensures the prior elaboration of the - -- unit. Include the unit in the elaboration context of the main unit. + -- Otherwise current construct is preelaborable. Unpdate the + -- early call region to include it. - Set_Elaboration_Status - (Unit_Id => Unit_Id, - Val => Elaboration_Attributes'(Source_Pragma => Empty, - With_Clause => Clause)); + else + Include (Curr, Curr); + end if; - -- Output extra information on an implicit Elaborate[_All] pragma when - -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is - -- in effect. + -- 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. - if Elab_Info_Messages then - Info_Implicit_Pragma; - end if; - end Ensure_Prior_Elaboration_Static; + 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. - ----------------------------- - -- Extract_Assignment_Name -- - ----------------------------- + Context := Parent (Start); - function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is - Nam : Node_Id; + -- 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); - begin - Nam := Name (Asmt); + -- Attempt the following transitions: + -- + -- statements -> declarations + -- statements -> upper level + -- statements -> corresponding package spec (Elab_Body) + -- statements -> terminate - -- When the name denotes an array or record component, find the whole - -- object. + elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then + Transition_Handled_Statements (Context, Curr); - while Nkind_In (Nam, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) - loop - Nam := Prefix (Nam); - end loop; + -- 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); - return Nam; - end Extract_Assignment_Name; + -- Otherwise it is not possible to transition. Stop the search + -- because there are no more declarations or statements to + -- check. - ----------------------------- - -- Extract_Call_Attributes -- - ----------------------------- + else + raise ECR_Found; + end if; + end if; + end Advance; - 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; + -------------------------- + -- Enter_Handled_Body -- + -------------------------- - begin - -- Extraction for call markers + 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; - 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); + begin + if Present (HSS) then + Stmts := Statements (HSS); + end if; - -- Extraction for entry calls, requeue, and subprogram calls + -- The handled body has a non-empty statement sequence. The + -- construct to inspect is the last statement. - else - pragma Assert (Nkind_In (Call, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement, - N_Requeue_Statement)); + if Has_Suitable_Construct (Stmts) then + Curr := Last (Stmts); - Target_Id := Entity (Extract_Call_Name (Call)); - From_Source := Comes_From_Source (Call); + -- The handled body lacks statements, but has non-empty + -- declarations. The construct to inspect is the last declaration. - -- Performance note: parent traversal + elsif Has_Suitable_Construct (Decls) then + Curr := Last (Decls); - 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; + -- 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. - -- 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. + else + Include (Curr, Curr); + end if; + end Enter_Handled_Body; - if not (Is_Subprogram (Target_Id) - and then Is_Generic_Instance (Target_Id)) - then - Target_Id := Get_Renamed_Entity (Target_Id); - end if; + ------------------------------- + -- Enter_Package_Declaration -- + ------------------------------- - -- Set all attributes + 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); - 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; + begin + -- The package has a non-empty private declarations. The construct + -- to inspect is the last private declaration. - ----------------------- - -- Extract_Call_Name -- - ----------------------- + if Has_Suitable_Construct (Prv_Decls) then + Curr := Last (Prv_Decls); - function Extract_Call_Name (Call : Node_Id) return Node_Id is - Nam : Node_Id; + -- The package lacks private declarations, but has non-empty + -- visible declarations. In this case the construct to inspect + -- is the last visible declaration. - begin - Nam := Name (Call); + elsif Has_Suitable_Construct (Vis_Decls) then + Curr := Last (Vis_Decls); - -- When the call invokes an entry family, the name appears as an indexed - -- component. + -- 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. - if Nkind (Nam) = N_Indexed_Component then - Nam := Prefix (Nam); - end if; + else + Include (Curr, Curr); + end if; + end Enter_Package_Declaration; - -- When the call employs the object.operation form, the name appears as - -- a selected component. + -------------- + -- Find_ECR -- + -------------- - if Nkind (Nam) = N_Selected_Component then - Nam := Selector_Name (Nam); - end if; + function Find_ECR (N : Node_Id) return Node_Id is + Curr : Node_Id; - return Nam; - end Extract_Call_Name; + begin + -- The early call region starts at N - --------------------------------- - -- Extract_Instance_Attributes -- - --------------------------------- + Curr := Prev (N); + Start := N; - procedure Extract_Instance_Attributes - (Exp_Inst : Node_Id; - Inst_Body : out Node_Id; - Inst_Decl : out Node_Id) - is - Body_Id : Entity_Id; + -- 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. - begin - -- Assume that the attributes are unavailable + loop + -- The current construct is not preelaboration-safe. Terminate + -- the traversal. - Inst_Body := Empty; - Inst_Decl := Empty; + if Present (Curr) + and then not Is_OK_Preelaborable_Construct (Curr) + then + raise ECR_Found; + end if; - -- Generic package or subprogram spec + -- Advance to the next suitable construct. This may terminate + -- the traversal by raising ECR_Found. - if Nkind_In (Exp_Inst, N_Package_Declaration, - N_Subprogram_Declaration) - then - Inst_Decl := Exp_Inst; - Body_Id := Corresponding_Body (Inst_Decl); + Advance (Curr); + end loop; - if Present (Body_Id) then - Inst_Body := Unit_Declaration_Node (Body_Id); - end if; + exception + when ECR_Found => + return Start; + end Find_ECR; - -- Generic package or subprogram body + ---------------------------- + -- Has_Suitable_Construct -- + ---------------------------- - else - pragma Assert - (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body)); + function Has_Suitable_Construct (List : List_Id) return Boolean is + Item : Node_Id; - Inst_Body := Exp_Inst; - Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body)); - end if; - end Extract_Instance_Attributes; + 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; - -------------------------------------- - -- Extract_Instantiation_Attributes -- - -------------------------------------- + Prev (Item); + end loop; + end if; - 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); + return False; + end Has_Suitable_Construct; - -- Traverse a possible chain of renamings to obtain the original generic - -- being instantiatied. + ------------- + -- Include -- + ------------- - Gen_Id := Get_Renamed_Entity (Entity (Name (Inst))); + procedure Include (N : Node_Id; Curr : out Node_Id) is + begin + Start := N; - -- Set all attributes + -- 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 - 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; + if Nkind (Parent (Start)) = N_Compilation_Unit then + raise ECR_Found; - ------------------------------- - -- Extract_Target_Attributes -- - ------------------------------- + -- Otherwise the input node is still within some list - 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; + else + Curr := Prev (Start); + end if; + end Include; - begin - -- Assume that the body is not available + ----------------------------------- + -- Is_OK_Preelaborable_Construct -- + ----------------------------------- - Body_Decl := Empty; - Spec_Id := Target_Id; + 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. - -- For body retrieval purposes, the entity of the initial declaration - -- is that of the spec. + if Nkind (N) = N_Assignment_Statement then + return Is_Elaboration_Code (N); - Init_Id := Spec_Id; + -- 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. - -- 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 Nkind (N) = N_Block_Statement then + return True; + end if; - if Ekind (Init_Id) = E_Function - and then Rewritten_For_C (Init_Id) - then - Init_Id := Corresponding_Procedure (Init_Id); - end if; + -- 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. - -- Extract the attributes of the body + return not Is_Non_Preelaborable_Construct (N); + end Is_OK_Preelaborable_Construct; - Spec_Decl := Unit_Declaration_Node (Init_Id); + --------------------------- + -- Is_Suitable_Construct -- + --------------------------- - -- The initial declaration is a stand alone subprogram body + function Is_Suitable_Construct (N : Node_Id) return Boolean is + Context : constant Node_Id := Parent (N); - if Nkind (Spec_Decl) = N_Subprogram_Body then - Body_Decl := Spec_Decl; + 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; - -- Otherwise the package or subprogram has a spec and a completing - -- body. + -- 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; - 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); + when others => + return True; + end case; + end Is_Suitable_Construct; - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; - end if; - end Extract_Package_Or_Subprogram_Attributes; + ---------------------------------- + -- Transition_Body_Declarations -- + ---------------------------------- - ---------------------------------------- - -- Extract_Protected_Entry_Attributes -- - ---------------------------------------- + procedure Transition_Body_Declarations + (Bod : Node_Id; + Curr : out Node_Id) + is + Decls : constant List_Id := Declarations (Bod); - procedure Extract_Protected_Entry_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id; - Body_Barf : out Node_Id) - is - Barf_Id : Entity_Id; - Body_Id : Entity_Id; + begin + -- The search must come from the declarations of the body - begin - -- Assume that the bodies are not available + pragma Assert + (Is_Non_Empty_List (Decls) + and then List_Containing (Start) = Decls); - Body_Barf := Empty; - Body_Decl := Empty; + -- 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 - -- 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. + Transition_Unit (Bod, Curr); + end Transition_Body_Declarations; - if Present (Protected_Body_Subprogram (Target_Id)) then - Spec_Id := Protected_Body_Subprogram (Target_Id); + ----------------------------------- + -- Transition_Handled_Statements -- + ----------------------------------- - -- Extract the attributes of the barrier function + 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); - Barf_Id := - Corresponding_Body - (Unit_Declaration_Node (Barrier_Function (Target_Id))); + begin + -- The search must come from the statements of certain bodies or + -- statements. - if Present (Barf_Id) then - Body_Barf := Unit_Declaration_Node (Barf_Id); - end if; + pragma Assert (Nkind_In (Bod, N_Block_Statement, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body)); - -- Otherwise no expansion took place + -- The search must come from the statements of the handled + -- sequence. - else - Spec_Id := Target_Id; - end if; + pragma Assert + (Is_Non_Empty_List (Stmts) + and then List_Containing (Start) = Stmts); - -- Extract the attributes of the entry body + -- The search finished inspecting the statements. The handled body + -- has non-empty declarations. The construct to inspect is the + -- last declaration. The transitions are: + -- + -- statements -> declarations - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + if Has_Suitable_Construct (Decls) then + Curr := Last (Decls); - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; - end Extract_Protected_Entry_Attributes; + -- 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 - --------------------------------------------- - -- Extract_Protected_Subprogram_Attributes -- - --------------------------------------------- + else + Transition_Unit (Bod, Curr); + end if; + end Transition_Handled_Statements; - procedure Extract_Protected_Subprogram_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id) - is - Body_Id : Entity_Id; + ---------------------------------- + -- Transition_Spec_Declarations -- + ---------------------------------- - begin - -- Assume that the body is not available + 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); - Body_Decl := Empty; + begin + pragma Assert (Present (Start) and then Is_List_Member (Start)); - -- When the protected subprogram has already been expanded, it - -- carries the subprogram which seizes the lock and invokes the - -- original statements. + -- The search came from the private declarations and finished + -- their inspection. - if Present (Protected_Subprogram (Target_Id)) then - Spec_Id := - Protected_Body_Subprogram (Protected_Subprogram (Target_Id)); + 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 - -- Otherwise no expansion took place + if Has_Suitable_Construct (Vis_Decls) then + Curr := Last (Vis_Decls); - else - Spec_Id := Target_Id; - end if; + -- 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 - -- Extract the attributes of the body + else + Transition_Unit (Parent (Spec), Curr); + end if; - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + -- 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 - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; - end Extract_Protected_Subprogram_Attributes; + elsif Has_Suitable_Construct (Vis_Decls) + and then List_Containing (Start) = Vis_Decls + then + Transition_Unit (Parent (Spec), Curr); - ----------------------------------- - -- Extract_Task_Entry_Attributes -- - ----------------------------------- + -- 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. - 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; + else + pragma Assert (False); + raise ECR_Found; + end if; + end Transition_Spec_Declarations; - begin - -- Assume that the body is not available + --------------------- + -- Transition_Unit -- + --------------------- - Body_Decl := Empty; + procedure Transition_Unit + (Unit : Node_Id; + Curr : out Node_Id) + is + Context : constant Node_Id := Parent (Unit); - -- The the task type has already been expanded, it carries the - -- procedure which emulates the behavior of the task body. + 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 Present (Task_Body_Procedure (Task_Typ)) then - Spec_Id := Task_Body_Procedure (Task_Typ); + if Nkind (Context) = N_Compilation_Unit then - -- Otherwise no expansion took place + -- 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) - else - Spec_Id := Task_Typ; - end if; + 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); - -- Extract the attributes of the body + -- Otherwise terminate the search. The transitions are: + -- + -- private declarations -> terminate + -- visible declarations -> terminate + -- statements -> terminate + -- declarations -> terminate - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + else + raise ECR_Found; + end if; - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; - end Extract_Task_Entry_Attributes; + -- 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. - -- Local variables + elsif Nkind (Context) = N_Subunit then + Start := Unit; + Curr := Corresponding_Stub (Context); - Prag : constant Node_Id := SPARK_Pragma (Target_Id); - Body_Barf : Node_Id; - Body_Decl : Node_Id; - Spec_Id : Entity_Id; + -- 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. - -- Start of processing for Extract_Target_Attributes + else + Include (Unit, Curr); + end if; + end Transition_Unit; - begin - -- Assume that the body of the barrier function is not available + -- Local variables - Body_Barf := Empty; + Body_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl); + Region : Node_Id; - -- The target is a protected entry [family] + -- Start of processing for Find_Early_Call_Region - if Is_Protected_Entry (Target_Id) then - Extract_Protected_Entry_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl, - Body_Barf => Body_Barf); + begin + -- The caller demands the start of the early call region without + -- saving or retrieving it to/from internal data structures. - -- The target is a protected subprogram + if Skip_Memoization then + Region := Find_ECR (Body_Decl); - 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); + -- Default behavior - -- The target is a task entry [family] + else + -- Check whether the early call region of the subprogram body is + -- available. - elsif Is_Task_Entry (Target_Id) then - Extract_Task_Entry_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl); + Region := Early_Call_Region (Body_Id); - -- Otherwise the target is a package or a subprogram + if No (Region) then + Region := Find_ECR (Body_Decl); - else - Extract_Package_Or_Subprogram_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl); - end if; + -- Associate the early call region with the subprogram body in + -- case other scenarios need it. - -- Set all attributes + Set_Early_Call_Region (Body_Id, Region); + end if; + end if; - 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); + -- A subprogram body must always have an early call region - -- At this point certain attributes should always be available + pragma Assert (Present (Region)); - pragma Assert (Present (Attrs.Spec_Decl)); - pragma Assert (Present (Attrs.Spec_Id)); - pragma Assert (Present (Attrs.Unit_Id)); - end Extract_Target_Attributes; + return Region; + end Find_Early_Call_Region; - ----------------------------- - -- Extract_Task_Attributes -- - ----------------------------- + -------------------------------------------- + -- Initialize_Early_Call_Region_Processor -- + -------------------------------------------- - procedure Extract_Task_Attributes - (Typ : Entity_Id; - Attrs : out Task_Attributes) - is - Task_Typ : constant Entity_Id := Non_Private_View (Typ); + procedure Initialize_Early_Call_Region_Processor is + begin + Early_Call_Regions_Map := ECR_Map.Create (100); + end Initialize_Early_Call_Region_Processor; - Body_Decl : Node_Id; - Body_Id : Entity_Id; - Prag : Node_Id; - Spec_Id : Entity_Id; + --------------------------- + -- Set_Early_Call_Region -- + --------------------------- - begin - -- Assume that the body of the task procedure is not available + procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is + pragma Assert (Present (Body_Id)); + pragma Assert (Present (Start)); - Body_Decl := Empty; + begin + ECR_Map.Put (Early_Call_Regions_Map, Body_Id, Start); + end Set_Early_Call_Region; + end Early_Call_Region_Processor; - -- The initial declaration is that of the task body procedure + ---------------------- + -- Elaborated_Units -- + ---------------------- - Spec_Id := Get_Task_Body_Procedure (Task_Typ); - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + package body Elaborated_Units is - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; + ----------- + -- Types -- + ----------- - Prag := SPARK_Pragma (Task_Typ); + -- The following type idenfities the elaboration attributes of a unit - -- Set all attributes + type Elaboration_Attributes_Id is new Natural; - 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); + No_Elaboration_Attributes : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Id'First; + First_Elaboration_Attributes : constant Elaboration_Attributes_Id := + No_Elaboration_Attributes + 1; - -- At this point certain attributes should always be available + -- The following type represents the elaboration attributes of a unit - pragma Assert (Present (Attrs.Spec_Id)); - pragma Assert (Present (Attrs.Task_Decl)); - pragma Assert (Present (Attrs.Unit_Id)); - end Extract_Task_Attributes; + 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. - ------------------------------------------- - -- Extract_Variable_Reference_Attributes -- - ------------------------------------------- + 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; - 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 + --------------------- + -- Data structures -- + --------------------- - -------------------------- - -- Get_Renamed_Variable -- - -------------------------- + -- 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. - function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is - Ren_Id : Entity_Id; + Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := + UA_Map.Create (250); - 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; + ------------------ + -- Constructors -- + ------------------ - return Ren_Id; - end Get_Renamed_Variable; + 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 - -- Start of processing for Extract_Variable_Reference_Attributes + ----------------------- + -- Local subprograms -- + ----------------------- - begin - -- Extraction for variable reference markers + 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. - if Nkind (Ref) = N_Variable_Reference_Marker then - Var_Id := Target (Ref); + ------------------------------ + -- Collect_Elaborated_Units -- + ------------------------------ - -- Extraction for expanded names and identifiers + 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; - else - Var_Id := Entity (Ref); - end if; + begin + -- Nothing to do if the pragma is not related to elaboration - -- Obtain the original variable which the reference mentions + if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then + return; - Var_Id := Get_Renamed_Variable (Var_Id); - Attrs.Unit_Id := Find_Top_Unit (Var_Id); + -- Nothing to do when the pragma is illegal - -- At this point certain attributes should always be available + elsif Error_Posted (Prag) then + return; + end if; - pragma Assert (Present (Attrs.Unit_Id)); - end Extract_Variable_Reference_Attributes; + Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); - -------------------- - -- Find_Code_Unit -- - -------------------- + -- The argument of the pragma may appear in package.package form - 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; + if Nkind (Unit_Arg) = N_Selected_Component then + Unit_Arg := Selector_Name (Unit_Arg); + end if; - ---------------------------- - -- Find_Early_Call_Region -- - ---------------------------- + Add_Unit + (Unit_Id => Entity (Unit_Arg), + Prag => Prag, + Full_Context => Prag_Nam = Name_Elaborate_All); + end Add_Pragma; - 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: - -- - -- - -- ... - -- <- Curr - -- <- Start - -- - -- - -- 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) - -- <- Curr (2.2) - -- begin - -- <- Curr (2.1) - -- end Nested; - -- <- 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) - -- <- Curr (2.2) - -- private - -- <- Curr (2.1) - -- end Nested; - -- <- 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) - -- <- Curr (4.1) - -- begin - -- <- 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) - -- <- 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) - -- <- Curr (6.2) - -- private - -- <- 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. + -------------- + -- Add_Unit -- + -------------- - ------------- - -- Advance -- - ------------- + 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; - procedure Advance (Curr : in out Node_Id) is - Context : Node_Id; + begin + -- Nothing to do when some previous error left a with clause or a + -- pragma in a bad state. - 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. + if No (Unit_Id) then + return; + end if; - -- The current construct is an encapsulator or is preelaborable + EA_Id := Elaboration_Attributes_Of (Unit_Id); + Unit_Prag := Elab_Pragma (EA_Id); - if Present (Curr) then + -- The unit is already included in the context by means of pragma + -- Elaborate[_All]. - -- Enter encapsulators by inspecting their declarations and/or - -- statements. + if Present (Unit_Prag) then - if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then - Enter_Handled_Body (Curr); + -- Upgrade an existing pragma Elaborate when the unit is + -- subject to Elaborate_All because the new pragma covers a + -- larger set of units. - elsif Nkind (Curr) = N_Package_Declaration then - Enter_Package_Declaration (Curr); + if Pragma_Name (Unit_Prag) = Name_Elaborate + and then Pragma_Name (Prag) = Name_Elaborate_All + then + Set_Elab_Pragma (EA_Id, Prag); - -- Early call regions have a property which can be exploited to - -- optimize the algorithm. - -- - -- - -- - -- ... - -- - -- - -- - -- 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. - - 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); + -- Otherwise the unit retains its existing pragma and does not + -- need to be included in the context again. - raise ECR_Found; + else + return; + end if; - -- Otherwise current construct is preelaborable. Unpdate the early - -- call region to include it. + -- Otherwise the current unit is not included in the context else - Include (Curr, Curr); + Set_Elab_Pragma (EA_Id, Prag); 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. + -- Includes all units withed by the current one when computing the + -- full context. - 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. + if Full_Context then - Context := Parent (Start); + -- Process all nonlimited with clauses found in the context of + -- the current unit. Note that limited clauses do not impose an + -- elaboration order. - -- Attempt the following transitions: - -- - -- private declarations -> visible declarations - -- private declarations -> upper level - -- private declarations -> terminate - -- visible declarations -> upper level - -- visible declarations -> terminate + 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; - if Nkind_In (Context, N_Package_Specification, - N_Protected_Definition, - N_Task_Definition) - then - Transition_Spec_Declarations (Context, Curr); + Next (Clause); + end loop; + end if; + end Add_Unit; - -- Attempt the following transitions: - -- - -- statements -> declarations - -- statements -> upper level - -- statements -> corresponding package spec (Elab_Body) - -- statements -> terminate + ------------------------------ + -- Find_Elaboration_Context -- + ------------------------------ - elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then - Transition_Handled_Statements (Context, Curr); + procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is + pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); - -- Attempt the following transitions: - -- - -- declarations -> upper level - -- declarations -> corresponding package spec (Elab_Body) - -- declarations -> terminate + Prag : Node_Id; - 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 + -- Process all elaboration-related pragmas found in the context of + -- the compilation unit. - -- Otherwise it is not possible to transition. Stop the search - -- because there are no more declarations or statements to check. + Prag := First (Context_Items (Comp_Unit)); + while Present (Prag) loop + if Nkind (Prag) = N_Pragma then + Add_Pragma (Prag); + end if; - else - raise ECR_Found; - end if; - end if; - end Advance; + Next (Prag); + end loop; + end Find_Elaboration_Context; - -------------------------- - -- Enter_Handled_Body -- - -------------------------- + -- Local variables + + Par_Id : Entity_Id; + Unit_Id : Node_Id; - 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; + -- Start of processing for Collect_Elaborated_Units begin - if Present (HSS) then - Stmts := Statements (HSS); - end if; + -- Perform a traversal to examines the context of the main unit. The + -- traversal performs the following jumps: + -- + -- subunit -> parent subunit + -- parent subunit -> body + -- body -> spec + -- spec -> parent spec + -- parent spec -> grandparent spec and so on + -- + -- 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. - -- The handled body has a non-empty statement sequence. The construct - -- to inspect is the last statement. + Unit_Id := Unit (Cunit (Main_Unit)); - if Has_Suitable_Construct (Stmts) then - Curr := Last (Stmts); + -- Perform the following traversals when the main unit is a subunit + -- + -- subunit -> parent subunit + -- parent subunit -> body - -- The handled body lacks statements, but has non-empty declarations. - -- The construct to inspect is the last declaration. + while Present (Unit_Id) and then Nkind (Unit_Id) = N_Subunit loop + Find_Elaboration_Context (Parent (Unit_Id)); - elsif Has_Suitable_Construct (Decls) then - Curr := Last (Decls); + -- Continue the traversal by going to the unit which contains the + -- corresponding stub. - -- 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. + if Present (Corresponding_Stub (Unit_Id)) then + Unit_Id := + Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unit_Id)))); - else - Include (Curr, Curr); - end if; - end Enter_Handled_Body; + -- Otherwise the subunit may be erroneous or left in a bad state - ------------------------------- - -- Enter_Package_Declaration -- - ------------------------------- + else + exit; + end if; + end loop; - 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); + -- Perform the following traversal now that subunits have been taken + -- care of, or the main unit is a body. + -- + -- body -> spec - begin - -- The package has a non-empty private declarations. The construct to - -- inspect is the last private declaration. + if Present (Unit_Id) + and then Nkind_In (Unit_Id, N_Package_Body, N_Subprogram_Body) + then + Find_Elaboration_Context (Parent (Unit_Id)); + + -- Continue the traversal by going to the unit which contains the + -- corresponding spec. - if Has_Suitable_Construct (Prv_Decls) then - Curr := Last (Prv_Decls); + if Present (Corresponding_Spec (Unit_Id)) then + Unit_Id := + Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unit_Id)))); + end if; + end if; - -- The package lacks private declarations, but has non-empty visible - -- declarations. In this case the construct to inspect is the last - -- visible declaration. + -- 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)); - elsif Has_Suitable_Construct (Vis_Decls) then - Curr := Last (Vis_Decls); + -- Process a potential chain of parent units which ends with the + -- main unit spec. The traversal can now safely rely on the scope + -- chain. - -- 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. + 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)); - else - Include (Curr, Curr); + Par_Id := Scope (Par_Id); + end loop; end if; - end Enter_Package_Declaration; - - -------------- - -- Find_ECR -- - -------------- + end Collect_Elaborated_Units; - function Find_ECR (N : Node_Id) return Node_Id is - Curr : Node_Id; + ------------- + -- Destroy -- + ------------- + procedure Destroy (EA_Id : in out Elaboration_Attributes_Id) is + pragma Unreferenced (EA_Id); begin - -- The early call region starts at N - - Curr := Prev (N); - Start := N; + null; + end Destroy; - -- 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. + ----------------- + -- Elab_Pragma -- + ----------------- - loop - -- The current construct is not preelaboration-safe. Terminate the - -- traversal. + function Elab_Pragma + (EA_Id : Elaboration_Attributes_Id) return Node_Id + is + pragma Assert (Present (EA_Id)); + begin + return Elaboration_Attributes.Table (EA_Id).Elab_Pragma; + end Elab_Pragma; - if Present (Curr) - and then not Is_OK_Preelaborable_Construct (Curr) - then - raise ECR_Found; - end if; + ------------------------------- + -- Elaboration_Attributes_Of -- + ------------------------------- - -- Advance to the next suitable construct. This may terminate the - -- traversal by raising ECR_Found. + function Elaboration_Attributes_Of + (Unit_Id : Entity_Id) return Elaboration_Attributes_Id + is + EA_Id : Elaboration_Attributes_Id; - Advance (Curr); - end loop; + begin + EA_Id := UA_Map.Get (Unit_To_Attributes_Map, Unit_Id); - exception - when ECR_Found => - return Start; - end Find_ECR; + -- The unit lacks elaboration attributes. This indicates that the + -- unit is encountered for the first time. Create the elaboration + -- attributes for it. - ---------------------------- - -- Has_Suitable_Construct -- - ---------------------------- + if not Present (EA_Id) then + Elaboration_Attributes.Append + ((Elab_Pragma => Empty, + With_Clause => Empty)); + EA_Id := Elaboration_Attributes.Last; - function Has_Suitable_Construct (List : List_Id) return Boolean is - Item : Node_Id; + -- Associate the elaboration attributes with the unit - begin - -- Examine the list in reverse declarative order, looking for a - -- suitable construct. + UA_Map.Put (Unit_To_Attributes_Map, Unit_Id, EA_Id); + end if; - if Present (List) then - Item := Last (List); - while Present (Item) loop - if Is_Suitable_Construct (Item) then - return True; - end if; + pragma Assert (Present (EA_Id)); - Prev (Item); - end loop; - end if; + return EA_Id; + end Elaboration_Attributes_Of; - return False; - end Has_Suitable_Construct; + ------------------------------ + -- Ensure_Prior_Elaboration -- + ------------------------------ - ------------- - -- Include -- - ------------- + procedure Ensure_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State) + is + pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); - procedure Include (N : Node_Id; Curr : out Node_Id) is begin - Start := N; + -- 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 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 + if In_State.Within_Partial_Finalization then + return; - if Nkind (Parent (Start)) = N_Compilation_Unit then - raise ECR_Found; + -- 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 input node is still within some list + elsif Debug_Flag_Dot_Y and then In_State.Within_Task_Body then + return; - else - Curr := Prev (Start); + -- 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; + -- + -- 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; - end Include; - ----------------------------------- - -- Is_OK_Preelaborable_Construct -- - ----------------------------------- + -- Suggest the use of pragma Prag_Nam when the dynamic model is in + -- effect. - 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. + if Dynamic_Elaboration_Checks then + Ensure_Prior_Elaboration_Dynamic + (N => N, + Unit_Id => Unit_Id, + Prag_Nam => Prag_Nam, + In_State => In_State); - if Nkind (N) = N_Assignment_Statement then - return Is_Elaboration_Code (N); + -- Install an implicit pragma Prag_Nam when the static model is in + -- effect. - -- 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. + else + pragma Assert (Static_Elaboration_Checks); - elsif Nkind (N) = N_Block_Statement then - return True; + Ensure_Prior_Elaboration_Static + (N => N, + Unit_Id => Unit_Id, + Prag_Nam => Prag_Nam, + In_State => In_State); end if; + end Ensure_Prior_Elaboration; - -- 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. + -------------------------------------- + -- Ensure_Prior_Elaboration_Dynamic -- + -------------------------------------- - return not Is_Non_Preelaborable_Construct (N); - end Is_OK_Preelaborable_Construct; + procedure Ensure_Prior_Elaboration_Dynamic + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State) + 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. - --------------------------- - -- Is_Suitable_Construct -- - --------------------------- + ------------------------- + -- Info_Missing_Pragma -- + ------------------------- - function Is_Suitable_Construct (N : Node_Id) return Boolean is - Context : constant Node_Id := Parent (N); + procedure Info_Missing_Pragma is + begin + -- Internal units are ignored as they cause unnecessary noise - 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 not In_Internal_Unit (Unit_Id) then - 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; + -- The name of the unit subjected to the elaboration pragma is + -- fully qualified to improve the clarity of the info message. - -- Otherwise only constructs which correspond to pure Ada constructs - -- are considered suitable. + Error_Msg_Name_1 := Prag_Nam; + Error_Msg_Qual_Level := Nat'Last; - 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; + Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); + Error_Msg_Qual_Level := 0; + end if; + end Info_Missing_Pragma; - when others => - return True; - end case; - end Is_Suitable_Construct; + -- Local variables - ---------------------------------- - -- Transition_Body_Declarations -- - ---------------------------------- + EA_Id : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Of (Unit_Id); + N_Lvl : Enclosing_Level_Kind; + N_Rep : Scenario_Rep_Id; - procedure Transition_Body_Declarations - (Bod : Node_Id; - Curr : out Node_Id) - is - Decls : constant List_Id := Declarations (Bod); + -- Start of processing for Ensure_Prior_Elaboration_Dynamic begin - -- The search must come from the declarations of the body + -- Nothing to do when the unit is guaranteed prior elaboration by + -- means of a source Elaborate[_All] pragma. - 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: - -- - -- declarations -> upper level - -- declarations -> corresponding package spec (Elab_Body) - -- declarations -> terminate + if Present (Elab_Pragma (EA_Id)) then + return; + end if; - Transition_Unit (Bod, Curr); - end Transition_Body_Declarations; + -- Output extra information on a missing Elaborate[_All] pragma when + -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas + -- is in effect. - ----------------------------------- - -- Transition_Handled_Statements -- - ----------------------------------- + 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); - 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); + -- Declaration-level scenario - begin - -- The search must come from the statements of certain bodies or - -- statements. + if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) + and then N_Lvl = Declaration_Level + then + null; - pragma Assert (Nkind_In (Bod, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body)); + -- Library-level scenario - -- The search must come from the statements of the handled sequence + elsif N_Lvl in Library_Level then + null; - pragma Assert - (Is_Non_Empty_List (Stmts) - and then List_Containing (Start) = Stmts); + -- Instantiation library-level scenario - -- The search finished inspecting the statements. The handled body - -- has non-empty declarations. The construct to inspect is the last - -- declaration. The transitions are: - -- - -- statements -> declarations + elsif N_Lvl = Instantiation_Level then + null; - if Has_Suitable_Construct (Decls) then - Curr := Last (Decls); + -- Otherwise the scenario does not appear at the proper level - -- 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 + else + return; + end if; - else - Transition_Unit (Bod, Curr); + Info_Missing_Pragma; end if; - end Transition_Handled_Statements; + end Ensure_Prior_Elaboration_Dynamic; - ---------------------------------- - -- Transition_Spec_Declarations -- - ---------------------------------- + ------------------------------------- + -- Ensure_Prior_Elaboration_Static -- + ------------------------------------- - procedure Transition_Spec_Declarations - (Spec : Node_Id; - Curr : out Node_Id) + procedure Ensure_Prior_Elaboration_Static + (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); + 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; - begin - pragma Assert (Present (Start) and then Is_List_Member (Start)); + begin + -- Examine the context clauses looking for a suitable with. Note + -- that limited clauses do not affect the elaboration order. - -- The search came from the private declarations and finished their - -- inspection. + 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; - 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 + Next (Item); + end loop; - if Has_Suitable_Construct (Vis_Decls) then - Curr := Last (Vis_Decls); + return Empty; + end Find_With_Clause; - -- 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 + -------------------------- + -- Info_Implicit_Pragma -- + -------------------------- - else - Transition_Unit (Parent (Spec), Curr); - end if; + procedure Info_Implicit_Pragma is + begin + -- Internal units are ignored as they cause unnecessary noise - -- 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 + if not In_Internal_Unit (Unit_Id) then - elsif Has_Suitable_Construct (Vis_Decls) - and then List_Containing (Start) = Vis_Decls - then - Transition_Unit (Parent (Spec), Curr); + -- The name of the unit subjected to the elaboration pragma is + -- fully qualified to improve the clarity of the info message. - -- 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. + Error_Msg_Name_1 := Prag_Nam; + Error_Msg_Qual_Level := Nat'Last; - else - pragma Assert (False); - raise ECR_Found; - end if; - end Transition_Spec_Declarations; + Error_Msg_NE + ("info: implicit pragma % generated for unit &", N, Unit_Id); - --------------------- - -- Transition_Unit -- - --------------------- + Error_Msg_Qual_Level := 0; + Output_Active_Scenarios (N, In_State); + end if; + end Info_Implicit_Pragma; - procedure Transition_Unit - (Unit : Node_Id; - Curr : out Node_Id) - is - Context : constant Node_Id := Parent (Unit); + -- Local variables + + EA_Id : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Of (Unit_Id); + + 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); + + Clause : Node_Id; + Items : List_Id; + + -- Start of processing for Ensure_Prior_Elaboration_Static 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. + -- Nothing to do when the caller has suppressed the generation of + -- implicit Elaborate[_All] pragmas. - if Nkind (Context) = N_Compilation_Unit then + if In_State.Suppress_Implicit_Pragmas then + return; - -- 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) + -- Nothing to do when the unit is guaranteed prior elaboration by + -- means of a source Elaborate[_All] pragma. - 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 Present (Unit_Prag) then + return; - -- Otherwise terminate the search. The transitions are: - -- - -- private declarations -> terminate - -- visible declarations -> terminate - -- statements -> terminate - -- declarations -> terminate + -- Nothing to do when the unit has an existing implicit Elaborate or + -- Elaborate_All pragma installed by a previous scenario. - else - raise ECR_Found; + elsif Present (Unit_With) then + + -- 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. + + 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; - -- 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. + return; + end if; - elsif Nkind (Context) = N_Subunit then - Start := Unit; - Curr := Corresponding_Stub (Context); + -- At this point it is known that the unit has no prior elaboration + -- according to pragmas and hierarchical relationships. - -- 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. + Items := Context_Items (Main_Cunit); - else - Include (Unit, Curr); + if No (Items) then + Items := New_List; + Set_Context_Items (Main_Cunit, Items); end if; - end Transition_Unit; - -- Local variables + -- 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. - Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); - Region : Node_Id; + Clause := + Find_With_Clause + (Items => Items, + Withed_Id => Unit_Id); - -- Start of processing for Find_Early_Call_Region + -- Generate: + -- with Id; - begin - -- The caller demands the start of the early call region without saving - -- or retrieving it to/from internal data structures. + -- 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 Skip_Memoization then - Region := Find_ECR (Body_Decl); + if No (Clause) then + Clause := + Make_With_Clause (Loc, + Name => New_Occurrence_Of (Unit_Id, Loc)); - -- Default behavior + Set_Implicit_With (Clause); + Set_Library_Unit (Clause, Unit_Cunit); - else - -- Check whether the early call region of the subprogram body is - -- available. + Append_To (Items, Clause); + end if; - Region := Early_Call_Region (Body_Id); + -- Mark the with clause depending on the pragma required - if No (Region) then + if Prag_Nam = Name_Elaborate then + Set_Elaborate_Desirable (Clause); + else + Set_Elaborate_All_Desirable (Clause); + end if; - -- 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. + -- The implicit Elaborate[_All] ensures the prior elaboration of + -- the unit. Include the unit in the elaboration context of the + -- main unit. - Region := Find_ECR (Body_Decl); + Set_With_Clause (EA_Id, Clause); - -- Associate the early call region with the subprogram body in - -- case other scenarios need it. + -- Output extra information on an implicit Elaborate[_All] pragma + -- when switch -gnatel (info messages on implicit Elaborate[_All] + -- pragmas is in effect. - Set_Early_Call_Region (Body_Id, Region); + if Elab_Info_Messages then + Info_Implicit_Pragma; end if; - end if; + end Ensure_Prior_Elaboration_Static; - -- A subprogram body must always have an early call region - - pragma Assert (Present (Region)); - - return Region; - end Find_Early_Call_Region; + ------------------------------- + -- Finalize_Elaborated_Units -- + ------------------------------- - --------------------------- - -- Find_Elaborated_Units -- - --------------------------- + procedure Finalize_Elaborated_Units is + begin + UA_Map.Destroy (Unit_To_Attributes_Map); + end Finalize_Elaborated_Units; - 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. + --------------------------- + -- Has_Prior_Elaboration -- + --------------------------- - procedure Add_Unit + function Has_Prior_Elaboration (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. + Context_OK : Boolean := False; + Elab_Body_OK : Boolean := False; + Same_Unit_OK : Boolean := False) return Boolean + is + EA_Id : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Of (Unit_Id); - 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. + 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); - ---------------- - -- Add_Pragma -- - ---------------- + begin + -- A preelaborated unit is always elaborated prior to the main unit - 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; + if Is_Preelaborated_Unit (Unit_Id) then + return True; - begin - -- Nothing to do if the pragma is not related to elaboration + -- An internal unit is always elaborated prior to a non-internal main + -- unit. - if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then - return; + elsif In_Internal_Unit (Unit_Id) + and then not In_Internal_Unit (Main_Id) + then + return True; - -- Nothing to do when the pragma is illegal + -- 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 Error_Posted (Prag) then - return; - end if; + elsif Context_OK + and then (Present (Unit_Prag) or else Present (Unit_With)) + then + return True; - Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); + -- 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; - -- The argument of the pragma may appear in package.package form + -- 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. - if Nkind (Unit_Arg) = N_Selected_Component then - Unit_Arg := Selector_Name (Unit_Arg); + elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then + return True; end if; - Add_Unit - (Unit_Id => Entity (Unit_Arg), - Prag => Prag, - Full_Context => Prag_Nam = Name_Elaborate_All); - end Add_Pragma; + return False; + end Has_Prior_Elaboration; - -------------- - -- Add_Unit -- - -------------- + --------------------------------- + -- Initialize_Elaborated_Units -- + --------------------------------- - procedure Add_Unit - (Unit_Id : Entity_Id; - Prag : Node_Id; - Full_Context : Boolean) + procedure Initialize_Elaborated_Units is + begin + null; + end Initialize_Elaborated_Units; + + ---------------------------------- + -- Meet_Elaboration_Requirement -- + ---------------------------------- + + procedure Meet_Elaboration_Requirement + (N : Node_Id; + Targ_Id : Entity_Id; + Req_Nam : Name_Id; + In_State : Processing_In_State) is - Clause : Node_Id; - Elab_Attrs : Elaboration_Attributes; + pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); - begin - -- Nothing to do when some previous error left a with clause or a - -- pragma in a bad state. + Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id); - if No (Unit_Id) then - return; - end if; + procedure Elaboration_Requirement_Error; + pragma Inline (Elaboration_Requirement_Error); + -- Emit an error concerning scenario N which has failed to meet the + -- elaboration requirement. - Elab_Attrs := Elaboration_Status (Unit_Id); + 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. - -- The unit is already included in the context by means of pragma - -- Elaborate[_All]. + procedure Info_Requirement_Met (Prag : Node_Id); + pragma Inline (Info_Requirement_Met); + -- Output information concerning pragma Prag which meets requirement + -- Req_Nam. - if Present (Elab_Attrs.Source_Pragma) then + ----------------------------------- + -- Elaboration_Requirement_Error -- + ----------------------------------- - -- Upgrade an existing pragma Elaborate when the unit is subject - -- to Elaborate_All because the new pragma covers a larger set of - -- units. + 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); - if Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate - and then Pragma_Name (Prag) = Name_Elaborate_All - then - Elab_Attrs.Source_Pragma := Prag; + elsif Is_Suitable_Variable_Reference (N) then + Info_Variable_Reference + (Ref => N, + Var_Id => Targ_Id, + Info_Msg => False, + In_SPARK => True); - -- Otherwise the unit retains its existing pragma and does not - -- need to be included in the context again. + -- 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; + + -------------------------------- + -- Find_Preelaboration_Pragma -- + -------------------------------- + + function Find_Preelaboration_Pragma + (Prag_Nam : Name_Id) return Node_Id + 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. + + 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; + + -- Otherwise the construct terminates the region where + -- the preelaboration-related pragma may appear. - -- Add or update the attributes of the unit + else + exit; + end if; + end if; - Set_Elaboration_Status (Unit_Id, Elab_Attrs); + Next (Decl); + end loop; + end if; - -- Includes all units withed by the current one when computing the - -- full context. + return Empty; + end Find_Preelaboration_Pragma; - if Full_Context then + -------------------------- + -- Info_Requirement_Met -- + -------------------------- - -- Process all nonlimited with clauses found in the context of - -- the current unit. Note that limited clauses do not impose an - -- elaboration order. + procedure Info_Requirement_Met (Prag : Node_Id) is + pragma Assert (Present (Prag)); - 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; + 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; - Next (Clause); - end loop; - end if; - end Add_Unit; + -- Local variables - ------------------------------ - -- Find_Elaboration_Context -- - ------------------------------ + EA_Id : Elaboration_Attributes_Id; + Elab_Nam : Name_Id; + Req_Met : Boolean; + Unit_Prag : Node_Id; - procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is - 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); + + -- The pragma must be either Elaborate_All or be as strong as the + -- requirement. - -- Perform the following traversal now that subunits have been taken - -- care of, or the main unit is a body. + if Present (Unit_Prag) + and then Nam_In (Pragma_Name (Unit_Prag), Name_Elaborate_All, + Req_Nam) + then + Req_Met := True; - -- body -> spec + -- Output extra information when switch -gnatel (info messages + -- on implicit Elaborate[_All] pragmas. - if Present (Unt) - and then Nkind_In (Unt, N_Package_Body, N_Subprogram_Body) - then - Find_Elaboration_Context (Parent (Unt)); + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + Info_Requirement_Met (Unit_Prag); + end if; + end if; + end if; - -- Continue the traversal by going to the unit which contains the - -- corresponding spec. + -- 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; + + ------------- + -- Present -- + ------------- - -- Perform the following traversals now that the body has been taken - -- care of, or the main unit is a spec. + function Present (EA_Id : Elaboration_Attributes_Id) return Boolean is + begin + return EA_Id /= No_Elaboration_Attributes; + end Present; - -- spec -> parent spec - -- parent spec -> grandparent spec and so on + --------------------- + -- Set_Elab_Pragma -- + --------------------- - 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)); + 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; + + --------------------- + -- Set_With_Clause -- + --------------------- - -- 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_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; - Par_Id := Scope (Defining_Entity (Unt)); - while Present (Par_Id) and then Par_Id /= Standard_Standard loop - Find_Elaboration_Context (Compilation_Unit (Par_Id)); + ----------------- + -- With_Clause -- + ----------------- - Par_Id := Scope (Par_Id); - end loop; - end if; - end Find_Elaborated_Units; + 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); @@ -5525,71 +9019,600 @@ package body Sem_Elab is Context : constant Node_Id := Parent (N); Orig_N : constant Node_Id := Original_Node (N); - begin - -- The unit denotes a package body of an instantiation which acts as - -- a compilation unit. The proper entity is that of the package spec. + begin + -- The unit denotes a package body of an instantiation which acts as + -- a compilation unit. The proper entity is that of the package spec. + + if Nkind (N) = N_Package_Body + and then Nkind (Orig_N) = N_Package_Instantiation + and then Nkind (Context) = N_Compilation_Unit + then + return Corresponding_Spec (N); + + -- The unit denotes an anonymous package created to wrap a subprogram + -- instantiation which acts as a compilation unit. The proper entity is + -- that of the "related instance". + + elsif Nkind (N) = N_Package_Declaration + and then Nkind_In (Orig_N, N_Function_Instantiation, + N_Procedure_Instantiation) + and then Nkind (Context) = N_Compilation_Unit + then + return + Related_Instance (Defining_Entity (N, Concurrent_Subunit => True)); + + -- Otherwise the proper entity is the defining entity + + else + return Defining_Entity (N, Concurrent_Subunit => True); + end if; + end Find_Unit_Entity; + + ----------------------- + -- First_Formal_Type -- + ----------------------- + + function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is + Formal_Id : constant Entity_Id := First_Formal (Subp_Id); + Typ : Entity_Id; + + begin + if Present (Formal_Id) then + Typ := Etype (Formal_Id); + + -- Handle various combinations of concurrent and private types + + loop + if Ekind_In (Typ, E_Protected_Type, E_Task_Type) + and then Present (Anonymous_Object (Typ)) + then + Typ := Anonymous_Object (Typ); + + elsif Is_Concurrent_Record_Type (Typ) then + Typ := Corresponding_Concurrent_Type (Typ); + + elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Typ := Full_View (Typ); + + else + exit; + end if; + end loop; + + return Typ; + end if; + + 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 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; + -- -- 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; - if Nkind (N) = N_Package_Body - and then Nkind (Orig_N) = N_Package_Instantiation - and then Nkind (Context) = N_Compilation_Unit - then - return Corresponding_Spec (N); + -- 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; + -- ... - -- The unit denotes an anonymous package created to wrap a subprogram - -- instantiation which acts as a compilation unit. The proper entity is - -- that of the "related instance". + 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; - elsif Nkind (N) = N_Package_Declaration - and then Nkind_In (Orig_N, N_Function_Instantiation, - N_Procedure_Instantiation) - and then Nkind (Context) = N_Compilation_Unit - then - return - Related_Instance (Defining_Entity (N, Concurrent_Subunit => True)); + -- Mark the call as a guarnateed ABE - -- Otherwise the proper entity is the defining entity + Set_Is_Known_Guaranteed_ABE (Call); - else - return Defining_Entity (N, Concurrent_Subunit => True); - end if; - end Find_Unit_Entity; + -- Install a run-time ABE failure because the call will always + -- result in an ABE. - ----------------------- - -- First_Formal_Type -- - ----------------------- + 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; - function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is - Formal_Id : constant Entity_Id := First_Formal (Subp_Id); - Typ : Entity_Id; + ------------------------------------------ + -- Process_Guaranteed_ABE_Instantiation -- + ------------------------------------------ - begin - if Present (Formal_Id) then - Typ := Etype (Formal_Id); + 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. - -- Handle various combinations of concurrent and private types + 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; - loop - if Ekind_In (Typ, E_Protected_Type, E_Task_Type) - and then Present (Anonymous_Object (Typ)) - then - Typ := Anonymous_Object (Typ); + -- 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_Concurrent_Record_Type (Typ) then - Typ := Corresponding_Concurrent_Type (Typ); + elsif Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then + return; - elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - Typ := Full_View (Typ); + -- 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; + -- ... - else - exit; + 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; - end loop; - return Typ; - end if; + -- Mark the instantiation as a guarantee ABE. This automatically + -- suppresses the instantiation of the generic body. - return Empty; - end First_Formal_Type; + 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 -- @@ -5597,16 +9620,19 @@ package body Sem_Elab is 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. @@ -6012,5195 +9990,5660 @@ package body Sem_Elab is -- level encapsulator indicates that N is at the library level in -- which case the compilation unit is the context. - elsif Nkind (Par) = N_Compilation_Unit then - return Par; - end if; + elsif Nkind (Par) = N_Compilation_Unit then + return Par; + end if; + + Par := Parent (Par); + end loop; + + return Empty; + end Find_Enclosing_Context; + + ----------------------- + -- In_Nested_Context -- + ----------------------- + + function In_Nested_Context + (Outer : Node_Id; + Inner : Node_Id) return Boolean + is + Par : Node_Id; + + begin + Par := Inner; + while Present (Par) loop + + -- A traversal from a subunit continues via the corresponding stub + + if Nkind (Par) = N_Subunit then + Par := Corresponding_Stub (Par); + + elsif Par = Outer then + return True; + end if; + + Par := Parent (Par); + end loop; + + return False; + end In_Nested_Context; + + -- Local variables + + Context_1 : constant Node_Id := Find_Enclosing_Context (N1); + Context_2 : constant Node_Id := Find_Enclosing_Context (N2); + + -- Start of processing for In_Same_Context + + begin + -- Both nodes appear within the same context + + if Context_1 = Context_2 then + return True; + + -- Both nodes appear in compilation units. Determine whether one unit + -- is the body of the other. + + elsif Nkind (Context_1) = N_Compilation_Unit + and then Nkind (Context_2) = N_Compilation_Unit + then + return + Is_Same_Unit + (Unit_1 => Defining_Entity (Unit (Context_1)), + Unit_2 => Defining_Entity (Unit (Context_2))); + + -- The context of N1 encloses the context of N2 + + elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then + return True; + end if; + + return False; + end In_Same_Context; + + ---------------- + -- Initialize -- + ---------------- + + 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 + -- Traverse a possible chain of renamings to obtain the original generic + -- being instantiatied. + + return Get_Renamed_Entity (Entity (Name (Inst))); + end Instantiated_Generic; + + ----------------------------- + -- Internal_Representation -- + ----------------------------- + + package body Internal_Representation is + + ----------- + -- Types -- + ----------- + + -- The following type represents the contents of a scenario + + type Scenario_Rep_Record is record + Elab_Checks_OK : Boolean := False; + -- The status of elaboration checks for the scenario + + Elab_Warnings_OK : Boolean := False; + -- The status of elaboration warnings for the scenario + + GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; + -- The Ghost mode of the scenario + + Kind : Scenario_Kind := No_Scenario; + -- The nature of the scenario + + Level : Enclosing_Level_Kind := No_Level; + -- The enclosing level where the scenario resides + + SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; + -- The SPARK mode of the scenario + + Target : Entity_Id := Empty; + -- The target of the scenario + + -- 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) + + Flag_1 : Boolean := False; + Field_1 : Node_Or_Entity_Id := Empty; + List_1 : NE_List.Doubly_Linked_List := NE_List.Nil; + end record; + + -- The following type represents the contents of a target + + type Target_Rep_Record is record + Body_Decl : Node_Id := Empty; + -- The declaration of the target body + + Elab_Checks_OK : Boolean := False; + -- The status of elaboration checks for the target + + Elab_Warnings_OK : Boolean := False; + -- The status of elaboration warnings for the target + + GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; + -- The Ghost mode of the target + + Kind : Target_Kind := No_Target; + -- The nature of the target + + SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; + -- The SPARK mode of the target + + Spec_Decl : Node_Id := Empty; + -- The declaration of the target spec + + Unit : Entity_Id := Empty; + -- The top unit where the target is declared + + Version : Representation_Kind := No_Representation; + -- The version of the target representation + + -- 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) + + Field_1 : Node_Or_Entity_Id := Empty; + end record; + + --------------------- + -- Data structures -- + --------------------- - Par := Parent (Par); - end loop; + 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"); - return Empty; - end Find_Enclosing_Context; + -------------- + -- Builders -- + -------------- + + 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 ----------------------- - -- In_Nested_Context -- + -- Local subprograms -- ----------------------- - function In_Nested_Context - (Outer : Node_Id; - Inner : Node_Id) return Boolean - is - Par : Node_Id; + 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 - begin - Par := Inner; - while Present (Par) loop + 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 - -- A traversal from a subunit continues via the corresponding stub + function Present (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Present); + -- Determine whether scenario representation S_Id exists - if Nkind (Par) = N_Subunit then - Par := Corresponding_Stub (Par); + function Present (T_Id : Target_Rep_Id) return Boolean; + pragma Inline (Present); + -- Determine whether target representation T_Id exists - elsif Par = Outer then - return True; - end if; + 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 - Par := Parent (Par); - end loop; + 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 - return False; - end In_Nested_Context; + 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. - -- Local variables + 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. - Context_1 : constant Node_Id := Find_Enclosing_Context (N1); - Context_2 : constant Node_Id := Find_Enclosing_Context (N2); + function Version (T_Id : Target_Rep_Id) return Representation_Kind; + pragma Inline (Version); + -- Obtain the version of target representation T_Id - -- Start of processing for In_Same_Context + ---------------------------- + -- Activated_Task_Objects -- + ---------------------------- - begin - -- Both nodes appear within the same context + 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); - if Context_1 = Context_2 then - return True; + begin + return Scenario_Reps.Table (S_Id).List_1; + end Activated_Task_Objects; - -- Both nodes appear in compilation units. Determine whether one unit - -- is the body of the other. + ------------------------- + -- Activated_Task_Type -- + ------------------------- - elsif Nkind (Context_1) = N_Compilation_Unit - and then Nkind (Context_2) = N_Compilation_Unit - then - return - Is_Same_Unit - (Unit_1 => Defining_Entity (Unit (Context_1)), - Unit_2 => Defining_Entity (Unit (Context_2))); + 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); - -- The context of N1 encloses the context of N2 + begin + return Scenario_Reps.Table (S_Id).Field_1; + end Activated_Task_Type; - elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then - return True; - end if; + ------------------------------ + -- Barrier_Body_Declaration -- + ------------------------------ - return False; - end In_Same_Context; + 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); - ------------------ - -- In_Task_Body -- - ------------------ + begin + return Target_Reps.Table (T_Id).Field_1; + end Barrier_Body_Declaration; - function In_Task_Body (N : Node_Id) return Boolean is - Par : Node_Id; + ---------------------- + -- Body_Declaration -- + ---------------------- - begin - -- Climb the parent chain looking for a task body [procedure] + 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; - Par := N; - while Present (Par) loop - if Nkind (Par) = N_Task_Body then - return True; + ----------------------------- + -- Create_Access_Taken_Rep -- + ----------------------------- - elsif Nkind (Par) = N_Subprogram_Body - and then Is_Task_Body_Procedure (Par) - then - return True; + function Create_Access_Taken_Rep + (Attr : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; - -- Prevent the search from going too far. Note that this predicate - -- shares nodes with the two cases above, and must come last. + 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))); - elsif Is_Body_Or_Package_Declaration (Par) then - return False; - end if; + return Rec; + end Create_Access_Taken_Rep; - Par := Parent (Par); - end loop; + ---------------------------------------- + -- Create_Call_Or_Task_Activation_Rep -- + ---------------------------------------- - return False; - end In_Task_Body; + 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; - ---------------- - -- Initialize -- - ---------------- + begin + if Is_Activation_Proc (Subp_Id) then + Kind := Task_Activation_Scenario; + else + Kind := Call_Scenario; + end if; - 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. + 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; - Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); - end Initialize; + -- Scenario-specific attributes - --------------- - -- Info_Call -- - --------------- + Rec.Flag_1 := Is_Dispatching_Call (Call); -- Dispatching_Call - 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. + return Rec; + end Create_Call_Or_Task_Activation_Rep; ----------------------------- - -- Info_Accept_Alternative -- + -- Create_Derived_Type_Rep -- ----------------------------- - procedure Info_Accept_Alternative is - Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); + 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; + + 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; begin - pragma Assert (Present (Entry_Id)); + Rec.Kind := Generic_Target; - 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; + Spec_And_Body_From_Entity + (Id => Gen_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - ---------------------- - -- Info_Simple_Call -- - ---------------------- + return Rec; + end Create_Generic_Rep; + + ------------------------------ + -- Create_Instantiation_Rep -- + ------------------------------ + + function Create_Instantiation_Rep + (Inst : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; - 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; + 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); - ----------------------- - -- Info_Type_Actions -- - ----------------------- + return Rec; + end Create_Instantiation_Rep; + + -------------------------------- + -- Create_Protected_Entry_Rep -- + -------------------------------- + + function Create_Protected_Entry_Rep + (PE_Id : Entity_Id) return Target_Rep_Record + is + Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PE_Id); - procedure Info_Type_Actions (Action : String) is - Typ : constant Entity_Id := First_Formal_Type (Target_Id); + Barf_Id : Entity_Id; + Dummy : Node_Id; + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; begin - pragma Assert (Present (Typ)); + -- 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. - 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; + if Present (Prot_Id) then + Barf_Id := Barrier_Function (PE_Id); + Spec_Id := Prot_Id; - ---------------------------- - -- Info_Verification_Call -- - ---------------------------- + -- Otherwise no expansion took place + + else + Barf_Id := Empty; + Spec_Id := PE_Id; + end if; + + Rec.Kind := Subprogram_Target; + + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); + + -- Target-specific attributes - procedure Info_Verification_Call - (Pred : String; - Id : Entity_Id; - Id_Kind : String) + 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; + + return Rec; + end Create_Protected_Entry_Rep; + + ------------------------------------- + -- Create_Protected_Subprogram_Rep -- + ------------------------------------- + + 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; + begin - pragma Assert (Present (Id)); + -- When the protected subprogram has already been expanded, it + -- carries the subprogram which seizes the lock and invokes the + -- original statements. - 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; + if Present (Prot_Id) then + Spec_Id := Prot_Id; - -- Start of processing for Info_Call + -- Otherwise no expansion took place - begin - -- Do not output anything for targets defined in internal units because - -- this creates noise. + else + Spec_Id := PS_Id; + end if; - if not In_Internal_Unit (Target_Id) then + Rec.Kind := Subprogram_Target; - -- Accept alternative + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - if Is_Accept_Alternative_Proc (Target_Id) then - Info_Accept_Alternative; + return Rec; + end Create_Protected_Subprogram_Rep; - -- Adjustment + ------------------------------------- + -- Create_Refined_State_Pragma_Rep -- + ------------------------------------- - elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then - Info_Type_Actions ("adjustment"); + function Create_Refined_State_Pragma_Rep + (Prag : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; - -- Default_Initial_Condition + begin + 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; - 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"); + return Rec; + end Create_Refined_State_Pragma_Rep; - -- Entries + ------------------------- + -- Create_Scenario_Rep -- + ------------------------- - elsif Is_Protected_Entry (Target_Id) then - Info_Simple_Call; + function Create_Scenario_Rep + (N : Node_Id; + In_State : Processing_In_State) return Scenario_Rep_Record + is + pragma Unreferenced (In_State); - -- Task entry calls are never processed because the entry being - -- invoked does not have a corresponding "body", it has a select. + Rec : Scenario_Rep_Record; - elsif Is_Task_Entry (Target_Id) then - null; + begin + if Is_Suitable_Access_Taken (N) then + Rec := Create_Access_Taken_Rep (N); - -- Finalization + elsif Is_Suitable_Call (N) then + Rec := Create_Call_Or_Task_Activation_Rep (N); - elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then - Info_Type_Actions ("finalization"); + elsif Is_Suitable_Instantiation (N) then + Rec := Create_Instantiation_Rep (N); - -- Calls to _Finalizer procedures must not appear in the output - -- because this creates confusing noise. + elsif Is_Suitable_SPARK_Derived_Type (N) then + Rec := Create_Derived_Type_Rep (N); - elsif Is_Finalizer_Proc (Target_Id) then - null; + elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then + Rec := Create_Refined_State_Pragma_Rep (N); - -- Initial_Condition + elsif Is_Suitable_Variable_Assignment (N) then + Rec := Create_Variable_Assignment_Rep (N); - elsif Is_Initial_Condition_Proc (Target_Id) then - Info_Verification_Call - (Pred => "Initial_Condition", - Id => Find_Enclosing_Scope (Call), - Id_Kind => "package"); + elsif Is_Suitable_Variable_Reference (N) then + Rec := Create_Variable_Reference_Rep (N); - -- Initialization + else + pragma Assert (False); + return Rec; + end if; + + -- Common scenario attributes + + Rec.Level := Find_Enclosing_Level (N); - elsif Is_Init_Proc (Target_Id) - or else Is_TSS (Target_Id, TSS_Deep_Initialize) + return Rec; + end Create_Scenario_Rep; + + --------------------------- + -- Create_Subprogram_Rep -- + --------------------------- + + function Create_Subprogram_Rep + (Subp_Id : Entity_Id) return Target_Rep_Record + is + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; + + begin + Spec_Id := Subp_Id; + + -- 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. + + if Ekind (Spec_Id) = E_Function + and then Rewritten_For_C (Spec_Id) then - Info_Type_Actions ("initialization"); + Spec_Id := Corresponding_Procedure (Spec_Id); + end if; - -- Invariant + Rec.Kind := Subprogram_Target; - elsif Is_Invariant_Proc (Target_Id) then - Info_Verification_Call - (Pred => "invariants", - Id => First_Formal_Type (Target_Id), - Id_Kind => "type"); + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - -- Partial invariant calls must not appear in the output because this - -- creates confusing noise. + return Rec; + end Create_Subprogram_Rep; - elsif Is_Partial_Invariant_Proc (Target_Id) then - null; + ----------------------- + -- Create_Target_Rep -- + ----------------------- - -- _Postconditions + function Create_Target_Rep + (Id : Entity_Id; + In_State : Processing_In_State) return Target_Rep_Record + is + Rec : Target_Rep_Record; - elsif Is_Postconditions_Proc (Target_Id) then - Info_Verification_Call - (Pred => "postconditions", - Id => Find_Enclosing_Scope (Call), - Id_Kind => "subprogram"); + begin + if Is_Generic_Unit (Id) then + Rec := Create_Generic_Rep (Id); - -- Subprograms must come last because some of the previous cases fall - -- under this category. + elsif Is_Protected_Entry (Id) then + Rec := Create_Protected_Entry_Rep (Id); + + elsif Is_Protected_Subp (Id) then + Rec := Create_Protected_Subprogram_Rep (Id); + + elsif Is_Task_Entry (Id) then + Rec := Create_Task_Entry_Rep (Id); - elsif Ekind (Target_Id) = E_Function then - Info_Simple_Call; + elsif Is_Task_Type (Id) then + Rec := Create_Task_Rep (Id); - elsif Ekind (Target_Id) = E_Procedure then - Info_Simple_Call; + elsif Ekind_In (Id, E_Constant, E_Variable) then + Rec := Create_Variable_Rep (Id); + + elsif Ekind_In (Id, E_Entry, + E_Function, + E_Operator, + E_Procedure) + then + Rec := Create_Subprogram_Rep (Id); else pragma Assert (False); - null; + return Rec; end if; - end if; - end Info_Call; - ------------------------ - -- Info_Instantiation -- - ------------------------ + -- Common target attributes - 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; + 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; - ----------------------------- - -- Info_Variable_Reference -- - ----------------------------- + return Rec; + end Create_Target_Rep; - 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; + --------------------------- + -- Create_Task_Entry_Rep -- + --------------------------- - -------------------- - -- Insertion_Node -- - -------------------- + 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); - 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. + 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. + + if Present (Task_Body_Id) then + Spec_Id := Task_Body_Id; + + -- Otherwise no expansion took place + + else + Spec_Id := TE_Id; + end if; - if Nkind (N) in N_Generic_Instantiation - and then Present (Instance_Spec (N)) - then - return Instance_Spec (N); + Rec.Kind := Subprogram_Target; - -- Otherwise the proper insertion node is the candidate insertion node + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - else - return Ins_Nod; - end if; - end Insertion_Node; + return Rec; + end Create_Task_Entry_Rep; - ----------------------- - -- Install_ABE_Check -- - ----------------------- + --------------------- + -- Create_Task_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 + function Create_Task_Rep + (Task_Typ : Entity_Id) return Target_Rep_Record + is + Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); - 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; + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; - begin - -- Nothing to do when compiling for GNATprove because raise statements - -- are not supported. + begin + -- The the task type has already been expanded, it carries the + -- procedure which emulates the behavior of the task body. - if GNATprove_Mode then - return; + if Present (Task_Body_Id) then + Spec_Id := Task_Body_Id; - -- Nothing to do when the compilation will not produce an executable + -- Otherwise no expansion took place - elsif Serious_Errors_Detected > 0 then - return; + else + Spec_Id := Task_Typ; + end if; - -- Nothing to do for a compilation unit because there is no executable - -- environment at that level. + Rec.Kind := Task_Target; - elsif Nkind (Parent (Check_Ins_Nod)) = N_Compilation_Unit then - return; + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - -- Nothing to do when the unit is elaborated prior to the main unit. - -- This check must also consider the following cases: + return Rec; + end Create_Task_Rep; - -- * Id's unit appears in the context of the main unit + ------------------------------------ + -- Create_Variable_Assignment_Rep -- + ------------------------------------ - -- * 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. + 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; - -- * 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). + 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; - elsif Has_Prior_Elaboration - (Unit_Id => Unit_Id, - Context_OK => True, - Elab_Body_OK => True) - then - return; - end if; + return Rec; + end Create_Variable_Assignment_Rep; - -- Prevent multiple scenarios from installing the same ABE check + ----------------------------------- + -- Create_Variable_Reference_Rep -- + ----------------------------------- - Set_Is_Elaboration_Checks_OK_Node (N, False); + function Create_Variable_Reference_Rep + (Ref : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; - -- Install the nearest enclosing scope of the scenario as there must be - -- something on the scope stack. + 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); - -- Performance note: parent traversal + -- Scenario-specific attributes - Scop_Id := Find_Enclosing_Scope (Check_Ins_Nod); - pragma Assert (Present (Scop_Id)); + Rec.Flag_1 := Is_Read (Ref); -- Is_Read_Reference - Push_Scope (Scop_Id); + return Rec; + end Create_Variable_Reference_Rep; - -- Generate: - -- if not Spec_Id'Elaborated then - -- raise Program_Error with "access before elaboration"; - -- end if; + ------------------------- + -- Create_Variable_Rep -- + ------------------------- - 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)); + function Create_Variable_Rep + (Var_Id : Entity_Id) return Target_Rep_Record + is + Rec : Target_Rep_Record; - Pop_Scope; - end Install_ABE_Check; + begin + Rec.Kind := Variable_Target; - ----------------------- - -- Install_ABE_Check -- - ----------------------- + -- Target-specific attributes - 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. + Rec.Field_1 := Declaration_Node (Var_Id); -- Variable_Declaration - ------------------------------ - -- Build_Elaboration_Entity -- - ------------------------------ + return Rec; + end Create_Variable_Rep; - procedure Build_Elaboration_Entity is - Loc : constant Source_Ptr := Sloc (Target_Id); - Flag_Id : Entity_Id; + ------------- + -- Destroy -- + ------------- + procedure Destroy (S_Id : in out Scenario_Rep_Id) is + pragma Unreferenced (S_Id); begin - -- Create the declaration of the elaboration flag. The name carries a - -- unique counter in case of name overloading. + null; + end Destroy; - Flag_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Target_Id), 'E', -1)); + ------------- + -- Destroy -- + ------------- - Set_Elaboration_Entity (Target_Id, Flag_Id); - Set_Elaboration_Entity_Required (Target_Id); + procedure Destroy (T_Id : in out Target_Rep_Id) is + pragma Unreferenced (T_Id); + begin + null; + end Destroy; - Push_Scope (Scope (Target_Id)); + -------------------------------- + -- Disable_Elaboration_Checks -- + -------------------------------- - -- Generate: - -- Enn : Short_Integer := 0; + 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; - 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))); + -------------------------------- + -- Disable_Elaboration_Checks -- + -------------------------------- - -- Generate: - -- Enn := 1; + 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; - Set_Elaboration_Flag (Target_Body, Target_Id); + --------------------------- + -- Elaboration_Checks_OK -- + --------------------------- - Pop_Scope; - end Build_Elaboration_Entity; + 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; - -- Local variables + --------------------------- + -- Elaboration_Checks_OK -- + --------------------------- - Target_Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); + 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; - -- Start for processing for Install_ABE_Check + ----------------------------- + -- Elaboration_Warnings_OK -- + ----------------------------- - begin - -- Nothing to do when compiling for GNATprove because raise statements - -- are not supported. + 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 GNATprove_Mode then - return; + ----------------------------- + -- Elaboration_Warnings_OK -- + ----------------------------- - -- Nothing to do when the compilation will not produce an executable + 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; - elsif Serious_Errors_Detected > 0 then - return; + -------------------------------------- + -- Finalize_Internal_Representation -- + -------------------------------------- - -- Nothing to do when the target is a protected subprogram because the - -- check is associated with the protected body subprogram. + procedure Finalize_Internal_Representation is + begin + ETT_Map.Destroy (Entity_To_Target_Map); + NTS_Map.Destroy (Node_To_Scenario_Map); + end Finalize_Internal_Representation; - elsif Is_Protected_Subp (Target_Id) then - return; + ------------------- + -- Ghost_Mode_Of -- + ------------------- - -- Nothing to do when the target is elaborated prior to the main unit. - -- This check must also consider the following cases: + 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; - -- * The unit of the target appears in the context of the main unit + ------------------- + -- Ghost_Mode_Of -- + ------------------- - -- * 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. + 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; - -- * 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). + -------------------------- + -- Ghost_Mode_Of_Entity -- + -------------------------- - elsif Has_Prior_Elaboration - (Unit_Id => Target_Unit_Id, - Context_OK => True, - Elab_Body_OK => True) - then - return; + 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; - -- Create an elaboration flag for the target when it does not have one + ------------------------ + -- Ghost_Mode_Of_Node -- + ------------------------ - elsif No (Elaboration_Entity (Target_Id)) then - Build_Elaboration_Entity; - end if; + 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; - Install_ABE_Check - (N => N, - Ins_Nod => Ins_Nod, - Id => Target_Id); - end Install_ABE_Check; + ---------------------------------------- + -- Initialize_Internal_Representation -- + ---------------------------------------- - ------------------------- - -- Install_ABE_Failure -- - ------------------------- + procedure Initialize_Internal_Representation is + begin + null; + end Initialize_Internal_Representation; - 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 + ------------------------- + -- Is_Dispatching_Call -- + ------------------------- - Loc : constant Source_Ptr := Sloc (N); - Scop_Id : Entity_Id; + function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Call_Scenario); - begin - -- Nothing to do when compiling for GNATprove because raise statements - -- are not supported. + begin + return Scenario_Reps.Table (S_Id).Flag_1; + end Is_Dispatching_Call; - if GNATprove_Mode then - return; + ----------------------- + -- Is_Read_Reference -- + ----------------------- - -- Nothing to do when the compilation will not produce an executable + 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); - elsif Serious_Errors_Detected > 0 then - return; + begin + return Scenario_Reps.Table (S_Id).Flag_1; + end Is_Read_Reference; - -- Do not install an ABE check for a compilation unit because there is - -- no executable environment at that level. + ---------- + -- Kind -- + ---------- - elsif Nkind (Parent (Fail_Ins_Nod)) = N_Compilation_Unit then - return; - end if; + 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; - -- Prevent multiple scenarios from installing the same ABE failure + ---------- + -- Kind -- + ---------- - Set_Is_Elaboration_Checks_OK_Node (N, False); + 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; - -- Install the nearest enclosing scope of the scenario as there must be - -- something on the scope stack. + ----------- + -- Level -- + ----------- - -- Performance note: parent traversal + 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; - Scop_Id := Find_Enclosing_Scope (Fail_Ins_Nod); - pragma Assert (Present (Scop_Id)); + ------------- + -- Present -- + ------------- - Push_Scope (Scop_Id); + function Present (S_Id : Scenario_Rep_Id) return Boolean is + begin + return S_Id /= No_Scenario_Rep; + end Present; - -- Generate: - -- raise Program_Error with "access before elaboration"; + ------------- + -- Present -- + ------------- - Insert_Action (Fail_Ins_Nod, - Make_Raise_Program_Error (Loc, - Reason => PE_Access_Before_Elaboration)); + function Present (T_Id : Target_Rep_Id) return Boolean is + begin + return T_Id /= No_Target_Rep; + end Present; - Pop_Scope; - end Install_ABE_Failure; + -------------------------------- + -- Scenario_Representation_Of -- + -------------------------------- - -------------------------------- - -- Is_Accept_Alternative_Proc -- - -------------------------------- + function Scenario_Representation_Of + (N : Node_Id; + In_State : Processing_In_State) return Scenario_Rep_Id + is + S_Id : Scenario_Rep_Id; - function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a procedure with a receiving entry + begin + S_Id := NTS_Map.Get (Node_To_Scenario_Map, N); - return Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); - end Is_Accept_Alternative_Proc; + -- The elaboration scenario lacks a representation. This indicates + -- that the scenario is encountered for the first time. Create the + -- representation of it. - ------------------------ - -- Is_Activation_Proc -- - ------------------------ + if not Present (S_Id) then + Scenario_Reps.Append (Create_Scenario_Rep (N, In_State)); + S_Id := Scenario_Reps.Last; - 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. + -- Associate the internal representation with the elaboration + -- scenario. - 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); + NTS_Map.Put (Node_To_Scenario_Map, N, S_Id); end if; - end if; - return False; - end Is_Activation_Proc; + pragma Assert (Present (S_Id)); - ---------------------------- - -- Is_Ada_Semantic_Target -- - ---------------------------- + return S_Id; + end Scenario_Representation_Of; - 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; + -------------------------------- + -- Set_Activated_Task_Objects -- + -------------------------------- - -------------------------------- - -- Is_Assertion_Pragma_Target -- - -------------------------------- + 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); - 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; + begin + Scenario_Reps.Table (S_Id).List_1 := Task_Objs; + end Set_Activated_Task_Objects; - ---------------------------- - -- Is_Bodiless_Subprogram -- - ---------------------------- + ----------------------------- + -- Set_Activated_Task_Type -- + ----------------------------- - function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is - begin - -- An abstract subprogram does not have a body + 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 Ekind_In (Subp_Id, E_Function, - E_Operator, - E_Procedure) - and then Is_Abstract_Subprogram (Subp_Id) - then - return True; + begin + Scenario_Reps.Table (S_Id).Field_1 := Task_Typ; + end Set_Activated_Task_Type; - -- A formal subprogram does not have a body + ------------------- + -- SPARK_Mode_Of -- + ------------------- - elsif Is_Formal_Subprogram (Subp_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; - -- 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. + ------------------- + -- SPARK_Mode_Of -- + ------------------- - elsif Is_Imported (Subp_Id) then - return True; - end if; + 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; - return False; - end Is_Bodiless_Subprogram; + -------------------------- + -- SPARK_Mode_Of_Entity -- + -------------------------- - ------------------------ - -- Is_Controlled_Proc -- - ------------------------ + function SPARK_Mode_Of_Entity + (Id : Entity_Id) return Extended_SPARK_Mode + is + Prag : constant Node_Id := SPARK_Pragma (Id); - function Is_Controlled_Proc - (Subp_Id : Entity_Id; - Subp_Nam : Name_Id) return Boolean - is - Formal_Id : Entity_Id; + begin + return + To_SPARK_Mode + (Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On); + end SPARK_Mode_Of_Entity; - begin - pragma Assert (Nam_In (Subp_Nam, Name_Adjust, - Name_Finalize, - Name_Initialize)); + ------------------------ + -- SPARK_Mode_Of_Node -- + ------------------------ - -- To qualify, the subprogram must denote a source procedure with name - -- Adjust, Finalize, or Initialize where the sole formal is controlled. + 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; - 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); + ---------------------- + -- Spec_Declaration -- + ---------------------- - return - Present (Formal_Id) - and then Is_Controlled (Etype (Formal_Id)) - and then No (Next_Formal (Formal_Id)); - end if; + 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; - return False; - end Is_Controlled_Proc; + ------------ + -- Target -- + ------------ - --------------------------------------- - -- Is_Default_Initial_Condition_Proc -- - --------------------------------------- + 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; - function Is_Default_Initial_Condition_Proc - (Id : Entity_Id) return Boolean - is - begin - -- To qualify, the entity must denote a Default_Initial_Condition - -- procedure. + ------------------------------ + -- Target_Representation_Of -- + ------------------------------ - return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); - end Is_Default_Initial_Condition_Proc; + function Target_Representation_Of + (Id : Entity_Id; + In_State : Processing_In_State) return Target_Rep_Id + is + T_Id : Target_Rep_Id; - ----------------------- - -- Is_Finalizer_Proc -- - ----------------------- + begin + T_Id := ETT_Map.Get (Entity_To_Target_Map, Id); - function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a _Finalizer procedure + -- The elaboration target lacks an internal representation. This + -- indicates that the target is encountered for the first time. + -- Create the internal representation of it. - return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; - end Is_Finalizer_Proc; + if not Present (T_Id) then + Target_Reps.Append (Create_Target_Rep (Id, In_State)); + T_Id := Target_Reps.Last; - ----------------------- - -- Is_Guaranteed_ABE -- - ----------------------- + -- Associate the internal representation with the elaboration + -- target. - 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. + ETT_Map.Put (Entity_To_Target_Map, Id, T_Id); - if Serious_Errors_Detected > 0 then - return False; + -- 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. - -- The scenario and the target appear within the same context ignoring - -- enclosing library levels. + elsif In_State.Representation = Inconsistent_Representation then + Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); - -- Performance note: parent traversal + -- 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. - elsif In_Same_Context (N, Target_Decl) then + elsif In_State.Representation /= Version (T_Id) then + Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); + end if; - -- The target body has already been encountered. The scenario results - -- in a guaranteed ABE if it appears prior to the body. + pragma Assert (Present (T_Id)); - if Present (Target_Body) then - return Earlier_In_Extended_Unit (N, Target_Body); + return T_Id; + end Target_Representation_Of; - -- 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. + ------------------- + -- To_Ghost_Mode -- + ------------------- + function To_Ghost_Mode + (Ignored_Status : Boolean) return Extended_Ghost_Mode + is + begin + if Ignored_Status then + return Is_Ignored; else - return True; + return Is_Checked_Or_Not_Specified; end if; - end if; + end To_Ghost_Mode; - return False; - end Is_Guaranteed_ABE; + ------------------- + -- To_SPARK_Mode -- + ------------------- - ------------------------------- - -- Is_Initial_Condition_Proc -- - ------------------------------- + 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; - function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote an Initial_Condition procedure + ---------- + -- Unit -- + ---------- - return - Ekind (Id) = E_Procedure and then Is_Initial_Condition_Procedure (Id); - end Is_Initial_Condition_Proc; + 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; - -------------------- - -- Is_Initialized -- - -------------------- + -------------------------- + -- Variable_Declaration -- + -------------------------- - function Is_Initialized (Obj_Decl : Node_Id) return Boolean is - begin - -- To qualify, the object declaration must have an expression + function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id is + pragma Assert (Present (T_Id)); + pragma Assert (Kind (T_Id) = Variable_Target); - return - Present (Expression (Obj_Decl)) or else Has_Init_Expression (Obj_Decl); - end Is_Initialized; + begin + return Target_Reps.Table (T_Id).Field_1; + end Variable_Declaration; - ----------------------- - -- Is_Invariant_Proc -- - ----------------------- + ------------- + -- Version -- + ------------- + + 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; + + ---------------------- + -- Invocation_Graph -- + ---------------------- + + package body Invocation_Graph is + + ----------- + -- Types -- + ----------- + + -- The following type represents simplified version of an invocation + -- relation. + + type Invoker_Target_Relation is record + Invoker : Entity_Id := Empty; + Target : Entity_Id := Empty; + end record; + + -- The following variables define the entities of the dummy elaboration + -- procedures used as origins of library level paths. + + Elab_Body_Id : Entity_Id := Empty; + Elab_Spec_Id : Entity_Id := Empty; + + --------------------- + -- Data structures -- + --------------------- - function Is_Invariant_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote the "full" invariant procedure + -- 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. - return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); - end Is_Invariant_Proc; + Saved_Constructs_Set : NE_Set.Membership_Set := NE_Set.Nil; - --------------------------------------- - -- Is_Non_Library_Level_Encapsulator -- - --------------------------------------- + function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type; + -- Obtain the hash value of pair Key - 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; + package IR_Set is new Membership_Sets + (Element_Type => Invoker_Target_Relation, + "=" => "=", + Hash => Hash); - when others => - return Is_Generic_Declaration_Or_Body (N); - end case; - end Is_Non_Library_Level_Encapsulator; + -- 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_Partial_Invariant_Proc -- - ------------------------------- + Saved_Relations_Set : IR_Set.Membership_Set := IR_Set.Nil; - function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote the "partial" invariant procedure + -------------- + -- Builders -- + -------------- - return - Ekind (Id) = E_Procedure and then Is_Partial_Invariant_Procedure (Id); - end Is_Partial_Invariant_Proc; + function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id; + pragma Inline (Signature_Of); + -- Obtain the invication signature id of arbitrary entity Id - ---------------------------- - -- Is_Postconditions_Proc -- - ---------------------------- + ----------------------- + -- Local subprograms -- + ----------------------- - function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a _Postconditions procedure + 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. - return - Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; - end Is_Postconditions_Proc; + ------------------------------------ + -- Build_Elaborate_Body_Procedure -- + ------------------------------------ - --------------------------- - -- Is_Preelaborated_Unit -- - --------------------------- + procedure Build_Elaborate_Body_Procedure is + Body_Decl : Node_Id; + Spec_Decl : Node_Id; - 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; + begin + -- Nothing to do when a previous call already created the procedure - ------------------------ - -- Is_Protected_Entry -- - ------------------------ + if Present (Elab_Body_Id) then + return; + end if; - function Is_Protected_Entry (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote an entry defined in a protected - -- type. + Spec_And_Body_From_Entity + (Id => Cunit_Entity (Main_Unit), + Body_Decl => Body_Decl, + Spec_Decl => Spec_Decl); - return - Is_Entry (Id) - and then Is_Protected_Type (Non_Private_View (Scope (Id))); - end Is_Protected_Entry; + pragma Assert (Present (Body_Decl)); - ----------------------- - -- Is_Protected_Subp -- - ----------------------- + Build_Elaborate_Procedure + (Proc_Id => Elab_Body_Id, + Proc_Nam => Name_B, + Loc => Sloc (Body_Decl)); + end Build_Elaborate_Body_Procedure; - function Is_Protected_Subp (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a subprogram defined within a - -- protected type. + ------------------------------- + -- Build_Elaborate_Procedure -- + ------------------------------- - return - Ekind_In (Id, E_Function, E_Procedure) - and then Is_Protected_Type (Non_Private_View (Scope (Id))); - end Is_Protected_Subp; + 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); - ---------------------------- - -- Is_Protected_Body_Subp -- - ---------------------------- + begin + Proc_Id := Make_Defining_Identifier (Loc, Proc_Nam); - 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. + -- Partially decorate the elaboration procedure because it will not + -- be insertred into the tree and analyzed. - return - Ekind_In (Id, E_Function, E_Procedure) - and then Present (Protected_Subprogram (Id)); - end Is_Protected_Body_Subp; + Set_Ekind (Proc_Id, E_Procedure); + Set_Etype (Proc_Id, Standard_Void_Type); + Set_Scope (Proc_Id, Unique_Entity (Cunit_Entity (Main_Unit))); - -------------------------------- - -- Is_Recorded_SPARK_Scenario -- - -------------------------------- + -- Create a dummy declaration for the elaboration procedure. The + -- declaration does not need to be syntactically legal, but must + -- carry an accurate source location. - 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; + 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; - return Recorded_SPARK_Scenarios_No_Element; - end Is_Recorded_SPARK_Scenario; + ------------------------------------ + -- Build_Elaborate_Spec_Procedure -- + ------------------------------------ - ------------------------------------ - -- Is_Recorded_Top_Level_Scenario -- - ------------------------------------ + procedure Build_Elaborate_Spec_Procedure is + Body_Decl : Node_Id; + Spec_Decl : Node_Id; - 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; + begin + -- Nothing to do when a previous call already created the procedure - return Recorded_Top_Level_Scenarios_No_Element; - end Is_Recorded_Top_Level_Scenario; + if Present (Elab_Spec_Id) then + return; + end if; - ------------------------ - -- Is_Safe_Activation -- - ------------------------ + Spec_And_Body_From_Entity + (Id => Cunit_Entity (Main_Unit), + Body_Decl => Body_Decl, + Spec_Decl => Spec_Decl); - 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. + pragma Assert (Present (Spec_Decl)); - return - In_External_Instance - (N => Call, - Target_Decl => Task_Decl); - end Is_Safe_Activation; + Build_Elaborate_Procedure + (Proc_Id => Elab_Spec_Id, + Proc_Nam => Name_S, + Loc => Sloc (Spec_Decl)); + end Build_Elaborate_Spec_Procedure; - ------------------ - -- Is_Safe_Call -- - ------------------ + --------------------------------- + -- Build_Subprogram_Invocation -- + --------------------------------- - 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. + 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); - if Is_Bodiless_Subprogram (Target_Attrs.Spec_Id) then - return True; + begin + -- Create a dummy call marker which invokes the subprogram - -- 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. + 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); - elsif Is_Generic_Instance (Target_Attrs.Spec_Id) then - return True; + -- Invoke the uniform canonical entity of the subprogram - -- 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. + Set_Target (Marker, Canonical_Subprogram (Subp_Id)); - elsif In_External_Instance - (N => Call, - Target_Decl => Target_Attrs.Spec_Decl) - then - return True; + -- Partially insert the marker into the tree - -- The target is a subprogram body without a previous declaration. The - -- call cannot cause an ABE because the body has already been seen. + Set_Parent (Marker, Parent (Subp_Decl)); - elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body - and then No (Corresponding_Spec (Target_Attrs.Spec_Decl)) - then - return True; + return Marker; + end Build_Subprogram_Invocation; - -- The target is a subprogram body stub without a prior declaration. - -- The call cannot cause an ABE because the proper body substitutes - -- the stub. + --------------------------- + -- Build_Task_Activation -- + --------------------------- - elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body_Stub - and then No (Corresponding_Spec_Of_Stub (Target_Attrs.Spec_Decl)) - then - return True; + 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); - -- Subprogram bodies which wrap attribute references used as actuals - -- in instantiations are always ABE-safe. These bodies are artifacts - -- of expansion. + Activ_Id : Entity_Id; + Marker_Rep_Id : Scenario_Rep_Id; + Task_Obj : Entity_Id; + Task_Objs : NE_List.Doubly_Linked_List; - 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; + begin + -- Create a dummy call marker which activates some tasks - return False; - end Is_Safe_Call; + 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); - --------------------------- - -- Is_Safe_Instantiation -- - --------------------------- + -- Invoke the appropriate version of Activate_Tasks - 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. + if Restricted_Profile then + Activ_Id := RTE (RE_Activate_Restricted_Tasks); + else + Activ_Id := RTE (RE_Activate_Tasks); + end if; - if Is_Bodiless_Subprogram (Gen_Attrs.Spec_Id) then - return True; + Set_Target (Marker, Activ_Id); - -- 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. + -- Partially insert the marker into the tree - elsif In_External_Instance - (N => Inst, - Target_Decl => Gen_Attrs.Spec_Decl) - then - return True; + Set_Parent (Marker, Parent (Task_Decl)); - -- The generic is a package. The instantiation cannot cause an ABE when - -- the package has no body. + -- Create a dummy task object. Partially decorate the object because + -- it will not be inserted into the tree and analyzed. - elsif Ekind (Gen_Attrs.Spec_Id) = E_Generic_Package - and then not Has_Body (Gen_Attrs.Spec_Decl) - then - return True; - end if; + Task_Obj := Make_Temporary (Loc, 'T'); + Set_Ekind (Task_Obj, E_Variable); + Set_Etype (Task_Obj, Task_Typ); - return False; - end Is_Safe_Instantiation; + -- Associate the dummy task object with the activation call - ------------------ - -- Is_Same_Unit -- - ------------------ + Task_Objs := NE_List.Create; + NE_List.Append (Task_Objs, Task_Obj); - 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; + 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); - ----------------- - -- Is_Scenario -- - ----------------- + return Marker; + end Build_Task_Activation; - 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; + ---------------------------------- + -- Declare_Invocation_Construct -- + ---------------------------------- - when others => - return False; - end case; - end Is_Scenario; + 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 - ------------------------------ - -- Is_SPARK_Semantic_Target -- - ------------------------------ + function Placement_Of (Id : Entity_Id) return Body_Placement_Kind; + pragma Inline (Placement_Of); + -- Obtain the body placement of arbitrary entity 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; + function Placement_Of_Node (N : Node_Id) return Body_Placement_Kind; + pragma Inline (Placement_Of_Node); + -- Obtain the body placement of arbitrary node N - ------------------------ - -- Is_Suitable_Access -- - ------------------------ + ------------- + -- Kind_Of -- + ------------- - function Is_Suitable_Access (N : Node_Id) return Boolean is - Nam : Name_Id; - Pref : Node_Id; - Subp_Id : Entity_Id; + function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is + begin + if Id = Elab_Body_Id then + return Elaborate_Body_Procedure; - 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. + elsif Id = Elab_Spec_Id then + return Elaborate_Spec_Procedure; - if not Static_Elaboration_Checks then - return False; + else + return Regular_Construct; + end if; + end Kind_Of; - -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect + ------------------ + -- Placement_Of -- + ------------------ - elsif Debug_Flag_Dot_UU then - return False; + 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); - -- Nothing to do when the scenario is not an attribute reference + begin + -- The entity has a body - elsif Nkind (N) /= N_Attribute_Reference then - return False; + if Present (Body_Decl) then + return Placement_Of_Node (Body_Decl); - -- Nothing to do for internally-generated attributes because they are - -- assumed to be ABE safe. + -- Otherwise the entity must have a spec - elsif not Comes_From_Source (N) then - return False; - end if; + else + pragma Assert (Present (Spec_Decl)); + return Placement_Of_Node (Spec_Decl); + end if; + end Placement_Of; - Nam := Attribute_Name (N); - Pref := Prefix (N); + ----------------------- + -- Placement_Of_Node -- + ----------------------- - -- Sanitize the prefix of the attribute + 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); - if not Is_Entity_Name (Pref) then - return False; + begin + -- The node is in the main unit, its placement depends on the main + -- unit kind. - elsif No (Entity (Pref)) then - return False; - end if; + if N_Unit_Id = Main_Unit_Id then - Subp_Id := Entity (Pref); + -- The main unit is a body - if not Is_Subprogram_Or_Entry (Subp_Id) then - return False; - end if; + if Ekind_In (Main_Unit_Id, E_Package_Body, + E_Subprogram_Body) + then + return In_Body; - -- Traverse a possible chain of renamings to obtain the original entry - -- or subprogram which the prefix may rename. + -- The main unit is a stand-alone subprogram body - Subp_Id := Get_Renamed_Entity (Subp_Id); + 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; - -- To qualify, the attribute must meet the following prerequisites: + -- Otherwise the main unit is a spec - return + else + return In_Spec; + end if; - -- The prefix must denote a source entry, operator, or subprogram - -- which is not imported. + -- Otherwise the node is in the complementary unit of the main + -- unit. The main unit is a body, the node is in the spec. - Comes_From_Source (Subp_Id) - and then Is_Subprogram_Or_Entry (Subp_Id) - and then not Is_Bodiless_Subprogram (Subp_Id) + elsif Ekind_In (Main_Unit_Id, E_Package_Body, + E_Subprogram_Body) + then + return In_Spec; - -- The attribute name must be one of the 'Access forms. Note that - -- 'Unchecked_Access cannot apply to a subprogram. + -- The main unit is a spec, the node is in the body - and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); - end Is_Suitable_Access; + else + return In_Body; + end if; + end Placement_Of_Node; - ---------------------- - -- Is_Suitable_Call -- - ---------------------- + -- Local variables - 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. + IC_Rec : Invocation_Construct_Record; - return Nkind (N) = N_Call_Marker; - end Is_Suitable_Call; + -- Start of processing for Declare_Invocation_Construct - ------------------------------- - -- Is_Suitable_Instantiation -- - ------------------------------- + begin + -- Nothing to do when the construct has already been declared in the + -- ALI file. - 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. + if Is_Saved_Construct (Constr_Id) then + return; + end if; - begin - -- To qualify, the instantiation must come from source + -- Mark the construct as declared in the ALI file - return - Comes_From_Source (Orig_N) - and then Nkind (Orig_N) in N_Generic_Instantiation; - end Is_Suitable_Instantiation; + Set_Is_Saved_Construct (Constr_Id); - -------------------------- - -- Is_Suitable_Scenario -- - -------------------------- + IC_Rec.Kind := Kind_Of (Constr_Id); + IC_Rec.Placement := Placement_Of (Constr_Id); + IC_Rec.Signature := Signature_Of (Constr_Id); - 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. + -- Add the construct in the ALI file - 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; + Add_Invocation_Construct + (IC_Rec => IC_Rec, + Update_Units => False); + end Declare_Invocation_Construct; - ------------------------------------ - -- Is_Suitable_SPARK_Derived_Type -- - ------------------------------------ + ------------------------------- + -- Finalize_Invocation_Graph -- + ------------------------------- - function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is - Prag : Node_Id; - Typ : Entity_Id; + procedure Finalize_Invocation_Graph is + begin + NE_Set.Destroy (Saved_Constructs_Set); + IR_Set.Destroy (Saved_Relations_Set); + end Finalize_Invocation_Graph; - begin - -- To qualify, the type declaration must denote a derived tagged type - -- with primitive operations, subject to pragma SPARK_Mode On. + ---------- + -- Hash -- + ---------- - 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); + function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type is + pragma Assert (Present (Key.Invoker)); + pragma Assert (Present (Key.Target)); + begin 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; + Hash_Two_Keys + (Bucket_Range_Type (Key.Invoker), + Bucket_Range_Type (Key.Target)); + end Hash; - return False; - end Is_Suitable_SPARK_Derived_Type; + --------------------------------- + -- Initialize_Invocation_Graph -- + --------------------------------- - ------------------------------------- - -- Is_Suitable_SPARK_Instantiation -- - ------------------------------------- + procedure Initialize_Invocation_Graph is + begin + Saved_Constructs_Set := NE_Set.Create (100); + Saved_Relations_Set := IR_Set.Create (200); + end Initialize_Invocation_Graph; - 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; + ----------------------------------- + -- Invocation_Graph_Recording_OK -- + ----------------------------------- - begin - -- To qualify, both the instantiation and the generic must be subject to - -- SPARK_Mode On. + function Invocation_Graph_Recording_OK return Boolean is + Main_Cunit : constant Node_Id := Cunit (Main_Unit); - 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); + begin + -- Nothing to do when switch -gnatd_G (encode invocation graph in ALI + -- files) is not in effect. - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + if not Debug_Flag_Underscore_GG then + return False; - return Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; - end if; + -- Nothing to do when compiling for GNATprove because the invocation + -- graph is not needed. - return False; - end Is_Suitable_SPARK_Instantiation; + elsif GNATprove_Mode then + return False; - -------------------------------------------- - -- Is_Suitable_SPARK_Refined_State_Pragma -- - -------------------------------------------- + -- Nothing to do when the compilation will not produce an ALI file - function Is_Suitable_SPARK_Refined_State_Pragma - (N : Node_Id) return Boolean - is - begin - -- To qualfy, the pragma must denote Refined_State + elsif Serious_Errors_Detected > 0 then + return False; - return - Nkind (N) = N_Pragma - and then Pragma_Name (N) = Name_Refined_State; - end Is_Suitable_SPARK_Refined_State_Pragma; + -- 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. - ------------------------------------- - -- Is_Suitable_Variable_Assignment -- - ------------------------------------- + elsif Body_Required (Main_Cunit) then + return False; + end if; - 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; + return True; + end Invocation_Graph_Recording_OK; - 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. + ---------------------------- + -- Is_Invocation_Scenario -- + ---------------------------- - if not Static_Elaboration_Checks then - return False; + 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; - -- Nothing to do when the scenario is not an assignment + -------------------------- + -- Is_Invocation_Target -- + -------------------------- - elsif Nkind (N) /= N_Assignment_Statement then - return False; + 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. + + 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; + + ----------------------- + -- Is_Saved_Relation -- + ----------------------- - -- Nothing to do for internally-generated assignments because they are - -- assumed to be ABE safe. + function Is_Saved_Relation + (Rel : Invoker_Target_Relation) return Boolean + is + pragma Assert (Present (Rel.Invoker)); + pragma Assert (Present (Rel.Target)); - elsif not Comes_From_Source (N) then - return False; + begin + return IR_Set.Contains (Saved_Relations_Set, Rel); + end Is_Saved_Relation; - -- Assignments are ignored in GNAT mode on the assumption that they are - -- ABE-safe. This behaviour parallels that of the old ABE mechanism. + -------------------------- + -- Process_Declarations -- + -------------------------- - elsif GNAT_Mode then - return False; - end if; + procedure Process_Declarations + (Decls : List_Id; + In_State : Processing_In_State) + is + Decl : Node_Id; - Nam := Extract_Assignment_Name (N); + begin + Decl := First (Decls); + while Present (Decl) loop - -- Sanitize the left hand side of the assignment + -- Freeze node - if not Is_Entity_Name (Nam) then - return False; + if Nkind (Decl) = N_Freeze_Entity then + Process_Freeze_Node + (Fnode => Decl, + In_State => In_State); - elsif No (Entity (Nam)) then - return False; - end if; + -- Package (nested) - Var_Id := Entity (Nam); + elsif Nkind (Decl) = N_Package_Declaration then + Process_Package_Declaration + (Pack_Decl => Decl, + In_State => In_State); - -- Sanitize the variable + -- Protected type - if Var_Id = Any_Id then - return False; + elsif Nkind_In (Decl, N_Protected_Type_Declaration, + N_Single_Protected_Declaration) + then + Process_Protected_Type_Declaration + (Prot_Decl => Decl, + In_State => In_State); - elsif Ekind (Var_Id) /= E_Variable then - return False; - end if; + -- Subprogram or entry - Var_Decl := Declaration_Node (Var_Id); + elsif Nkind_In (Decl, N_Entry_Declaration, + N_Subprogram_Declaration) + then + Process_Subprogram_Declaration + (Subp_Decl => Decl, + In_State => In_State); - if Nkind (Var_Decl) /= N_Object_Declaration then - return False; - end if; + -- Subprogram body (stand alone) - N_Unit_Id := Find_Top_Unit (N); - N_Unit := Unit_Declaration_Node (N_Unit_Id); + elsif Nkind (Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Decl)) + then + Process_Subprogram_Declaration + (Subp_Decl => Decl, + In_State => In_State); - Var_Unit_Id := Find_Top_Unit (Var_Decl); - Var_Unit := Unit_Declaration_Node (Var_Unit_Id); + -- Subprogram instantiation - -- To qualify, the assignment must meet the following prerequisites: + elsif Nkind (Decl) in N_Subprogram_Instantiation then + Process_Subprogram_Instantiation + (Inst => Decl, + In_State => In_State); - return - Comes_From_Source (Var_Id) + -- Task type - -- The variable must be declared in the spec of compilation unit U + elsif Nkind_In (Decl, N_Single_Task_Declaration, + N_Task_Type_Declaration) + then + Process_Task_Type_Declaration + (Task_Decl => Decl, + In_State => In_State); - and then Nkind (Var_Unit) = N_Package_Declaration + -- Task type (derived) - -- Performance note: parent traversal + 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; - and then Find_Enclosing_Level (Var_Decl) = Package_Spec + Next (Decl); + end loop; + end Process_Declarations; - -- The assignment must occur in the body of compilation unit U + ------------------------- + -- Process_Freeze_Node -- + ------------------------- - 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; + procedure Process_Freeze_Node + (Fnode : Node_Id; + In_State : Processing_In_State) + is + begin + Process_Declarations + (Decls => Actions (Fnode), + In_State => In_State); + end Process_Freeze_Node; - ------------------------------------ - -- Is_Suitable_Variable_Reference -- - ------------------------------------ + ----------------------------------- + -- Process_Invocation_Activation -- + ----------------------------------- - 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. + 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); - return Nkind (N) = N_Variable_Reference_Marker; - end Is_Suitable_Variable_Reference; + begin + -- Nothing to do when the task type appears within an internal unit - ------------------------------------ - -- Is_Synchronous_Suspension_Call -- - ------------------------------------ + if In_Internal_Unit (Task_Typ) then + return; + end if; - function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean is - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; + -- The task type being activated is within the main unit. Extend the + -- DFS traversal into its body. - begin - -- To qualify, the call must invoke one of the runtime routines which - -- perform synchronous suspension. + if In_Extended_Main_Code_Unit (Task_Typ) then + Traverse_Invocation_Body + (N => Body_Declaration (Task_Rep), + In_State => In_State); - if Is_Suitable_Call (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); + -- 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. - return - Is_RTE (Target_Id, RE_Suspend_Until_True) - or else - Is_RTE (Target_Id, RE_Wait_For_Release); - end if; + else + Record_Invocation_Path (In_State); + end if; + end Process_Invocation_Activation; - return False; - end Is_Synchronous_Suspension_Call; + --------------------------------------- + -- Process_Invocation_Body_Scenarios -- + --------------------------------------- - ------------------- - -- Is_Task_Entry -- - ------------------- + 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; - function Is_Task_Entry (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote an entry defined in a task type + ----------------------------- + -- Process_Invocation_Call -- + ----------------------------- - return - Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); - end Is_Task_Entry; + procedure Process_Invocation_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Call); - ------------------------ - -- Is_Up_Level_Target -- - ------------------------ + Subp_Id : constant Entity_Id := Target (Call_Rep); + Subp_Rep : constant Target_Rep_Id := + Target_Representation_Of (Subp_Id, In_State); - function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean is - Root : constant Node_Id := Root_Scenario; + begin + -- Nothing to do when the subprogram appears within an internal unit - 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 In_Internal_Unit (Subp_Id) then + return; - -- Performance note: parent traversal + -- Nothing to do for an abstract subprogram because it has no body to + -- examine. - 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 (Subp_Id, E_Function, E_Procedure) + and then Is_Abstract_Subprogram (Subp_Id) + then + return; - -- package body Main_Unit is - -- function Func ...; -- target + -- Nothin to do for a formal subprogram because it has no body to + -- examine. - -- procedure Proc is - -- X : ... := Func; -- root scenario + elsif Is_Formal_Subprogram (Subp_Id) then + return; + end if; - if In_Extended_Main_Code_Unit (Target_Decl) then + -- The subprogram being called is within the main unit. Extend the + -- DFS traversal into its barrier function and body. - -- Performance note: parent traversal + 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; - return not In_Same_Context (Root, Target_Decl, Nested_OK => True); + Traverse_Invocation_Body + (N => Body_Declaration (Subp_Rep), + In_State => In_State); - -- Otherwise the target is external to the main unit which makes it - -- an up-level target. + -- 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. else - return True; + Record_Invocation_Path (In_State); end if; - end if; - - return False; - end Is_Up_Level_Target; - - --------------------- - -- Is_Visited_Body -- - --------------------- - - 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; + end Process_Invocation_Call; - return Visited_Bodies_No_Element; - end Is_Visited_Body; + --------------------------------- + -- Process_Invocation_Scenario -- + --------------------------------- - ------------------------------- - -- Kill_Elaboration_Scenario -- - ------------------------------- + procedure Process_Invocation_Scenario + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); + Scen_Rep : Scenario_Rep_Id; - 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. + begin + -- Add the current scenario to the stack of active scenarios - procedure Kill_Top_Level_Scenario; - pragma Inline (Kill_Top_Level_Scenario); - -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded - -- there. + Push_Active_Scenario (Scen); - ------------------------- - -- Kill_SPARK_Scenario -- - ------------------------- + -- Call or task activation - procedure Kill_SPARK_Scenario is - package Scenarios renames SPARK_Scenarios; + if Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - begin - if Is_Recorded_SPARK_Scenario (N) then + -- 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. - -- Performance note: list traversal + if In_Main_Context (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - for Index in Scenarios.First .. Scenarios.Last loop - if Scenarios.Table (Index) = N then - Scenarios.Table (Index) := Empty; + if Kind (Scen_Rep) = Call_Scenario then + Process_Invocation_Call + (Call => Scen, + Call_Rep => Scen_Rep, + In_State => In_State); - -- The SPARK scenario is no longer recorded + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); - Set_Is_Recorded_SPARK_Scenario (N, False); - return; + Process_Activation + (Call => Scen, + Call_Rep => Scen_Rep, + Processor => Process_Invocation_Activation'Access, + In_State => In_State); end if; - end loop; + end if; + end if; - -- A recorded SPARK scenario must be in the table of recorded - -- SPARK scenarios. + -- Remove the current scenario from the stack of active scenarios + -- once all invocation constructs and paths have been saved. - pragma Assert (False); - end if; - end Kill_SPARK_Scenario; + Pop_Active_Scenario (Scen); + end Process_Invocation_Scenario; - ----------------------------- - -- Kill_Top_Level_Scenario -- - ----------------------------- + ---------------------------------- + -- Process_Invocation_Scenarios -- + ---------------------------------- - procedure Kill_Top_Level_Scenario is - package Scenarios renames Top_Level_Scenarios; + procedure Process_Invocation_Scenarios + (Iter : in out NE_Set.Iterator; + In_State : Processing_In_State) + is + N : Node_Id; begin - if Is_Recorded_Top_Level_Scenario (N) then - - -- Performance node: list traversal + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - for Index in Scenarios.First .. Scenarios.Last loop - if Scenarios.Table (Index) = N then - Scenarios.Table (Index) := Empty; + -- Reset the traversed status of all subprogram bodies because the + -- current invocation scenario acts as a new DFS traversal root. - -- The top-level scenario is no longer recorded + Reset_Traversed_Bodies; - Set_Is_Recorded_Top_Level_Scenario (N, False); - return; - end if; - end loop; + Process_Invocation_Scenario (N, In_State); + end loop; + end Process_Invocation_Scenarios; - -- A recorded top-level scenario must be in the table of recorded - -- top-level scenarios. + --------------------------------------- + -- Process_Invocation_Spec_Scenarios -- + --------------------------------------- - pragma Assert (False); - end if; - end Kill_Top_Level_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; - -- Start of processing for Kill_Elaboration_Scenario + ----------------------- + -- Process_Main_Unit -- + ----------------------- - 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. + procedure Process_Main_Unit is + Unit_Decl : constant Node_Id := Unit (Cunit (Main_Unit)); + Spec_Id : Entity_Id; - if Legacy_Elaboration_Checks then - return; - end if; + begin + -- The main unit is a [generic] package body - -- Eliminate a recorded scenario when it appears within dead code - -- because it will not be executed at elaboration time. + if Nkind (Unit_Decl) = N_Package_Body then + Spec_Id := Corresponding_Spec (Unit_Decl); + pragma Assert (Present (Spec_Id)); - if Is_Scenario (N) then - Kill_SPARK_Scenario; - Kill_Top_Level_Scenario; - end if; - end Kill_Elaboration_Scenario; + Process_Package_Declaration + (Pack_Decl => Unit_Declaration_Node (Spec_Id), + In_State => Invocation_Construct_State); - ---------------------------------- - -- Meet_Elaboration_Requirement -- - ---------------------------------- + -- The main unit is a [generic] package declaration - 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); + elsif Nkind (Unit_Decl) = N_Package_Declaration then + Process_Package_Declaration + (Pack_Decl => Unit_Decl, + In_State => Invocation_Construct_State); - 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. + -- The main unit is a [generic] subprogram body - procedure Info_Requirement_Met (Prag : Node_Id); - pragma Inline (Info_Requirement_Met); - -- Output information concerning pragma Prag which meets requirement - -- Req_Nam. + elsif Nkind (Unit_Decl) = N_Subprogram_Body then + Spec_Id := Corresponding_Spec (Unit_Decl); - procedure Info_Scenario; - pragma Inline (Info_Scenario); - -- Output information concerning scenario N + -- The body completes a previous declaration - -------------------------------- - -- Find_Preelaboration_Pragma -- - -------------------------------- + if Present (Spec_Id) then + Process_Subprogram_Declaration + (Subp_Decl => Unit_Declaration_Node (Spec_Id), + In_State => Invocation_Construct_State); - function Find_Preelaboration_Pragma - (Prag_Nam : Name_Id) return Node_Id - is - Spec : constant Node_Id := Parent (Unit_Id); - Decl : Node_Id; + -- Otherwise the body is stand-alone - begin - -- A preelaboration-related pragma comes from source and appears at - -- the top of the visible declarations of a package. + else + Process_Subprogram_Declaration + (Subp_Decl => Unit_Decl, + In_State => Invocation_Construct_State); + end if; - 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; + -- The main unit is a subprogram instantiation - -- Otherwise the construct terminates the region where the - -- preelaboration-related pragma may appear. + elsif Nkind (Unit_Decl) in N_Subprogram_Instantiation then + Process_Subprogram_Instantiation + (Inst => Unit_Decl, + In_State => Invocation_Construct_State); - else - exit; - end if; - end if; + -- The main unit is an imported subprogram declaration - Next (Decl); - end loop; + 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; - return Empty; - end Find_Preelaboration_Pragma; - - -------------------------- - -- Info_Requirement_Met -- - -------------------------- - - procedure Info_Requirement_Met (Prag : Node_Id) is - begin - pragma Assert (Present (Prag)); - - 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_Package_Declaration -- + --------------------------------- - ------------------- - -- Info_Scenario -- - ------------------- + 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); - 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); + -- Add a declaration for the generic package in the ALI of the main + -- unit in case a client unit instantiates it. - elsif Is_Suitable_Instantiation (N) then - Info_Instantiation - (Inst => N, - Gen_Id => Target_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 => Target_Id, - Info_Msg => False, - In_SPARK => True); + if Ekind (Spec_Id) = E_Generic_Package then + Declare_Invocation_Construct + (Constr_Id => Spec_Id, + In_State => In_State); - -- No other scenario may impose a requirement on the context of the - -- main unit. + -- Otherwise inspect the visible and private declarations of the + -- package for invocation constructs. else - pragma Assert (False); - null; + 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 Info_Scenario; + end Process_Package_Declaration; - -- Local variables + ---------------------------------------- + -- Process_Protected_Type_Declaration -- + ---------------------------------------- - Elab_Attrs : Elaboration_Attributes; - Elab_Nam : Name_Id; - Req_Met : Boolean; + procedure Process_Protected_Type_Declaration + (Prot_Decl : Node_Id; + In_State : Processing_In_State) + is + Prot_Def : constant Node_Id := Protected_Definition (Prot_Decl); - -- Start of processing for Meet_Elaboration_Requirement + begin + if Present (Prot_Def) then + Process_Declarations + (Decls => Visible_Declarations (Prot_Def), + In_State => In_State); + end if; + end Process_Protected_Type_Declaration; - begin - pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); + ------------------------------------ + -- Process_Subprogram_Declaration -- + ------------------------------------ - -- Assume that the requirement has not been met + procedure Process_Subprogram_Declaration + (Subp_Decl : Node_Id; + In_State : Processing_In_State) + is + Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); - Req_Met := False; + begin + -- Nothing to do when the subprogram is not an invocation target - -- Elaboration requirements are verified only when the static model is - -- in effect because this diagnostic is graph-dependent. + if not Is_Invocation_Target (Subp_Id) then + return; + end if; - if not Static_Elaboration_Checks then - return; + -- Add a declaration for the subprogram in the ALI file of the main + -- unit in case a client unit calls or instantiates it. - -- 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. + Declare_Invocation_Construct + (Constr_Id => Subp_Id, + In_State => In_State); - elsif In_Extended_Main_Code_Unit (Target_Id) then - Req_Met := True; + -- Do not process subprograms without a body because they do not + -- contain any invocation scenarios. - -- Otherwise the target resides in an external unit + if Is_Bodiless_Subprogram (Subp_Id) then + null; - -- The requirement is met when the target comes from an internal unit - -- because such a unit is elaborated prior to a non-internal unit. + -- Do not process generic subprograms because generics must not be + -- examined. - elsif In_Internal_Unit (Unit_Id) - and then not In_Internal_Unit (Main_Id) - then - Req_Met := True; + elsif Is_Generic_Subprogram (Subp_Id) then + null; - -- The requirement is met when the target comes from a preelaborated - -- unit. This portion must parallel predicate Is_Preelaborated_Unit. + -- Otherwise create a dummy scenario which calls the subprogram to + -- act as a root for a DFS traversal. - elsif Is_Preelaborated_Unit (Unit_Id) then - Req_Met := True; + else + -- Reset the traversed status of all subprogram bodies because the + -- subprogram acts as a new DFS traversal root. - -- Output extra information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas. + Reset_Traversed_Bodies; - if Elab_Info_Messages then - if Is_Preelaborated (Unit_Id) then - Elab_Nam := Name_Preelaborate; + Process_Invocation_Scenario + (N => Build_Subprogram_Invocation (Subp_Id), + In_State => In_State); + end if; + end Process_Subprogram_Declaration; - elsif Is_Pure (Unit_Id) then - Elab_Nam := Name_Pure; + -------------------------------------- + -- Process_Subprogram_Instantiation -- + -------------------------------------- - elsif Is_Remote_Call_Interface (Unit_Id) then - Elab_Nam := Name_Remote_Call_Interface; + procedure Process_Subprogram_Instantiation + (Inst : Node_Id; + In_State : Processing_In_State) + is + begin + -- Add a declaration for the instantiation in the ALI file of the + -- main unit in case a client unit calls it. - elsif Is_Remote_Types (Unit_Id) then - Elab_Nam := Name_Remote_Types; + Declare_Invocation_Construct + (Constr_Id => Defining_Entity (Inst), + In_State => In_State); + end Process_Subprogram_Instantiation; - else - pragma Assert (Is_Shared_Passive (Unit_Id)); - Elab_Nam := Name_Shared_Passive; - end if; + ----------------------------------- + -- Process_Task_Type_Declaration -- + ----------------------------------- - Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); - end if; + 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; - -- Determine whether the context of the main unit has a pragma strong - -- enough to meet the requirement. + 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. - else - Elab_Attrs := Elaboration_Status (Unit_Id); + Declare_Invocation_Construct + (Constr_Id => Task_Typ, + In_State => In_State); - -- The pragma must be either Elaborate_All or be as strong as the - -- requirement. + -- Process the entries of the task type because they represent valid + -- entry points into the task body. - if Present (Elab_Attrs.Source_Pragma) - and then Nam_In (Pragma_Name (Elab_Attrs.Source_Pragma), - Name_Elaborate_All, - Req_Nam) + if Nkind_In (Task_Decl, N_Single_Task_Declaration, + N_Task_Type_Declaration) then - Req_Met := True; - - -- Output extra information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas. + Task_Def := Task_Definition (Task_Decl); - if Elab_Info_Messages then - Info_Requirement_Met (Elab_Attrs.Source_Pragma); + if Present (Task_Def) then + Process_Declarations + (Decls => Visible_Declarations (Task_Def), + In_State => In_State); 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; + -- Reset the traversed status of all subprogram bodies because the + -- task type acts as a new DFS traversal root. - Error_Msg_Name_1 := Req_Nam; - Error_Msg_Node_2 := Unit_Id; - Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); + Reset_Traversed_Bodies; - Output_Active_Scenarios (N); - end if; - end Meet_Elaboration_Requirement; - - ---------------------- - -- Non_Private_View -- - ---------------------- + -- Create a dummy scenario which activates an anonymous object of the + -- task type to acts as a root of a DFS traversal. - 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; + Process_Invocation_Scenario + (N => Build_Task_Activation (Task_Typ, In_State), + In_State => In_State); + end Process_Task_Type_Declaration; - ----------------------------- - -- Output_Active_Scenarios -- - ----------------------------- + --------------------------------- + -- Record_Full_Invocation_Path -- + --------------------------------- - 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 + procedure Record_Full_Invocation_Path (In_State : Processing_In_State) is + package Scenarios renames Active_Scenario_Stack; - procedure Output_Activation_Call (N : Node_Id); - -- Emit a specific diagnostic message for task activation N + 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 Output_Call (N : Node_Id; Target_Id : Entity_Id); - -- Emit a specific diagnostic message for call N which invokes target - -- Target_Id. + if In_State.Processing = Invocation_Body_Processing then + Build_Elaborate_Body_Procedure; - procedure Output_Header; - -- Emit a specific diagnostic message for the unit of the root scenario + Record_Invocation_Relation + (Invk_Id => Elab_Body_Id, + Targ_Id => Target_Of (Scenarios.First, In_State), + In_State => In_State); - procedure Output_Instantiation (N : Node_Id); - -- Emit a specific diagnostic message for instantiation N + -- The path originates from the elaboration of the spec. Add an extra + -- relation from the elaboration spec procedure to the first active + -- scenario. - procedure Output_SPARK_Refined_State_Pragma (N : Node_Id); - -- Emit a specific diagnostic message for Refined_State pragma N + elsif In_State.Processing = Invocation_Spec_Processing then + Build_Elaborate_Spec_Procedure; - procedure Output_Variable_Assignment (N : Node_Id); - -- Emit a specific diagnostic message for assignment statement N + Record_Invocation_Relation + (Invk_Id => Elab_Spec_Id, + Targ_Id => Target_Of (Scenarios.First, In_State), + In_State => In_State); + end if; - procedure Output_Variable_Reference (N : Node_Id); - -- Emit a specific diagnostic message for reference N which mentions a - -- variable. + -- Record individual relations formed by pairs of scenarios - ------------------- - -- Output_Access -- - ------------------- + 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; - procedure Output_Access (N : Node_Id) is - Subp_Id : constant Entity_Id := Entity (Prefix (N)); + ----------------------------- + -- Record_Invocation_Graph -- + ----------------------------- + procedure Record_Invocation_Graph is 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; - - ---------------------------- - -- Output_Activation_Call -- - ---------------------------- - - 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 - - -------------------- - -- Find_Activator -- - -------------------- - - function Find_Activator (Call : Node_Id) return Entity_Id is - Par : Node_Id; - - begin - -- Climb the parent chain looking for a package [body] or a - -- construct with a statement sequence. + -- Nothing to do when the invocation graph is not recorded - Par := Parent (Call); - while Present (Par) loop - if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then - return Defining_Entity (Par); + if not Invocation_Graph_Recording_OK then + return; + end if; - elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then - return Defining_Entity (Parent (Par)); - end if; + -- 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. - Par := Parent (Par); - end loop; + Process_Invocation_Body_Scenarios; + Process_Invocation_Spec_Scenarios; - return Empty; - end Find_Activator; + -- 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. - -- Local variables + Process_Main_Unit; + end Record_Invocation_Graph; - Activator : constant Entity_Id := Find_Activator (N); + ---------------------------- + -- Record_Invocation_Path -- + ---------------------------- - -- Start of processing for Output_Activation_Call + procedure Record_Invocation_Path (In_State : Processing_In_State) is + package Scenarios renames Active_Scenario_Stack; begin - pragma Assert (Present (Activator)); + -- Save a path when the active scenario stack contains at least one + -- invocation scenario. - Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); - end Output_Activation_Call; - - ----------------- - -- Output_Call -- - ----------------- + if Scenarios.Last - Scenarios.First < 0 then + return; + end if; - 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. + -- Register all relations in the path when switch -gnatd_F (encode + -- full invocation paths in ALI files) is in effect. - procedure Output_Call (Kind : String); - pragma Inline (Output_Call); - -- Emit a specific diagnostic message concerning a call of kind Kind + if Debug_Flag_Underscore_FF then + Record_Full_Invocation_Path (In_State); - procedure Output_Type_Actions (Action : String); - pragma Inline (Output_Type_Actions); - -- Emit a specific diagnostic message concerning action Action of a - -- type. + -- Otherwise register a single relation - 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. + else + Record_Simple_Invocation_Path (In_State); + end if; - ------------------------------- - -- Output_Accept_Alternative -- - ------------------------------- + Write_Invocation_Path (In_State); + end Record_Invocation_Path; - procedure Output_Accept_Alternative is - Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); + -------------------------------- + -- Record_Invocation_Relation -- + -------------------------------- - begin - pragma Assert (Present (Entry_Id)); + 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)); - Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); - end Output_Accept_Alternative; + 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. - ----------------- - -- Output_Call -- - ----------------- + ------------------------------- + -- Get_Invocation_Attributes -- + ------------------------------- - procedure Output_Call (Kind : String) is + procedure Get_Invocation_Attributes + (Extra : out Entity_Id; + Kind : out Invocation_Kind) + is begin - Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Target_Id); - end Output_Call; + -- Accept within a task body - ------------------------- - -- Output_Type_Actions -- - ------------------------- + if Is_Accept_Alternative_Proc (Targ_Id) then + Extra := Receiving_Entry (Targ_Id); + Kind := Accept_Alternative; - procedure Output_Type_Actions (Action : String) is - Typ : constant Entity_Id := First_Formal_Type (Target_Id); + -- Activation of a task object - begin - pragma Assert (Present (Typ)); + elsif Is_Activation_Proc (Targ_Id) + or else Is_Task_Type (Targ_Id) + then + Extra := Empty; + Kind := Task_Activation; - Error_Msg_NE - ("\\ " & Action & " actions for type & #", Error_Nod, Typ); - end Output_Type_Actions; + -- Controlled adjustment actions - ------------------------------ - -- Output_Verification_Call -- - ------------------------------ + elsif Is_Controlled_Proc (Targ_Id, Name_Adjust) then + Extra := First_Formal_Type (Targ_Id); + Kind := Controlled_Adjustment; - procedure Output_Verification_Call - (Pred : String; - Id : Entity_Id; - Id_Kind : String) - is - begin - pragma Assert (Present (Id)); + -- Controlled finalization actions - Error_Msg_NE - ("\\ " & Pred & " of " & Id_Kind & " & verified #", - Error_Nod, Id); - end Output_Verification_Call; + 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; - -- Start of processing for Output_Call + -- Controlled initialization actions - begin - Error_Msg_Sloc := Sloc (N); + elsif Is_Controlled_Proc (Targ_Id, Name_Initialize) then + Extra := First_Formal_Type (Targ_Id); + Kind := Controlled_Initialization; - -- Accept alternative + -- Default_Initial_Condition verification - if Is_Accept_Alternative_Proc (Target_Id) then - Output_Accept_Alternative; + elsif Is_Default_Initial_Condition_Proc (Targ_Id) then + Extra := First_Formal_Type (Targ_Id); + Kind := Default_Initial_Condition_Verification; - -- Adjustment + -- Initialization of object - elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then - Output_Type_Actions ("adjustment"); + elsif Is_Init_Proc (Targ_Id) then + Extra := First_Formal_Type (Targ_Id); + Kind := Type_Initialization; - -- Default_Initial_Condition + -- Initial_Condition verification - 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"); + elsif Is_Initial_Condition_Proc (Targ_Id) then + Extra := First_Formal_Type (Targ_Id); + Kind := Initial_Condition_Verification; - -- Entries + -- Instantiation - elsif Is_Protected_Entry (Target_Id) then - Output_Call ("entry"); + elsif Is_Generic_Unit (Targ_Id) then + Extra := Empty; + Kind := Instantiation; - -- 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. + -- Internal controlled adjustment actions - elsif Is_Task_Entry (Target_Id) then - null; + elsif Is_TSS (Targ_Id, TSS_Deep_Adjust) then + Extra := First_Formal_Type (Targ_Id); + Kind := Internal_Controlled_Adjustment; - -- Finalization + -- Internal controlled finalization actions - elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then - Output_Type_Actions ("finalization"); + elsif Is_TSS (Targ_Id, TSS_Deep_Finalize) then + Extra := First_Formal_Type (Targ_Id); + Kind := Internal_Controlled_Finalization; - -- Calls to _Finalizer procedures must not appear in the output - -- because this creates confusing noise. + -- Internal controlled initialization actions - elsif Is_Finalizer_Proc (Target_Id) then - null; + elsif Is_TSS (Targ_Id, TSS_Deep_Initialize) then + Extra := First_Formal_Type (Targ_Id); + Kind := Internal_Controlled_Initialization; - -- Initial_Condition + -- Invariant verification - elsif Is_Initial_Condition_Proc (Target_Id) then - Output_Verification_Call - (Pred => "Initial_Condition", - Id => Find_Enclosing_Scope (N), - Id_Kind => "package"); + elsif Is_Invariant_Proc (Targ_Id) + or else Is_Partial_Invariant_Proc (Targ_Id) + then + Extra := First_Formal_Type (Targ_Id); + Kind := Invariant_Verification; - -- Initialization + -- Postcondition verification - elsif Is_Init_Proc (Target_Id) - or else Is_TSS (Target_Id, TSS_Deep_Initialize) - then - Output_Type_Actions ("initialization"); + elsif Is_Postconditions_Proc (Targ_Id) then + Extra := Find_Enclosing_Scope (Targ_Id); + Kind := Postcondition_Verification; - -- Invariant + -- Protected entry call - elsif Is_Invariant_Proc (Target_Id) then - Output_Verification_Call - (Pred => "invariants", - Id => First_Formal_Type (Target_Id), - Id_Kind => "type"); + elsif Is_Protected_Entry (Targ_Id) then + Extra := Empty; + Kind := Protected_Entry_Call; - -- 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. + -- Protected subprogram call - elsif Is_Partial_Invariant_Proc (Target_Id) then - null; + elsif Is_Protected_Subp (Targ_Id) then + Extra := Empty; + Kind := Protected_Subprogram_Call; - -- _Postconditions + -- Task entry call - elsif Is_Postconditions_Proc (Target_Id) then - Output_Verification_Call - (Pred => "postconditions", - Id => Find_Enclosing_Scope (N), - Id_Kind => "subprogram"); + elsif Is_Task_Entry (Targ_Id) then + Extra := Empty; + Kind := Task_Entry_Call; - -- Subprograms must come last because some of the previous cases fall - -- under this category. + -- Entry, operator, or subprogram call. This case must come last + -- because most invocations above are variations of this case. - elsif Ekind (Target_Id) = E_Function then - Output_Call ("function"); + elsif Ekind_In (Targ_Id, E_Entry, + E_Function, + E_Operator, + E_Procedure) + then + Extra := Empty; + Kind := Call; - elsif Ekind (Target_Id) = E_Procedure then - Output_Call ("procedure"); + else + pragma Assert (False); + Extra := Empty; + Kind := No_Invocation; + end if; + end Get_Invocation_Attributes; - else - pragma Assert (False); - null; - end if; - end Output_Call; + -- Local variables - ------------------- - -- Output_Header -- - ------------------- + Extra : Entity_Id; + Extra_Nam : Name_Id; + IR_Rec : Invocation_Relation_Record; + Kind : Invocation_Kind; + Rel : Invoker_Target_Relation; - procedure Output_Header is - Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); + -- Start of processing for Record_Invocation_Relation begin - if Ekind (Unit_Id) = E_Package then - Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); + Rel.Invoker := Invk_Id; + Rel.Target := Targ_Id; - elsif Ekind (Unit_Id) = E_Package_Body then - Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); + -- Nothing to do when the invocation relation has already been + -- recorded in ALI file of the main unit. - else - Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); + if Is_Saved_Relation (Rel) then + return; end if; - end Output_Header; - -------------------------- - -- Output_Instantiation -- - -------------------------- + -- Mark the relation as recorded in the ALI file - 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. + Set_Is_Saved_Relation (Rel); - -------------------------- - -- Output_Instantiation -- - -------------------------- + -- Declare the invoker in the ALI file - procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is - begin - Error_Msg_NE - ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); - end Output_Instantiation; + Declare_Invocation_Construct + (Constr_Id => Invk_Id, + In_State => In_State); - -- Local variables + -- Obtain the invocation-specific attributes of the relation - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; - Gen_Id : Entity_Id; + Get_Invocation_Attributes (Extra, Kind); - -- Start of processing for Output_Instantiation + -- Certain invocations lack an extra entity used in error diagnostics - begin - Extract_Instantiation_Attributes - (Exp_Inst => N, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + if Present (Extra) then + Extra_Nam := Chars (Extra); + else + Extra_Nam := No_Name; + end if; - Error_Msg_Node_2 := Inst_Id; - Error_Msg_Sloc := Sloc (Inst); + IR_Rec.Extra := Extra_Nam; + IR_Rec.Invoker := Signature_Of (Invk_Id); + IR_Rec.Kind := Kind; + IR_Rec.Target := Signature_Of (Targ_Id); - if Nkind (Inst) = N_Function_Instantiation then - Output_Instantiation (Gen_Id, "function"); + -- Add the relation in the ALI file - elsif Nkind (Inst) = N_Package_Instantiation then - Output_Instantiation (Gen_Id, "package"); + Add_Invocation_Relation + (IR_Rec => IR_Rec, + Update_Units => False); + end Record_Invocation_Relation; - elsif Nkind (Inst) = N_Procedure_Instantiation then - Output_Instantiation (Gen_Id, "procedure"); + ----------------------------------- + -- Record_Simple_Invocation_Path -- + ----------------------------------- - else - pragma Assert (False); - null; - end if; - end Output_Instantiation; + procedure Record_Simple_Invocation_Path + (In_State : Processing_In_State) + is + package Scenarios renames Active_Scenario_Stack; - --------------------------------------- - -- Output_SPARK_Refined_State_Pragma -- - --------------------------------------- + Last_Targ : constant Entity_Id := + Target_Of (Scenarios.Last, In_State); + First_Targ : Entity_Id; - 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; + -- The path originates from the elaboration of the body. Add an extra + -- relation from the elaboration body procedure to the first active + -- scenario. - -------------------------------- - -- Output_Variable_Assignment -- - -------------------------------- + if In_State.Processing = Invocation_Body_Processing then + Build_Elaborate_Body_Procedure; + First_Targ := Elab_Body_Id; - procedure Output_Variable_Assignment (N : Node_Id) is - Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (N)); + -- The path originates from the elaboration of the spec. Add an extra + -- relation from the elaboration spec procedure to the first active + -- scenario. - begin - Error_Msg_Sloc := Sloc (N); - Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); - end Output_Variable_Assignment; + elsif In_State.Processing = Invocation_Spec_Processing then + Build_Elaborate_Spec_Procedure; + First_Targ := Elab_Spec_Id; - ------------------------------- - -- Output_Variable_Reference -- - ------------------------------- + else + First_Targ := Target_Of (Scenarios.First, In_State); + end if; - procedure Output_Variable_Reference (N : Node_Id) is - Dummy : Variable_Attributes; - Var_Id : Entity_Id; + -- Record a single relation from the first to the last scenario - begin - Extract_Variable_Reference_Attributes - (Ref => N, - Var_Id => Var_Id, - Attrs => Dummy); + 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; - Error_Msg_Sloc := Sloc (N); + ---------------------------- + -- Set_Is_Saved_Construct -- + ---------------------------- - if Is_Read (N) then - Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); + procedure Set_Is_Saved_Construct + (Constr : Entity_Id; + Val : Boolean := True) + is + pragma Assert (Present (Constr)); + begin + if Val then + NE_Set.Insert (Saved_Constructs_Set, Constr); else - pragma Assert (False); - null; + NE_Set.Delete (Saved_Constructs_Set, Constr); end if; - end Output_Variable_Reference; + end Set_Is_Saved_Construct; - -- Local variables + --------------------------- + -- Set_Is_Saved_Relation -- + --------------------------- - package Stack renames Scenario_Stack; + 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; - Dummy : Call_Attributes; - N : Node_Id; - Posted : Boolean; - Target_Id : Entity_Id; + ------------------ + -- Signature_Of -- + ------------------ - -- Start of processing for Output_Active_Scenarios + function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id is + Loc : constant Source_Ptr := Sloc (Id); - 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. + 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. - if not Static_Elaboration_Checks then - return; - end if; + function Qualified_Scope return Name_Id; + pragma Inline (Qualified_Scope); + -- Obtain the qualified name of Id's scope - Posted := False; + ----------------------------- + -- Instantiation_Locations -- + ----------------------------- - for Index in Stack.First .. Stack.Last loop - N := Stack.Table (Index); + function Instantiation_Locations return Name_Id is + Buffer : Bounded_String (2052); + Inst : Source_Ptr; + Loc_Nam : Name_Id; + SFI : Source_File_Index; - if not Posted then - Posted := True; - Output_Header; - end if; + begin + SFI := Get_Source_File_Index (Loc); + Inst := Instantiation (SFI); - -- 'Access + -- 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 - if Nkind (N) = N_Attribute_Reference then - Output_Access (N); + if Inst /= No_Location then + loop + Append (Buffer, Nat (Get_Logical_Line_Number (Inst))); + Append (Buffer, '_'); + Append (Buffer, Nat (Get_Column_Number (Inst))); - -- Calls + SFI := Get_Source_File_Index (Inst); + Inst := Instantiation (SFI); - elsif Is_Suitable_Call (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Dummy); + exit when Inst = No_Location; - if Is_Activation_Proc (Target_Id) then - Output_Activation_Call (N); - else - Output_Call (N, Target_Id); - end if; + Append (Buffer, '_'); + end loop; - -- Instantiations + Loc_Nam := Name_Find (Buffer); + return Loc_Nam; - elsif Is_Suitable_Instantiation (N) then - Output_Instantiation (N); + -- Otherwise there no instances are involved - -- Pragma Refined_State + else + return No_Name; + end if; + end Instantiation_Locations; - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Output_SPARK_Refined_State_Pragma (N); + --------------------- + -- Qualified_Scope -- + --------------------- - -- Variable assignments + function Qualified_Scope return Name_Id is + Scop : Entity_Id; - elsif Nkind (N) = N_Assignment_Statement then - Output_Variable_Assignment (N); + begin + Scop := Scope (Id); - -- Variable references + -- 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. - elsif Is_Suitable_Variable_Reference (N) then - Output_Variable_Reference (N); + if Is_Concurrent_Type (Scop) + and then Present (Anonymous_Object (Scop)) + then + Scop := Anonymous_Object (Scop); + end if; - else - pragma Assert (False); - null; - end if; - end loop; - end Output_Active_Scenarios; + return Get_Qualified_Name (Scop); + end Qualified_Scope; - ------------------------- - -- Pop_Active_Scenario -- - ------------------------- + -- Start of processing for Signature_Of - procedure Pop_Active_Scenario (N : Node_Id) is - Top : Node_Id renames Scenario_Stack.Table (Scenario_Stack.Last); + 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; - begin - pragma Assert (Top = N); - Scenario_Stack.Decrement_Last; - end Pop_Active_Scenario; + --------------- + -- Target_Of -- + --------------- - -------------------------------- - -- Process_Activation_Generic -- - -------------------------------- + function Target_Of + (Pos : Active_Scenario_Pos; + In_State : Processing_In_State) return Entity_Id + is + package Scenarios renames Active_Scenario_Stack; - 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. + -- Ensure that the position is within the bounds of the active + -- scenario stack. - procedure Process_Task_Objects (List : List_Id); - -- Perform ABE checks and diagnostics for all task objects found in the - -- list List. + pragma Assert (Scenarios.First <= Pos); + pragma Assert (Pos <= Scenarios.Last); - ------------------------- - -- Process_Task_Object -- - ------------------------- + Scen_Rep : constant Scenario_Rep_Id := + Scenario_Representation_Of + (Scenarios.Table (Pos), In_State); - procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is - Base_Typ : constant Entity_Id := Base_Type (Typ); + begin + -- The true target of an activation call is the current task type + -- rather than routine Activate_Tasks. - Comp_Id : Entity_Id; - Task_Attrs : Task_Attributes; + if Kind (Scen_Rep) = Task_Activation_Scenario then + return Activated_Task_Type (Scen_Rep); + else + return Target (Scen_Rep); + end if; + end Target_Of; - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + ------------------------------ + -- Traverse_Invocation_Body -- + ------------------------------ + procedure Traverse_Invocation_Body + (N : Node_Id; + In_State : Processing_In_State) + is begin - if Is_Task_Type (Typ) then - Extract_Task_Attributes - (Typ => Base_Typ, - Attrs => Task_Attrs); + Traverse_Body + (N => N, + Requires_Processing => Is_Invocation_Scenario'Access, + Processor => Process_Invocation_Scenario'Access, + In_State => In_State); + end Traverse_Invocation_Body; + + --------------------------- + -- Write_Invocation_Path -- + --------------------------- - -- 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. + 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. - 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; + ------------- + -- Targ_Id -- + ------------- - -- Update the state of the Processing phase to indicate that any - -- further traversal is now within a task body. + procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean) is + begin + if not Is_First then + Write_Str (" --> "); + end if; - New_State.Within_Task_Body := True; + Write_Name (Get_Qualified_Name (Targ_Id)); + Write_Eol; + end Write_Target; - Process_Single_Activation - (Call => Call, - Call_Attrs => Call_Attrs, - Obj_Id => Obj_Id, - Task_Attrs => Task_Attrs, - State => New_State); + -- Local variables - -- Examine the component type when the object is an array + package Scenarios renames Active_Scenario_Stack; - elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then - Process_Task_Object - (Obj_Id => Obj_Id, - Typ => Component_Type (Typ)); + First_Seen : Boolean := False; - -- Examine individual component types when the object is a record + -- Start of processing for Write_Invocation_Path - 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 + -- Nothing to do when flag -gnatd_T (output trace information on + -- invocation path recording) is not in effect. - Next_Component (Comp_Id); - end loop; + if not Debug_Flag_Underscore_TT then + return; end if; - end Process_Task_Object; - -------------------------- - -- Process_Task_Objects -- - -------------------------- + -- The path originates from the elaboration of the body. Write the + -- elaboration body procedure. - procedure Process_Task_Objects (List : List_Id) is - Item : Node_Id; - Item_Id : Entity_Id; - Item_Typ : Entity_Id; + if In_State.Processing = Invocation_Body_Processing then + Write_Target (Elab_Body_Id, True); + First_Seen := True; - begin - -- Examine the contents of the list looking for an object declaration - -- of a task type or one that contains a task within. + -- The path originates from the elaboration of the spec. Write the + -- elaboration spec procedure. - Item := First (List); - while Present (Item) loop - if Nkind (Item) = N_Object_Declaration then - Item_Id := Defining_Entity (Item); - Item_Typ := Etype (Item_Id); + elsif In_State.Processing = Invocation_Spec_Processing then + Write_Target (Elab_Spec_Id, True); + First_Seen := True; + end if; - if Has_Task (Item_Typ) then - Process_Task_Object - (Obj_Id => Item_Id, - Typ => Item_Typ); - end if; - end if; + -- Write each individual target invoked by its corresponding scenario + -- on the active scenario stack. - Next (Item); + 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; - end Process_Task_Objects; - - -- Local variables - Context : Node_Id; - Spec : Node_Id; + Write_Eol; + end Write_Invocation_Path; + end Invocation_Graph; - -- Start of processing for Process_Activation_Generic + ------------------------ + -- Is_Safe_Activation -- + ------------------------ + function Is_Safe_Activation + (Call : Node_Id; + Task_Rep : Target_Rep_Id) return Boolean + is begin - -- Nothing to do when the activation is a guaranteed ABE - - if Is_Known_Guaranteed_ABE (Call) then - return; - end if; + -- 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. - -- 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. + return + In_External_Instance + (N => Call, + Target_Decl => Spec_Declaration (Task_Rep)); + end Is_Safe_Activation; - Context := Parent (Call); + ------------------ + -- Is_Safe_Call -- + ------------------ - -- 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. + 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); - if Nkind (Context) = N_Handled_Sequence_Of_Statements - and then Nkind (Parent (Context)) = N_Package_Body - then - Context := Parent (Context); - end if; + 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. - -- Process all task objects defined in both the spec and body when the - -- activation call precedes the "begin" of a package body. + if Is_Bodiless_Subprogram (Subp_Id) then + return True; - if Nkind (Context) = N_Package_Body then - Spec := - Specification - (Unit_Declaration_Node (Corresponding_Spec (Context))); + -- 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. - Process_Task_Objects (Visible_Declarations (Spec)); - Process_Task_Objects (Private_Declarations (Spec)); - Process_Task_Objects (Declarations (Context)); + elsif Is_Generic_Instance (Subp_Id) then + return True; - -- Process all task objects defined in the spec when the activation call - -- appears at the end of a package spec. + -- 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. - elsif Nkind (Context) = N_Package_Specification then - Process_Task_Objects (Visible_Declarations (Context)); - Process_Task_Objects (Private_Declarations (Context)); + elsif In_External_Instance + (N => Call, + Target_Decl => Spec_Decl) + then + return True; - -- 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. + -- The target is a subprogram body without a previous declaration. The + -- call cannot cause an ABE because the body has already been seen. - else - pragma Assert (Nkind (Context) = N_Handled_Sequence_Of_Statements); + elsif Nkind (Spec_Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Spec_Decl)) + then + return True; - Process_Task_Objects (Statements (Context)); - end if; - end Process_Activation_Generic; + -- The target is a subprogram body stub without a prior declaration. + -- The call cannot cause an ABE because the proper body substitutes + -- the stub. - ------------------------------------ - -- Process_Conditional_ABE_Access -- - ------------------------------------ + elsif Nkind (Spec_Decl) = N_Subprogram_Body_Stub + and then No (Corresponding_Spec_Of_Stub (Spec_Decl)) + then + return True; - 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 + -- Subprogram bodies which wrap attribute references used as actuals + -- in instantiations are always ABE-safe. These bodies are artifacts + -- of expansion. - ------------------------- - -- Build_Access_Marker -- - ------------------------- + elsif Present (Body_Decl) + and then Nkind (Body_Decl) = N_Subprogram_Body + and then Was_Attribute_Reference (Body_Decl) + then + return True; + end if; - function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id is - Marker : Node_Id; + return False; + end Is_Safe_Call; - begin - Marker := Make_Call_Marker (Sloc (Attr)); + --------------------------- + -- Is_Safe_Instantiation -- + --------------------------- - -- Inherit relevant attributes from the attribute + 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); - -- Performance note: parent traversal + 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. - 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 Is_Bodiless_Subprogram (Gen_Id) then + return True; - -- Partially insert the call marker into the tree by setting its - -- parent pointer. + -- 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. - Set_Parent (Marker, Attr); + elsif In_External_Instance + (N => Inst, + Target_Decl => Spec_Decl) + then + return True; - return Marker; - end Build_Access_Marker; + -- The generic is a package. The instantiation cannot cause an ABE when + -- the package has no body. - -- Local variables + elsif Ekind (Gen_Id) = E_Generic_Package + and then not Has_Body (Spec_Decl) + then + return True; + end if; - Root : constant Node_Id := Root_Scenario; - Target_Id : constant Entity_Id := Entity (Prefix (Attr)); + return False; + end Is_Safe_Instantiation; - Target_Attrs : Target_Attributes; + ------------------ + -- Is_Same_Unit -- + ------------------ - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + 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; - -- Start of processing for Process_Conditional_ABE_Access + ------------------------------- + -- Kill_Elaboration_Scenario -- + ------------------------------- + procedure Kill_Elaboration_Scenario (N : Node_Id) is begin - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + -- 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 Elab_Info_Messages then - Error_Msg_NE - ("info: access to & during elaboration", Attr, Target_Id); + if Legacy_Elaboration_Checks then + return; end if; - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); - - -- 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. - - 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; - - -- Do not emit any ABE diagnostics when the current or previous scenario - -- in this traversal has suppressed elaboration warnings. - - if New_State.Suppress_Warnings then - null; - - -- 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) - 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); + -- Eliminate a recorded scenario when it appears within dead code + -- because it will not be executed at elaboration time. - Output_Active_Scenarios (Attr); + if Is_Scenario (N) then + Delete_Scenario (N); end if; + end Kill_Elaboration_Scenario; - -- 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. - - if Debug_Flag_Dot_O then - Process_Conditional_ABE - (N => Build_Access_Marker (Target_Id), - State => New_State); - - -- Otherwise ensure that the unit with the corresponding body is - -- elaborated prior to the main unit. + ---------------------- + -- 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 - Ensure_Prior_Elaboration - (N => Attr, - Unit_Id => Target_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - State => New_State); + return Typ; 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; + end Non_Private_View; - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + --------------------------------- + -- Record_Elaboration_Scenario -- + --------------------------------- - begin - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + 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. - if Elab_Info_Messages then - Error_Msg_NE - ("info: activation of & during elaboration", Call, Obj_Id); - end if; + 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 - -- 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. + ------------------------------ + -- Check_Preelaborated_Call -- + ------------------------------ - if Debug_Flag_Underscore_I - and then In_External_Instance - (N => Call, - Target_Decl => Task_Attrs.Task_Decl) - then - return; + 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. - -- Nothing to do when the activation is a guaranteed ABE + if not Is_Source_Call (Call) then + return; - elsif Is_Known_Guaranteed_ABE (Call) then - return; + -- Library-level calls are always considered because they are part of + -- the associated unit's elaboration actions. - -- 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 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 Call_Lvl in Library_Level then + null; - -- Performance note: parent traversal + -- 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. - elsif Is_Up_Level_Target (Task_Attrs.Task_Decl) then - return; + elsif Call_Lvl = Generic_Body_Level then + null; - -- 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; - -- -- safe activation - -- end Nested; - -- ... + -- Otherwise the call does not appear at the proper level and must + -- not be considered for this check. - elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then + else + return; + end if; - -- Note that the task body must still be examined for any nested - -- scenarios. + -- The call appears within a preelaborated unit. Emit a warning only + -- for internal uses, otherwise this is an error. - null; + if In_Preelaborated_Context (Call) then + Error_Msg_Warn := GNAT_Mode; + Error_Msg_N + ("< Call, - Ins_Nod => Call, - Target_Id => Task_Attrs.Spec_Id, - Target_Decl => Task_Attrs.Task_Decl, - Target_Body => Task_Attrs.Body_Decl); + -- Add 'Access to the appropriate set - -- 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 - -- - -- 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. + if Attr_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Attr); - New_State.Suppress_Implicit_Pragmas := True; - end if; + elsif Attr_Lvl = Library_Spec_Level + or else Attr_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Attr); 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. + -- 'Access requires a conditional ABE check when the dynamic model is + -- in effect. - elsif Dynamic_Elaboration_Checks and then Check_OK then - Install_ABE_Check - (N => Call, - Ins_Nod => Call, - Id => Task_Attrs.Unit_Id); - end if; + Add_Dynamic_ABE_Check_Scenario (Attr); + end Record_Access_Taken; - -- 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. + ------------------------------------ + -- Record_Call_Or_Task_Activation -- + ------------------------------------ - if Call_Attrs.SPARK_Mode_On and Task_Attrs.SPARK_Mode_On then - null; + 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. - -- Otherwise the Ada rules are in effect. Ensure that the unit with the - -- task body is elaborated prior to the main unit. + Possible_Local_Raise (Call, Standard_Program_Error); - else - Ensure_Prior_Elaboration + -- 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 + -- 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 Is_Suitable_Call (Scen) then + Check_Preelaborated_Call (Scen, Scen_Lvl); + end if; + + -- Nothing to do when the scenario does not appear within the main unit + + if not In_Main_Context (Scen) then return; - -- Nothing to do when the call is a guaranteed ABE + -- Nothing to do when the scenario appears within a generic - elsif Is_Known_Guaranteed_ABE (Call) then + elsif Inside_A_Generic then return; - -- 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. + -- 'Access - -- Performance note: parent traversal + elsif Is_Suitable_Access_Taken (Scen) then + Record_Access_Taken + (Attr => Scen, + Attr_Lvl => Scen_Lvl); - elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then - return; - end if; + -- Call or task activation + + elsif Is_Suitable_Call (Scen) then + Record_Call_Or_Task_Activation + (Call => Scen, + Call_Lvl => Scen_Lvl); + + -- Derived type declaration + + elsif Is_Suitable_SPARK_Derived_Type (Scen) then + Add_SPARK_Scenario (Scen); + + -- Instantiation + + elsif Is_Suitable_Instantiation (Scen) then + Record_Instantiation + (Inst => Scen, + Inst_Lvl => Scen_Lvl); - -- 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. + -- Refined_State pragma - New_State.Suppress_Warnings := - New_State.Suppress_Warnings - or else not Call_Attrs.Elab_Warnings_OK - or else not Target_Attrs.Elab_Warnings_OK; + elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then + Add_SPARK_Scenario (Scen); - -- 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. + -- Variable assignment - New_State.Within_Initial_Condition := - New_State.Within_Initial_Condition - or else Is_Initial_Condition_Proc (Target_Id); + elsif Is_Suitable_Variable_Assignment (Scen) then + Record_Variable_Assignment + (Asmt => Scen, + Asmt_Lvl => Scen_Lvl); - -- 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. + -- Variable reference - New_State.Within_Partial_Finalization := - New_State.Within_Partial_Finalization - or else Is_Partial_Finalization_Proc; + elsif Is_Suitable_Variable_Reference (Scen) then + Record_Variable_Reference + (Ref => Scen, + Ref_Lvl => Scen_Lvl); + end if; + end Record_Elaboration_Scenario; + + -------------- + -- Scenario -- + -------------- + + function Scenario (N : Node_Id) return Node_Id is + Orig_N : constant Node_Id := Original_Node (N); - -- 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. + begin + -- 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 SPARK_Rules_On then - Process_Conditional_ABE_Call_SPARK - (Call => Call, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs, - State => New_State); + if Nkind (Orig_N) in N_Generic_Instantiation then + return Orig_N; - -- Otherwise the Ada rules are in effect + -- Otherwise the scenario is already in its proper form else - Process_Conditional_ABE_Call_Ada - (Call => Call, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs, - State => New_State); + return N; end if; + end Scenario; - -- Inspect the target body (and barried function) for other suitable - -- elaboration scenarios. + ---------------------- + -- Scenario_Storage -- + ---------------------- - Traverse_Body - (N => Target_Attrs.Body_Barf, - State => New_State); + package body Scenario_Storage is + + --------------------- + -- Data structures -- + --------------------- - Traverse_Body - (N => Target_Attrs.Body_Decl, - State => New_State); - end Process_Conditional_ABE_Call; + -- The following sets store all scenarios - -------------------------------------- - -- Process_Conditional_ABE_Call_Ada -- - -------------------------------------- + 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); - 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. + ------------------------------- + -- Finalize_Scenario_Storage -- + ------------------------------- - Root : constant Node_Id := Root_Scenario; + 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; - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + ------------------------------ + -- Add_Declaration_Scenario -- + ------------------------------ - 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. + procedure Add_Declaration_Scenario (N : Node_Id) is + pragma Assert (Present (N)); + begin + NE_Set.Insert (Declaration_Scenarios, N); + end Add_Declaration_Scenario; - if Call_Attrs.Is_Dispatching then - return; + ------------------------------------ + -- Add_Dynamic_ABE_Check_Scenario -- + ------------------------------------ - -- 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 - -- ... + procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id) is + pragma Assert (Present (N)); - elsif Is_Safe_Call (Call, Target_Attrs) then - return; + begin + if not Check_Or_Failure_Generation_OK then + return; - -- The call and the target body are both in the main unit + -- Nothing to do if the dynamic model is not in effect - 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. + elsif not Dynamic_Elaboration_Checks then + return; + end if; - if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then + NE_Set.Insert (Dynamic_ABE_Check_Scenarios, N); + end Add_Dynamic_ABE_Check_Scenario; - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + ------------------------------- + -- Add_Library_Body_Scenario -- + ------------------------------- - if State.Suppress_Warnings then - null; + 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; - -- Do not emit any ABE diagnostics when the call occurs in a - -- partial finalization context because this leads to confusing - -- noise. + ------------------------------- + -- Add_Library_Spec_Scenario -- + ------------------------------- - elsif State.Within_Partial_Finalization then - null; + 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; - -- 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_SPARK_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_SPARK_Scenario (N : Node_Id) is + pragma Assert (Present (N)); + begin + NE_Set.Insert (SPARK_Scenarios, N); + end Add_SPARK_Scenario; - Output_Active_Scenarios (Call); - end if; + --------------------- + -- Delete_Scenario -- + --------------------- - -- Install a conditional run-time ABE check to verify that the - -- target body has been elaborated prior to the call. + procedure Delete_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 + -- Delete the scenario from whichever set it belongs to - -- 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 - -- - -- 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. + 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; - New_State.Suppress_Implicit_Pragmas := True; - end if; - end if; + ----------------------------------- + -- Iterate_Declaration_Scenarios -- + ----------------------------------- - -- 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. + function Iterate_Declaration_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Declaration_Scenarios); + end Iterate_Declaration_Scenarios; - elsif Dynamic_Elaboration_Checks and then Check_OK then - Install_ABE_Check - (N => Call, - Ins_Nod => Call, - Id => Target_Attrs.Unit_Id); - end if; + ----------------------------------------- + -- Iterate_Dynamic_ABE_Check_Scenarios -- + ----------------------------------------- - -- 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. + 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; - 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; + ------------------------------------ + -- Iterate_Library_Body_Scenarios -- + ------------------------------------ - ---------------------------------------- - -- Process_Conditional_ABE_Call_SPARK -- - ---------------------------------------- + function Iterate_Library_Body_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Library_Body_Scenarios); + end Iterate_Library_Body_Scenarios; - procedure Process_Conditional_ABE_Call_SPARK - (Call : Node_Id; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - State : Processing_Attributes) - is - Region : Node_Id; + ------------------------------------ + -- Iterate_Library_Spec_Scenarios -- + ------------------------------------ - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + function Iterate_Library_Spec_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Library_Spec_Scenarios); + end Iterate_Library_Spec_Scenarios; - Check_SPARK_Model_In_Effect (Call); + ----------------------------- + -- Iterate_SPARK_Scenarios -- + ----------------------------- - -- The call and the target body are both in the main unit + function Iterate_SPARK_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (SPARK_Scenarios); + end Iterate_SPARK_Scenarios; - 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 - -- - -- --+ - -- ... | early call region - -- --+ - -- - -- 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. - -- - -- --+ - -- | - -- function B ...; | - -- | - -- function A ... is | - -- begin | early call region - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; | - -- | - -- --+ - -- - -- 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: - -- - -- - -- function B ...; - -- - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; - -- ... - -- end 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. + ---------------------- + -- Replace_Scenario -- + ---------------------- + + 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. + + ------------------------- + -- Replace_Scenario_In -- + ------------------------- - if Earlier_In_Extended_Unit (Call, Target_Attrs.Body_Decl) then + 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. - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + 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; - if State.Suppress_Warnings then - null; + -- Start of processing for Replace_Scenario - -- Do not emit any ABE diagnostics when the call occurs in an - -- initial condition context because this leads to incorrect - -- diagnostics. + 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; - elsif State.Within_Initial_Condition then - null; + --------------- + -- Semantics -- + --------------- - -- Do not emit any ABE diagnostics when the call occurs in a - -- partial finalization context because this leads to confusing - -- noise. + package body Semantics is - elsif State.Within_Partial_Finalization then - null; + -------------------------------- + -- Is_Accept_Alternative_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_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a procedure with a receiving + -- entry. - elsif Static_Elaboration_Checks then + return + Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); + end Is_Accept_Alternative_Proc; - -- Ensure that a call which textually precedes the subprogram - -- body it invokes appears within the early call region of the - -- subprogram body. + ------------------------ + -- Is_Activation_Proc -- + ------------------------ - -- 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 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. - Region := Find_Early_Call_Region (Target_Attrs.Body_Decl); + 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; - 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); + return False; + end Is_Activation_Proc; - Error_Msg_Sloc := Sloc (Region); - Error_Msg_N ("\region starts #", Call); + ---------------------------- + -- Is_Ada_Semantic_Target -- + ---------------------------- - Error_Msg_Sloc := Sloc (Target_Attrs.Body_Decl); - Error_Msg_N ("\region ends #", Call); + 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; - Output_Active_Scenarios (Call); - end if; - end if; + -------------------------------- + -- Is_Assertion_Pragma_Target -- + -------------------------------- - -- 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. + 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; - else - null; + ---------------------------- + -- Is_Bodiless_Subprogram -- + ---------------------------- + + function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is + begin + -- An abstract subprogram does not have a body + + if Ekind_In (Subp_Id, E_Function, + E_Operator, + E_Procedure) + and then Is_Abstract_Subprogram (Subp_Id) + then + return True; + + -- A formal subprogram does not have a body + + elsif Is_Formal_Subprogram (Subp_Id) then + return True; + + -- 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_Imported (Subp_Id) then + return True; 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. + return False; + end Is_Bodiless_Subprogram; + + ---------------------- + -- 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_Controlled_Proc -- + ------------------------ - -- 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. + function Is_Controlled_Proc + (Subp_Id : Entity_Id; + Subp_Nam : Name_Id) return Boolean + is + Formal_Id : Entity_Id; + + begin + pragma Assert (Nam_In (Subp_Nam, Name_Adjust, + Name_Finalize, + Name_Initialize)); + + -- To qualify, the subprogram must denote a source procedure with + -- name Adjust, Finalize, or Initialize where the sole formal is + -- controlled. - 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) + if Comes_From_Source (Subp_Id) + and then Ekind (Subp_Id) = E_Procedure + and then Chars (Subp_Id) = Subp_Nam then - Meet_Elaboration_Requirement - (N => Call, - Target_Id => Target_Id, - Req_Nam => Name_Elaborate_All); + Formal_Id := First_Formal (Subp_Id); + + return + Present (Formal_Id) + and then Is_Controlled (Etype (Formal_Id)) + and then No (Next_Formal (Formal_Id)); end if; - -- Otherwise ensure that the unit with the target body is elaborated - -- prior to the main unit. + return False; + end Is_Controlled_Proc; - 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; + --------------------------------------- + -- Is_Default_Initial_Condition_Proc -- + --------------------------------------- - ------------------------------------------- - -- Process_Conditional_ABE_Instantiation -- - ------------------------------------------- + function Is_Default_Initial_Condition_Proc + (Id : Entity_Id) return Boolean + is + begin + -- To qualify, the entity must denote a Default_Initial_Condition + -- procedure. - 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; + return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); + end Is_Default_Initial_Condition_Proc; - SPARK_Rules_On : Boolean; - -- This flag is set when the SPARK rules are in effect + ----------------------- + -- Is_Finalizer_Proc -- + ----------------------- - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a _Finalizer procedure - begin - Extract_Instantiation_Attributes - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; + end Is_Finalizer_Proc; - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + ------------------------------- + -- Is_Initial_Condition_Proc -- + ------------------------------- - -- The SPARK rules are in effect when both the instantiation and generic - -- are subject to SPARK_Mode On. + function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an Initial_Condition procedure - SPARK_Rules_On := Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; + return + Ekind (Id) = E_Procedure + and then Is_Initial_Condition_Procedure (Id); + end Is_Initial_Condition_Proc; - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + -------------------- + -- Is_Initialized -- + -------------------- - 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_Initialized (Obj_Decl : Node_Id) return Boolean is + begin + -- To qualify, the object declaration must have an expression - -- Nothing to do when the instantiation is a guaranteed ABE + return + Present (Expression (Obj_Decl)) + or else Has_Init_Expression (Obj_Decl); + end Is_Initialized; - if Is_Known_Guaranteed_ABE (Inst) then - return; + ----------------------- + -- Is_Invariant_Proc -- + ----------------------- - -- 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. + function Is_Invariant_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote the "full" invariant procedure - -- Performance note: parent traversal + return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); + end Is_Invariant_Proc; - elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then - return; - end if; + --------------------------------------- + -- Is_Non_Library_Level_Encapsulator -- + --------------------------------------- - -- 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. + 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; - New_State.Suppress_Warnings := - New_State.Suppress_Warnings or else not Inst_Attrs.Elab_Warnings_OK; + when others => + return Is_Generic_Declaration_Or_Body (N); + end case; + end Is_Non_Library_Level_Encapsulator; - -- The SPARK rules are in effect + ------------------------------- + -- Is_Partial_Invariant_Proc -- + ------------------------------- - if SPARK_Rules_On then - Process_Conditional_ABE_Instantiation_SPARK - (Inst => Inst, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs, - State => New_State); + function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote the "partial" invariant + -- procedure. - -- Otherwise the Ada rules are in effect, or SPARK code is allowed to - -- violate the SPARK rules. + return + Ekind (Id) = E_Procedure + and then Is_Partial_Invariant_Procedure (Id); + end Is_Partial_Invariant_Proc; - 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. + ---------------------------- + -- Is_Postconditions_Proc -- + ---------------------------- - Root : constant Node_Id := Root_Scenario; + function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a _Postconditions procedure - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + return + Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; + end Is_Postconditions_Proc; - 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 - -- ... + --------------------------- + -- Is_Preelaborated_Unit -- + --------------------------- - if Is_Safe_Instantiation (Inst, Gen_Attrs) then - return; + 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. - -- The instantiation and the generic body are both in the main unit + return + Is_Entry (Id) + and then Is_Protected_Type (Non_Private_View (Scope (Id))); + end Is_Protected_Entry; - 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. + ----------------------- + -- Is_Protected_Subp -- + ----------------------- - if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then + function Is_Protected_Subp (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a subprogram defined within a + -- protected type. - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + return + Ekind_In (Id, E_Function, E_Procedure) + and then Is_Protected_Type (Non_Private_View (Scope (Id))); + end Is_Protected_Subp; - if State.Suppress_Warnings then - null; + ---------------------------- + -- Is_Protected_Body_Subp -- + ---------------------------- - -- Do not emit any ABE diagnostics when the instantiation occurs - -- in partial finalization context because this leads to unwanted - -- noise. + 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. - elsif State.Within_Partial_Finalization then - null; + return + Ekind_In (Id, E_Function, E_Procedure) + and then Present (Protected_Subprogram (Id)); + end Is_Protected_Body_Subp; - -- 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. + ----------------- + -- Is_Scenario -- + ----------------- - 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); + 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; - Output_Active_Scenarios (Inst); - end if; + when others => + return False; + end case; + end Is_Scenario; - -- Install a conditional run-time ABE check to verify that the - -- generic body has been elaborated prior to the instantiation. + ------------------------------ + -- Is_SPARK_Semantic_Target -- + ------------------------------ - 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); + 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; - -- 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 - -- - -- 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_Subprogram_Inst -- + ------------------------ - New_State.Suppress_Implicit_Pragmas := True; - end if; - end if; + 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. - -- 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_In (Id, E_Function, E_Procedure) + and then Is_Hidden (Id) + and then Is_Generic_Instance (Id); + end Is_Subprogram_Inst; - 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_Suitable_Access_Taken -- + ------------------------------ - -- 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_Suitable_Access_Taken (N : Node_Id) return Boolean is + Nam : Name_Id; + Pref : Node_Id; + Subp_Id : Entity_Id; - 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; + begin + -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect - ------------------------------------------------- - -- Process_Conditional_ABE_Instantiation_SPARK -- - ------------------------------------------------- + if Debug_Flag_Dot_UU then + return False; - 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; + -- Nothing to do when the scenario is not an attribute reference - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + elsif Nkind (N) /= N_Attribute_Reference then + return False; - Check_SPARK_Model_In_Effect (Inst); + -- Nothing to do for internally-generated attributes because they are + -- assumed to be ABE safe. - -- 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. + elsif not Comes_From_Source (N) then + return False; + end if; - -- 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. + Nam := Attribute_Name (N); + Pref := Prefix (N); - 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; + -- Sanitize the prefix of the attribute - Meet_Elaboration_Requirement - (N => Inst, - Target_Id => Gen_Id, - Req_Nam => Req_Nam); + if not Is_Entity_Name (Pref) then + return False; - -- Otherwise ensure that the unit with the target body is elaborated - -- prior to the main unit. + elsif No (Entity (Pref)) then + return False; + end if; - 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; + Subp_Id := Entity (Pref); - ------------------------------------------------- - -- Process_Conditional_ABE_Variable_Assignment -- - ------------------------------------------------- + if not Is_Subprogram_Or_Entry (Subp_Id) then + return False; + end if; - 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); + -- Traverse a possible chain of renamings to obtain the original + -- entry or subprogram which the prefix may rename. - SPARK_Rules_On : Boolean; - -- This flag is set when the SPARK rules are in effect + Subp_Id := Get_Renamed_Entity (Subp_Id); - begin - -- The SPARK rules are in effect when both the assignment and the - -- variable are subject to SPARK_Mode On. + -- To qualify, the attribute must meet the following prerequisites: - SPARK_Rules_On := - Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On - and then Is_SPARK_Mode_On_Node (Asmt); + return - -- 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 => "assignment to & during elaboration", - N => Asmt, - Id => Var_Id, - Info_Msg => True, - In_SPARK => SPARK_Rules_On); - end if; + Comes_From_Source (Subp_Id) + and then Is_Subprogram_Or_Entry (Subp_Id) + and then not Is_Bodiless_Subprogram (Subp_Id) - -- 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. + -- The attribute name must be one of the 'Access forms. Note that + -- 'Unchecked_Access cannot apply to a subprogram. - if SPARK_Rules_On then - Process_Conditional_ABE_Variable_Assignment_SPARK - (Asmt => Asmt, - Var_Id => Var_Id); + and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); + end Is_Suitable_Access_Taken; - -- Otherwise the Ada rules are in effect + ---------------------- + -- Is_Suitable_Call -- + ---------------------- - else - Process_Conditional_ABE_Variable_Assignment_Ada - (Asmt => Asmt, - Var_Id => Var_Id); - end if; - end Process_Conditional_ABE_Variable_Assignment; + 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. - ----------------------------------------------------- - -- Process_Conditional_ABE_Variable_Assignment_Ada -- - ----------------------------------------------------- + return Nkind (N) = N_Call_Marker; + end Is_Suitable_Call; - 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); + ------------------------------- + -- Is_Suitable_Instantiation -- + ------------------------------- - 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. + function Is_Suitable_Instantiation (N : Node_Id) return Boolean is + Inst : constant Node_Id := Scenario (N); - 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); + begin + -- To qualify, the instantiation must come from source - Error_Msg_NE - ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " - & "initialization", Asmt, Spec_Id); + return + Comes_From_Source (Inst) + and then Nkind (Inst) in N_Generic_Instantiation; + end Is_Suitable_Instantiation; - Output_Active_Scenarios (Asmt); + ------------------------------------ + -- Is_Suitable_SPARK_Derived_Type -- + ------------------------------------ - -- Generate an implicit Elaborate_Body in the spec + function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is + Prag : Node_Id; + Typ : Entity_Id; - Set_Elaborate_Body_Desirable (Spec_Id); - end if; - end Process_Conditional_ABE_Variable_Assignment_Ada; + begin + -- To qualify, the type declaration must denote a derived tagged type + -- with primitive operations, subject to pragma SPARK_Mode On. - ------------------------------------------------------- - -- Process_Conditional_ABE_Variable_Assignment_SPARK -- - ------------------------------------------------------- + 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 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); + 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 - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + return False; + end Is_Suitable_SPARK_Derived_Type; - Check_SPARK_Model_In_Effect (Asmt); + ------------------------------------- + -- Is_Suitable_SPARK_Instantiation -- + ------------------------------------- - -- 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. + function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is + Inst : constant Node_Id := Scenario (N); - 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); + Gen_Id : Entity_Id; + Prag : Node_Id; - Error_Msg_NE - ("\add pragma ""Elaborate_Body"" to spec & to ensure full " - & "initialization", Asmt, Spec_Id); + begin + -- To qualify, both the instantiation and the generic must be subject + -- to SPARK_Mode On. - Output_Active_Scenarios (Asmt); - end if; - end Process_Conditional_ABE_Variable_Assignment_SPARK; + if Is_Suitable_Instantiation (N) then + Gen_Id := Instantiated_Generic (Inst); + Prag := SPARK_Pragma (Gen_Id); - ------------------------------------------------ - -- Process_Conditional_ABE_Variable_Reference -- - ------------------------------------------------ + return + Is_SPARK_Mode_On_Node (Inst) + and then Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On; + end if; - procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id) is - Var_Attrs : Variable_Attributes; - Var_Id : Entity_Id; + return False; + end Is_Suitable_SPARK_Instantiation; - 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; + -------------------------------------------- + -- Is_Suitable_SPARK_Refined_State_Pragma -- + -------------------------------------------- - ----------------------------------------------------- - -- Process_Conditional_ABE_Variable_Reference_Read -- - ----------------------------------------------------- + function Is_Suitable_SPARK_Refined_State_Pragma + (N : Node_Id) return Boolean + is + begin + -- To qualfy, the pragma must denote Refined_State - 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. + 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; - 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; + begin + -- Nothing to do when the scenario is not an assignment - -- Nothing to do when the variable appears within the main unit because - -- diagnostics on reads are relevant only for external variables. + if Nkind (N) /= N_Assignment_Statement then + return False; - if Is_Same_Unit (Attrs.Unit_Id, Cunit_Entity (Main_Unit)) then - null; + -- Nothing to do for internally-generated assignments because they + -- are assumed to be ABE safe. - -- Nothing to do when the variable is already initialized. Note that the - -- variable may be further modified by the external unit. + elsif not Comes_From_Source (N) then + return False; - elsif Is_Initialized (Declaration_Node (Var_Id)) then - null; + -- Assignments are ignored in GNAT mode on the assumption that + -- they are ABE-safe. This behaviour parallels that of the old + -- ABE mechanism. - -- Nothing to do when the external unit guarantees the initialization of - -- the variable by means of pragma Elaborate_Body. + elsif GNAT_Mode then + return False; + end if; - elsif Has_Pragma_Elaborate_Body (Attrs.Unit_Id) then - null; + Nam := Assignment_Target (N); - -- 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. + -- Sanitize the left hand side of the assignment - else - Meet_Elaboration_Requirement - (N => Ref, - Target_Id => Var_Id, - Req_Nam => Name_Elaborate); - end if; - end Process_Conditional_ABE_Variable_Reference_Read; + if not Is_Entity_Name (Nam) then + return False; - ----------------------------- - -- Process_Conditional_ABE -- - ----------------------------- + elsif No (Entity (Nam)) then + return False; + end if; - -- 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. + Var_Id := Entity (Nam); - procedure Process_Conditional_ABE - (N : Node_Id; - State : Processing_Attributes := Initial_State) - is - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; + -- Sanitize the variable - begin - -- Add the current scenario to the stack of active scenarios + if Var_Id = Any_Id then + return False; - Push_Active_Scenario (N); + elsif Ekind (Var_Id) /= E_Variable then + return False; + end if; - -- 'Access + Var_Decl := Declaration_Node (Var_Id); - if Is_Suitable_Access (N) then - Process_Conditional_ABE_Access - (Attr => N, - State => State); + if Nkind (Var_Decl) /= N_Object_Declaration then + return False; + end if; - -- Activations and calls + N_Unit_Id := Find_Top_Unit (N); + N_Unit := Unit_Declaration_Node (N_Unit_Id); - elsif Is_Suitable_Call (N) then + Var_Unit_Id := Find_Top_Unit (Var_Decl); + Var_Unit := Unit_Declaration_Node (Var_Unit_Id); - -- 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. + -- To qualify, the assignment must meet the following prerequisites: - if In_Main_Context (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); + return + Comes_From_Source (Var_Id) - if Is_Activation_Proc (Target_Id) then - Process_Conditional_ABE_Activation - (Call => N, - Call_Attrs => Call_Attrs, - State => State); + -- The variable must be declared in the spec of compilation unit + -- U. - else - Process_Conditional_ABE_Call - (Call => N, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - State => State); - end if; - end if; + and then Nkind (Var_Unit) = N_Package_Declaration + and then Find_Enclosing_Level (Var_Decl) = Library_Spec_Level - -- Instantiations + -- The assignment must occur in the body of compilation unit U - elsif Is_Suitable_Instantiation (N) then - Process_Conditional_ABE_Instantiation - (Exp_Inst => N, - State => State); + 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; - -- Variable assignments + ------------------------------------ + -- Is_Suitable_Variable_Reference -- + ------------------------------------ - elsif Is_Suitable_Variable_Assignment (N) then - Process_Conditional_ABE_Variable_Assignment (N); + 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. - -- Variable references + return Nkind (N) = N_Variable_Reference_Marker; + end Is_Suitable_Variable_Reference; - elsif Is_Suitable_Variable_Reference (N) then + ------------------- + -- Is_Task_Entry -- + ------------------- - -- 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. + function Is_Task_Entry (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an entry defined in a task type - if In_Main_Context (N) then - Process_Conditional_ABE_Variable_Reference (N); - end if; - end if; + return + Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); + end Is_Task_Entry; - -- Remove the current scenario from the stack of active scenarios once - -- all ABE diagnostics and checks have been performed. + ------------------------ + -- Is_Up_Level_Target -- + ------------------------ - Pop_Active_Scenario (N); - end Process_Conditional_ABE; + 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); - -------------------------------------------- - -- Process_Guaranteed_ABE_Activation_Impl -- - -------------------------------------------- + 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. - 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); + 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 - 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 In_Extended_Main_Code_Unit (Targ_Decl) then + return not In_Same_Context (Root, Targ_Decl, Nested_OK => True); - 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 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. + -- Otherwise the target is external to the main unit which makes + -- it an up-level target. - -- Performance note: parent traversal + else + return True; + end if; + end if; - if Is_Up_Level_Target (Task_Attrs.Task_Decl) then - return; + return False; + end Is_Up_Level_Target; + end Semantics; - -- 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; + --------------------- + -- SPARK_Processor -- + --------------------- - -- 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; - -- -- guaranteed ABE - -- end Nested; - -- - -- task body Task_Typ is - -- ... - -- end Task_Typ; - -- ... + package body SPARK_Processor is - -- Performance note: parent traversal + ----------------------- + -- Local subprograms -- + ----------------------- - 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); - end if; + 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)); - -- Mark the activation call as a guaranteed ABE + begin + -- Do not emit the warning multiple times as this creates useless + -- noise. - Set_Is_Known_Guaranteed_ABE (Call); + if SPARK_Model_Warning_Posted then + null; - -- Install a run-time ABE failue because this activation call will - -- always result in an ABE. + -- SPARK rule verification requires the "strict" static model - if Check_OK then - Install_ABE_Failure - (N => Call, - Ins_Nod => Call); - end if; - end if; - end Process_Guaranteed_ABE_Activation_Impl; + elsif Static_Elaboration_Checks + and not Relaxed_Elaboration_Checks + then + null; - procedure Process_Guaranteed_ABE_Activation is - new Process_Activation_Generic (Process_Guaranteed_ABE_Activation_Impl); + -- 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. - --------------------------------- - -- Process_Guaranteed_ABE_Call -- - --------------------------------- + else + SPARK_Model_Warning_Posted := True; - procedure Process_Guaranteed_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id) - is - Target_Attrs : Target_Attributes; + Error_Msg_N + ("??SPARK elaboration checks require static elaboration model", + Spec_Id); - begin - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); + if Dynamic_Elaboration_Checks then + Error_Msg_N + ("\dynamic elaboration model is in effect", Spec_Id); - -- 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. + 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; - -- Performance note: parent traversal + --------------------------- + -- Check_SPARK_Scenarios -- + --------------------------- - if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then - return; + procedure Check_SPARK_Scenarios is + Iter : NE_Set.Iterator; + N : Node_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 - -- ... + begin + Iter := Iterate_SPARK_Scenarios; + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - elsif Is_Safe_Call (Call, Target_Attrs) then - return; + Process_SPARK_Scenario + (N => N, + In_State => SPARK_State); + end loop; + end Check_SPARK_Scenarios; - -- 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; - -- ... + -------------------------------- + -- Process_SPARK_Derived_Type -- + -------------------------------- - -- Performance note: parent traversal + 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; - 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; + begin + -- Nothing to do for predefined primitives because they are + -- artifacts of tagged type expansion and cannot override source + -- primitives. - -- Mark the call as a guarnateed ABE + if Is_Predefined_Dispatching_Operation (Prim) then + return; + end if; - Set_Is_Known_Guaranteed_ABE (Call); + Body_Id := Corresponding_Body (Prim_Decl); - -- 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. + -- 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 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); - end if; - end if; - end Process_Guaranteed_ABE_Call; + if No (Body_Id) then + return; - ------------------------------------------ - -- Process_Guaranteed_ABE_Instantiation -- - ------------------------------------------ + -- The primitive overrides a parent or progenitor primitive - 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; + elsif Present (Overridden_Operation (Prim)) then - begin - Extract_Instantiation_Attributes - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + -- 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. - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + if Present (Alias (Prim)) then + return; + end if; - -- 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. + -- 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. - -- Performance note: parent traversal + else + return; + end if; - if Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then - return; + Body_Decl := Unit_Declaration_Node (Body_Id); + Region := Find_Early_Call_Region (Body_Decl); - -- 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 - -- ... + -- The freeze node appears prior to the early call region of the + -- primitive body. - elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then - return; + -- 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. - -- 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; - -- ... + 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); - -- Performance note: parent traversal + Error_Msg_Sloc := Sloc (Region); + Error_Msg_N ("\region starts #", Typ_Decl); - 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); - end if; + Error_Msg_Sloc := Sloc (Body_Decl); + Error_Msg_N ("\region ends #", Typ_Decl); - -- Mark the instantiation as a guarantee ABE. This automatically - -- suppresses the instantiation of the generic body. + Error_Msg_Sloc := Freeze_Node_Location (FNode); + Error_Msg_N ("\first freezing point #", Typ_Decl); - Set_Is_Known_Guaranteed_ABE (Inst); + -- If applicable, suggest the use of pragma Elaborate_Body in + -- the associated package spec. - -- 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. + Suggest_Elaborate_Body + (N => FNode, + Body_Decl => Body_Decl, + Error_Nod => Typ_Decl); - 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; + raise Stop_Check; + end if; + end Check_Overriding_Primitive; - ---------------------------- - -- Process_Guaranteed_ABE -- - ---------------------------- + -------------------------- + -- Freeze_Node_Location -- + -------------------------- - -- 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. + function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is + Context : constant Node_Id := Parent (FNode); + Loc : constant Source_Ptr := Sloc (FNode); - procedure Process_Guaranteed_ABE (N : Node_Id) is - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; + Prv_Decls : List_Id; + Vis_Decls : List_Id; - begin - -- Add the current scenario to the stack of active scenarios + 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. - Push_Active_Scenario (N); + if Nkind (Context) = N_Package_Specification then + Prv_Decls := Private_Declarations (Context); + Vis_Decls := Visible_Declarations (Context); - -- Only calls, instantiations, and task activations may result in a - -- guaranteed ABE. + -- The freeze node appears in the private declarations of the + -- package. - if Is_Suitable_Call (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); + if Present (Prv_Decls) + and then List_Containing (FNode) = Prv_Decls + then + null; - if Is_Activation_Proc (Target_Id) then - Process_Guaranteed_ABE_Activation - (Call => N, - Call_Attrs => Call_Attrs, - State => Initial_State); + -- The freeze node appears in the visible declarations of the + -- package and there are no private declarations. - else - Process_Guaranteed_ABE_Call - (Call => N, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id); - end if; + 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 Is_Suitable_Instantiation (N) then - Process_Guaranteed_ABE_Instantiation (N); - end if; + -- Otherwise the freeze node is not in the "last" declarative + -- list of the package. Use the existing source location of the + -- freeze node. - -- Remove the current scenario from the stack of active scenarios once - -- all ABE diagnostics and checks have been performed. + else + return Loc; + end if; - Pop_Active_Scenario (N); - end Process_Guaranteed_ABE; + -- 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. - -------------------------- - -- Push_Active_Scenario -- - -------------------------- + if not Precedes_Source_Construct (FNode) then + return Sloc (End_Label (Context)); + end if; + end if; - procedure Push_Active_Scenario (N : Node_Id) is - begin - Scenario_Stack.Append (N); - end Push_Active_Scenario; + return Loc; + end Freeze_Node_Location; - --------------------------------- - -- Record_Elaboration_Scenario -- - --------------------------------- + ------------------------------- + -- Precedes_Source_Construct -- + ------------------------------- - procedure Record_Elaboration_Scenario (N : Node_Id) is - Level : Enclosing_Level_Kind; + function Precedes_Source_Construct (N : Node_Id) return Boolean is + Decl : Node_Id; - Any_Level_OK : Boolean; - -- This flag is set when a particular scenario is allowed to appear at - -- any level. + begin + Decl := Next (N); + while Present (Decl) loop + if Comes_From_Source (Decl) then + return True; - Declaration_Level_OK : Boolean; - -- This flag is set when a particular scenario is allowed to appear at - -- the declaration level. + -- A generated body for a source expression function is treated + -- as a source construct. - Library_Level_OK : Boolean; - -- This flag is set when a particular scenario is allowed to appear at - -- the library level. + 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; - begin - -- Assume that the scenario cannot appear on any level + Next (Decl); + end loop; - Any_Level_OK := False; - Declaration_Level_OK := False; - Library_Level_OK := False; + return False; + end Precedes_Source_Construct; - -- 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 -- + ---------------------------- - if Legacy_Elaboration_Checks then - return; + 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; - -- Nothing to do for ASIS because ABE checks and diagnostics are not - -- performed in this mode. + 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. - elsif ASIS_Mode then - return; + if Nkind (Unit_Id) = N_Package_Body then - -- Nothing to do when the scenario is being preanalyzed + -- 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. - elsif Preanalysis_Active then - return; - end if; + Region := + Find_Early_Call_Region + (Body_Decl => Body_Decl, + Assume_Elab_Body => True, + Skip_Memoization => True); - -- 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 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. - if Is_Suitable_Call (N) then - Check_Preelaborated_Call (N); - end if; + 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; - -- Nothing to do when the scenario does not appear within the main unit + -- Local variables - if not In_Main_Context (N) then - return; + FNode : constant Node_Id := Freeze_Node (Typ); + Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); - -- Scenarios within a generic unit are never considered because generics - -- cannot be elaborated. + Prim_Elmt : Elmt_Id; - elsif Inside_A_Generic then - return; + -- Start of processing for Process_SPARK_Derived_Type - -- Scenarios which do not fall in one of the elaboration categories - -- listed below are not considered. The categories are: + begin + -- A type should have its freeze node set by the time SPARK scenarios + -- are being verified. - -- 'Access for entries, operators, and subprograms - -- Assignments to variables - -- Calls (includes task activation) - -- Derived types - -- Instantiations - -- Pragma Refined_State - -- Reads of variables + pragma Assert (Present (FNode)); - elsif Is_Suitable_Access (N) then - Library_Level_OK := True; + -- 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)). - -- 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. + if Present (Prims) then + Prim_Elmt := First_Elmt (Prims); + while Present (Prim_Elmt) loop + Check_Overriding_Primitive + (Prim => Node (Prim_Elmt), + FNode => FNode); - if Debug_Flag_Dot_O then - Possible_Local_Raise (N, Standard_Program_Error); + Next_Elmt (Prim_Elmt); + end loop; end if; - elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then - Declaration_Level_OK := True; - Library_Level_OK := True; - - -- 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. + exception + when Stop_Check => + null; + end Process_SPARK_Derived_Type; - Possible_Local_Raise (N, Standard_Program_Error); + --------------------------------- + -- Process_SPARK_Instantiation -- + --------------------------------- - elsif Is_Suitable_SPARK_Derived_Type (N) then - Any_Level_OK := True; + 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); - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Library_Level_OK := True; + begin + -- The instantiation and the generic body are both in the main unit - elsif Is_Suitable_Variable_Assignment (N) - or else Is_Suitable_Variable_Reference (N) - then - Library_Level_OK := True; + if Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) - -- Otherwise the input does not denote a suitable scenario + -- If the instantiation appears prior to the generic body, then the + -- instantiation is illegal (SPARK RM 7.7(6)). - else - return; - end if; + -- 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. - -- 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. + 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; - if Static_Elaboration_Checks then + ---------------------------- + -- Process_SPARK_Scenario -- + ---------------------------- - -- Certain scenarios are allowed to appear at any level. This check - -- is performed here in order to save on a parent traversal. + procedure Process_SPARK_Scenario + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); - if Any_Level_OK then - null; + begin + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - -- Otherwise the scenario must appear at a specific level + Check_SPARK_Model_In_Effect; - else - -- Performance note: parent traversal + -- Add the current scenario to the stack of active scenarios - Level := Find_Enclosing_Level (N); + Push_Active_Scenario (Scen); - -- Declaration-level scenario + -- Derived type - if Declaration_Level_OK and then Level = Declaration_Level then - null; + 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); - -- Library-level or instantiation scenario + -- Instantiation - elsif Library_Level_OK - and then Level in Library_Or_Instantiation_Level - then - null; + elsif Is_Suitable_SPARK_Instantiation (Scen) then + Process_SPARK_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - -- Otherwise the scenario does not appear at the proper level and - -- cannot possibly act as a top-level scenario. + -- Refined_State pragma - else - return; - end if; + 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; - 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. + -- Remove the current scenario from the stack of active scenarios + -- once all ABE diagnostics and checks have been performed. - if Is_Suitable_SPARK_Derived_Type (N) then - Record_SPARK_Elaboration_Scenario (N); + Pop_Active_Scenario (Scen); + end Process_SPARK_Scenario; - -- Nothing left to do for derived types + ---------------------------------------- + -- Process_SPARK_Refined_State_Pragma -- + ---------------------------------------- - return; + procedure Process_SPARK_Refined_State_Pragma + (Prag : Node_Id; + Prag_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Prag_Rep); - -- 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. + 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. - -- IMPORTANT: A SPARK instantiation is also a normal instantiation which - -- is subject to common conditional and guaranteed ABE checks. + 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. - elsif Is_Suitable_SPARK_Instantiation (N) then - Record_SPARK_Elaboration_Scenario (N); + 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. - -- 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. + 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. - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Record_SPARK_Elaboration_Scenario (N); + ----------------------------- + -- Check_SPARK_Constituent -- + ----------------------------- - -- Nothing left to do for pragma Refined_State + procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is + SM_Prag : Node_Id; - return; - end if; + begin + -- Nothing to do for "null" constituents - -- Perform early detection of guaranteed ABEs in order to suppress the - -- instantiation of generic bodies as gigi cannot handle certain types - -- of premature instantiations. + if Nkind (Constit_Id) = N_Null then + return; - Process_Guaranteed_ABE (N); + -- Nothing to do for illegal constituents - -- At this point all checks have been performed. Record the scenario for - -- later processing by the ABE phase. + elsif Error_Posted (Constit_Id) then + return; + end if; - Top_Level_Scenarios.Append (N); - Set_Is_Recorded_Top_Level_Scenario (N); - end Record_Elaboration_Scenario; + SM_Prag := SPARK_Pragma (Constit_Id); - --------------------------------------- - -- Record_SPARK_Elaboration_Scenario -- - --------------------------------------- + -- The check applies only when the constituent is subject to + -- pragma SPARK_Mode On. - 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; + 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. - ----------------------------------- - -- Recorded_SPARK_Scenarios_Hash -- - ----------------------------------- + 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; - 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; + ------------------------------ + -- Check_SPARK_Constituents -- + ------------------------------ - --------------------------------------- - -- Recorded_Top_Level_Scenarios_Hash -- - --------------------------------------- + procedure Check_SPARK_Constituents (Constits : Elist_Id) is + Constit_Elmt : Elmt_Id; - 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; + 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; - -------------------------- - -- Reset_Visited_Bodies -- - -------------------------- + ----------------------------------- + -- Check_SPARK_Initialized_State -- + ----------------------------------- - 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; + procedure Check_SPARK_Initialized_State (State : Node_Id) is + SM_Prag : Node_Id; + State_Id : Entity_Id; - ------------------- - -- Root_Scenario -- - ------------------- + begin + -- Nothing to do for "null" initialization items - function Root_Scenario return Node_Id is - package Stack renames Scenario_Stack; + if Nkind (State) = N_Null then + return; - 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. + -- Nothing to do for illegal states - pragma Assert (Stack.Last >= Stack.First); - return Stack.Table (Stack.First); - end Root_Scenario; + elsif Error_Posted (State) then + return; + end if; - --------------------------- - -- Set_Early_Call_Region -- - --------------------------- + State_Id := Entity_Of (State); - 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)); + -- Sanitize the state - Early_Call_Regions_In_Use := True; - Early_Call_Regions.Set (Body_Id, Start); - end Set_Early_Call_Region; + if No (State_Id) then + return; - ---------------------------- - -- Set_Elaboration_Status -- - ---------------------------- + elsif Error_Posted (State_Id) then + return; - 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; + elsif Ekind (State_Id) /= E_Abstract_State then + return; + end if; - ------------------------------------ - -- Set_Is_Recorded_SPARK_Scenario -- - ------------------------------------ + -- The check is performed only when the abstract state is subject + -- to SPARK_Mode On. - 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; + SM_Prag := SPARK_Pragma (State_Id); - ---------------------------------------- - -- Set_Is_Recorded_Top_Level_Scenario -- - ---------------------------------------- + if Present (SM_Prag) + and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On + then + Check_SPARK_Constituents (Refinement_Constituents (State_Id)); + end if; + end Check_SPARK_Initialized_State; - 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; + ------------------------------------ + -- Check_SPARK_Initialized_States -- + ------------------------------------ - ------------------------- - -- Set_Is_Visited_Body -- - ------------------------- + procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is + Init_Prag : constant Node_Id := + Get_Pragma (Pack_Id, Pragma_Initializes); - 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; + Init : Node_Id; + Inits : Node_Id; - ------------------------------- - -- Static_Elaboration_Checks -- - ------------------------------- + begin + if Present (Init_Prag) then + Inits := Expression (Get_Argument (Init_Prag, Pack_Id)); - function Static_Elaboration_Checks return Boolean is - begin - return not Dynamic_Elaboration_Checks; - end Static_Elaboration_Checks; + -- Avoid processing a "null" initialization list. The only + -- other alternative is an aggregate. - ------------------- - -- Traverse_Body -- - ------------------- + if Nkind (Inits) = N_Aggregate then - 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. + -- The initialization items appear in list form: + -- + -- (state1, state2) - --------------------------------------- - -- Find_And_Process_Nested_Scenarios -- - --------------------------------------- + if Present (Expressions (Inits)) then + Init := First (Expressions (Inits)); + while Present (Init) loop + Check_SPARK_Initialized_State (Init); + Next (Init); + end loop; + end if; - 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. + -- 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); - pragma Inline (Traverse_List); - -- Invoke Traverse_Potential_Scenarios on each node in list List + -- Local variables - procedure Traverse_Potential_Scenarios is - new Traverse_Proc (Is_Potential_Scenario); + Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (Prag); - --------------------------- - -- Is_Potential_Scenario -- - --------------------------- + -- Start of processing for Process_SPARK_Refined_State_Pragma - function Is_Potential_Scenario - (Nod : Node_Id) return Traverse_Result - is - begin - -- Special cases + begin + -- Pragma Refined_State must be associated with a package body - -- Skip constructs which do not have elaboration of their own and - -- need to be elaborated by other means such as invocation, task - -- activation, etc. + pragma Assert + (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); - if Is_Non_Library_Level_Encapsulator (Nod) then - return Skip; + -- Verify that each external contitunent of an abstract state + -- mentioned in pragma Initializes is properly elaborated. - -- 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. + Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); + end Process_SPARK_Refined_State_Pragma; + end SPARK_Processor; - 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; + ------------------------------- + -- Spec_And_Body_From_Entity -- + ------------------------------- - -- 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. + procedure Spec_And_Body_From_Entity + (Id : Node_Id; + Spec_Decl : out Node_Id; + Body_Decl : out Node_Id) + is + begin + Spec_And_Body_From_Node + (N => Unit_Declaration_Node (Id), + Spec_Decl => Spec_Decl, + Body_Decl => Body_Decl); + end Spec_And_Body_From_Entity; - 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) - then - return Abandon; + ----------------------------- + -- Spec_And_Body_From_Node -- + ----------------------------- - -- 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. + 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; - elsif Nkind_In (Nod, N_And_Then, N_Or_Else) then - Traverse_List (Actions (Nod)); + begin + -- Assume that the construct lacks spec and body - elsif Nkind_In (Nod, N_Elsif_Part, N_Iteration_Scheme) then - Traverse_List (Condition_Actions (Nod)); + Body_Decl := Empty; + Spec_Decl := Empty; - elsif Nkind (Nod) = N_If_Expression then - Traverse_List (Then_Actions (Nod)); - Traverse_List (Else_Actions (Nod)); + -- Bodies - elsif Nkind_In (Nod, N_Component_Association, - N_Iterated_Component_Association) - then - Traverse_List (Loop_Actions (Nod)); + if Nkind_In (N, N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) + then + Spec_Id := Corresponding_Spec (N); - -- General case + -- The body completes a previous declaration - elsif Is_Suitable_Scenario (Nod) then - Process_Conditional_ABE - (N => Nod, - State => State); - end if; + if Present (Spec_Id) then + Spec_Decl := Unit_Declaration_Node (Spec_Id); - return OK; - end Is_Potential_Scenario; + -- 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. - ------------------- - -- Traverse_List -- - ------------------- + else + Body_Decl := N; + Spec_Decl := N; + return; + end if; - procedure Traverse_List (List : List_Id) is - Item : Node_Id; + -- Declarations - begin - Item := First (List); - while Present (Item) loop - Traverse_Potential_Scenarios (Item); - Next (Item); - end loop; - end Traverse_List; + 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; - -- Start of processing for Find_And_Process_Nested_Scenarios + -- Expression function - begin - -- Examine the declarations for suitable scenarios + elsif Nkind (N) = N_Expression_Function then + Spec_Id := Corresponding_Spec (N); + pragma Assert (Present (Spec_Id)); - Traverse_List (Declarations (N)); + Spec_Decl := Unit_Declaration_Node (Spec_Id); - -- Examine the handled sequence of statements. This also includes any - -- exceptions handlers. + -- Instantiations - Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); - end Find_And_Process_Nested_Scenarios; + elsif Nkind (N) in N_Generic_Instantiation then + Spec_Decl := Instance_Spec (N); + pragma Assert (Present (Spec_Decl)); - -- Start of processing for Traverse_Body + -- Stubs - begin - -- Nothing to do when there is no body + elsif Nkind (N) in N_Body_Stub then + Spec_Id := Corresponding_Spec_Of_Stub (N); - if No (N) then - return; + -- The stub completes a previous declaration - elsif Nkind (N) /= N_Subprogram_Body then - return; - end if; + if Present (Spec_Id) then + Spec_Decl := Unit_Declaration_Node (Spec_Id); - -- Nothing to do if the body was already traversed during the processing - -- of the same top-level scenario. + -- Otherwise the stub acts as a spec - if Is_Visited_Body (N) then - return; + else + Spec_Decl := N; + end if; + end if; - -- Otherwise mark the body as traversed + -- Obtain an optional or mandatory body - else - Set_Is_Visited_Body (N); + if Present (Spec_Decl) then + Body_Id := Corresponding_Body (Spec_Decl); + + if Present (Body_Id) then + Body_Decl := Unit_Declaration_Node (Body_Id); + end if; end if; + end Spec_And_Body_From_Node; - -- Examine the declarations and statements of the subprogram body for - -- suitable scenarios, save and process them accordingly. + ------------------------------- + -- Static_Elaboration_Checks -- + ------------------------------- - Find_And_Process_Nested_Scenarios; - end Traverse_Body; + 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 5d479576125..f47d5254f3b 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 5e7f743aff9..b499dbd1584 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); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 50ea52a69f4..77eefdc25c3 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 -- -------------------------- @@ -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 4e4d4ba8826..3f8d2e75d68 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/sinfo.adb b/gcc/ada/sinfo.adb index 2464b97e40b..d24938c2ed7 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 b3e1309882d..75883f015be 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) @@ -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 @@ -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/switch-b.adb b/gcc/ada/switch-b.adb index fdba595166e..dc62ec20510 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 -- 2.30.2