diff options
Diffstat (limited to 'gcc')
50 files changed, 24227 insertions, 7981 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4ce8d74..15d40a5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,155 @@ +2019-07-03 Hristian Kirtchev <kirtchev@adacore.com> + + * ali.adb: Add with and use clauses for GNAT, + GNAT.Dynamic_HTables, and Snames. Add a map from invocation + signature records to invocation signature ids. Add various + encodings of invocation-related attributes. Sort and update + table Known_ALI_Lines. + (Add_Invocation_Construct, Add_Invocation_Relation, + Body_Placement_Kind_To_Code, Code_To_Body_Placement_Kind, + Code_To_Invocation_Construct_Kind, Code_To_Invocation_Kind, + Code_To_Invocation_Graph_Line_Kind, Destroy, Hash): New + routines. + (Initialize_ALI): Sort the initialization sequence. Add + initialization for all invocation-related tables. + (Invocation_Construct_Kind_To_Code, + Invocation_Graph_Line_Kind_To_Code, Invocation_Kind_To_Code, + Invocation_Signature_Of, Present): New routines. + (Scan_ALI): Add the default values for invocation-related ids. + Scan invocation graph lines. + (Scan_Invocation_Graph_Line): New routine. + * ali.ads: Add with clause for GNAT.Dynamic_Tables. Add types + for invocation constructs, relations, and signatures. Add + tables for invocation constructs, relations, and signatures. + Update Unit_Record to capture invocation-related ids. Relocate + table Unit_Id_Tables and subtypes Unit_Id_Table, Unit_Id_Array + from Binde. + (Add_Invocation_Construct, Add_Invocation_Relation, + Body_Placement_Kind_To_Code, Code_To_Body_Placement_Kind, + Code_To_Invocation_Construct_Kind, Code_To_Invocation_Kind, + Code_To_Invocation_Graph_Line_Kind, + Invocation_Construct_Kind_To_Code, + Invocation_Graph_Line_Kind_To_Code, Invocation_Kind_To_Code, + Invocation_Signature_Of, Present): New routines. + * binde.adb: Add with and use clause for Types. Add use clause + for ALI.Unit_Id_Tables; + * binde.ads: Relocate table Unit_Id_Tables and subtypes + Unit_Id_Table, Unit_Id_Array to ALI. + * bindgen.adb: Remove with and use clause for ALI. + * bindgen.ads: Remove with and use clause for Binde. Add with + and use clause for ALI. + * bindo.adb, bindo.ads, bindo-augmentors.adb, + bindo-augmentors.ads, bindo-builders.adb, bindo-builders.ads, + bindo-diagnostics.adb, bindo-diagnostics.ads, + bindo-elaborators.adb, bindo-elaborators.ads, bindo-graphs.adb, + bindo-graphs.ads, bindo-units.adb, bindo-units.ads, + bindo-validators.adb, bindo-validators.ads, bindo-writers.adb, + bindo-writers.ads: New units. + * debug.adb: Use and describe GNAT debug switches -gnatd_F and + -gnatd_G. Add GNATbind debug switches in the ranges dA .. dZ, + d.a .. d.z, d.A .. d.Z, d.1 .. d.9, d_a .. d_z, d_A .. d_Z, and + d_1 .. d_9. Use and describe GNATbind debug switches -d_A, + -d_I, -d_L, -d_N, -d_O, -d_T, and -d_V. + * exp_util.adb, exp_util.ads (Exceptions_OK): Relocate to + Sem_Util. + * gnatbind.adb: Add with and use clause for Bindo. Use the new + Bindo elaboration order only when -d_N is in effect. + * lib-writ.adb + (Column, Extra, Invoker, Kind, Line, Locations, Name, Placement, + Scope, Signature, Target): New routines. + (Write_ALI): Output all invocation-related data. + (Write_Invocation_Graph): New routine. + * lib-writ.ads: Document the invocation graph ALI line. + * namet.adb, namet.ads (Present): New routines. + * sem_ch8.adb (Find_Direct_Name): Capture the status of + elaboration checks and warnings of an identifier. + (Find_Expanded_Name): Capture the status of elaboration checks + and warnings of an expanded name. + * sem_ch12.adb (Analyze_Generic_Package_Declaration): Ensure + that invocation graph-related data within the body of the main + unit is encoded in the ALI file. + (Analyze_Generic_Subprogram_Declaration): Ensure that invocation + graph-related data within the body of the main unit is encoded + in the ALI file. + (Analyze_Package_Instantiation): Perform minimal decoration of + the instance entity. + (Analyze_Subprogram_Instantiation): Perform minimal decoration + of the instance entity. + * sem_elab.adb: Perform heavy refactoring of all code. The unit + is now split into "services" which specialize in one area of ABE + checks. Add processing in order to capture invocation-graph + related attributes of the main unit, and encode them in the ALI + file. The Processing phase can now operate in multiple modes, + all described by type Processing_Kind. Scenarios and targets + are now distinct at the higher level, and carry their own + representations. This eliminates the need to constantly + recompute their attributes, and offers the various processors a + uniform interface. The various initial states of the Processing + phase are now encoded using type Processing_In_State, and + xxx_State constants. + * sem_elab.ads: Update the literals of type + Enclosing_Level_Kind. Add Inline pragmas on several routines. + * sem_prag.adb (Process_Inline): Ensure that invocation + graph-related data within the body of the main unit is encoded + in the ALI file. + * sem_util.adb (Enclosing_Generic_Body, Enclosing_Generic_Unit): + Code clean up. + (Exceptions_OK): Relocated from Sem_Util. + (Mark_Save_Invocation_Graph_Of_Body): New routine. + * sem_util.ads (Exceptions_OK): Relocated from Sem_Util. + (Mark_Save_Invocation_Graph_Of_Body): New routine. + * sinfo.adb (Is_Elaboration_Checks_OK_Node): Now applicable to + N_Variable_Reference_Marker. + (Is_Elaboration_Warnings_OK_Node): Now applicable to + N_Expanded_Name, N_Identifier, N_Variable_Reference_Marker. + (Is_Read): Use Flag4. + (Is_SPARK_Mode_On_Node): New applicable to + N_Variable_Reference_Marker. + (Is_Write): Use Flag5. + (Save_Invocation_Graph_Of_Body): New routine. + (Set_Is_Elaboration_Checks_OK_Node): Now applicable to + N_Variable_Reference_Marker. + (Set_Is_Elaboration_Warnings_OK_Node): Now applicable to + N_Expanded_Name, N_Identifier, N_Variable_Reference_Marker. + (Set_Is_SPARK_Mode_On_Node): New applicable to + N_Variable_Reference_Marker. + (Set_Save_Invocation_Graph_Of_Body): New routine. + * sinfo.ads: Update the documentation of attributes + Is_Elaboration_Checks_OK_Node, Is_Elaboration_Warnings_OK_Node, + Is_SPARK_Mode_On_Node. Update the flag usage of attributes + Is_Read, Is_Write. Add attribute Save_Invocation_Graph_Of_Body + and update its occurrence in nodes. + (Save_Invocation_Graph_Of_Body): New routine along with pragma + Inline. + (Set_Save_Invocation_Graph_Of_Body): New routine along with + pragma Inline. + * switch-b.adb (Scan_Binder_Switches): Refactor the scanning of + debug switches. + (Scan_Debug_Switches): New routine. + * libgnat/g-dynhta.adb, libgnat/g-dynhta.ads (Contains): New routine. + * libgnat/g-graphs.adb (Associate_Vertices): Update the use of + Component_Vertex_Iterator. + (Contains_Component, Contains_Edge, Contains_Vertex, Has_Next): + Reimplemented. + (Iterate_Component_Vertices): New routine. + (Iterate_Vertices): Removed. + (Next): Update the parameter profile. + (Number_Of_Component_Vertices, Number_Of_Outgoing_Edges): New + routines. + * libgnat/g-graphs.ads: Update the initialization of + No_Component. Add type Component_Vertex_Iterator. Remove type + Vertex_Iterator. + (Has_Next): Add new versions and remove old ones. + (Iterate_Component_Vertices): New routine. + (Iterate_Vertices): Removed. + (Next): Add new versions and remove old ones. + (Number_Of_Component_Vertices, Number_Of_Outgoing_Edges): New + routines. + * libgnat/g-sets.adb (Contains): Reimplemented. + * gcc-interface/Make-lang.in (GNATBIND_OBJS): Add + GNAT.Dynamic_HTables, GNAT.Graphs and Bindo units. + * rtsfind.ads: Remove extra space. + 2019-07-03 Yannick Moy <moy@adacore.com> * sem_spark.adb: Add support for locally borrowing and observing diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 818e67a..978fb3d 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -29,39 +29,328 @@ with Fname; use Fname; with Opt; use Opt; with Osint; use Osint; with Output; use Output; +with Snames; use Snames; + +with GNAT; use GNAT; +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; package body ALI is use ASCII; -- Make control characters visible + --------------------- + -- Data structures -- + --------------------- + + procedure Destroy (IS_Id : in out Invocation_Signature_Id); + -- Destroy an invocation signature with id IS_Id + + function Hash + (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type; + -- Obtain the hash of key IS_Rec + + package Sig_Map is new Dynamic_Hash_Tables + (Key_Type => Invocation_Signature_Record, + Value_Type => Invocation_Signature_Id, + No_Value => No_Invocation_Signature, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy, + Hash => Hash); + + -- The following map relates invocation signature records to invocation + -- signature ids. + + Sig_To_Sig_Map : constant Sig_Map.Dynamic_Hash_Table := + Sig_Map.Create (500); + + -- The folowing table maps body placement kinds to character codes for + -- invocation construct encoding in ALI files. + + Body_Placement_Codes : + constant array (Body_Placement_Kind) of Character := + (In_Body => 'b', + In_Spec => 's', + No_Body_Placement => 'Z'); + + -- The following table maps invocation kinds to character codes for + -- invocation relation encoding in ALI files. + + Invocation_Codes : + constant array (Invocation_Kind) of Character := + (Accept_Alternative => 'a', + Access_Taken => 'b', + Call => 'c', + Controlled_Adjustment => 'd', + Controlled_Finalization => 'e', + Controlled_Initialization => 'f', + Default_Initial_Condition_Verification => 'g', + Initial_Condition_Verification => 'h', + Instantiation => 'i', + Internal_Controlled_Adjustment => 'j', + Internal_Controlled_Finalization => 'k', + Internal_Controlled_Initialization => 'l', + Invariant_Verification => 'm', + Postcondition_Verification => 'n', + Protected_Entry_Call => 'o', + Protected_Subprogram_Call => 'p', + Task_Activation => 'q', + Task_Entry_Call => 'r', + Type_Initialization => 's', + No_Invocation => 'Z'); + + -- The following table maps invocation construct kinds to character codes + -- for invocation construct encoding in ALI files. + + Invocation_Construct_Codes : + constant array (Invocation_Construct_Kind) of Character := + (Elaborate_Body_Procedure => 'b', + Elaborate_Spec_Procedure => 's', + Regular_Construct => 'Z'); + + -- The following table maps invocation graph line kinds to character codes + -- used in ALI files. + + Invocation_Graph_Line_Codes : + constant array (Invocation_Graph_Line_Kind) of Character := + (Invocation_Construct_Line => 'c', + Invocation_Relation_Line => 'r'); + -- The following variable records which characters currently are used as -- line type markers in the ALI file. This is used in Scan_ALI to detect -- (or skip) invalid lines. The following letters are still available: -- - -- B F G H J K O Q Z + -- B F H J K O Q Z Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean := - ('V' => True, -- version - 'M' => True, -- main program - 'A' => True, -- argument - 'P' => True, -- program - 'R' => True, -- restriction - 'I' => True, -- interrupt - 'U' => True, -- unit - 'W' => True, -- with - 'L' => True, -- linker option - 'N' => True, -- notes - 'E' => True, -- external - 'D' => True, -- dependency - 'X' => True, -- xref - 'S' => True, -- specific dispatching - 'Y' => True, -- limited_with - 'Z' => True, -- implicit with from instantiation - 'C' => True, -- SCO information - 'T' => True, -- task stack information + ('A' => True, -- argument + 'C' => True, -- SCO information + 'D' => True, -- dependency + 'E' => True, -- external + 'G' => True, -- invocation graph + 'I' => True, -- interrupt + 'L' => True, -- linker option + 'M' => True, -- main program + 'N' => True, -- notes + 'P' => True, -- program + 'R' => True, -- restriction + 'S' => True, -- specific dispatching + 'T' => True, -- task stack information + 'U' => True, -- unit + 'V' => True, -- version + 'W' => True, -- with + 'X' => True, -- xref + 'Y' => True, -- limited_with + 'Z' => True, -- implicit with from instantiation others => False); + ------------------------------ + -- Add_Invocation_Construct -- + ------------------------------ + + procedure Add_Invocation_Construct + (IC_Rec : Invocation_Construct_Record; + Update_Units : Boolean := True) + is + IC_Id : Invocation_Construct_Id; + + begin + pragma Assert (Present (IC_Rec.Signature)); + + -- Create a invocation construct from the scanned attributes + + Invocation_Constructs.Append (IC_Rec); + IC_Id := Invocation_Constructs.Last; + + -- Update the invocation construct counter of the current unit only when + -- requested by the caller. + + if Update_Units then + declare + Curr_Unit : Unit_Record renames Units.Table (Units.Last); + + begin + Curr_Unit.Last_Invocation_Construct := IC_Id; + end; + end if; + end Add_Invocation_Construct; + + ----------------------------- + -- Add_Invocation_Relation -- + ----------------------------- + + procedure Add_Invocation_Relation + (IR_Rec : Invocation_Relation_Record; + Update_Units : Boolean := True) + is + IR_Id : Invocation_Relation_Id; + + begin + pragma Assert (Present (IR_Rec.Invoker)); + pragma Assert (Present (IR_Rec.Target)); + pragma Assert (IR_Rec.Kind /= No_Invocation); + + -- Create an invocation relation from the scanned attributes + + Invocation_Relations.Append (IR_Rec); + IR_Id := Invocation_Relations.Last; + + -- Update the invocation relation counter of the current unit only when + -- requested by the caller. + + if Update_Units then + declare + Curr_Unit : Unit_Record renames Units.Table (Units.Last); + + begin + Curr_Unit.Last_Invocation_Relation := IR_Id; + end; + end if; + end Add_Invocation_Relation; + + --------------------------------- + -- Body_Placement_Kind_To_Code -- + --------------------------------- + + function Body_Placement_Kind_To_Code + (Kind : Body_Placement_Kind) return Character + is + begin + return Body_Placement_Codes (Kind); + end Body_Placement_Kind_To_Code; + + --------------------------------- + -- Code_To_Body_Placement_Kind -- + --------------------------------- + + function Code_To_Body_Placement_Kind + (Code : Character) return Body_Placement_Kind + is + begin + -- Determine which body placement kind corresponds to the character code + -- by traversing the contents of the mapping table. + + for Kind in Body_Placement_Kind loop + if Body_Placement_Codes (Kind) = Code then + return Kind; + end if; + end loop; + + raise Program_Error; + end Code_To_Body_Placement_Kind; + + --------------------------------------- + -- Code_To_Invocation_Construct_Kind -- + --------------------------------------- + + function Code_To_Invocation_Construct_Kind + (Code : Character) return Invocation_Construct_Kind + is + begin + -- Determine which invocation construct kind matches the character code + -- by traversing the contents of the mapping table. + + for Kind in Invocation_Construct_Kind loop + if Invocation_Construct_Codes (Kind) = Code then + return Kind; + end if; + end loop; + + raise Program_Error; + end Code_To_Invocation_Construct_Kind; + + ----------------------------- + -- Code_To_Invocation_Kind -- + ----------------------------- + + function Code_To_Invocation_Kind + (Code : Character) return Invocation_Kind + is + begin + -- Determine which invocation kind corresponds to the character code by + -- traversing the contents of the mapping table. + + for Kind in Invocation_Kind loop + if Invocation_Codes (Kind) = Code then + return Kind; + end if; + end loop; + + raise Program_Error; + end Code_To_Invocation_Kind; + + ---------------------------------------- + -- Code_To_Invocation_Graph_Line_Kind -- + ---------------------------------------- + + function Code_To_Invocation_Graph_Line_Kind + (Code : Character) return Invocation_Graph_Line_Kind + is + begin + -- Determine which invocation graph line kind matches the character + -- code by traversing the contents of the mapping table. + + for Kind in Invocation_Graph_Line_Kind loop + if Invocation_Graph_Line_Codes (Kind) = Code then + return Kind; + end if; + end loop; + + raise Program_Error; + end Code_To_Invocation_Graph_Line_Kind; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (IS_Id : in out Invocation_Signature_Id) is + pragma Unreferenced (IS_Id); + begin + null; + end Destroy; + + ---------- + -- Hash -- + ---------- + + function Hash + (IS_Rec : Invocation_Signature_Record) return Bucket_Range_Type + is + Buffer : Bounded_String (2052); + IS_Nam : Name_Id; + + begin + -- The hash is obtained in the following manner: + -- + -- * A String signature based on the scope, name, line number, column + -- number, and locations, in the following format: + -- + -- scope__name__line_column__locations + -- + -- * The String is converted into a Name_Id + -- * The Name_Id is used as the hash + + Append (Buffer, IS_Rec.Scope); + Append (Buffer, "__"); + Append (Buffer, IS_Rec.Name); + Append (Buffer, "__"); + Append (Buffer, IS_Rec.Line); + Append (Buffer, '_'); + Append (Buffer, IS_Rec.Column); + + if IS_Rec.Locations /= No_Name then + Append (Buffer, "__"); + Append (Buffer, IS_Rec.Locations); + end if; + + IS_Nam := Name_Find (Buffer); + return Bucket_Range_Type (IS_Nam); + end Hash; + -------------------- -- Initialize_ALI -- -------------------- @@ -90,16 +379,19 @@ package body ALI is -- Initialize all tables ALIs.Init; + Invocation_Constructs.Init; + Invocation_Relations.Init; + Invocation_Signatures.Init; + Linker_Options.Init; No_Deps.Init; + Notes.Init; + Sdep.Init; Units.Init; + Version_Ref.Reset; Withs.Init; - Sdep.Init; - Linker_Options.Init; - Notes.Init; - Xref_Section.Init; Xref_Entity.Init; Xref.Init; - Version_Ref.Reset; + Xref_Section.Init; -- Add dummy zero'th item in Linker_Options and Notes for sort calls @@ -125,6 +417,131 @@ package body ALI is Zero_Cost_Exceptions_Specified := False; end Initialize_ALI; + --------------------------------------- + -- Invocation_Construct_Kind_To_Code -- + --------------------------------------- + + function Invocation_Construct_Kind_To_Code + (Kind : Invocation_Construct_Kind) return Character + is + begin + return Invocation_Construct_Codes (Kind); + end Invocation_Construct_Kind_To_Code; + + ---------------------------------------- + -- Invocation_Graph_Line_Kind_To_Code -- + ---------------------------------------- + + function Invocation_Graph_Line_Kind_To_Code + (Kind : Invocation_Graph_Line_Kind) return Character + is + begin + return Invocation_Graph_Line_Codes (Kind); + end Invocation_Graph_Line_Kind_To_Code; + + ----------------------------- + -- Invocation_Kind_To_Code -- + ----------------------------- + + function Invocation_Kind_To_Code + (Kind : Invocation_Kind) return Character + is + begin + return Invocation_Codes (Kind); + end Invocation_Kind_To_Code; + + ----------------------------- + -- Invocation_Signature_Of -- + ----------------------------- + + function Invocation_Signature_Of + (Column : Nat; + Line : Nat; + Locations : Name_Id; + Name : Name_Id; + Scope : Name_Id) return Invocation_Signature_Id + is + IS_Rec : constant Invocation_Signature_Record := + (Column => Column, + Line => Line, + Locations => Locations, + Name => Name, + Scope => Scope); + IS_Id : Invocation_Signature_Id; + + begin + IS_Id := Sig_Map.Get (Sig_To_Sig_Map, IS_Rec); + + -- The invocation signature lacks an id. This indicates that it + -- is encountered for the first time during the construction of + -- the graph. + + if not Present (IS_Id) then + Invocation_Signatures.Append (IS_Rec); + IS_Id := Invocation_Signatures.Last; + + -- Map the invocation signature record to its corresponding id + + Sig_Map.Put (Sig_To_Sig_Map, IS_Rec, IS_Id); + end if; + + return IS_Id; + end Invocation_Signature_Of; + + ------------- + -- Present -- + ------------- + + function Present (IC_Id : Invocation_Construct_Id) return Boolean is + begin + return IC_Id /= No_Invocation_Construct; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (IR_Id : Invocation_Relation_Id) return Boolean is + begin + return IR_Id /= No_Invocation_Relation; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (IS_Id : Invocation_Signature_Id) return Boolean is + begin + return IS_Id /= No_Invocation_Signature; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (Dep : Sdep_Id) return Boolean is + begin + return Dep /= No_Sdep_Id; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (U_Id : Unit_Id) return Boolean is + begin + return U_Id /= No_Unit_Id; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (W_Id : With_Id) return Boolean is + begin + return W_Id /= No_With_Id; + end Present; + -------------- -- Scan_ALI -- -------------- @@ -256,6 +673,9 @@ package body ALI is Standard_Entity : out Name_Id); -- Parse the definition of a typeref (<...>, {...} or (...)) + procedure Scan_Invocation_Graph_Line; + -- Parse a single line which encodes a piece of the invocation graph + procedure Skip_Eol; -- Skip past spaces, then skip past end of line (fatal error if not -- at end of line). Also skips past any following blank lines. @@ -771,6 +1191,202 @@ package body ALI is return T (P); end Nextc; + -------------------------------- + -- Scan_Invocation_Graph_Line -- + -------------------------------- + + procedure Scan_Invocation_Graph_Line is + procedure Scan_Invocation_Construct_Line; + pragma Inline (Scan_Invocation_Construct_Line); + -- Parse an invocation construct line and construct the corresponding + -- construct. The following data structures are updated: + -- + -- * Invocation_Constructs + -- * Units + + procedure Scan_Invocation_Relation_Line; + pragma Inline (Scan_Invocation_Relation_Line); + -- Parse an invocation relation line and construct the corresponding + -- relation. The following data structures are updated: + -- + -- * Invocation_Relations + -- * Units + + function Scan_Invocation_Signature return Invocation_Signature_Id; + pragma Inline (Scan_Invocation_Signature); + -- Parse a single invocation signature while populating the following + -- data structures: + -- + -- * Invocation_Signatures + -- * Sig_To_Sig_Map + + ------------------------------------ + -- Scan_Invocation_Construct_Line -- + ------------------------------------ + + procedure Scan_Invocation_Construct_Line is + IC_Rec : Invocation_Construct_Record; + + begin + -- construct-kind + + IC_Rec.Kind := Code_To_Invocation_Construct_Kind (Getc); + Checkc (' '); + Skip_Space; + + -- construct-body-placement + + IC_Rec.Placement := Code_To_Body_Placement_Kind (Getc); + Checkc (' '); + Skip_Space; + + -- construct-signature + + IC_Rec.Signature := Scan_Invocation_Signature; + pragma Assert (Present (IC_Rec.Signature)); + + Skip_Eol; + + Add_Invocation_Construct (IC_Rec); + end Scan_Invocation_Construct_Line; + + ----------------------------------- + -- Scan_Invocation_Relation_Line -- + ----------------------------------- + + procedure Scan_Invocation_Relation_Line is + IR_Rec : Invocation_Relation_Record; + + begin + -- relation-kind + + IR_Rec.Kind := Code_To_Invocation_Kind (Getc); + Checkc (' '); + Skip_Space; + + -- (extra-name | "none") + + IR_Rec.Extra := Get_Name; + + if IR_Rec.Extra = Name_None then + IR_Rec.Extra := No_Name; + end if; + + Checkc (' '); + Skip_Space; + + -- invoker-signature + + IR_Rec.Invoker := Scan_Invocation_Signature; + pragma Assert (Present (IR_Rec.Invoker)); + + Checkc (' '); + Skip_Space; + + -- target-signature + + IR_Rec.Target := Scan_Invocation_Signature; + pragma Assert (Present (IR_Rec.Target)); + + Skip_Eol; + + Add_Invocation_Relation (IR_Rec); + end Scan_Invocation_Relation_Line; + + ------------------------------- + -- Scan_Invocation_Signature -- + ------------------------------- + + function Scan_Invocation_Signature return Invocation_Signature_Id is + Column : Nat; + Line : Nat; + Locations : Name_Id; + Name : Name_Id; + Scope : Name_Id; + + begin + -- [ + + Checkc ('['); + + -- name + + Name := Get_Name; + Checkc (' '); + Skip_Space; + + -- scope + + Scope := Get_Name; + Checkc (' '); + Skip_Space; + + -- line + + Line := Get_Nat; + Checkc (' '); + Skip_Space; + + -- column + + Column := Get_Nat; + Checkc (' '); + Skip_Space; + + -- (locations | "none") + + Locations := Get_Name; + + if Locations = Name_None then + Locations := No_Name; + end if; + + -- ] + + Checkc (']'); + + -- Create an invocation signature from the scanned attributes + + return + Invocation_Signature_Of + (Column => Column, + Line => Line, + Locations => Locations, + Name => Name, + Scope => Scope); + end Scan_Invocation_Signature; + + -- Local variables + + Line : Invocation_Graph_Line_Kind; + + -- Start of processing for Scan_Invocation_Graph_Line + + begin + if Ignore ('G') then + return; + end if; + + Checkc (' '); + Skip_Space; + + -- line-kind + + Line := Code_To_Invocation_Graph_Line_Kind (Getc); + Checkc (' '); + Skip_Space; + + -- line-attributes + + if Line = Invocation_Construct_Line then + Scan_Invocation_Construct_Line; + + else + pragma Assert (Line = Invocation_Relation_Line); + Scan_Invocation_Relation_Line; + end if; + end Scan_Invocation_Graph_Line; + -------------- -- Skip_Eol -- -------------- @@ -1716,38 +2332,42 @@ package body ALI is UL : Unit_Record renames Units.Table (Units.Last); begin - UL.Uname := Get_Unit_Name; - UL.Predefined := Is_Predefined_Unit; - UL.Internal := Is_Internal_Unit; - UL.My_ALI := Id; - UL.Sfile := Get_File_Name (Lower => True); - UL.Pure := False; - UL.Preelab := False; - UL.No_Elab := False; - UL.Shared_Passive := False; - UL.RCI := False; - UL.Remote_Types := False; - UL.Serious_Errors := False; - UL.Has_RACW := False; - UL.Init_Scalars := False; - UL.Is_Generic := False; - UL.Icasing := Mixed_Case; - UL.Kcasing := All_Lower_Case; - UL.Dynamic_Elab := False; - UL.Elaborate_Body := False; - UL.Set_Elab_Entity := False; - UL.Version := "00000000"; - UL.First_With := Withs.Last + 1; - UL.First_Arg := First_Arg; - UL.Elab_Position := 0; - UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; - UL.Directly_Scanned := Directly_Scanned; - UL.Body_Needed_For_SAL := False; - UL.Elaborate_Body_Desirable := False; - UL.Optimize_Alignment := 'O'; - UL.Has_Finalizer := False; - UL.Primary_Stack_Count := 0; - UL.Sec_Stack_Count := 0; + UL.Uname := Get_Unit_Name; + UL.Predefined := Is_Predefined_Unit; + UL.Internal := Is_Internal_Unit; + UL.My_ALI := Id; + UL.Sfile := Get_File_Name (Lower => True); + UL.Pure := False; + UL.Preelab := False; + UL.No_Elab := False; + UL.Shared_Passive := False; + UL.RCI := False; + UL.Remote_Types := False; + UL.Serious_Errors := False; + UL.Has_RACW := False; + UL.Init_Scalars := False; + UL.Is_Generic := False; + UL.Icasing := Mixed_Case; + UL.Kcasing := All_Lower_Case; + UL.Dynamic_Elab := False; + UL.Elaborate_Body := False; + UL.Set_Elab_Entity := False; + UL.Version := "00000000"; + UL.First_With := Withs.Last + 1; + UL.First_Arg := First_Arg; + UL.First_Invocation_Construct := Invocation_Constructs.Last + 1; + UL.Last_Invocation_Construct := No_Invocation_Construct; + UL.First_Invocation_Relation := Invocation_Relations.Last + 1; + UL.Last_Invocation_Relation := No_Invocation_Relation; + UL.Elab_Position := 0; + UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; + UL.Directly_Scanned := Directly_Scanned; + UL.Body_Needed_For_SAL := False; + UL.Elaborate_Body_Desirable := False; + UL.Optimize_Alignment := 'O'; + UL.Has_Finalizer := False; + UL.Primary_Stack_Count := 0; + UL.Sec_Stack_Count := 0; if Debug_Flag_U then Write_Str (" ----> reading unit "); @@ -2444,6 +3064,17 @@ package body ALI is ALIs.Table (Id).Last_Sdep := Sdep.Last; + -- Loop through invocation graph lines + + G_Loop : loop + Check_Unknown_Line; + exit G_Loop when C /= 'G'; + + Scan_Invocation_Graph_Line; + + C := Getc; + end loop G_Loop; + -- We must at this stage be at an Xref line or the end of file if C = EOF then @@ -2786,7 +3417,6 @@ package body ALI is -- Record last entity XS.Last_Entity := Xref_Entity.Last; - end Read_Refs_For_One_File; C := Getc; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 7835857..79eabb1 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -34,6 +34,7 @@ with Rident; use Rident; with Table; with Types; use Types; +with GNAT.Dynamic_Tables; with GNAT.HTable; use GNAT.HTable; package ALI is @@ -66,6 +67,39 @@ package ALI is type Priority_Specific_Dispatching_Id is range 0 .. 99_999_999; -- Id values used for Priority_Specific_Dispatching table entries + type Invocation_Construct_Id is range 0 .. 99_999_999; + -- Id values used for Invocation_Constructs table entries + + type Invocation_Relation_Id is range 0 .. 99_999_999; + -- Id values used for Invocation_Relations table entries + + type Invocation_Signature_Id is range 0 .. 99_999_999; + -- Id values used for Invocation_Signatures table entries + + function Present (IC_Id : Invocation_Construct_Id) return Boolean; + pragma Inline (Present); + -- Determine whether invocation construct IC_Id exists + + function Present (IR_Id : Invocation_Relation_Id) return Boolean; + pragma Inline (Present); + -- Determine whether invocation relation IR_Id exists + + function Present (IS_Id : Invocation_Signature_Id) return Boolean; + pragma Inline (Present); + -- Determine whether invocation signature IS_Id exists + + function Present (Dep : Sdep_Id) return Boolean; + pragma Inline (Present); + -- Determine whether dependant Dep exists + + function Present (U_Id : Unit_Id) return Boolean; + pragma Inline (Present); + -- Determine whether unit U_Id exists + + function Present (W_Id : With_Id) return Boolean; + pragma Inline (Present); + -- Determine whether with W_Id exists + -------------------- -- ALI File Table -- -------------------- @@ -334,6 +368,18 @@ package ALI is Last_Arg : Arg_Id; -- Id of last args table entry for this file + First_Invocation_Construct : Invocation_Construct_Id; + -- Id of the first invocation construct for this unit + + Last_Invocation_Construct : Invocation_Construct_Id; + -- Id of the last invocation construct for this unit + + First_Invocation_Relation : Invocation_Relation_Id; + -- Id of the first invocation relation for this unit + + Last_Invocation_Relation : Invocation_Relation_Id; + -- Id of the last invocation relation for this unit + Utype : Unit_Type; -- Type of entry @@ -408,6 +454,16 @@ package ALI is Table_Increment => 200, Table_Name => "Unit"); + package Unit_Id_Tables is new GNAT.Dynamic_Tables + (Table_Component_Type => Unit_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 500, + Table_Increment => 200); + + subtype Unit_Id_Table is Unit_Id_Tables.Instance; + subtype Unit_Id_Array is Unit_Id_Tables.Table_Type; + --------------------------- -- Interrupt State Table -- --------------------------- @@ -794,6 +850,7 @@ package ALI is Unit_Name : Name_Id; -- Name_Id for the unit name if not a subunit (No_Name for a subunit) + Rfile : File_Name_Type; -- Reference file name. Same as Sfile unless a Source_Reference pragma -- was used, in which case it reflects the name used in the pragma. @@ -1026,6 +1083,265 @@ package ALI is Table_Increment => 300, Table_Name => "Xref"); + ---------------------------- + -- Invocation Graph Types -- + ---------------------------- + + -- The following type identifies an invocation signature + + No_Invocation_Signature : constant Invocation_Signature_Id := + Invocation_Signature_Id'First; + First_Invocation_Signature : constant Invocation_Signature_Id := + No_Invocation_Signature + 1; + + -- The following type represents an invocation signature. Its purpose is + -- to uniquely identify an invocation construct within the ALI space. The + -- signature is comprised out of several pieces, some of which are used in + -- error diagnostics by the binder. Identification issues are resolved as + -- follows: + -- + -- * The Column, Line, and Locations attributes together differentiate + -- between homonyms. In most cases, the Column and Line are sufficient + -- except when generic instantiations are involved. Together, the three + -- attributes offer a sequence of column-line pairs which eventually + -- reflect the location within the generic template. + -- + -- * The Name attribute differentiates between invocation constructs at + -- the scope level. Since it is illegal for two entities with the same + -- name to coexist in the same scope, the Name attribute is sufficient + -- to distinguish them. Overloaded entities are already handled by the + -- Column, Line, and Locations attributes. + -- + -- * The Scope attribute differentiates between invocation constructs at + -- various levels of nesting. + + type Invocation_Signature_Record is record + Column : Nat := 0; + -- The column number where the invocation construct is declared + + Line : Nat := 0; + -- The line number where the invocation construct is declared + + Locations : Name_Id := No_Name; + -- Sequence of column and line numbers within nested instantiations + + Name : Name_Id := No_Name; + -- The name of the invocation construct + + Scope : Name_Id := No_Name; + -- The qualified name of the scope where the invocation construct is + -- declared. + end record; + + -- The following type enumerates all possible placements of an invocation + -- construct's body body with respect to the unit it is declared in. + + type Body_Placement_Kind is + (In_Body, + -- The body of the invocation construct is within the body of the unit + -- it is declared in. + + In_Spec, + -- The body of the invocation construct is within the spec of the unit + -- it is declared in. + + No_Body_Placement); + -- The invocation construct does not have a body + + -- The following type enumerates all possible invocation construct kinds + + type Invocation_Construct_Kind is + (Elaborate_Body_Procedure, + -- The invocation construct denotes the procedure which elaborates a + -- package body. + + Elaborate_Spec_Procedure, + -- The invocation construct denotes the procedure which elaborates a + -- package spec. + + Regular_Construct); + -- The invocation construct is a normal invocation construct + + -- The following type identifies an invocation construct + + No_Invocation_Construct : constant Invocation_Construct_Id := + Invocation_Construct_Id'First; + First_Invocation_Construct : constant Invocation_Construct_Id := + No_Invocation_Construct + 1; + + -- The following type represents an invocation construct + + type Invocation_Construct_Record is record + Kind : Invocation_Construct_Kind := Regular_Construct; + -- The nature of the invocation construct + + Placement : Body_Placement_Kind := No_Body_Placement; + -- The location of the invocation construct's body with respect to the + -- body of the unit it is declared in. + + Signature : Invocation_Signature_Id := No_Invocation_Signature; + -- The invocation signature which uniquely identifies the invocation + -- construct in the ALI space. + end record; + + -- The following type identifies an invocation relation + + No_Invocation_Relation : constant Invocation_Relation_Id := + Invocation_Relation_Id'First; + First_Invocation_Relation : constant Invocation_Relation_Id := + No_Invocation_Relation + 1; + + -- The following type enumerates all possible invocation kinds + + type Invocation_Kind is + (Accept_Alternative, + Access_Taken, + Call, + Controlled_Adjustment, + Controlled_Finalization, + Controlled_Initialization, + Default_Initial_Condition_Verification, + Initial_Condition_Verification, + Instantiation, + Internal_Controlled_Adjustment, + Internal_Controlled_Finalization, + Internal_Controlled_Initialization, + Invariant_Verification, + Postcondition_Verification, + Protected_Entry_Call, + Protected_Subprogram_Call, + Task_Activation, + Task_Entry_Call, + Type_Initialization, + No_Invocation); + + subtype Internal_Controlled_Invocation_Kind is Invocation_Kind range + Internal_Controlled_Adjustment .. + -- Internal_Controlled_Finalization + Internal_Controlled_Initialization; + + -- The following type represents an invocation relation. It associates an + -- invoker which activates/calls/instantiates with a target. + + type Invocation_Relation_Record is record + Extra : Name_Id := No_Name; + -- The name of an additional entity used in error diagnostics + + Invoker : Invocation_Signature_Id := No_Invocation_Signature; + -- The invocation signature which uniquely identifies the invoker within + -- the ALI space. + + Kind : Invocation_Kind := No_Invocation; + -- The nature of the invocation + + Target : Invocation_Signature_Id := No_Invocation_Signature; + -- The invocation signature which uniquely identifies the target within + -- the ALI space. + end record; + + -- The following type enumerates all possible invocation graph ALI lines + + type Invocation_Graph_Line_Kind is + (Invocation_Construct_Line, + Invocation_Relation_Line); + + -------------------------------------- + -- Invocation Graph Data Structures -- + -------------------------------------- + + package Invocation_Constructs is new Table.Table + (Table_Index_Type => Invocation_Construct_Id, + Table_Component_Type => Invocation_Construct_Record, + Table_Low_Bound => First_Invocation_Construct, + Table_Initial => 2500, + Table_Increment => 200, + Table_Name => "Invocation_Constructs"); + + package Invocation_Relations is new Table.Table + (Table_Index_Type => Invocation_Relation_Id, + Table_Component_Type => Invocation_Relation_Record, + Table_Low_Bound => First_Invocation_Relation, + Table_Initial => 2500, + Table_Increment => 200, + Table_Name => "Invocation_Relation"); + + package Invocation_Signatures is new Table.Table + (Table_Index_Type => Invocation_Signature_Id, + Table_Component_Type => Invocation_Signature_Record, + Table_Low_Bound => First_Invocation_Signature, + Table_Initial => 2500, + Table_Increment => 200, + Table_Name => "Invocation_Signatures"); + + ---------------------------------- + -- Invocation Graph Subprograms -- + ---------------------------------- + + procedure Add_Invocation_Construct + (IC_Rec : Invocation_Construct_Record; + Update_Units : Boolean := True); + pragma Inline (Add_Invocation_Construct); + -- Add invocation construct attributes IC_Rec to internal data structures. + -- Flag Undate_Units should be set when this addition must be reflected in + -- the attributes of the current unit. + + procedure Add_Invocation_Relation + (IR_Rec : Invocation_Relation_Record; + Update_Units : Boolean := True); + pragma Inline (Add_Invocation_Relation); + -- Add invocation relation attributes IR_Rec to internal data structures. + -- Flag Undate_Units should be set when this addition must be reflected in + -- the attributes of the current unit. + + function Body_Placement_Kind_To_Code + (Kind : Body_Placement_Kind) return Character; + pragma Inline (Body_Placement_Kind_To_Code); + -- Obtain the character encoding of body placement kind Kind + + function Code_To_Body_Placement_Kind + (Code : Character) return Body_Placement_Kind; + pragma Inline (Code_To_Body_Placement_Kind); + -- Obtain the body placement kind of character encoding Code + + function Code_To_Invocation_Construct_Kind + (Code : Character) return Invocation_Construct_Kind; + pragma Inline (Code_To_Invocation_Construct_Kind); + -- Obtain the invocation construct kind of character encoding Code + + function Code_To_Invocation_Kind + (Code : Character) return Invocation_Kind; + pragma Inline (Code_To_Invocation_Kind); + -- Obtain the invocation kind of character encoding Code + + function Code_To_Invocation_Graph_Line_Kind + (Code : Character) return Invocation_Graph_Line_Kind; + pragma Inline (Code_To_Invocation_Graph_Line_Kind); + -- Obtain the invocation graph line kind of character encoding Code + + function Invocation_Construct_Kind_To_Code + (Kind : Invocation_Construct_Kind) return Character; + pragma Inline (Invocation_Construct_Kind_To_Code); + -- Obtain the character encoding of invocation kind Kind + + function Invocation_Graph_Line_Kind_To_Code + (Kind : Invocation_Graph_Line_Kind) return Character; + pragma Inline (Invocation_Graph_Line_Kind_To_Code); + -- Obtain the character encoding for invocation like kind Kind + + function Invocation_Kind_To_Code + (Kind : Invocation_Kind) return Character; + pragma Inline (Invocation_Kind_To_Code); + -- Obtain the character encoding of invocation kind Kind + + function Invocation_Signature_Of + (Column : Nat; + Line : Nat; + Locations : Name_Id; + Name : Name_Id; + Scope : Name_Id) return Invocation_Signature_Id; + pragma Inline (Invocation_Signature_Of); + -- Obtain the invocation signature that corresponds to the input attributes + -------------------------------------- -- Subprograms for Reading ALI File -- -------------------------------------- diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index f5bd4b8..d060fd8 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 6412d26..bdea7dc 100644 --- a/gcc/ada/binde.ads +++ b/gcc/ada/binde.ads @@ -28,23 +28,9 @@ with ALI; use ALI; with Namet; use Namet; -with Types; use Types; - -with GNAT.Dynamic_Tables; package Binde is - package Unit_Id_Tables is new GNAT.Dynamic_Tables - (Table_Component_Type => Unit_Id, - Table_Index_Type => Nat, - Table_Low_Bound => 1, - Table_Initial => 500, - Table_Increment => 200); - use Unit_Id_Tables; - - subtype Unit_Id_Table is Unit_Id_Tables.Instance; - subtype Unit_Id_Array is Unit_Id_Tables.Table_Type; - procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table; First_Main_Lib_File : File_Name_Type); diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 5cc3ea2..e135540 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with ALI; use ALI; with Casing; use Casing; with Fname; use Fname; with Gnatvsn; use Gnatvsn; diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads index 86466f4..722cfad 100644 --- a/gcc/ada/bindgen.ads +++ b/gcc/ada/bindgen.ads @@ -32,10 +32,9 @@ -- See the body for exact details of the file that is generated -with Binde; use Binde; +with ALI; use ALI; package Bindgen is - procedure Gen_Output_File (Filename : String; Elab_Order : Unit_Id_Array); diff --git a/gcc/ada/bindo-augmentors.adb b/gcc/ada/bindo-augmentors.adb new file mode 100644 index 0000000..b94ff7a --- /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 0000000..0efae61 --- /dev/null +++ b/gcc/ada/bindo-augmentors.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . A U G M E N T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to enhance the library graph which +-- reflects source dependencies between units with information obtained from +-- the invocation graph which reflects all activations of tasks, calls, and +-- instantiations within units. + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Invocation_Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Augmentors is + + ------------------------------ + -- Library_Graph_Augmentors -- + ------------------------------ + + package Library_Graph_Augmentors is + procedure Augment_Library_Graph + (Inv_G : Invocation_Graph; + Lib_G : Library_Graph); + -- Augment library graph Lib_G with information from invocation graph + -- Inv_G as follows: + -- + -- 1) Traverse the invocation graph starting from each elaboration + -- procedure of unit Root. + -- + -- 2) Each time the traversal transitions from one unit into another + -- unit Curr, add an invocation edge between predecessor Curr and + -- successor Root in the library graph. + -- + -- 3) Do the above steps for all units with an elaboration procedure. + + end Library_Graph_Augmentors; + +end Bindo.Augmentors; diff --git a/gcc/ada/bindo-builders.adb b/gcc/ada/bindo-builders.adb new file mode 100644 index 0000000..33adede --- /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 0000000..39cde4f --- /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 0000000..bf11d39 --- /dev/null +++ b/gcc/ada/bindo-diagnostics.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . D I A G N O S T I C S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Bindo.Diagnostics is + + ----------------------- + -- Cycle_Diagnostics -- + ----------------------- + + package body Cycle_Diagnostics is + + ----------------------------- + -- Has_Elaborate_All_Cycle -- + ----------------------------- + + function Has_Elaborate_All_Cycle (G : Library_Graph) return Boolean is + Has_Cycle : Boolean; + Iter : All_Edge_Iterator; + LGE_Id : Library_Graph_Edge_Id; + + begin + pragma Assert (Present (G)); + + -- Assume that the graph lacks a cycle + + Has_Cycle := False; + + -- The library graph has an Elaborate_All cycle when one of its edges + -- represents a with clause for a unit with pragma Elaborate_All, and + -- both the predecessor and successor reside in the same component. + -- Note that the iteration must run to completion in order to unlock + -- the graph. + + Iter := Iterate_All_Edges (G); + while Has_Next (Iter) loop + Next (Iter, LGE_Id); + pragma Assert (Present (LGE_Id)); + + if Kind (G, LGE_Id) = Elaborate_All_Edge + and then Links_Vertices_In_Same_Component (G, LGE_Id) + then + Has_Cycle := True; + end if; + end loop; + + return Has_Cycle; + end Has_Elaborate_All_Cycle; + end Cycle_Diagnostics; + +end Bindo.Diagnostics; diff --git a/gcc/ada/bindo-diagnostics.ads b/gcc/ada/bindo-diagnostics.ads new file mode 100644 index 0000000..3b1d01c --- /dev/null +++ b/gcc/ada/bindo-diagnostics.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . D I A G N O S T I C S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to diagnose various issues with the +-- elaboration order. + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Diagnostics is + + ----------- + -- Types -- + ----------- + + -- The following type enumerates all possible statuses of the elaboration + -- order. + + type Elaboration_Order_Status is + (Order_Has_Circularity, + Order_Has_Elaborate_All_Circularity, + Order_OK); + + ----------------------- + -- Cycle_Diagnostics -- + ----------------------- + + package Cycle_Diagnostics is + function Has_Elaborate_All_Cycle (G : Library_Graph) return Boolean; + pragma Inline (Has_Elaborate_All_Cycle); + -- Determine whether library graph G contains a cycle where pragma + -- Elaborate_All appears within a component. + + end Cycle_Diagnostics; + +end Bindo.Diagnostics; diff --git a/gcc/ada/bindo-elaborators.adb b/gcc/ada/bindo-elaborators.adb new file mode 100644 index 0000000..42b5b6d --- /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 0000000..c65f593 --- /dev/null +++ b/gcc/ada/bindo-elaborators.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . E L A B O R A T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to find the elaboration order of +-- units based on various graphs. + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Invocation_Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Elaborators is + + ---------------------------------------------- + -- Invocation_And_Library_Graph_Elaborators -- + ---------------------------------------------- + + package Invocation_And_Library_Graph_Elaborators is + procedure Elaborate_Units + (Order : out Unit_Id_Table; + Main_Lib_File : File_Name_Type); + -- Find an order of all units in the bind that need to be elaborated + -- such that elaboration code flow, pragmas Elaborate, Elaborate_All, + -- and Elaborate_Body, and with clause dependencies are all honoured. + -- Main_Lib_File is the argument of the bind. If a satisfactory order + -- exists, it is returned in Order, otherwise Unrecoverable_Error is + -- raised. + + end Invocation_And_Library_Graph_Elaborators; + +end Bindo.Elaborators; diff --git a/gcc/ada/bindo-graphs.adb b/gcc/ada/bindo-graphs.adb new file mode 100644 index 0000000..ec99fe4 --- /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 0000000..3f55027 --- /dev/null +++ b/gcc/ada/bindo-graphs.ads @@ -0,0 +1,1248 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . G R A P H S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit defines the various graphs used in determining the +-- elaboration order of units. + +with Bindo.Units; use Bindo.Units; + +with GNAT; use GNAT; +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; +with GNAT.Graphs; use GNAT.Graphs; +with GNAT.Sets; use GNAT.Sets; + +package Bindo.Graphs is + + --------------------------- + -- Invocation graph edge -- + --------------------------- + + -- The following type denotes an invocation graph edge handle + + type Invocation_Graph_Edge_Id is new Natural; + No_Invocation_Graph_Edge : constant Invocation_Graph_Edge_Id := + Invocation_Graph_Edge_Id'First; + First_Invocation_Graph_Edge : constant Invocation_Graph_Edge_Id := + No_Invocation_Graph_Edge + 1; + + function Hash_Invocation_Graph_Edge + (IGE_Id : Invocation_Graph_Edge_Id) return Bucket_Range_Type; + pragma Inline (Hash_Invocation_Graph_Edge); + -- Obtain the hash value of key IGE_Id + + function Present (IGE_Id : Invocation_Graph_Edge_Id) return Boolean; + pragma Inline (Present); + -- Determine whether invocation graph edge IGE_Id exists + + ------------------------------ + -- Invocation graph vertex -- + ------------------------------ + + -- The following type denotes an invocation graph vertex handle + + type Invocation_Graph_Vertex_Id is new Natural; + No_Invocation_Graph_Vertex : constant Invocation_Graph_Vertex_Id := + Invocation_Graph_Vertex_Id'First; + First_Invocation_Graph_Vertex : constant Invocation_Graph_Vertex_Id := + No_Invocation_Graph_Vertex + 1; + + function Hash_Invocation_Graph_Vertex + (IGV_Id : Invocation_Graph_Vertex_Id) return Bucket_Range_Type; + pragma Inline (Hash_Invocation_Graph_Vertex); + -- Obtain the hash value of key IGV_Id + + function Present (IGV_Id : Invocation_Graph_Vertex_Id) return Boolean; + pragma Inline (Present); + -- Determine whether invocation graph vertex IGV_Id exists + + ------------------------ + -- Library graph edge -- + ------------------------ + + -- The following type denotes a library graph edge handle + + type Library_Graph_Edge_Id is new Natural; + No_Library_Graph_Edge : constant Library_Graph_Edge_Id := + Library_Graph_Edge_Id'First; + First_Library_Graph_Edge : constant Library_Graph_Edge_Id := + No_Library_Graph_Edge + 1; + + function Hash_Library_Graph_Edge + (LGE_Id : Library_Graph_Edge_Id) return Bucket_Range_Type; + pragma Inline (Hash_Library_Graph_Edge); + -- Obtain the hash value of key LGE_Id + + function Present (LGE_Id : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Present); + -- Determine whether library graph edge LGE_Id exists + + -------------------------- + -- Library graph vertex -- + -------------------------- + + -- The following type denotes a library graph vertex handle + + type Library_Graph_Vertex_Id is new Natural; + No_Library_Graph_Vertex : constant Library_Graph_Vertex_Id := + Library_Graph_Vertex_Id'First; + First_Library_Graph_Vertex : constant Library_Graph_Vertex_Id := + No_Library_Graph_Vertex + 1; + + function Hash_Library_Graph_Vertex + (LGV_Id : Library_Graph_Vertex_Id) return Bucket_Range_Type; + pragma Inline (Hash_Library_Graph_Vertex); + -- Obtain the hash value of key LGV_Id + + function Present (LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Present); + -- Determine whether library graph vertex LGV_Id exists + + ----------------------- + -- Invocation_Graphs -- + ----------------------- + + package Invocation_Graphs is + + ----------- + -- Graph -- + ----------- + + -- The following type denotes an invocation graph handle. Each instance + -- must be created using routine Create. + + type Invocation_Graph is private; + Nil : constant Invocation_Graph; + + ---------------------- + -- Graph operations -- + ---------------------- + + procedure Add_Edge + (G : Invocation_Graph; + Source : Invocation_Graph_Vertex_Id; + Target : Invocation_Graph_Vertex_Id; + IR_Id : Invocation_Relation_Id); + pragma Inline (Add_Edge); + -- Create a new edge in invocation graph G with source vertex Source and + -- destination vertex Target. IR_Id is the invocation relation the edge + -- describes. + + procedure Add_Vertex + (G : Invocation_Graph; + IC_Id : Invocation_Construct_Id; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Add_Vertex); + -- Create a new vertex in invocation graph G. IC_Id is the invocation + -- construct the vertex describes. LGV_Id is the library graph vertex + -- where the invocation construct appears. + + function Create + (Initial_Vertices : Positive; + Initial_Edges : Positive) return Invocation_Graph; + pragma Inline (Create); + -- Create a new empty graph with vertex capacity Initial_Vertices and + -- edge capacity Initial_Edges. + + procedure Destroy (G : in out Invocation_Graph); + pragma Inline (Destroy); + -- Destroy the contents of invocation graph G, rendering it unusable + + function Present (G : Invocation_Graph) return Boolean; + pragma Inline (Present); + -- Determine whether invocation graph G exists + + ----------------------- + -- Vertex attributes -- + ----------------------- + + function Construct + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id; + pragma Inline (Construct); + -- Obtain the invocation construct vertex IGV_Id of invocation graph G + -- describes. + + function Corresponding_Vertex + (G : Invocation_Graph; + IS_Id : Invocation_Signature_Id) return Invocation_Graph_Vertex_Id; + pragma Inline (Corresponding_Vertex); + -- Obtain the vertex of invocation graph G that corresponds to signature + -- IS_Id. + + function Lib_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + pragma Inline (Lib_Vertex); + -- Obtain the library graph vertex where vertex IGV_Id of invocation + -- graph appears. + + function Name + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Name_Id; + pragma Inline (Name); + -- Obtain the name of the construct vertex IGV_Id of invocation graph G + -- describes. + + --------------------- + -- Edge attributes -- + --------------------- + + function Kind + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Kind; + pragma Inline (Kind); + -- Obtain the nature of edge IGE_Id of invocation graph G + + function Relation + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Relation_Id; + pragma Inline (Relation); + -- Obtain the relation edge IGE_Id of invocation graph G describes + + function Target + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id; + pragma Inline (Target); + -- Obtain the target vertex edge IGE_Id of invocation graph G designates + + ---------------- + -- Statistics -- + ---------------- + + function Invocation_Graph_Edge_Count + (G : Invocation_Graph; + Kind : Invocation_Kind) return Natural; + pragma Inline (Invocation_Graph_Edge_Count); + -- Obtain the total number of edges of kind Kind in invocation graph G + + function Number_Of_Edges (G : Invocation_Graph) return Natural; + pragma Inline (Number_Of_Edges); + -- Obtain the total number of edges in invocation graph G + + function Number_Of_Edges_To_Targets + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Natural; + pragma Inline (Number_Of_Edges_To_Targets); + -- Obtain the total number of edges to targets vertex IGV_Id of + -- invocation graph G has. + + function Number_Of_Elaboration_Roots + (G : Invocation_Graph) return Natural; + pragma Inline (Number_Of_Elaboration_Roots); + -- Obtain the total number of elaboration roots in invocation graph G + + function Number_Of_Vertices (G : Invocation_Graph) return Natural; + pragma Inline (Number_Of_Vertices); + -- Obtain the total number of vertices in invocation graph G + + --------------- + -- Iterators -- + --------------- + + -- The following type represents an iterator over all edges of an + -- invocation graph. + + type All_Edge_Iterator is private; + + function Has_Next (Iter : All_Edge_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more edges to examine + + function Iterate_All_Edges + (G : Invocation_Graph) return All_Edge_Iterator; + pragma Inline (Iterate_All_Edges); + -- Obtain an iterator over all edges of invocation graph G + + procedure Next + (Iter : in out All_Edge_Iterator; + IGE_Id : out Invocation_Graph_Edge_Id); + pragma Inline (Next); + -- Return the current edge referenced by iterator Iter and advance to + -- the next available edge. + + -- The following type represents an iterator over all vertices of an + -- invocation graph. + + type All_Vertex_Iterator is private; + + function Has_Next (Iter : All_Vertex_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more vertices to examine + + function Iterate_All_Vertices + (G : Invocation_Graph) return All_Vertex_Iterator; + pragma Inline (Iterate_All_Vertices); + -- Obtain an iterator over all vertices of invocation graph G + + procedure Next + (Iter : in out All_Vertex_Iterator; + IGV_Id : out Invocation_Graph_Vertex_Id); + pragma Inline (Next); + -- Return the current vertex referenced by iterator Iter and advance + -- to the next available vertex. + + -- The following type represents an iterator over all edges that reach + -- targets starting from a particular source vertex. + + type Edges_To_Targets_Iterator is private; + + function Has_Next (Iter : Edges_To_Targets_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more edges to examine + + function Iterate_Edges_To_Targets + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator; + pragma Inline (Iterate_Edges_To_Targets); + -- Obtain an iterator over all edges to targets with source vertex + -- IGV_Id of invocation graph G. + + procedure Next + (Iter : in out Edges_To_Targets_Iterator; + IGE_Id : out Invocation_Graph_Edge_Id); + pragma Inline (Next); + -- Return the current edge referenced by iterator Iter and advance to + -- the next available edge. + + -- The following type represents an iterator over all vertices of an + -- invocation graph that denote the elaboration procedure or a spec or + -- a body, referred to as elaboration root. + + type Elaboration_Root_Iterator is private; + + function Has_Next (Iter : Elaboration_Root_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more elaboration roots to examine + + function Iterate_Elaboration_Roots + (G : Invocation_Graph) return Elaboration_Root_Iterator; + pragma Inline (Iterate_Elaboration_Roots); + -- Obtain an iterator over all elaboration roots of invocation graph G + + procedure Next + (Iter : in out Elaboration_Root_Iterator; + Root : out Invocation_Graph_Vertex_Id); + pragma Inline (Next); + -- Return the current elaboration root referenced by iterator Iter and + -- advance to the next available elaboration root. + + private + + -------------- + -- Vertices -- + -------------- + + procedure Destroy_Invocation_Graph_Vertex + (IGV_Id : in out Invocation_Graph_Vertex_Id); + pragma Inline (Destroy_Invocation_Graph_Vertex); + -- Destroy invocation graph vertex IGV_Id + + -- The following type represents the attributes of an invocation graph + -- vertex. + + type Invocation_Graph_Vertex_Attributes is record + Construct : Invocation_Construct_Id := No_Invocation_Construct; + -- Reference to the invocation construct this vertex represents + + Lib_Vertex : Library_Graph_Vertex_Id := No_Library_Graph_Vertex; + -- Reference to the library graph vertex where this vertex resides + end record; + + No_Invocation_Graph_Vertex_Attributes : + constant Invocation_Graph_Vertex_Attributes := + (Construct => No_Invocation_Construct, + Lib_Vertex => No_Library_Graph_Vertex); + + procedure Destroy_Invocation_Graph_Vertex_Attributes + (Attrs : in out Invocation_Graph_Vertex_Attributes); + pragma Inline (Destroy_Invocation_Graph_Vertex_Attributes); + -- Destroy the contents of attributes Attrs + + package VA is new Dynamic_Hash_Tables + (Key_Type => Invocation_Graph_Vertex_Id, + Value_Type => Invocation_Graph_Vertex_Attributes, + No_Value => No_Invocation_Graph_Vertex_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Invocation_Graph_Vertex_Attributes, + Hash => Hash_Invocation_Graph_Vertex); + + ----------- + -- Edges -- + ----------- + + procedure Destroy_Invocation_Graph_Edge + (IGE_Id : in out Invocation_Graph_Edge_Id); + pragma Inline (Destroy_Invocation_Graph_Edge); + -- Destroy invocation graph edge IGE_Id + + -- The following type represents the attributes of an invocation graph + -- edge. + + type Invocation_Graph_Edge_Attributes is record + Relation : Invocation_Relation_Id := No_Invocation_Relation; + -- Reference to the invocation relation this edge represents + end record; + + No_Invocation_Graph_Edge_Attributes : + constant Invocation_Graph_Edge_Attributes := + (Relation => No_Invocation_Relation); + + procedure Destroy_Invocation_Graph_Edge_Attributes + (Attrs : in out Invocation_Graph_Edge_Attributes); + pragma Inline (Destroy_Invocation_Graph_Edge_Attributes); + -- Destroy the contents of attributes Attrs + + package EA is new Dynamic_Hash_Tables + (Key_Type => Invocation_Graph_Edge_Id, + Value_Type => Invocation_Graph_Edge_Attributes, + No_Value => No_Invocation_Graph_Edge_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Invocation_Graph_Edge_Attributes, + Hash => Hash_Invocation_Graph_Edge); + + --------------- + -- Relations -- + --------------- + + -- The following type represents a relation between a source and target + -- vertices. + + type Source_Target_Relation is record + Source : Invocation_Graph_Vertex_Id := No_Invocation_Graph_Vertex; + -- The source vertex + + Target : Invocation_Graph_Vertex_Id := No_Invocation_Graph_Vertex; + -- The destination vertex + end record; + + No_Source_Target_Relation : + constant Source_Target_Relation := + (Source => No_Invocation_Graph_Vertex, + Target => No_Invocation_Graph_Vertex); + + function Hash_Source_Target_Relation + (Rel : Source_Target_Relation) return Bucket_Range_Type; + pragma Inline (Hash_Source_Target_Relation); + -- Obtain the hash value of key Rel + + package ST is new Membership_Sets + (Element_Type => Source_Target_Relation, + "=" => "=", + Hash => Hash_Source_Target_Relation); + + ---------------- + -- Statistics -- + ---------------- + + type Invocation_Graph_Edge_Counts is array (Invocation_Kind) of Natural; + + ---------------- + -- Signatures -- + ---------------- + + function Hash_Invocation_Signature + (IS_Id : Invocation_Signature_Id) return Bucket_Range_Type; + pragma Inline (Hash_Invocation_Signature); + -- Obtain the hash value of key IS_Id + + package SV is new Dynamic_Hash_Tables + (Key_Type => Invocation_Signature_Id, + Value_Type => Invocation_Graph_Vertex_Id, + No_Value => No_Invocation_Graph_Vertex, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Invocation_Graph_Vertex, + Hash => Hash_Invocation_Signature); + + ----------------------- + -- Elaboration roots -- + ----------------------- + + package ER is new Membership_Sets + (Element_Type => Invocation_Graph_Vertex_Id, + "=" => "=", + Hash => Hash_Invocation_Graph_Vertex); + + ----------- + -- Graph -- + ----------- + + package DG is new Directed_Graphs + (Vertex_Id => Invocation_Graph_Vertex_Id, + No_Vertex => No_Invocation_Graph_Vertex, + Hash_Vertex => Hash_Invocation_Graph_Vertex, + Same_Vertex => "=", + Edge_id => Invocation_Graph_Edge_Id, + No_Edge => No_Invocation_Graph_Edge, + Hash_Edge => Hash_Invocation_Graph_Edge, + Same_Edge => "="); + + -- The following type represents the attributes of an invocation graph + + type Invocation_Graph_Attributes is record + Counts : Invocation_Graph_Edge_Counts := (others => 0); + -- Edge statistics + + Edge_Attributes : EA.Dynamic_Hash_Table := EA.Nil; + -- The map of edge -> edge attributes for all edges in the graph + + Graph : DG.Directed_Graph := DG.Nil; + -- The underlying graph describing the relations between edges and + -- vertices. + + Relations : ST.Membership_Set := ST.Nil; + -- The set of relations between source and targets, used to prevent + -- duplicate edges in the graph. + + Roots : ER.Membership_Set := ER.Nil; + -- The set of elaboration root vertices + + Signature_To_Vertex : SV.Dynamic_Hash_Table := SV.Nil; + -- The map of signature -> vertex + + Vertex_Attributes : VA.Dynamic_Hash_Table := VA.Nil; + -- The map of vertex -> vertex attributes for all vertices in the + -- graph. + end record; + + type Invocation_Graph is access Invocation_Graph_Attributes; + Nil : constant Invocation_Graph := null; + + --------------- + -- Iterators -- + --------------- + + type All_Edge_Iterator is new DG.All_Edge_Iterator; + type All_Vertex_Iterator is new DG.All_Vertex_Iterator; + type Edges_To_Targets_Iterator is new DG.Outgoing_Edge_Iterator; + type Elaboration_Root_Iterator is new ER.Iterator; + end Invocation_Graphs; + + -------------------- + -- Library_Graphs -- + -------------------- + + package Library_Graphs is + + -- The following type represents the various kinds of library edges + + type Library_Graph_Edge_Kind is + (Body_Before_Spec_Edge, + -- Successor denotes spec, Predecessor denotes a body. This is a + -- special edge kind used only during the discovery of components. + -- Note that a body can never be elaborated before its spec. + + Elaborate_Edge, + -- Successor withs Predecessor, and has pragma Elaborate for it + + Elaborate_All_Edge, + -- Successor withs Predecessor, and has pragma Elaborate_All for it + +-- Forced_Edge, + -- Successor is forced to with Predecessor by virtue of an existing + -- elaboration order provided in a file. + + Invocation_Edge, + -- An invocation construct in unit Successor invokes a target in unit + -- Predecessor. + + Spec_Before_Body_Edge, + -- Successor denotes a body, Predecessor denotes a spec + + With_Edge, + -- Successor withs Predecessor + + No_Edge); + + ----------- + -- Graph -- + ----------- + + -- The following type denotes a library graph handle. Each instance must + -- be created using routine Create. + + type Library_Graph is private; + Nil : constant Library_Graph; + + ---------------------- + -- Graph operations -- + ---------------------- + + procedure Add_Edge + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + Kind : Library_Graph_Edge_Kind); + pragma Inline (Add_Edge); + -- Create a new edge in library graph G with source vertex Pred and + -- destination vertex Succ. Kind denotes the nature of the edge. + + procedure Add_Vertex + (G : Library_Graph; + U_Id : Unit_Id); + pragma Inline (Add_Vertex); + -- Create a new vertex in library graph G. U_Id is the unit the vertex + -- describes. + + function Create + (Initial_Vertices : Positive; + Initial_Edges : Positive) return Library_Graph; + pragma Inline (Create); + -- Create a new empty graph with vertex capacity Initial_Vertices and + -- edge capacity Initial_Edges. + + procedure Destroy (G : in out Library_Graph); + pragma Inline (Destroy); + -- Destroy the contents of library graph G, rendering it unusable + + procedure Find_Components (G : Library_Graph); + pragma Inline (Find_Components); + -- Find all components in library graph G + + function Present (G : Library_Graph) return Boolean; + pragma Inline (Present); + -- Determine whether library graph G exists + + ----------------------- + -- Vertex attributes -- + ----------------------- + + function Component + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Component_Id; + pragma Inline (Component); + -- Obtain the component where vertex LGV_Id of library graph G resides + + function Corresponding_Item + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + pragma Inline (Corresponding_Item); + -- Obtain the complementary vertex which represents the corresponding + -- spec or body of vertex LGV_Id of library graph G. + + function Corresponding_Vertex + (G : Library_Graph; + U_Id : Unit_Id) return Library_Graph_Vertex_Id; + pragma Inline (Corresponding_Vertex); + -- Obtain the corresponding vertex of library graph G which represents + -- unit U_Id. + + procedure Decrement_Pending_Predecessors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Decrement_Pending_Predecessors); + -- Decrease the number of pending predecessors vertex LGV_Id of library + -- graph G must wait on until it can be elaborated. + + function In_Elaboration_Order + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (In_Elaboration_Order); + -- Determine whether vertex LGV_Id of library graph G is already in some + -- elaboration order. + + function Name + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Unit_Name_Type; + pragma Inline (Name); + -- Obtain the name of the unit which vertex LGV_Id of library graph G + -- represents. + + function Pending_Predecessors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Natural; + pragma Inline (Pending_Predecessors); + -- Obtain the number of pending predecessors vertex LGV_Id of library + -- graph G must wait on until it can be elaborated. + + procedure Set_Corresponding_Item + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Val : Library_Graph_Vertex_Id); + pragma Inline (Set_Corresponding_Item); + -- Set the complementary vertex which represents the corresponding + -- spec or body of vertex LGV_Id of library graph G to value Val. + + procedure Set_In_Elaboration_Order + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id; + Val : Boolean := True); + pragma Inline (Set_In_Elaboration_Order); + -- Mark vertex LGV_Id of library graph G as included in some elaboration + -- order depending on value Val. + + function Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Unit_Id; + pragma Inline (Unit); + -- Obtain the unit vertex LGV_Id of library graph G represents + + --------------------- + -- Edge attributes -- + --------------------- + + function Kind + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Edge_Kind; + pragma Inline (Kind); + -- Obtain the nature of edge LGE_Id of library graph G + + function Predecessor + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id; + pragma Inline (Predecessor); + -- Obtain the predecessor vertex of edge LGE_Id of library graph G + + function Successor + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id; + pragma Inline (Successor); + -- Obtain the successor vertex of edge LGE_Id of library graph G + + -------------------------- + -- Component attributes -- + -------------------------- + + procedure Decrement_Pending_Predecessors + (G : Library_Graph; + Comp : Component_Id); + pragma Inline (Decrement_Pending_Predecessors); + -- Decrease the number of pending predecessors component Comp of library + -- graph G must wait on until it can be elaborated. + + function Pending_Predecessors + (G : Library_Graph; + Comp : Component_Id) return Natural; + pragma Inline (Pending_Predecessors); + -- Obtain the number of pending predecessors component Comp of library + -- graph G must wait on until it can be elaborated. + + --------------- + -- Semantics -- + --------------- + + function Is_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Body); + -- Determine whether vertex LGV_Id of library graph G denotes a body + + function Is_Body_Of_Spec_With_Elaborate_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Body_Of_Spec_With_Elaborate_Body); + -- Determine whether vertex LGV_Id of library graph G denotes a body + -- with a corresponding spec, and the spec has pragma Elaborate_Body. + + function Is_Body_With_Spec + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Body_With_Spec); + -- Determine whether vertex LGV_Id of library graph G denotes a body + -- with a corresponding spec. + + function Is_Elaborable_Component + (G : Library_Graph; + Comp : Component_Id) return Boolean; + pragma Inline (Is_Elaborable_Component); + -- Determine whether component Comp of library graph G can be elaborated + + function Is_Elaborable_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Elaborable_Vertex); + -- Determine whether vertex LGV_Id of library graph G can be elaborated + + function Is_Internal_Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Internal_Unit); + -- Determine whether vertex LGV_Id of library graph G denotes an + -- internal unit. + + function Is_Predefined_Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Predefined_Unit); + -- Determine whether vertex LGV_Id of library graph G denotes a + -- predefined unit. + + function Is_Preelaborated_Unit + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Preelaborated_Unit); + -- Determine whether vertex LGV_Id of library graph G denotes a unit + -- subjec to pragma Pure or Preelaborable. + + function Is_Spec + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Spec); + -- Determine whether vertex LGV_Id of library graph G denotes a spec + + function Is_Spec_With_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Spec_With_Body); + -- Determine whether vertex LGV_Id of library graph G denotes a spec + -- with a corresponding body. + + function Is_Spec_With_Elaborate_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Spec_With_Elaborate_Body); + -- Determine whether vertex LGV_Id of library graph G denotes a spec + -- with a corresponding body, and is subject to pragma Elaborate_Body. + + function Links_Vertices_In_Same_Component + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Links_Vertices_In_Same_Component); + -- Determine whether edge LGE_Id of library graph G links a predecessor + -- and a successor that reside within the same component. + + function Needs_Elaboration + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Needs_Elaboration); + -- Determine whether vertex LGV_Id of library graph G represents a unit + -- that needs to be elaborated. + + function Proper_Body + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + pragma Inline (Proper_Body); + -- Obtain the body of vertex LGV_Id of library graph G + + function Proper_Spec + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + pragma Inline (Proper_Spec); + -- Obtain the spec of vertex LGV_Id of library graph G + + ---------------- + -- Statistics -- + ---------------- + + function Library_Graph_Edge_Count + (G : Library_Graph; + Kind : Library_Graph_Edge_Kind) return Natural; + pragma Inline (Library_Graph_Edge_Count); + -- Obtain the total number of edges of kind Kind in library graph G + + function Number_Of_Component_Vertices + (G : Library_Graph; + Comp : Component_Id) return Natural; + pragma Inline (Number_Of_Component_Vertices); + -- Obtain the total number of vertices component Comp of library graph + -- contains. + + function Number_Of_Components (G : Library_Graph) return Natural; + pragma Inline (Number_Of_Components); + -- Obtain the total number of components in library graph G + + function Number_Of_Edges (G : Library_Graph) return Natural; + pragma Inline (Number_Of_Edges); + -- Obtain the total number of edges in library graph G + + function Number_Of_Edges_To_Successors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Natural; + pragma Inline (Number_Of_Edges_To_Successors); + -- Obtain the total number of edges to successors vertex LGV_Id of + -- library graph G has. + + function Number_Of_Vertices (G : Library_Graph) return Natural; + pragma Inline (Number_Of_Vertices); + -- Obtain the total number of vertices in library graph G + + --------------- + -- Iterators -- + --------------- + + -- The following type represents an iterator over all edges of a library + -- graph. + + type All_Edge_Iterator is private; + + function Has_Next (Iter : All_Edge_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more edges to examine + + function Iterate_All_Edges (G : Library_Graph) return All_Edge_Iterator; + pragma Inline (Iterate_All_Edges); + -- Obtain an iterator over all edges of library graph G + + procedure Next + (Iter : in out All_Edge_Iterator; + LGE_Id : out Library_Graph_Edge_Id); + pragma Inline (Next); + -- Return the current edge referenced by iterator Iter and advance to + -- the next available edge. + + -- The following type represents an iterator over all vertices of a + -- library graph. + + type All_Vertex_Iterator is private; + + function Has_Next (Iter : All_Vertex_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more vertices to examine + + function Iterate_All_Vertices + (G : Library_Graph) return All_Vertex_Iterator; + pragma Inline (Iterate_All_Vertices); + -- Obtain an iterator over all vertices of library graph G + + procedure Next + (Iter : in out All_Vertex_Iterator; + LGV_Id : out Library_Graph_Vertex_Id); + pragma Inline (Next); + -- Return the current vertex referenced by iterator Iter and advance + -- to the next available vertex. + + -- The following type represents an iterator over all components of a + -- library graph. + + type Component_Iterator is private; + + function Has_Next (Iter : Component_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more components to examine + + function Iterate_Components + (G : Library_Graph) return Component_Iterator; + pragma Inline (Iterate_Components); + -- Obtain an iterator over all components of library graph G + + procedure Next + (Iter : in out Component_Iterator; + Comp : out Component_Id); + pragma Inline (Next); + -- Return the current component referenced by iterator Iter and advance + -- to the next available component. + + -- The following type represents an iterator over all vertices of a + -- component. + + type Component_Vertex_Iterator is private; + + function Has_Next (Iter : Component_Vertex_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more vertices to examine + + function Iterate_Component_Vertices + (G : Library_Graph; + Comp : Component_Id) return Component_Vertex_Iterator; + pragma Inline (Iterate_Component_Vertices); + -- Obtain an iterator over all vertices of component Comp of library + -- graph G. + + procedure Next + (Iter : in out Component_Vertex_Iterator; + LGV_Id : out Library_Graph_Vertex_Id); + pragma Inline (Next); + -- Return the current vertex referenced by iterator Iter and advance + -- to the next available vertex. + + -- The following type represents an iterator over all edges that reach + -- successors starting from a particular predecessor vertex. + + type Edges_To_Successors_Iterator is private; + + function Has_Next (Iter : Edges_To_Successors_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more edges to examine + + function Iterate_Edges_To_Successors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) return Edges_To_Successors_Iterator; + pragma Inline (Iterate_Components); + -- Obtain an iterator over all edges to successors with predecessor + -- vertex LGV_Id of library graph G. + + procedure Next + (Iter : in out Edges_To_Successors_Iterator; + LGE_Id : out Library_Graph_Edge_Id); + pragma Inline (Next); + -- Return the current edge referenced by iterator Iter and advance to + -- the next available edge. + + private + + -------------- + -- Vertices -- + -------------- + + procedure Destroy_Library_Graph_Vertex + (LGV_Id : in out Library_Graph_Vertex_Id); + pragma Inline (Destroy_Library_Graph_Vertex); + -- Destroy library graph vertex LGV_Id + + -- The following type represents the attributes of a library graph + -- vertex. + + type Library_Graph_Vertex_Attributes is record + Corresponding_Item : Library_Graph_Vertex_Id := + No_Library_Graph_Vertex; + -- The reference to the corresponding spec or body. This attribute is + -- set as follows: + -- + -- * If predicate Is_Body_With_Spec is True, the reference denotes + -- the corresponding spec. + -- + -- * If predicate Is_Spec_With_Body is True, the reference denotes + -- the corresponding body. + -- + -- * Otherwise the attribute remains empty. + + In_Elaboration_Order : Boolean := False; + -- Set when this vertex is elaborated + + Pending_Predecessors : Natural := 0; + -- The number of pending predecessor vertices this vertex must wait + -- on before it can be elaborated. + + Unit : Unit_Id := No_Unit_Id; + -- The reference to unit this vertex represents + end record; + + No_Library_Graph_Vertex_Attributes : + constant Library_Graph_Vertex_Attributes := + (Corresponding_Item => No_Library_Graph_Vertex, + In_Elaboration_Order => False, + Pending_Predecessors => 0, + Unit => No_Unit_Id); + + procedure Destroy_Library_Graph_Vertex_Attributes + (Attrs : in out Library_Graph_Vertex_Attributes); + pragma Inline (Destroy_Library_Graph_Vertex_Attributes); + -- Destroy the contents of attributes Attrs + + package VA is new Dynamic_Hash_Tables + (Key_Type => Library_Graph_Vertex_Id, + Value_Type => Library_Graph_Vertex_Attributes, + No_Value => No_Library_Graph_Vertex_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Library_Graph_Vertex_Attributes, + Hash => Hash_Library_Graph_Vertex); + + ----------- + -- Edges -- + ----------- + + procedure Destroy_Library_Graph_Edge + (LGE_Id : in out Library_Graph_Edge_Id); + pragma Inline (Destroy_Library_Graph_Edge); + -- Destroy library graph edge LGE_Id + + -- The following type represents the attributes of a library graph edge + + type Library_Graph_Edge_Attributes is record + Kind : Library_Graph_Edge_Kind := No_Edge; + -- The nature of the library graph edge + end record; + + No_Library_Graph_Edge_Attributes : + constant Library_Graph_Edge_Attributes := + (Kind => No_Edge); + + procedure Destroy_Library_Graph_Edge_Attributes + (Attrs : in out Library_Graph_Edge_Attributes); + pragma Inline (Destroy_Library_Graph_Edge_Attributes); + -- Destroy the contents of attributes Attrs + + package EA is new Dynamic_Hash_Tables + (Key_Type => Library_Graph_Edge_Id, + Value_Type => Library_Graph_Edge_Attributes, + No_Value => No_Library_Graph_Edge_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Library_Graph_Edge_Attributes, + Hash => Hash_Library_Graph_Edge); + + ---------------- + -- Components -- + ---------------- + + -- The following type represents the attributes of a component + + type Component_Attributes is record + Pending_Predecessors : Natural := 0; + -- The number of pending predecessor components this component must + -- wait on before it can be elaborated. + end record; + + No_Component_Attributes : constant Component_Attributes := + (Pending_Predecessors => 0); + + procedure Destroy_Component_Attributes + (Attrs : in out Component_Attributes); + pragma Inline (Destroy_Component_Attributes); + -- Destroy the contents of attributes Attrs + + package CA is new Dynamic_Hash_Tables + (Key_Type => Component_Id, + Value_Type => Component_Attributes, + No_Value => No_Component_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Component_Attributes, + Hash => Hash_Component); + + --------------- + -- Relations -- + --------------- + + -- The following type represents a relation between a predecessor and + -- successor vertices. + + type Predecessor_Successor_Relation is record + Predecessor : Library_Graph_Vertex_Id := No_Library_Graph_Vertex; + -- The source vertex + + Successor : Library_Graph_Vertex_Id := No_Library_Graph_Vertex; + -- The destination vertex + end record; + + No_Predecessor_Successor_Relation : + constant Predecessor_Successor_Relation := + (Predecessor => No_Library_Graph_Vertex, + Successor => No_Library_Graph_Vertex); + + function Hash_Predecessor_Successor_Relation + (Rel : Predecessor_Successor_Relation) return Bucket_Range_Type; + pragma Inline (Hash_Predecessor_Successor_Relation); + -- Obtain the hash value of key Rel + + package PS is new Membership_Sets + (Element_Type => Predecessor_Successor_Relation, + "=" => "=", + Hash => Hash_Predecessor_Successor_Relation); + + ---------------- + -- Statistics -- + ---------------- + + type Library_Graph_Edge_Counts is + array (Library_Graph_Edge_Kind) of Natural; + + ----------- + -- Units -- + ----------- + + package UV is new Dynamic_Hash_Tables + (Key_Type => Unit_Id, + Value_Type => Library_Graph_Vertex_Id, + No_Value => No_Library_Graph_Vertex, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Library_Graph_Vertex, + Hash => Hash_Unit); + + ----------- + -- Graph -- + ----------- + + package DG is new Directed_Graphs + (Vertex_Id => Library_Graph_Vertex_Id, + No_Vertex => No_Library_Graph_Vertex, + Hash_Vertex => Hash_Library_Graph_Vertex, + Same_Vertex => "=", + Edge_Id => Library_Graph_Edge_Id, + No_Edge => No_Library_Graph_Edge, + Hash_Edge => Hash_Library_Graph_Edge, + Same_Edge => "="); + + -- The following type represents the attributes of a library graph + + type Library_Graph_Attributes is record + Component_Attributes : CA.Dynamic_Hash_Table := CA.Nil; + -- The map of component -> component attributes for all components in + -- the graph. + + Counts : Library_Graph_Edge_Counts := (others => 0); + -- Edge statistics + + Edge_Attributes : EA.Dynamic_Hash_Table := EA.Nil; + -- The map of edge -> edge attributes for all edges in the graph + + Graph : DG.Directed_Graph := DG.Nil; + -- The underlying graph describing the relations between edges and + -- vertices. + + Relations : PS.Membership_Set := PS.Nil; + -- The set of relations between successors and predecessors, used to + -- prevent duplicate edges in the graph. + + Unit_To_Vertex : UV.Dynamic_Hash_Table := UV.Nil; + -- The map of unit -> vertex + + Vertex_Attributes : VA.Dynamic_Hash_Table := VA.Nil; + -- The map of vertex -> vertex attributes for all vertices in the + -- graph. + end record; + + type Library_Graph is access Library_Graph_Attributes; + Nil : constant Library_Graph := null; + + --------------- + -- Iterators -- + --------------- + + type All_Edge_Iterator is new DG.All_Edge_Iterator; + type All_Vertex_Iterator is new DG.All_Vertex_Iterator; + type Component_Iterator is new DG.Component_Iterator; + type Component_Vertex_Iterator is new DG.Component_Vertex_Iterator; + type Edges_To_Successors_Iterator is new DG.Outgoing_Edge_Iterator; + end Library_Graphs; + +end Bindo.Graphs; diff --git a/gcc/ada/bindo-units.adb b/gcc/ada/bindo-units.adb new file mode 100644 index 0000000..04471fa --- /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 0000000..0c1d901 --- /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 0000000..54d2fc6 --- /dev/null +++ b/gcc/ada/bindo-validators.adb @@ -0,0 +1,679 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . V A L I D A T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Output; use Output; +with Types; use Types; + +with Bindo.Units; use Bindo.Units; + +with GNAT; use GNAT; +with GNAT.Sets; use GNAT.Sets; + +package body Bindo.Validators is + + ---------------------------------- + -- Elaboration_Order_Validators -- + ---------------------------------- + + package body Elaboration_Order_Validators is + package US is new Membership_Sets + (Element_Type => Unit_Id, + "=" => "=", + Hash => Hash_Unit); + use US; + + Has_Invalid_Data : Boolean := False; + -- Flag set when the elaboration order contains invalid data + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Build_Elaborable_Unit_Set return Membership_Set; + pragma Inline (Build_Elaborable_Unit_Set); + -- Create a set from all units that need to be elaborated + + procedure Report_Missing_Elaboration (U_Id : Unit_Id); + pragma Inline (Report_Missing_Elaboration); + -- Emit an error concerning unit U_Id that must be elaborated, but was + -- not. + + procedure Report_Missing_Elaborations (Set : Membership_Set); + pragma Inline (Report_Missing_Elaborations); + -- Emit errors on all units in set Set that must be elaborated, but were + -- not. + + procedure Report_Spurious_Elaboration (U_Id : Unit_Id); + pragma Inline (Report_Spurious_Elaboration); + -- Emit an error concerning unit U_Id that is incorrectly elaborated + + procedure Validate_Unit (U_Id : Unit_Id; Elab_Set : Membership_Set); + pragma Inline (Validate_Unit); + -- Validate the elaboration status of unit U_Id. Elab_Set is the set of + -- all units that need to be elaborated. + + procedure Validate_Units (Order : Unit_Id_Table); + pragma Inline (Validate_Units); + -- Validate all units in elaboration order Order + + procedure Write_Error (Msg : String); + pragma Inline (Write_Error); + -- Write error message Msg to standard output and signal that the + -- elaboration order is incorrect. + + ------------------------------- + -- Build_Elaborable_Unit_Set -- + ------------------------------- + + function Build_Elaborable_Unit_Set return Membership_Set is + Iter : Elaborable_Units_Iterator; + Set : Membership_Set; + U_Id : Unit_Id; + + begin + Set := Create (Number_Of_Elaborable_Units); + Iter := Iterate_Elaborable_Units; + while Has_Next (Iter) loop + Next (Iter, U_Id); + pragma Assert (Present (U_Id)); + + Insert (Set, U_Id); + end loop; + + return Set; + end Build_Elaborable_Unit_Set; + + -------------------------------- + -- Report_Missing_Elaboration -- + -------------------------------- + + procedure Report_Missing_Elaboration (U_Id : Unit_Id) is + Msg : constant String := "Report_Missing_Elaboration"; + + begin + pragma Assert (Present (U_Id)); + Write_Error (Msg); + + Write_Str ("unit (U_Id_"); + Write_Int (Int (U_Id)); + Write_Str (") name = "); + Write_Name (Name (U_Id)); + Write_Str (" must be elaborated"); + Write_Eol; + end Report_Missing_Elaboration; + + --------------------------------- + -- Report_Missing_Elaborations -- + --------------------------------- + + procedure Report_Missing_Elaborations (Set : Membership_Set) is + Iter : Iterator; + U_Id : Unit_Id; + + begin + Iter := Iterate (Set); + while Has_Next (Iter) loop + Next (Iter, U_Id); + pragma Assert (Present (U_Id)); + + Report_Missing_Elaboration (U_Id); + end loop; + end Report_Missing_Elaborations; + + --------------------------------- + -- Report_Spurious_Elaboration -- + --------------------------------- + + procedure Report_Spurious_Elaboration (U_Id : Unit_Id) is + Msg : constant String := "Report_Spurious_Elaboration"; + + begin + pragma Assert (Present (U_Id)); + Write_Error (Msg); + + Write_Str ("unit (U_Id_"); + Write_Int (Int (U_Id)); + Write_Str (") name = "); + Write_Name (Name (U_Id)); + Write_Str (" must not be elaborated"); + end Report_Spurious_Elaboration; + + -------------------------------- + -- Validate_Elaboration_Order -- + -------------------------------- + + procedure Validate_Elaboration_Order (Order : Unit_Id_Table) is + begin + -- Nothing to do when switch -d_V (validate bindo graphs and order) + -- is not in effect. + + if not Debug_Flag_Underscore_VV then + return; + end if; + + Validate_Units (Order); + + if Has_Invalid_Data then + raise Invalid_Elaboration_Order; + end if; + end Validate_Elaboration_Order; + + ------------------- + -- Validate_Unit -- + ------------------- + + procedure Validate_Unit (U_Id : Unit_Id; Elab_Set : Membership_Set) is + begin + pragma Assert (Present (U_Id)); + + -- The current unit in the elaboration order appears within the set + -- of units that require elaboration. Remove it from the set. + + if Contains (Elab_Set, U_Id) then + Delete (Elab_Set, U_Id); + + -- Otherwise the current unit in the elaboration order must not be + -- elaborated. + + else + Report_Spurious_Elaboration (U_Id); + end if; + end Validate_Unit; + + -------------------- + -- Validate_Units -- + -------------------- + + procedure Validate_Units (Order : Unit_Id_Table) is + Elab_Set : Membership_Set; + + begin + -- Collect all units in the compilation that need to be elaborated + -- in a set. + + Elab_Set := Build_Elaborable_Unit_Set; + + -- Validate each unit in the elaboration order against the set of + -- units that need to be elaborated. + + for Index in Unit_Id_Tables.First .. Unit_Id_Tables.Last (Order) loop + Validate_Unit + (U_Id => Order.Table (Index), + Elab_Set => Elab_Set); + end loop; + + -- At this point all units that need to be elaborated should have + -- been eliminated from the set. Report any units that are missing + -- their elaboration. + + Report_Missing_Elaborations (Elab_Set); + Destroy (Elab_Set); + end Validate_Units; + + ----------------- + -- Write_Error -- + ----------------- + + procedure Write_Error (Msg : String) is + begin + Has_Invalid_Data := True; + + Write_Str ("ERROR: "); + Write_Str (Msg); + Write_Eol; + end Write_Error; + end Elaboration_Order_Validators; + + --------------------------------- + -- Invocation_Graph_Validators -- + --------------------------------- + + package body Invocation_Graph_Validators is + Has_Invalid_Data : Boolean := False; + -- Flag set when the invocation graph contains invalid data + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Validate_Invocation_Graph_Edge + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id); + pragma Inline (Validate_Invocation_Graph_Edge); + -- Verify that the attributes of edge IGE_Id of invocation graph G are + -- properly set. + + procedure Validate_Invocation_Graph_Edges (G : Invocation_Graph); + pragma Inline (Validate_Invocation_Graph_Edges); + -- Verify that the attributes of all edges of invocation graph G are + -- properly set. + + procedure Validate_Invocation_Graph_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id); + pragma Inline (Validate_Invocation_Graph_Vertex); + -- Verify that the attributes of vertex IGV_Id of inbocation graph G are + -- properly set. + + procedure Validate_Invocation_Graph_Vertices (G : Invocation_Graph); + pragma Inline (Validate_Invocation_Graph_Vertices); + -- Verify that the attributes of all vertices of invocation graph G are + -- properly set. + + procedure Write_Error (Msg : String); + pragma Inline (Write_Error); + -- Write error message Msg to standard output and signal that the + -- invocation graph is incorrect. + + ------------------------------- + -- Validate_Invocation_Graph -- + ------------------------------- + + procedure Validate_Invocation_Graph (G : Invocation_Graph) is + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -d_V (validate bindo graphs and order) + -- is not in effect. + + if not Debug_Flag_Underscore_VV then + return; + end if; + + Validate_Invocation_Graph_Vertices (G); + Validate_Invocation_Graph_Edges (G); + + if Has_Invalid_Data then + raise Invalid_Invocation_Graph; + end if; + end Validate_Invocation_Graph; + + ------------------------------------ + -- Validate_Invocation_Graph_Edge -- + ------------------------------------ + + procedure Validate_Invocation_Graph_Edge + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) + is + Msg : constant String := "Validate_Invocation_Graph_Edge"; + + begin + pragma Assert (Present (G)); + + if not Present (IGE_Id) then + Write_Error (Msg); + + Write_Str (" emply invocation graph edge"); + Write_Eol; + Write_Eol; + return; + end if; + + if not Present (Relation (G, IGE_Id)) then + Write_Error (Msg); + + Write_Str (" invocation graph edge (IGE_Id_"); + Write_Int (Int (IGE_Id)); + Write_Str (") lacks Relation"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Target (G, IGE_Id)) then + Write_Error (Msg); + + Write_Str (" invocation graph edge (IGE_Id_"); + Write_Int (Int (IGE_Id)); + Write_Str (") lacks Target"); + Write_Eol; + Write_Eol; + end if; + end Validate_Invocation_Graph_Edge; + + ------------------------------------- + -- Validate_Invocation_Graph_Edges -- + ------------------------------------- + + procedure Validate_Invocation_Graph_Edges (G : Invocation_Graph) is + IGE_Id : Invocation_Graph_Edge_Id; + Iter : Invocation_Graphs.All_Edge_Iterator; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Edges (G); + while Has_Next (Iter) loop + Next (Iter, IGE_Id); + + Validate_Invocation_Graph_Edge (G, IGE_Id); + end loop; + end Validate_Invocation_Graph_Edges; + + -------------------------------------- + -- Validate_Invocation_Graph_Vertex -- + -------------------------------------- + + procedure Validate_Invocation_Graph_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) + is + Msg : constant String := "Validate_Invocation_Graph_Vertex"; + + begin + pragma Assert (Present (G)); + + if not Present (IGV_Id) then + Write_Error (Msg); + + Write_Str (" emply invocation graph vertex"); + Write_Eol; + Write_Eol; + return; + end if; + + if not Present (Construct (G, IGV_Id)) then + Write_Error (Msg); + + Write_Str (" invocation graph vertex (IGV_Id_"); + Write_Int (Int (IGV_Id)); + Write_Str (") lacks Construct"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Lib_Vertex (G, IGV_Id)) then + Write_Error (Msg); + + Write_Str (" invocation graph vertex (IGV_Id_"); + Write_Int (Int (IGV_Id)); + Write_Str (") lacks Lib_Vertex"); + Write_Eol; + Write_Eol; + end if; + end Validate_Invocation_Graph_Vertex; + + ---------------------------------------- + -- Validate_Invocation_Graph_Vertices -- + ---------------------------------------- + + procedure Validate_Invocation_Graph_Vertices (G : Invocation_Graph) is + IGV_Id : Invocation_Graph_Vertex_Id; + Iter : Invocation_Graphs.All_Vertex_Iterator; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, IGV_Id); + + Validate_Invocation_Graph_Vertex (G, IGV_Id); + end loop; + end Validate_Invocation_Graph_Vertices; + + ----------------- + -- Write_Error -- + ----------------- + + procedure Write_Error (Msg : String) is + begin + Has_Invalid_Data := True; + + Write_Str ("ERROR: "); + Write_Str (Msg); + Write_Eol; + end Write_Error; + end Invocation_Graph_Validators; + + ------------------------------ + -- Library_Graph_Validators -- + ------------------------------ + + package body Library_Graph_Validators is + Has_Invalid_Data : Boolean := False; + -- Flag set when the library graph contains invalid data + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Validate_Library_Graph_Edge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id); + pragma Inline (Validate_Library_Graph_Edge); + -- Verify that the attributes of edge LGE_Id of library graph G are + -- properly set. + + procedure Validate_Library_Graph_Edges (G : Library_Graph); + pragma Inline (Validate_Library_Graph_Edges); + -- Verify that the attributes of all edges of library graph G are + -- properly set. + + procedure Validate_Library_Graph_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Validate_Library_Graph_Vertex); + -- Verify that the attributes of vertex LGV_Id of library graph G are + -- properly set. + + procedure Validate_Library_Graph_Vertices (G : Library_Graph); + pragma Inline (Validate_Library_Graph_Vertices); + -- Verify that the attributes of all vertices of library graph G are + -- properly set. + + procedure Write_Error (Msg : String); + pragma Inline (Write_Error); + -- Write error message Msg to standard output and signal that the + -- library graph is incorrect. + + ---------------------------- + -- Validate_Library_Graph -- + ---------------------------- + + procedure Validate_Library_Graph (G : Library_Graph) is + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -d_V (validate bindo graphs and order) + -- is not in effect. + + if not Debug_Flag_Underscore_VV then + return; + end if; + + Validate_Library_Graph_Vertices (G); + Validate_Library_Graph_Edges (G); + + if Has_Invalid_Data then + raise Invalid_Library_Graph; + end if; + end Validate_Library_Graph; + + --------------------------------- + -- Validate_Library_Graph_Edge -- + --------------------------------- + + procedure Validate_Library_Graph_Edge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) + is + Msg : constant String := "Validate_Library_Graph_Edge"; + + begin + pragma Assert (Present (G)); + + if not Present (LGE_Id) then + Write_Error (Msg); + + Write_Str (" emply library graph edge"); + Write_Eol; + Write_Eol; + return; + end if; + + if Kind (G, LGE_Id) = No_Edge then + Write_Error (Msg); + + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (LGE_Id)); + Write_Str (") is not a valid edge"); + Write_Eol; + Write_Eol; + + elsif Kind (G, LGE_Id) = Body_Before_Spec_Edge then + Write_Error (Msg); + + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (LGE_Id)); + Write_Str (") is a Body_Before_Spec edge"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Predecessor (G, LGE_Id)) then + Write_Error (Msg); + + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (LGE_Id)); + Write_Str (") lacks Predecessor"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Successor (G, LGE_Id)) then + Write_Error (Msg); + + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (LGE_Id)); + Write_Str (") lacks Successor"); + Write_Eol; + Write_Eol; + end if; + end Validate_Library_Graph_Edge; + + ---------------------------------- + -- Validate_Library_Graph_Edges -- + ---------------------------------- + + procedure Validate_Library_Graph_Edges (G : Library_Graph) is + Iter : Library_Graphs.All_Edge_Iterator; + LGE_Id : Library_Graph_Edge_Id; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Edges (G); + while Has_Next (Iter) loop + Next (Iter, LGE_Id); + pragma Assert (Present (LGE_Id)); + + Validate_Library_Graph_Edge (G, LGE_Id); + end loop; + end Validate_Library_Graph_Edges; + + ----------------------------------- + -- Validate_Library_Graph_Vertex -- + ----------------------------------- + + procedure Validate_Library_Graph_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + is + Msg : constant String := "Validate_Library_Graph_Vertex"; + + begin + pragma Assert (Present (G)); + + if not Present (LGV_Id) then + Write_Error (Msg); + + Write_Str (" empty library graph vertex"); + Write_Eol; + Write_Eol; + return; + end if; + + if (Is_Body_With_Spec (G, LGV_Id) + or else + Is_Spec_With_Body (G, LGV_Id)) + and then not Present (Corresponding_Item (G, LGV_Id)) + then + Write_Error (Msg); + + Write_Str (" library graph vertex (LGV_Id_"); + Write_Int (Int (LGV_Id)); + Write_Str (") lacks Corresponding_Item"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Unit (G, LGV_Id)) then + Write_Error (Msg); + + Write_Str (" library graph vertex (LGV_Id_"); + Write_Int (Int (LGV_Id)); + Write_Str (") lacks Unit"); + Write_Eol; + Write_Eol; + end if; + end Validate_Library_Graph_Vertex; + + ------------------------------------- + -- Validate_Library_Graph_Vertices -- + ------------------------------------- + + procedure Validate_Library_Graph_Vertices (G : Library_Graph) is + Iter : Library_Graphs.All_Vertex_Iterator; + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, LGV_Id); + pragma Assert (Present (LGV_Id)); + + Validate_Library_Graph_Vertex (G, LGV_Id); + end loop; + end Validate_Library_Graph_Vertices; + + ----------------- + -- Write_Error -- + ----------------- + + procedure Write_Error (Msg : String) is + begin + Has_Invalid_Data := True; + + Write_Str ("ERROR: "); + Write_Str (Msg); + Write_Eol; + end Write_Error; + end Library_Graph_Validators; + +end Bindo.Validators; diff --git a/gcc/ada/bindo-validators.ads b/gcc/ada/bindo-validators.ads new file mode 100644 index 0000000..39fccc6 --- /dev/null +++ b/gcc/ada/bindo-validators.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . V A L I D A T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to verify the validity of the +-- various graphs used in determining the elaboration order of units. + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Invocation_Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Validators is + + ---------------------------------- + -- Elaboration_Order_Validators -- + ---------------------------------- + + package Elaboration_Order_Validators is + Invalid_Elaboration_Order : exception; + -- Exception raised when the elaboration order contains invalid data + + procedure Validate_Elaboration_Order (Order : Unit_Id_Table); + -- Ensure that elaboration order Order meets the following requirements: + -- + -- * All units that must be elaborated appear in the order + -- * No other units appear in the order + -- + -- Diagnose issues and raise Invalid_Elaboration_Order if this is not + -- the case. + + end Elaboration_Order_Validators; + + --------------------------------- + -- Invocation_Graph_Validators -- + --------------------------------- + + package Invocation_Graph_Validators is + Invalid_Invocation_Graph : exception; + -- Exception raised when the invocation graph contains invalid data + + procedure Validate_Invocation_Graph (G : Invocation_Graph); + -- Ensure that invocation graph G meets the following requirements: + -- + -- * All attributes of edges are properly set + -- * All attributes of vertices are properly set + -- + -- Diagnose issues and raise Invalid_Invocation_Graph if this is not the + -- case. + + end Invocation_Graph_Validators; + + ------------------------------ + -- Library_Graph_Validators -- + ------------------------------ + + package Library_Graph_Validators is + Invalid_Library_Graph : exception; + -- Exception raised when the library graph contains invalid data + + procedure Validate_Library_Graph (G : Library_Graph); + -- Ensure that library graph G meets the following requirements: + -- + -- * All attributes edges are properly set + -- * All attributes of vertices are properly set + -- + -- Diagnose issues and raise Invalid_Library_Graph if this is not the + -- case. + + end Library_Graph_Validators; + +end Bindo.Validators; diff --git a/gcc/ada/bindo-writers.adb b/gcc/ada/bindo-writers.adb new file mode 100644 index 0000000..7450c15 --- /dev/null +++ b/gcc/ada/bindo-writers.adb @@ -0,0 +1,1333 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . W R I T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Debug; use Debug; +with Fname; use Fname; +with Opt; use Opt; +with Output; use Output; + +with Bindo.Units; use Bindo.Units; + +with GNAT; use GNAT; +with GNAT.Graphs; use GNAT.Graphs; +with GNAT.Sets; use GNAT.Sets; + +package body Bindo.Writers is + + ----------------- + -- ALI_Writers -- + ----------------- + + package body ALI_Writers is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_All_Units; + pragma Inline (Write_All_Units); + -- Write the common form of units to standard output + + procedure Write_Invocation_Construct (IC_Id : Invocation_Construct_Id); + pragma Inline (Write_Invocation_Construct); + -- Write invocation construct IC_Id to standard output + + procedure Write_Invocation_Relation (IR_Id : Invocation_Relation_Id); + pragma Inline (Write_Invocation_Relation); + -- Write invocation relation IR_Id to standard output + + procedure Write_Invocation_Signature (IS_Id : Invocation_Signature_Id); + pragma Inline (Write_Invocation_Signature); + -- Write invocation signature IS_Id to standard output + + procedure Write_Statistics; + pragma Inline (Write_Statistics); + -- Write the statistical information of units to standard output + + procedure Write_Unit (U_Id : Unit_Id); + pragma Inline (Write_Unit); + -- Write the invocation constructs and relations of unit U_Id to + -- standard output. + + procedure Write_Unit_Common (U_Id : Unit_Id); + pragma Inline (Write_Unit_Common); + -- Write the common form of unit U_Id to standard output + + ----------- + -- Debug -- + ----------- + + procedure pau renames Write_All_Units; + pragma Unreferenced (pau); + + procedure pu (U_Id : Unit_Id) renames Write_Unit_Common; + pragma Unreferenced (pu); + + ---------------------- + -- Write_ALI_Tables -- + ---------------------- + + procedure Write_ALI_Tables is + begin + -- Nothing to do when switch -d_A (output invocation tables) is not + -- in effect. + + if not Debug_Flag_Underscore_AA then + return; + end if; + + Write_Str ("ALI Tables"); + Write_Eol; + Write_Eol; + + Write_Statistics; + For_Each_Unit (Write_Unit'Access); + + Write_Str ("ALI Tables end"); + Write_Eol; + Write_Eol; + end Write_ALI_Tables; + + --------------------- + -- Write_All_Units -- + --------------------- + + procedure Write_All_Units is + begin + For_Each_Unit (Write_Unit_Common'Access); + end Write_All_Units; + + -------------------------------- + -- Write_Invocation_Construct -- + -------------------------------- + + procedure Write_Invocation_Construct (IC_Id : Invocation_Construct_Id) is + pragma Assert (Present (IC_Id)); + + IC_Rec : Invocation_Construct_Record renames + Invocation_Constructs.Table (IC_Id); + + begin + Write_Str (" invocation construct (IC_Id_"); + Write_Int (Int (IC_Id)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Kind = "); + Write_Str (IC_Rec.Kind'Img); + Write_Eol; + + Write_Str (" Placement = "); + Write_Str (IC_Rec.Placement'Img); + Write_Eol; + + Write_Invocation_Signature (IC_Rec.Signature); + Write_Eol; + end Write_Invocation_Construct; + + ------------------------------- + -- Write_Invocation_Relation -- + ------------------------------- + + procedure Write_Invocation_Relation (IR_Id : Invocation_Relation_Id) is + pragma Assert (Present (IR_Id)); + + IR_Rec : Invocation_Relation_Record renames + Invocation_Relations.Table (IR_Id); + + begin + Write_Str (" invocation relation (IR_Id_"); + Write_Int (Int (IR_Id)); + Write_Str (")"); + Write_Eol; + + if Present (IR_Rec.Extra) then + Write_Str (" Extra = "); + Write_Name (IR_Rec.Extra); + else + Write_Str (" Extra = none"); + end if; + + Write_Eol; + Write_Str (" Invoker"); + Write_Eol; + + Write_Invocation_Signature (IR_Rec.Invoker); + + Write_Str (" Kind = "); + Write_Str (IR_Rec.Kind'Img); + Write_Eol; + + Write_Str (" Target"); + Write_Eol; + + Write_Invocation_Signature (IR_Rec.Target); + Write_Eol; + end Write_Invocation_Relation; + + -------------------------------- + -- Write_Invocation_Signature -- + -------------------------------- + + procedure Write_Invocation_Signature (IS_Id : Invocation_Signature_Id) is + pragma Assert (Present (IS_Id)); + + IS_Rec : Invocation_Signature_Record renames + Invocation_Signatures.Table (IS_Id); + + begin + Write_Str (" Signature (IS_Id_"); + Write_Int (Int (IS_Id)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Column = "); + Write_Int (Int (IS_Rec.Column)); + Write_Eol; + + Write_Str (" Line = "); + Write_Int (Int (IS_Rec.Line)); + Write_Eol; + + if Present (IS_Rec.Locations) then + Write_Str (" Locations = "); + Write_Name (IS_Rec.Locations); + else + Write_Str (" Locations = none"); + end if; + + Write_Eol; + Write_Str (" Name = "); + Write_Name (IS_Rec.Name); + Write_Eol; + + Write_Str (" Scope = "); + Write_Name (IS_Rec.Scope); + Write_Eol; + end Write_Invocation_Signature; + + ---------------------- + -- Write_Statistics -- + ---------------------- + + procedure Write_Statistics is + begin + Write_Str ("Units : "); + Write_Num (Int (Number_Of_Units)); + Write_Eol; + + Write_Str ("Units to elaborate: "); + Write_Num (Int (Number_Of_Elaborable_Units)); + Write_Eol; + Write_Eol; + end Write_Statistics; + + ---------------- + -- Write_Unit -- + ---------------- + + procedure Write_Unit (U_Id : Unit_Id) is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + Write_Unit_Common (U_Id); + + Write_Str (" First_Invocation_Construct (IC_Id_"); + Write_Int (Int (U_Rec.First_Invocation_Construct)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Last_Invocation_Construct (IC_Id_"); + Write_Int (Int (U_Rec.Last_Invocation_Construct)); + Write_Str (")"); + Write_Eol; + + Write_Str (" First_Invocation_Relation (IR_Id_"); + Write_Int (Int (U_Rec.First_Invocation_Relation)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Last_Invocation_Relation (IR_Id_"); + Write_Int (Int (U_Rec.Last_Invocation_Relation)); + Write_Str (")"); + Write_Eol; + Write_Eol; + + for IC_Id in U_Rec.First_Invocation_Construct .. + U_Rec.Last_Invocation_Construct + loop + Write_Invocation_Construct (IC_Id); + end loop; + + for IR_Id in U_Rec.First_Invocation_Relation .. + U_Rec.Last_Invocation_Relation + loop + Write_Invocation_Relation (IR_Id); + end loop; + end Write_Unit; + + ----------------------- + -- Write_Unit_Common -- + ----------------------- + + procedure Write_Unit_Common (U_Id : Unit_Id) is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + Write_Str ("unit (U_Id_"); + Write_Int (Int (U_Id)); + Write_Str (") name = "); + Write_Name (U_Rec.Uname); + Write_Eol; + + if U_Rec.SAL_Interface then + Write_Str (" SAL_Interface = True"); + Write_Eol; + end if; + end Write_Unit_Common; + end ALI_Writers; + + ------------------------------- + -- Elaboration_Order_Writers -- + ------------------------------- + + package body Elaboration_Order_Writers is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_Unit (U_Id : Unit_Id); + pragma Inline (Write_Unit); + -- Write unit U_Id to standard output + + procedure Write_Units (Order : Unit_Id_Table); + pragma Inline (Write_Units); + -- Write all units found in elaboration order Order to standard output + + ----------------------------- + -- Write_Elaboration_Order -- + ----------------------------- + + procedure Write_Elaboration_Order (Order : Unit_Id_Table) is + begin + -- Nothing to do when switch -d_O (output elaboration order) is not + -- in effect. + + if not Debug_Flag_Underscore_OO then + return; + end if; + + Write_Str ("Elaboration Order"); + Write_Eol; + Write_Eol; + + Write_Units (Order); + + Write_Eol; + Write_Str ("Elaboration Order end"); + Write_Eol; + + Write_Eol; + end Write_Elaboration_Order; + + ---------------- + -- Write_Unit -- + ---------------- + + procedure Write_Unit (U_Id : Unit_Id) is + begin + pragma Assert (Present (U_Id)); + + Write_Str ("unit (U_Id_"); + Write_Int (Int (U_Id)); + Write_Str (") name = "); + Write_Name (Name (U_Id)); + Write_Eol; + end Write_Unit; + + ----------------- + -- Write_Units -- + ----------------- + + procedure Write_Units (Order : Unit_Id_Table) is + begin + for Index in Unit_Id_Tables.First .. Unit_Id_Tables.Last (Order) loop + Write_Unit (Order.Table (Index)); + end loop; + end Write_Units; + end Elaboration_Order_Writers; + + --------------- + -- Indent_By -- + --------------- + + procedure Indent_By (Indent : Indentation_Level) is + begin + for Count in 1 .. Indent loop + Write_Char (' '); + end loop; + end Indent_By; + + ------------------------------ + -- Invocation_Graph_Writers -- + ------------------------------ + + package body Invocation_Graph_Writers is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_Elaboration_Root + (G : Invocation_Graph; + Root : Invocation_Graph_Vertex_Id); + pragma Inline (Write_Elaboration_Root); + -- Write elaboration root Root of invocation graph G to standard output + + procedure Write_Elaboration_Roots (G : Invocation_Graph); + pragma Inline (Write_Elaboration_Roots); + -- Write all elaboration roots of invocation graph G to standard output + + procedure Write_Invocation_Graph_Edge + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id); + pragma Inline (Write_Invocation_Graph_Edge); + -- Write edge IGE_Id of invocation graph G to standard output + + procedure Write_Invocation_Graph_Edges + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id); + pragma Inline (Write_Invocation_Graph_Edges); + -- Write all edges of invocation graph G to standard output + + procedure Write_Invocation_Graph_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id); + pragma Inline (Write_Invocation_Graph_Vertex); + -- Write vertex IGV_Id of invocation graph G to standard output + + procedure Write_Invocation_Graph_Vertices (G : Invocation_Graph); + pragma Inline (Write_Invocation_Graph_Vertices); + -- Write all vertices of invocation graph G to standard output + + procedure Write_Statistics (G : Invocation_Graph); + pragma Inline (Write_Statistics); + -- Write the statistical information of invocation graph G to standard + -- output. + + ----------- + -- Debug -- + ----------- + + procedure pige + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) + renames Write_Invocation_Graph_Edge; + pragma Unreferenced (pige); + + procedure pigv + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) + renames Write_Invocation_Graph_Vertex; + pragma Unreferenced (pigv); + + ---------------------------- + -- Write_Elaboration_Root -- + ---------------------------- + + procedure Write_Elaboration_Root + (G : Invocation_Graph; + Root : Invocation_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Root)); + + Write_Str ("elaboration root (IGV_Id_"); + Write_Int (Int (Root)); + Write_Str (") name = "); + Write_Name (Name (G, Root)); + Write_Eol; + end Write_Elaboration_Root; + + ----------------------------- + -- Write_Elaboration_Roots -- + ----------------------------- + + procedure Write_Elaboration_Roots (G : Invocation_Graph) is + pragma Assert (Present (G)); + + Num_Of_Roots : constant Natural := Number_Of_Elaboration_Roots (G); + + Iter : Elaboration_Root_Iterator; + Root : Invocation_Graph_Vertex_Id; + + begin + Write_Str ("Elaboration roots: "); + Write_Int (Int (Num_Of_Roots)); + Write_Eol; + + if Num_Of_Roots > 0 then + Iter := Iterate_Elaboration_Roots (G); + while Has_Next (Iter) loop + Next (Iter, Root); + pragma Assert (Present (Root)); + + Write_Elaboration_Root (G, Root); + end loop; + else + Write_Eol; + end if; + end Write_Elaboration_Roots; + + ---------------------------- + -- Write_Invocation_Graph -- + ---------------------------- + + procedure Write_Invocation_Graph (G : Invocation_Graph) is + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -d_I (output invocation graph) is not in + -- effect. + + if not Debug_Flag_Underscore_II then + return; + end if; + + Write_Str ("Invocation Graph"); + Write_Eol; + Write_Eol; + + Write_Statistics (G); + Write_Invocation_Graph_Vertices (G); + Write_Elaboration_Roots (G); + + Write_Str ("Invocation Graph end"); + Write_Eol; + + Write_Eol; + end Write_Invocation_Graph; + + --------------------------------- + -- Write_Invocation_Graph_Edge -- + --------------------------------- + + procedure Write_Invocation_Graph_Edge + (G : Invocation_Graph; + IGE_Id : Invocation_Graph_Edge_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (IGE_Id)); + + Targ : constant Invocation_Graph_Vertex_Id := Target (G, IGE_Id); + + pragma Assert (Present (Targ)); + + begin + Write_Str (" invocation graph edge (IGE_Id_"); + Write_Int (Int (IGE_Id)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Relation (IR_Id_"); + Write_Int (Int (Relation (G, IGE_Id))); + Write_Str (")"); + Write_Eol; + + Write_Str (" Target (IGV_Id_"); + Write_Int (Int (Targ)); + Write_Str (") name = "); + Write_Name (Name (G, Targ)); + Write_Eol; + + Write_Eol; + end Write_Invocation_Graph_Edge; + + ---------------------------------- + -- Write_Invocation_Graph_Edges -- + ---------------------------------- + + procedure Write_Invocation_Graph_Edges + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + Num_Of_Edges : constant Natural := + Number_Of_Edges_To_Targets (G, IGV_Id); + + IGE_Id : Invocation_Graph_Edge_Id; + Iter : Invocation_Graphs.Edges_To_Targets_Iterator; + + begin + Write_Str (" Edges to targets: "); + Write_Int (Int (Num_Of_Edges)); + Write_Eol; + + if Num_Of_Edges > 0 then + Iter := Iterate_Edges_To_Targets (G, IGV_Id); + while Has_Next (Iter) loop + Next (Iter, IGE_Id); + pragma Assert (Present (IGE_Id)); + + Write_Invocation_Graph_Edge (G, IGE_Id); + end loop; + else + Write_Eol; + end if; + end Write_Invocation_Graph_Edges; + + ----------------------------------- + -- Write_Invocation_Graph_Vertex -- + ----------------------------------- + + procedure Write_Invocation_Graph_Vertex + (G : Invocation_Graph; + IGV_Id : Invocation_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (IGV_Id)); + + Write_Str ("invocation graph vertex (IGV_Id_"); + Write_Int (Int (IGV_Id)); + Write_Str (") name = "); + Write_Name (Name (G, IGV_Id)); + Write_Eol; + + Write_Str (" Construct (IC_Id_"); + Write_Int (Int (Construct (G, IGV_Id))); + Write_Str (")"); + Write_Eol; + + Write_Str (" Lib_Vertex (LGV_Id_"); + Write_Int (Int (Lib_Vertex (G, IGV_Id))); + Write_Str (")"); + Write_Eol; + + Write_Invocation_Graph_Edges (G, IGV_Id); + end Write_Invocation_Graph_Vertex; + + ------------------------------------- + -- Write_Invocation_Graph_Vertices -- + ------------------------------------- + + procedure Write_Invocation_Graph_Vertices (G : Invocation_Graph) is + IGV_Id : Invocation_Graph_Vertex_Id; + Iter : Invocation_Graphs.All_Vertex_Iterator; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, IGV_Id); + pragma Assert (Present (IGV_Id)); + + Write_Invocation_Graph_Vertex (G, IGV_Id); + end loop; + end Write_Invocation_Graph_Vertices; + + ---------------------- + -- Write_Statistics -- + ---------------------- + + procedure Write_Statistics (G : Invocation_Graph) is + begin + pragma Assert (Present (G)); + + Write_Str ("Edges : "); + Write_Num (Int (Number_Of_Edges (G))); + Write_Eol; + + Write_Str ("Roots : "); + Write_Num (Int (Number_Of_Elaboration_Roots (G))); + Write_Eol; + + Write_Str ("Vertices: "); + Write_Num (Int (Number_Of_Vertices (G))); + Write_Eol; + Write_Eol; + + for Kind in Invocation_Kind'Range loop + Write_Str (" "); + Write_Num (Int (Invocation_Graph_Edge_Count (G, Kind))); + Write_Str (" - "); + Write_Str (Kind'Img); + Write_Eol; + end loop; + + Write_Eol; + end Write_Statistics; + end Invocation_Graph_Writers; + + --------------------------- + -- Library_Graph_Writers -- + --------------------------- + + package body Library_Graph_Writers is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_Component + (G : Library_Graph; + Comp : Component_Id); + pragma Inline (Write_Component); + -- Write component Comp of library graph G to standard output + + procedure Write_Component_Vertices + (G : Library_Graph; + Comp : Component_Id); + pragma Inline (Write_Component_Vertices); + -- Write all vertices of component Comp of library graph G to standard + -- output. + + procedure Write_Components (G : Library_Graph); + pragma Inline (Write_Components); + -- Write all components of library graph G to standard output + + procedure Write_Edges_To_Successors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Write_Edges_To_Successors); + -- Write all edges to successors of predecessor LGV_Id of library graph + -- G to standard output. + + procedure Write_Library_Graph_Edge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id); + pragma Inline (Write_Library_Graph_Edge); + -- Write edge LGE_Id of library graph G to standard output + + procedure Write_Library_Graph_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id); + pragma Inline (Write_Library_Graph_Vertex); + -- Write vertex LGV_Id of library graph G to standard output + + procedure Write_Library_Graph_Vertices (G : Library_Graph); + pragma Inline (Write_Library_Graph_Vertices); + -- Write all vertices of library graph G to standard output + + procedure Write_Statistics (G : Library_Graph); + pragma Inline (Write_Statistics); + -- Write the statistical information of library graph G to standard + -- output. + + ----------- + -- Debug -- + ----------- + + procedure pc + (G : Library_Graph; + Comp : Component_Id) renames Write_Component; + pragma Unreferenced (pc); + + procedure plge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) renames Write_Library_Graph_Edge; + pragma Unreferenced (plge); + + procedure plgv + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) renames Write_Library_Graph_Vertex; + pragma Unreferenced (plgv); + + --------------------- + -- Write_Component -- + --------------------- + + procedure Write_Component + (G : Library_Graph; + Comp : Component_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + Write_Str ("component (Comp_"); + Write_Int (Int (Comp)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Pending_Predecessors = "); + Write_Int (Int (Pending_Predecessors (G, Comp))); + Write_Eol; + + Write_Component_Vertices (G, Comp); + end Write_Component; + + ------------------------------ + -- Write_Component_Vertices -- + ------------------------------ + + procedure Write_Component_Vertices + (G : Library_Graph; + Comp : Component_Id) + is + Iter : Component_Vertex_Iterator; + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + Iter := Iterate_Component_Vertices (G, Comp); + while Has_Next (Iter) loop + Next (Iter, LGV_Id); + pragma Assert (Present (LGV_Id)); + + Write_Str (" library graph vertex (LGV_Id_"); + Write_Int (Int (LGV_Id)); + Write_Str (") name = "); + Write_Name (Name (G, LGV_Id)); + Write_Eol; + end loop; + + Write_Eol; + end Write_Component_Vertices; + + ---------------------- + -- Write_Components -- + ---------------------- + + procedure Write_Components (G : Library_Graph) is + pragma Assert (Present (G)); + + Num_Of_Comps : constant Natural := Number_Of_Components (G); + + Comp : Component_Id; + Iter : Component_Iterator; + + begin + if Num_Of_Comps > 0 then + Iter := Iterate_Components (G); + while Has_Next (Iter) loop + Next (Iter, Comp); + pragma Assert (Present (Comp)); + + Write_Component (G, Comp); + end loop; + else + Write_Eol; + end if; + end Write_Components; + + ------------------------------- + -- Write_Edges_To_Successors -- + ------------------------------- + + procedure Write_Edges_To_Successors + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Num_Of_Edges : constant Natural := + Number_Of_Edges_To_Successors (G, LGV_Id); + + Iter : Edges_To_Successors_Iterator; + LGE_Id : Library_Graph_Edge_Id; + + begin + Write_Str (" Edges to successors: "); + Write_Int (Int (Num_Of_Edges)); + Write_Eol; + + if Num_Of_Edges > 0 then + Iter := Iterate_Edges_To_Successors (G, LGV_Id); + while Has_Next (Iter) loop + Next (Iter, LGE_Id); + pragma Assert (Present (LGE_Id)); + + Write_Library_Graph_Edge (G, LGE_Id); + end loop; + else + Write_Eol; + end if; + end Write_Edges_To_Successors; + + ------------------------- + -- Write_Library_Graph -- + ------------------------- + + procedure Write_Library_Graph (G : Library_Graph) is + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -d_L (output library item graph) is not + -- in effect. + + if not Debug_Flag_Underscore_LL then + return; + end if; + + Write_Str ("Library Graph"); + Write_Eol; + Write_Eol; + + Write_Statistics (G); + Write_Library_Graph_Vertices (G); + Write_Components (G); + + Write_Str ("Library Graph end"); + Write_Eol; + + Write_Eol; + end Write_Library_Graph; + + ------------------------------ + -- Write_Library_Graph_Edge -- + ------------------------------ + + procedure Write_Library_Graph_Edge + (G : Library_Graph; + LGE_Id : Library_Graph_Edge_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (LGE_Id)); + + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, LGE_Id); + Succ : constant Library_Graph_Vertex_Id := Successor (G, LGE_Id); + + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + + begin + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (LGE_Id)); + Write_Str (")"); + Write_Eol; + + Write_Str (" Kind = "); + Write_Str (Kind (G, LGE_Id)'Img); + Write_Eol; + + Write_Str (" Predecessor (LGV_Id_"); + Write_Int (Int (Pred)); + Write_Str (") name = "); + Write_Name (Name (G, Pred)); + Write_Eol; + + Write_Str (" Successor (LGV_Id_"); + Write_Int (Int (Succ)); + Write_Str (") name = "); + Write_Name (Name (G, Succ)); + Write_Eol; + + Write_Eol; + end Write_Library_Graph_Edge; + + -------------------------------- + -- Write_Library_Graph_Vertex -- + -------------------------------- + + procedure Write_Library_Graph_Vertex + (G : Library_Graph; + LGV_Id : Library_Graph_Vertex_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (LGV_Id)); + + Item : constant Library_Graph_Vertex_Id := + Corresponding_Item (G, LGV_Id); + U_Id : constant Unit_Id := Unit (G, LGV_Id); + + pragma Assert (Present (U_Id)); + + begin + Write_Str ("library graph vertex (LGV_Id_"); + Write_Int (Int (LGV_Id)); + Write_Str (") name = "); + Write_Name (Name (G, LGV_Id)); + Write_Eol; + + if Present (Item) then + Write_Str (" Corresponding_Item (LGV_Id_"); + Write_Int (Int (Item)); + Write_Str (") name = "); + Write_Name (Name (G, Item)); + else + Write_Str (" Corresponding_Item = none"); + end if; + + Write_Eol; + Write_Str (" In_Elaboration_Order = "); + + if In_Elaboration_Order (G, LGV_Id) then + Write_Str ("True"); + else + Write_Str ("False"); + end if; + + Write_Eol; + Write_Str (" Pending_Predecessors = "); + Write_Int (Int (Pending_Predecessors (G, LGV_Id))); + Write_Eol; + + Write_Str (" Component (Comp_Id_"); + Write_Int (Int (Component (G, LGV_Id))); + Write_Str (")"); + Write_Eol; + + Write_Str (" Unit (U_Id_"); + Write_Int (Int (U_Id)); + Write_Str (") name = "); + Write_Name (Name (U_Id)); + Write_Eol; + + Write_Edges_To_Successors (G, LGV_Id); + end Write_Library_Graph_Vertex; + + ---------------------------------- + -- Write_Library_Graph_Vertices -- + ---------------------------------- + + procedure Write_Library_Graph_Vertices (G : Library_Graph) is + Iter : Library_Graphs.All_Vertex_Iterator; + LGV_Id : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, LGV_Id); + pragma Assert (Present (LGV_Id)); + + Write_Library_Graph_Vertex (G, LGV_Id); + end loop; + end Write_Library_Graph_Vertices; + + ---------------------- + -- Write_Statistics -- + ---------------------- + + procedure Write_Statistics (G : Library_Graph) is + begin + Write_Str ("Components: "); + Write_Num (Int (Number_Of_Components (G))); + Write_Eol; + + Write_Str ("Edges : "); + Write_Num (Int (Number_Of_Edges (G))); + Write_Eol; + + Write_Str ("Vertices : "); + Write_Num (Int (Number_Of_Vertices (G))); + Write_Eol; + Write_Eol; + + for Kind in Library_Graph_Edge_Kind'Range loop + Write_Str (" "); + Write_Num (Int (Library_Graph_Edge_Count (G, Kind))); + Write_Str (" - "); + Write_Str (Kind'Img); + Write_Eol; + end loop; + + Write_Eol; + end Write_Statistics; + end Library_Graph_Writers; + + -------------------------- + -- Unit_Closure_Writers -- + -------------------------- + + package body Unit_Closure_Writers is + function Hash_File_Name (Nam : File_Name_Type) return Bucket_Range_Type; + pragma Inline (Hash_File_Name); + -- Obtain the hash value of key Nam + + package FS is new Membership_Sets + (Element_Type => File_Name_Type, + "=" => "=", + Hash => Hash_File_Name); + use FS; + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_File_Name (Nam : File_Name_Type); + pragma Inline (Write_File_Name); + -- Write file name Nam to standard output + + procedure Write_Subunit_Closure + (Dep : Sdep_Id; + Set : Membership_Set); + pragma Inline (Write_Subunit_Closure); + -- Write the subunit which corresponds to dependency Dep to standard + -- output if it does not appear in set Set. + + procedure Write_Subunits_Closure (Set : Membership_Set); + pragma Inline (Write_Subunits_Closure); + -- Write all subunits to standard output if they do not appear in set + -- Set. + + procedure Write_Unit_Closure + (U_Id : Unit_Id; + Set : Membership_Set); + pragma Inline (Write_Unit_Closure); + -- Write unit U_Id to standard output if it does not appear in set Set + + procedure Write_Units_Closure + (Order : Unit_Id_Table; + Set : Membership_Set); + pragma Inline (Write_Units_Closure); + -- Write all units of elaboration order Order to standard output if they + -- do not appear in set Set. + + -------------------- + -- Hash_File_Name -- + -------------------- + + function Hash_File_Name + (Nam : File_Name_Type) return Bucket_Range_Type + is + begin + pragma Assert (Present (Nam)); + + return Bucket_Range_Type (Nam); + end Hash_File_Name; + + --------------------- + -- Write_File_Name -- + --------------------- + + procedure Write_File_Name (Nam : File_Name_Type) is + begin + pragma Assert (Present (Nam)); + + if not Zero_Formatting then + Write_Str (" "); + end if; + + Write_Line (Get_Name_String (Nam)); + end Write_File_Name; + + --------------------------- + -- Write_Subunit_Closure -- + --------------------------- + + procedure Write_Subunit_Closure + (Dep : Sdep_Id; + Set : Membership_Set) + is + pragma Assert (Present (Dep)); + pragma Assert (Present (Set)); + + Dep_Rec : Sdep_Record renames Sdep.Table (Dep); + Source : constant File_Name_Type := Dep_Rec.Sfile; + + pragma Assert (Present (Source)); + + begin + -- Nothing to do when the source file has already been written + + if Contains (Set, Source) then + return; + + -- Nothing to do when the source file does not denote a non-internal + -- subunit. + + elsif not Present (Dep_Rec.Subunit_Name) + or else Is_Internal_File_Name (Source) + then + return; + end if; + + -- Mark the subunit as written + + Insert (Set, Source); + Write_File_Name (Source); + end Write_Subunit_Closure; + + ---------------------------- + -- Write_Subunits_Closure -- + ---------------------------- + + procedure Write_Subunits_Closure (Set : Membership_Set) is + begin + pragma Assert (Present (Set)); + + for Dep in Sdep.First .. Sdep.Last loop + Write_Subunit_Closure (Dep, Set); + end loop; + end Write_Subunits_Closure; + + ------------------------ + -- Write_Unit_Closure -- + ------------------------ + + procedure Write_Unit_Closure (Order : Unit_Id_Table) is + Set : Membership_Set; + + begin + -- Nothing to do when switch -R (list sources referenced in closure) + -- is not in effect. + + if not List_Closure then + return; + end if; + + if not Zero_Formatting then + Write_Eol; + Write_Line ("REFERENCED SOURCES"); + end if; + + -- Use a set to avoid writing duplicate units and subunits + + Set := Create (Number_Of_Elaborable_Units); + + Write_Units_Closure (Order, Set); + Write_Subunits_Closure (Set); + + Destroy (Set); + + if not Zero_Formatting then + Write_Eol; + end if; + end Write_Unit_Closure; + + ------------------------ + -- Write_Unit_Closure -- + ------------------------ + + procedure Write_Unit_Closure + (U_Id : Unit_Id; + Set : Membership_Set) + is + pragma Assert (Present (U_Id)); + pragma Assert (Present (Set)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + Source : constant File_Name_Type := U_Rec.Sfile; + + pragma Assert (Present (Source)); + + begin + -- Nothing to do when the source file has already been written + + if Contains (Set, Source) then + return; + + -- Nothing to do for internal source files unless switch -Ra (???) is + -- in effect. + + elsif Is_Internal_File_Name (Source) + and then not List_Closure_All + then + return; + end if; + + -- Mark the source file as written + + Insert (Set, Source); + Write_File_Name (Source); + end Write_Unit_Closure; + + ------------------------- + -- Write_Units_Closure -- + ------------------------- + + procedure Write_Units_Closure + (Order : Unit_Id_Table; + Set : Membership_Set) + is + begin + pragma Assert (Present (Set)); + + for Index in reverse Unit_Id_Tables.First .. + Unit_Id_Tables.Last (Order) + loop + Write_Unit_Closure + (U_Id => Order.Table (Index), + Set => Set); + end loop; + end Write_Units_Closure; + end Unit_Closure_Writers; + + --------------- + -- Write_Num -- + --------------- + + procedure Write_Num + (Val : Int; + Val_Indent : Indentation_Level := Number_Column) + is + function Digits_Indentation return Indentation_Level; + pragma Inline (Digits_Indentation); + -- Determine the level of indentation the number requies in order to + -- be right-justified by Val_Indent. + + ------------------------ + -- Digits_Indentation -- + ------------------------ + + function Digits_Indentation return Indentation_Level is + Indent : Indentation_Level; + Num : Int; + + begin + -- Treat zero as a single digit + + if Val = 0 then + Indent := 1; + + else + Indent := 0; + Num := Val; + + -- Shrink the input value by dividing it until all of its digits + -- are exhausted. + + while Num /= 0 loop + Indent := Indent + 1; + Num := Num / 10; + end loop; + end if; + + return Val_Indent - Indent; + end Digits_Indentation; + + -- Start of processing for Write_Num + + begin + Indent_By (Digits_Indentation); + Write_Int (Val); + end Write_Num; + +end Bindo.Writers; diff --git a/gcc/ada/bindo-writers.ads b/gcc/ada/bindo-writers.ads new file mode 100644 index 0000000..9ed598e --- /dev/null +++ b/gcc/ada/bindo-writers.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O . W R I T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For full architecture, see unit Bindo. + +-- The following unit contains facilities to output the various graphs used in +-- determining the elaboration order, as well as the elaboration order itself +-- to standard output. + +with Types; use Types; + +with Bindo.Graphs; +use Bindo.Graphs; +use Bindo.Graphs.Invocation_Graphs; +use Bindo.Graphs.Library_Graphs; + +package Bindo.Writers is + + ----------------- + -- Indentation -- + ----------------- + + -- The following type defines the level of indentation used in various + -- output routines. + + type Indentation_Level is new Natural; + No_Indentation : constant Indentation_Level := Indentation_Level'First; + + Nested_Indentation : constant Indentation_Level := 2; + -- The level of indentation for a nested new line + + Number_Column : constant Indentation_Level := 6; + -- The level of right justification of numbers + + Step_Column : constant Indentation_Level := 4; + -- The level of right justification of the elaboration order step + + procedure Indent_By (Indent : Indentation_Level); + pragma Inline (Indent_By); + -- Indent the current line by Indent spaces + + procedure Write_Num + (Val : Int; + Val_Indent : Indentation_Level := Number_Column); + pragma Inline (Write_Num); + -- Output integer value Val in a right-justified form based on the value of + -- Val_Col. + + ----------------- + -- ALI_Writers -- + ----------------- + + package ALI_Writers is + procedure Write_ALI_Tables; + -- Write the contents of the following tables to standard output: + -- + -- * ALI.Invocation_Constructs + -- * ALI.Invocation_Relations + + end ALI_Writers; + + ------------------------------- + -- Elaboration_Order_Writers -- + ------------------------------- + + package Elaboration_Order_Writers is + procedure Write_Elaboration_Order (Order : Unit_Id_Table); + -- Write elaboration order Order to standard output + + end Elaboration_Order_Writers; + + ------------------------------ + -- Invocation_Graph_Writers -- + ------------------------------ + + package Invocation_Graph_Writers is + procedure Write_Invocation_Graph (G : Invocation_Graph); + -- Write invocation graph G to standard output + + end Invocation_Graph_Writers; + + --------------------------- + -- Library_Graph_Writers -- + --------------------------- + + package Library_Graph_Writers is + procedure Write_Library_Graph (G : Library_Graph); + -- Write library graph G to standard output + + end Library_Graph_Writers; + + -------------------------- + -- Unit_Closure_Writers -- + -------------------------- + + package Unit_Closure_Writers is + procedure Write_Unit_Closure (Order : Unit_Id_Table); + -- Write all sources in the closure of the main unit as enumerated in + -- elaboration order Order. + + end Unit_Closure_Writers; + +end Bindo.Writers; diff --git a/gcc/ada/bindo.adb b/gcc/ada/bindo.adb new file mode 100644 index 0000000..7d26476 --- /dev/null +++ b/gcc/ada/bindo.adb @@ -0,0 +1,287 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Bindo.Elaborators; +use Bindo.Elaborators.Invocation_And_Library_Graph_Elaborators; + +package body Bindo is + + --------------------------------- + -- Elaboration order mechanism -- + --------------------------------- + + -- The elaboration order (EO) mechanism implemented in this unit and its + -- children has the following objectives: + -- + -- * Find an ordering of all library items (historically referred to as + -- "units") in the bind which require elaboration, taking into account: + -- + -- - The dependencies between units expressed in the form of with + -- clauses. + -- + -- - Pragmas Elaborate, Elaborate_All, Elaborate_Body, Preelaborable, + -- and Pure. + -- + -- - The flow of execution at elaboration time. + -- + -- - Additional dependencies between units supplied to the binder by + -- means of a file. + -- + -- The high-level idea is to construct two graphs: + -- + -- - Invocation graph - Models the flow of execution at elaboration + -- time. + -- + -- - Library graph - Represents with clause and pragma dependencies + -- between units. + -- + -- The library graph is further augmented with additional information + -- from the invocation graph by exploring the execution paths from a + -- unit with elaboration code to other external units. All strongly + -- connected components of the library graph are discovered. Finally, + -- the order is obtained via a topological sort-like algorithm which + -- attempts to order available units while enabling other units to be + -- ordered. + -- + -- * Diagnose elaboration circularities between units + -- + -- The library graph may contain at least one cycle, in which case no + -- ordering is possible. + -- + -- ??? more on this later + + ----------------- + -- Terminology -- + ----------------- + + -- * Component - A strongly connected component of a graph. + -- + -- * Elaboration root - A special invocation construct which denotes the + -- elaboration procedure of a unit. + -- + -- * Invocation - The act of activating a task, calling a subprogram, or + -- instantiating a generic. + -- + -- * Invocation construct - An entry declaration, [single] protected type, + -- subprogram declaration, subprogram instantiation, or a [single] task + -- type declared in the visible, private, or body declarations of some + -- unit. The construct is encoded in the ALI file of the related unit. + -- + -- * Invocation graph - A directed graph which models the flow of execution + -- at elaboration time. + -- + -- - Vertices - Invocation constructs plus extra information. Certain + -- vertices act as elaboration roots. + -- + -- - Edges - Invocation relations plus extra information. + -- + -- * Invocation relation - A flow link between two invocation constructs. + -- This link is encoded in the ALI file of unit that houses the invoker. + -- + -- * Invocation signature - A set of attributes that uniquely identify an + -- invocation construct within the namespace of all ALI files. + -- + -- * Invoker - The source construct of an invocation relation (the caller, + -- instantiator, or task activator). + -- + -- * Library graph - A directed graph which captures with clause and pragma + -- dependencies between units. + -- + -- - Vertices - Units plus extra information. + -- + -- - Edges - With clause, pragma, and additional dependencies between + -- units. + -- + -- * Pending predecessor - A vertex that must be elaborated before another + -- vertex can be elaborated. + -- + -- * Target - The destination construct of an invocation relation (the + -- generic, subprogram, or task type). + + ------------------ + -- Architecture -- + ------------------ + + -- Find_Elaboration_Order + -- | + -- +--> Collect_Elaborable_Units + -- +--> Write_ALI_Tables + -- +--> Elaborate_Units + -- | + -- +------ | -------------- Construction phase ------------------------+ + -- | | | + -- | +--> Build_Library_Graph | + -- | +--> Validate_Library_Graph | + -- | +--> Write_Library_Graph | + -- | | | + -- | +--> Build_Invocation_Graph | + -- | +--> Validate_Invocation_Graph | + -- | +--> Write_Invocation_Graph | + -- | | | + -- +------ | ----------------------------------------------------------+ + -- | + -- +------ | -------------- Augmentation phase ------------------------+ + -- | | | + -- | +--> Augment_Library_Graph | + -- | | | + -- +------ | ----------------------------------------------------------+ + -- | + -- +------ | -------------- Ordering phase ----------------------------+ + -- | | | + -- | +--> Find_Components | + -- | | | + -- | +--> Elaborate_Library_Graph | + -- | +--> Validate_Elaboration_Order | + -- | +--> Write_Elaboration_Order | + -- | | | + -- | +--> Write_Unit_Closure | + -- | | | + -- +------ | ----------------------------------------------------------+ + -- | + -- +------ | -------------- Diagnostics phase -------------------------+ + -- | | | + -- | +--> ??? more on this later | + -- | | + -- +-------------------------------------------------------------------+ + + ------------------------ + -- Construction phase -- + ------------------------ + + -- The Construction phase has the following objectives: + -- + -- * Build the library graph by inspecting the ALI file of each unit that + -- requires elaboration. + -- + -- * Validate the consistency of the library graph, only when switch -d_V + -- is in effect. + -- + -- * Write the contents of the invocation graph in human-readable form to + -- standard output when switch -d_L is in effect. + -- + -- * Build the invocation graph by inspecting invocation constructs and + -- relations in the ALI file of each unit that requires elaboration. + -- + -- * Validate the consistency of the invocation graph, only when switch + -- -d_V is in effect. + -- + -- * Write the contents of the invocation graph in human-readable form to + -- standard output when switch -d_I is in effect. + + ------------------------ + -- Augmentation phase -- + ------------------------ + + -- The Augmentation phase has the following objectives: + -- + -- * Discover transitions of the elaboration flow from a unit with an + -- elaboration root to other units. Augment the library graph with + -- extra edges for each such transition. + + -------------------- + -- Ordering phase -- + -------------------- + + -- The Ordering phase has the following objectives: + -- + -- * Discover all components of the library graph by treating specs and + -- bodies as single vertices. + -- + -- * Try to order as many vertices of the library graph as possible by + -- peforming a topological sort based on the pending predecessors of + -- vertices across all components and within a single component. + -- + -- * Validate the consistency of the order, only when switch -d_V is in + -- effect. + -- + -- * Write the contents of the order in human-readable form to standard + -- output when switch -d_O is in effect. + -- + -- * Write the sources of the order closure when switch -R is in effect. + + ----------------------- + -- Diagnostics phase -- + ----------------------- + + -- ??? more on this later + + -------------- + -- Switches -- + -------------- + + -- -d_A Output ALI invocation tables + -- + -- GNATbind outputs the contents of ALI table Invocation_Constructs + -- and Invocation_Edges in textual format to standard output. + -- + -- -d_I Output invocation graph + -- + -- GNATbind outputs the invocation graph in text format to standard + -- output. + -- + -- -d_L Output library graph + -- + -- GNATbind outputs the library graph in textual format to standard + -- output. + -- + -- -d_N New bindo order + -- + -- GNATbind utilizes the new bindo elaboration order + -- + -- -d_O Output elaboration order + -- + -- GNATbind outputs the elaboration order in text format to standard + -- output. + -- + -- -d_T Output elaboration order trace information + -- + -- GNATbind outputs trace information on elaboration order activities + -- to standard output. + -- + -- -d_V Validate bindo graphs and order + -- + -- GNATbind validates the invocation graph, library graph, SCC graph + -- and elaboration order by detecting inconsistencies and producing + -- error reports. + + ---------------------------------------- + -- Debugging elaboration order issues -- + ---------------------------------------- + + -- ??? more on this later + + ---------------------------- + -- Find_Elaboration_Order -- + ---------------------------- + + procedure Find_Elaboration_Order + (Order : out Unit_Id_Table; + Main_Lib_File : File_Name_Type) + is + begin + Elaborate_Units (Order, Main_Lib_File); + end Find_Elaboration_Order; + +end Bindo; diff --git a/gcc/ada/bindo.ads b/gcc/ada/bindo.ads new file mode 100644 index 0000000..39cf7a4 --- /dev/null +++ b/gcc/ada/bindo.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The following unit contains the main entry point into the elaboration order +-- mechanism. See the body for details. + +with ALI; use ALI; +with Namet; use Namet; + +package Bindo is + + procedure Find_Elaboration_Order + (Order : out Unit_Id_Table; + Main_Lib_File : File_Name_Type); + -- Find an order of all units in the bind that need to be elaborated + -- such that elaboration code flow, pragmas Elaborate, Elaborate_All, + -- and Elaborate_Body, and with clause dependencies are all honoured. + -- Main_Lib_File is the argument of the bind. If a satisfactory order + -- exists, it is returned in Order, otherwise Unrecoverable_Error is + -- raised. + +end Bindo; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index e43174c..d76d93d 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -177,8 +177,8 @@ package body Debug is -- d_C -- d_D -- d_E - -- d_F - -- d_G + -- d_F Encode full invocation paths in ALI files + -- d_G Encode invocation graph in ALI files -- d_H -- d_I -- d_J @@ -191,7 +191,7 @@ package body Debug is -- d_Q -- d_R -- d_S - -- d_T + -- d_T Output trace information on invocation path recording -- d_U -- d_V -- d_W @@ -258,6 +258,160 @@ package body Debug is -- dy -- dz + -- dA + -- dB + -- dC + -- dD + -- dE + -- dF + -- dG + -- dH + -- dI + -- dJ + -- dK + -- dL + -- dM + -- dN + -- dO + -- dP + -- dQ + -- dR + -- dS + -- dT + -- dU + -- dV + -- dW + -- dX + -- dY + -- dZ + + -- d.a + -- d.b + -- d.c + -- d.d + -- d.e + -- d.f + -- d.g + -- d.h + -- d.i + -- d.j + -- d.k + -- d.l + -- d.m + -- d.n + -- d.o + -- d.p + -- d.q + -- d.r + -- d.s + -- d.t + -- d.u + -- d.v + -- d.w + -- d.x + -- d.y + -- d.z + + -- d.A + -- d.B + -- d.C + -- d.D + -- d.E + -- d.F + -- d.G + -- d.H + -- d.I + -- d.J + -- d.K + -- d.L + -- d.M + -- d.N + -- d.O + -- d.P + -- d.Q + -- d.R + -- d.S + -- d.T + -- d.U + -- d.V + -- d.W + -- d.X + -- d.Y + -- d.Z + + -- d.1 + -- d.2 + -- d.3 + -- d.4 + -- d.5 + -- d.6 + -- d.7 + -- d.8 + -- d.9 + + -- d_a + -- d_b + -- d_c + -- d_d + -- d_e + -- d_f + -- d_g + -- d_h + -- d_i + -- d_j + -- d_k + -- d_l + -- d_m + -- d_n + -- d_o + -- d_p + -- d_q + -- d_r + -- d_s + -- d_t + -- d_u + -- d_v + -- d_w + -- d_x + -- d_y + -- d_z + + -- d_A Output ALI invocation tables + -- d_B + -- d_C + -- d_D + -- d_F + -- d_G + -- d_H + -- d_I Output invocation graph + -- d_J + -- d_K + -- d_L Output library graph + -- d_M + -- d_N New bindo order + -- d_O Output elaboration order + -- d_P + -- d_Q + -- d_R + -- d_S + -- d_T Output elaboration order trace information + -- d_U + -- d_V Validate bindo graphs and order + -- d_W + -- d_X + -- d_Y + -- d_Z + + -- d_1 + -- d_2 + -- d_3 + -- d_4 + -- d_5 + -- d_6 + -- d_7 + -- d_8 + -- d_9 + -- Debug flags used in package Make and its clients (e.g. GNATMAKE) -- da @@ -850,11 +1004,21 @@ package body Debug is -- d_A Do not generate ALI files by setting Opt.Disable_ALI_File. + -- d_F The compiler encodes the full path from an invocation construct to + -- an external target, offering additional information to GNATBIND for + -- purposes of error diagnostics. + + -- d_G The compiler encodes the invocation graph of a unit in its ALI + -- file. + -- d_L Output trace information on elaboration checking. This debug switch -- causes output to be generated showing each call or instantiation as -- it is checked, and the progress of the recursive trace through -- elaboration calls at compile time. + -- d_T The compiler outputs trance information to standard output whenever + -- an invocation path is recorded. + -- d1 Error messages have node numbers where possible. Normally error -- messages have only source locations. This option is useful when -- debugging errors caused by expanded code, where the source location @@ -954,11 +1118,10 @@ package body Debug is -- dependencies) except that internal units are included in the -- listing. - -- di Normally gnatbind calls Read_Ali with Ignore_Errors set to - -- False, since the binder really needs correct version ALI - -- files to do its job. This debug flag causes Ignore_Errors - -- mode to be set for the binder (and is particularly useful - -- for testing ignore errors mode). + -- di Normally GNATBIND calls Read_Ali with Ignore_Errors set to False, + -- since the binder really needs correct version ALI files to do its + -- job. This debug flag causes Ignore_Errors mode to be set for the + -- binder (and is particularly useful for testing ignore errors mode). -- dn List details of manipulation of Num_Pred values during execution of -- the algorithm used to determine a correct order of elaboration. This @@ -985,6 +1148,25 @@ package body Debug is -- dx Force the binder to read (and then ignore) the xref information -- in ali files (used to check that read circuit is working OK). + -- d_A GNATBIND output the contents of all ALI invocation-related tables + -- in textual format to standard output. + -- + -- d_I GNATBIND outputs the contents of the invocation graph in textual + -- format to standard output. + -- + -- d_L GNATBIND outputs the contents of the library graph in textual + -- format to standard output. + -- + -- d_N GNATBIND utilizes the elaboration order provided by bindo + -- + -- d_O GNATBIND outputs the elaboration order of units to standard output + -- + -- d_T GNATBIND outputs trace information of elaboration order activities + -- to standard output. + -- + -- d_V GNATBIND validates the invocation graph, library graph, SCC graph + -- and elaboration order. + -------------------------------------------- -- Documentation for gnatmake Debug Flags -- -------------------------------------------- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 6b884ef..4206090 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4940,18 +4940,6 @@ package body Exp_Util is end if; end Evolve_Or_Else; - ------------------- - -- Exceptions_OK -- - ------------------- - - function Exceptions_OK return Boolean is - begin - return - not (Restriction_Active (No_Exception_Handlers) or else - Restriction_Active (No_Exception_Propagation) or else - Restriction_Active (No_Exceptions)); - end Exceptions_OK; - ----------------------------------------- -- Expand_Static_Predicates_In_Choices -- ----------------------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index aac4433..7cb9d2d 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -559,10 +559,6 @@ package Exp_Util is -- indicating that no checks were required). The Sloc field of the -- constructed N_Or_Else node is copied from Cond1. - function Exceptions_OK return Boolean; - -- Determine whether exceptions are allowed to be caught, propagated, or - -- raised. - procedure Expand_Static_Predicates_In_Choices (N : Node_Id); -- N is either a case alternative or a variant. The Discrete_Choices field -- of N points to a list of choices. If any of these choices is the name diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 104b214..dd90c7b 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 be703a9..41541c3 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -29,6 +29,7 @@ with Bcheck; use Bcheck; with Binde; use Binde; with Binderr; use Binderr; with Bindgen; use Bindgen; +with Bindo; use Bindo; with Bindusg; with Casing; use Casing; with Csets; @@ -878,11 +879,18 @@ begin if Errors_Detected = 0 then declare - Elab_Order : Unit_Id_Table; use Unit_Id_Tables; + Elab_Order : Unit_Id_Table; begin - Find_Elab_Order (Elab_Order, First_Main_Lib_File); + -- Use the invocation and library graph-based elaboration order + -- when switch -d_N (new bindo order) is in effect. + + if Debug_Flag_Underscore_NN then + Find_Elaboration_Order (Elab_Order, First_Main_Lib_File); + else + Find_Elab_Order (Elab_Order, First_Main_Lib_File); + end if; if Errors_Detected = 0 and then not Check_Only then Gen_Output_File @@ -892,12 +900,12 @@ begin end; end if; - Total_Errors := Total_Errors + Errors_Detected; + Total_Errors := Total_Errors + Errors_Detected; Total_Warnings := Total_Warnings + Warnings_Detected; exception when Unrecoverable_Error => - Total_Errors := Total_Errors + Errors_Detected; + Total_Errors := Total_Errors + Errors_Detected; Total_Warnings := Total_Warnings + Warnings_Detected; end; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 319557e..ffd6a90 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -62,6 +62,63 @@ package body Lib.Writ is -- Local Subprograms -- ----------------------- + function Column (IS_Id : Invocation_Signature_Id) return Nat; + pragma Inline (Column); + -- Obtain attribute Column of an invocation signature with id IS_Id + + function Extra (IR_Id : Invocation_Relation_Id) return Name_Id; + pragma Inline (Extra); + -- Obtain attribute Extra of an invocation relation with id IR_Id + + function Invoker + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id; + pragma Inline (Invoker); + -- Obtain attribute Invoker of an invocation relation with id IR_Id + + function Kind + (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind; + pragma Inline (Kind); + -- Obtain attribute Kind of an invocation construct with id IC_Id + + function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind; + pragma Inline (Kind); + -- Obtain attribute Kind of an invocation relation with id IR_Id + + function Line (IS_Id : Invocation_Signature_Id) return Nat; + pragma Inline (Line); + -- Obtain attribute Line of an invocation signature with id IS_Id + + function Locations (IS_Id : Invocation_Signature_Id) return Name_Id; + pragma Inline (Locations); + -- Obtain attribute Locations of an invocation signature with id IS_Id + + function Name (IS_Id : Invocation_Signature_Id) return Name_Id; + pragma Inline (Name); + -- Obtain attribute Name of an invocation signature with id IS_Id + + function Placement + (IC_Id : Invocation_Construct_Id) return Body_Placement_Kind; + pragma Inline (Placement); + -- Obtain attribute Placement of an invocation construct with id IC_Id + + function Present (N_Id : Name_Id) return Boolean; + pragma Inline (Present); + -- Determine whether a name with id N_Id exists + + function Scope (IS_Id : Invocation_Signature_Id) return Name_Id; + pragma Inline (Scope); + -- Obtain attribute Scope of an invocation signature with id IS_Id + + function Signature + (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id; + pragma Inline (Signature); + -- Obtain attribute Signature of an invocation construct with id IC_Id + + function Target + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id; + pragma Inline (Target); + -- Obtain attribute Target of an invocation relation with id IR_Id + procedure Write_Unit_Name (N : Node_Id); -- Used to write out the unit name for R (pragma Restriction) lines -- for uses of Restriction (No_Dependence => unit-name). @@ -104,6 +161,16 @@ package body Lib.Writ is OA_Setting => 'O'); end Add_Preprocessing_Dependency; + ------------ + -- Column -- + ------------ + + function Column (IS_Id : Invocation_Signature_Id) return Nat is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Column; + end Column; + ------------------------------ -- Ensure_System_Dependency -- ------------------------------ @@ -185,6 +252,135 @@ package body Lib.Writ is end; end Ensure_System_Dependency; + ----------- + -- Extra -- + ----------- + + function Extra (IR_Id : Invocation_Relation_Id) return Name_Id is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Extra; + end Extra; + + ------------- + -- Invoker -- + ------------- + + function Invoker + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id + is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Invoker; + end Invoker; + + ---------- + -- Kind -- + ---------- + + function Kind + (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind + is + begin + pragma Assert (Present (IC_Id)); + return Invocation_Constructs.Table (IC_Id).Kind; + end Kind; + + ---------- + -- Kind -- + ---------- + + function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Kind; + end Kind; + + ---------- + -- Line -- + ---------- + + function Line (IS_Id : Invocation_Signature_Id) return Nat is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Line; + end Line; + + --------------- + -- Locations -- + --------------- + + function Locations (IS_Id : Invocation_Signature_Id) return Name_Id is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Locations; + end Locations; + + ---------- + -- Name -- + ---------- + + function Name (IS_Id : Invocation_Signature_Id) return Name_Id is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Name; + end Name; + + --------------- + -- Placement -- + --------------- + + function Placement + (IC_Id : Invocation_Construct_Id) return Body_Placement_Kind + is + begin + pragma Assert (Present (IC_Id)); + return Invocation_Constructs.Table (IC_Id).Placement; + end Placement; + + ------------- + -- Present -- + ------------- + + function Present (N_Id : Name_Id) return Boolean is + begin + return N_Id /= No_Name; + end Present; + + ----------- + -- Scope -- + ----------- + + function Scope (IS_Id : Invocation_Signature_Id) return Name_Id is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Scope; + end Scope; + + --------------- + -- Signature -- + --------------- + + function Signature + (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id + is + begin + pragma Assert (Present (IC_Id)); + return Invocation_Constructs.Table (IC_Id).Signature; + end Signature; + + ------------ + -- Target -- + ------------ + + function Target + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id + is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Target; + end Target; + --------------- -- Write_ALI -- --------------- @@ -245,6 +441,9 @@ package body Lib.Writ is -- this file (using Scan_ALI) and returns True. If no file exists, -- or the file is not up to date, then False is returned. + procedure Write_Invocation_Graph; + -- Write out the invocation graph + procedure Write_Unit_Information (Unit_Num : Unit_Number_Type); -- Write out the library information for one unit for which code is -- generated (includes unit line and with lines). @@ -434,6 +633,175 @@ package body Lib.Writ is end Update_Tables_From_ALI_File; ---------------------------- + -- Write_Invocation_Graph -- + ---------------------------- + + procedure Write_Invocation_Graph is + procedure Write_Invocation_Construct + (IC_Id : Invocation_Construct_Id); + pragma Inline (Write_Invocation_Construct); + -- Write invocation construct IC_Id to the ALI file + + procedure Write_Invocation_Relation (IR_Id : Invocation_Relation_Id); + pragma Inline (Write_Invocation_Relation); + -- Write invocation relation IR_Id to the ALI file + + procedure Write_Invocation_Signature + (IS_Id : Invocation_Signature_Id); + pragma Inline (Write_Invocation_Signature); + -- Write invocation signature IS_Id to the ALI file + + -------------------------------- + -- Write_Invocation_Construct -- + -------------------------------- + + procedure Write_Invocation_Construct + (IC_Id : Invocation_Construct_Id) + is + begin + -- G header + + Write_Info_Initiate ('G'); + Write_Info_Char (' '); + + -- line-kind + + Write_Info_Char + (Invocation_Graph_Line_Kind_To_Code (Invocation_Construct_Line)); + Write_Info_Char (' '); + + -- construct-kind + + Write_Info_Char (Invocation_Construct_Kind_To_Code (Kind (IC_Id))); + Write_Info_Char (' '); + + -- construct-body-placement + + Write_Info_Char (Body_Placement_Kind_To_Code (Placement (IC_Id))); + Write_Info_Char (' '); + + -- construct-signature + + Write_Invocation_Signature (Signature (IC_Id)); + Write_Info_EOL; + end Write_Invocation_Construct; + + ------------------------------- + -- Write_Invocation_Relation -- + ------------------------------- + + procedure Write_Invocation_Relation + (IR_Id : Invocation_Relation_Id) + is + begin + -- G header + + Write_Info_Initiate ('G'); + Write_Info_Char (' '); + + -- line-kind + + Write_Info_Char + (Invocation_Graph_Line_Kind_To_Code (Invocation_Relation_Line)); + Write_Info_Char (' '); + + -- relation-kind + + Write_Info_Char (Invocation_Kind_To_Code (Kind (IR_Id))); + Write_Info_Char (' '); + + -- (extra-name | "none") + + if Present (Extra (IR_Id)) then + Write_Info_Name (Extra (IR_Id)); + else + Write_Info_Str ("none"); + end if; + + Write_Info_Char (' '); + + -- invoker-signature + + Write_Invocation_Signature (Invoker (IR_Id)); + Write_Info_Char (' '); + + -- target-signature + + Write_Invocation_Signature (Target (IR_Id)); + + Write_Info_EOL; + end Write_Invocation_Relation; + + -------------------------------- + -- Write_Invocation_Signature -- + -------------------------------- + + procedure Write_Invocation_Signature + (IS_Id : Invocation_Signature_Id) + is + begin + -- [ + + Write_Info_Char ('['); + + -- name + + Write_Info_Name (Name (IS_Id)); + Write_Info_Char (' '); + + -- scope + + Write_Info_Name (Scope (IS_Id)); + Write_Info_Char (' '); + + -- line + + Write_Info_Nat (Line (IS_Id)); + Write_Info_Char (' '); + + -- column + + Write_Info_Nat (Column (IS_Id)); + Write_Info_Char (' '); + + -- (locations | "none") + + if Present (Locations (IS_Id)) then + Write_Info_Name (Locations (IS_Id)); + else + Write_Info_Str ("none"); + end if; + + -- ] + + Write_Info_Char (']'); + end Write_Invocation_Signature; + + -- Start of processing for Write_Invocation_Graph + + begin + -- First write out all invocation constructs declared within the + -- current unit. This ensures that when this invocation is read, + -- the invocation constructs are materialized before they are + -- referenced by invocation relations. + + for IC_Id in Invocation_Constructs.First .. + Invocation_Constructs.Last + loop + Write_Invocation_Construct (IC_Id); + end loop; + + -- Write out all invocation relations that originate from invocation + -- constructs delared in the current unit. + + for IR_Id in Invocation_Relations.First .. + Invocation_Relations.Last + loop + Write_Invocation_Relation (IR_Id); + end loop; + end Write_Invocation_Graph; + + ---------------------------- -- Write_Unit_Information -- ---------------------------- @@ -1618,6 +1986,10 @@ package body Lib.Writ is end loop; end; + -- Output the invocation graph + + Write_Invocation_Graph; + -- Output cross-references if Opt.Xref_Active then diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 34e2480..c17233a 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -846,6 +846,94 @@ package Lib.Writ is -- dependency checking, but must be present for proper interpretation -- of the cross-reference data. + -- ------------------------- + -- -- G Invocation Graph -- + -- ------------------------- + + -- An invocation graph line has the following format: + -- + -- G line-kind line-attributes + -- + -- Attribute line-kind is a Character which denotes the nature of the + -- line. Table ALI.Invocation_Graph_Line_Codes lists all legal values. + -- + -- Attribute line-attributes depends on the value of line-kind, and is + -- contents are described further below. + -- + -- An invocation signature uniquely identifies an invocation construct in + -- the ALI file namespace, and has the following format: + -- + -- [ name scope line column (locations | "none") ] + -- + -- Attribute name is a String which denotes the name of the construct + -- + -- Attribute scope is a String which denotes the qualified name of the + -- scope where the construct is declared. + -- + -- Attribute line is a Positive which denotes the line number where the + -- initial declaration of the construct appears. + -- + -- Attribute column is a Positive which denotes the column number where + -- the initial declaration of the construct appears. + -- + -- Attribute locations is a String which denotes the line and column + -- locations of all instances where the initial declaration of the + -- construct appears. + -- + -- When the line-kind denotes an invocation construct, line-attributes are + -- set as follows: + -- + -- construct-kind construct-body-placement construct-signature + -- + -- Attribute construct-kind is a Character which denotes the nature of + -- the construct. Table ALI.Invocation_Construct_Codes lists all legal + -- values. + -- + -- Attribute construct-body-placement is a Character which denotes the + -- placement of the construct's body within the unit. All legal values + -- are listed in table ALI.Body_Placement_Codes. + -- + -- Attribute construct-signature is the invocation signature of the + -- construct. + -- + -- When the line-kind denotes an invocation relation, line-attributes are + -- set as follows: + -- + -- relation-kind (extra-name | "none") invoker-signature + -- target-signature + -- + -- Attribute relation-kind is a Character which denotes the nature of + -- the relation. All legal values are listed in ALI.Invocation_Codes. + -- + -- Attribute extra-name is a String which denotes the name of an extra + -- entity used for error diagnostics. The value of extra-name depends + -- on the relation-kind as follows: + -- + -- Accept_Alternative - related entry + -- Access_Taken - related subprogram + -- Call - not present + -- Controlled_Adjustment - related controlled type + -- Controlled_Finalization - related controlled type + -- Controlled_Initialization - related controlled type + -- Default_Initial_Condition_Verification - related private type + -- Initial_Condition_Verification - not present + -- Instantiation - not present + -- Internal_Controlled_Adjustment - related controlled type + -- Internal_Controlled_Finalization - related controlled type + -- Internal_Controlled_Initialization - related controlled type + -- Invariant_Verification - related private type + -- Postcondition_Verification - related routine + -- Protected_Entry_Call - not present + -- Protected_Subprogram_Call - not present + -- Task_Activation - related task object + -- Task_Entry_Call - not present + -- Type_Initialization - related type + -- + -- Attribute invoker-signature is the invocation signature of the + -- invoker. + -- + -- Attribute target-signature is the invocation signature of the target + -------------------------- -- Cross-Reference Data -- -------------------------- diff --git a/gcc/ada/libgnat/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb index 6cb4182..84dcc30 100644 --- a/gcc/ada/libgnat/g-dynhta.adb +++ b/gcc/ada/libgnat/g-dynhta.adb @@ -34,6 +34,34 @@ with Ada.Unchecked_Deallocation; package body GNAT.Dynamic_HTables is ------------------- + -- Hash_Two_Keys -- + ------------------- + + function Hash_Two_Keys + (Left : Bucket_Range_Type; + Right : Bucket_Range_Type) return Bucket_Range_Type + is + Half : constant := 2 ** (Bucket_Range_Type'Size / 2); + Mask : constant := Half - 1; + + begin + -- The hash is obtained in the following manner: + -- + -- 1) The low bits of Left are obtained, then shifted over to the high + -- bits position. + -- + -- 2) The low bits of Right are obtained + -- + -- The results from 1) and 2) are or-ed to produce a value within the + -- range of Bucket_Range_Type. + + return + ((Left and Mask) * Half) + or + (Right and Mask); + end Hash_Two_Keys; + + ------------------- -- Static_HTable -- ------------------- @@ -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 6c19f0f..107c4c0 100644 --- a/gcc/ada/libgnat/g-dynhta.ads +++ b/gcc/ada/libgnat/g-dynhta.ads @@ -50,6 +50,12 @@ pragma Compiler_Unit_Warning; package GNAT.Dynamic_HTables is + function Hash_Two_Keys + (Left : Bucket_Range_Type; + Right : Bucket_Range_Type) return Bucket_Range_Type; + pragma Inline (Hash_Two_Keys); + -- Obtain the hash value of keys Left and Right + ------------------- -- Static_HTable -- ------------------- @@ -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 210e083..1049641 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 106f06c..3b65522 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 1490181..b588880 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 5f1ff90..51c7cf46 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 58fbc08..a788b55 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 cd6e521..47ad874 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -3155,7 +3155,7 @@ package Rtsfind is -- immediately, since obviously Ent cannot be the entity in question if the -- corresponding unit has not been loaded. - function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean; + function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean; pragma Inline (Is_RTU); -- This function determines if the given entity corresponds to the entity -- for the unit referenced by U. If this unit has not been loaded, the diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 2427364..bf85b28 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 8f2d245..5f515bc 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 b74f88d..f57b3b1 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with ALI; use ALI; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -59,7 +60,10 @@ with Tbuild; use Tbuild; with Uintp; use Uintp; with Uname; use Uname; -with GNAT.HTable; use GNAT.HTable; +with GNAT; use GNAT; +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; +with GNAT.Lists; use GNAT.Lists; +with GNAT.Sets; use GNAT.Sets; package body Sem_Elab is @@ -80,30 +84,41 @@ package body Sem_Elab is -- Due to control and data flow, the ABE mechanism cannot accurately -- determine whether a particular scenario will be elaborated or not. -- Conditional ABE checks are therefore used to verify the elaboration - -- status of a local and external target at run time. + -- status of local and external targets at run time. -- - -- * Supply elaboration dependencies for a unit to binde + -- * Supply implicit elaboration dependencies for a unit to binde -- - -- The ABE mechanism registers each outgoing elaboration edge for the - -- main unit in its ALI file. GNATbind and binde can then reconstruct - -- the full elaboration graph and determine the proper elaboration - -- order for all units in the compilation. + -- The ABE mechanism creates implicit dependencies in the form of with + -- clauses subject to pragma Elaborate[_All] when the elaboration graph + -- reaches into an external unit. The implicit dependencies are encoded + -- in the ALI file of the main unit. GNATbind and binde then use these + -- dependencies to augment the library item graph and determine the + -- elaboration order of all units in the compilation. + -- + -- * Supply pieces of the invocation graph for a unit to bindo + -- + -- The ABE mechanism captures paths starting from elaboration code or + -- top level constructs that reach into an external unit. The paths are + -- encoded in the ALI file of the main unit in the form of declarations + -- which represent nodes, and relations which represent edges. GNATbind + -- and bindo then build the full invocation graph in order to augment + -- the library item graph and determine the elaboration order of all + -- units in the compilation. -- -- The ABE mechanism supports three models of elaboration: -- -- * Dynamic model - This is the most permissive of the three models. - -- When the dynamic model is in effect, the mechanism performs very - -- little diagnostics and generates run-time checks to detect ABE - -- issues. The behaviour of this model is identical to that specified - -- by the Ada RM. This model is enabled with switch -gnatE. + -- When the dynamic model is in effect, the mechanism diagnoses and + -- installs run-time checks to detect ABE issues in the main unit. + -- The behaviour of this model is identical to that specified by the + -- Ada RM. This model is enabled with switch -gnatE. -- - -- * Static model - This is the middle ground of the three models. When + -- Static model - This is the middle ground of the three models. When -- the static model is in effect, the mechanism diagnoses and installs -- run-time checks to detect ABE issues in the main unit. In addition, - -- the mechanism generates implicit Elaborate or Elaborate_All pragmas - -- to ensure the prior elaboration of withed units. The model employs - -- textual order, with clause context, and elaboration-related source - -- pragmas. This is the default model. + -- the mechanism generates implicit dependencies between units in the + -- form of with clauses subject to pragma Elaborate[_All] to ensure + -- the prior elaboration of withed units. This is the default model. -- -- * SPARK model - This is the most conservative of the three models and -- impelements the semantics defined in SPARK RM 7.7. The SPARK model @@ -117,8 +132,8 @@ package body Sem_Elab is -- Terminology -- ----------------- - -- * ABE - An attempt to activate, call, or instantiate a scenario which - -- has not been fully elaborated. + -- * ABE - An attempt to invoke a scenario which has not been elaborated + -- yet. -- -- * Bridge target - A type of target. A bridge target is a link between -- scenarios. It is usually a byproduct of expansion and does not have @@ -129,9 +144,9 @@ package body Sem_Elab is -- call. N_Call_Marker nodes do not have static and run-time semantics. -- -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the - -- elaboration or invocation of a target by a scenario within the main - -- unit causes an ABE, but does not cause an ABE for another scenarios - -- within the main unit. + -- invocation of a target by a scenario within the main unit causes an + -- ABE, but does not cause an ABE for another scenarios within the main + -- unit. -- -- * Declaration level - A type of enclosing level. A scenario or target is -- at the declaration level when it appears within the declarations of a @@ -148,13 +163,26 @@ package body Sem_Elab is -- package library unit, ignoring enclosing packages. -- -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the - -- elaboration or invocation of a target by all scenarios within the - -- main unit causes an ABE. + -- invocation of a target by all scenarios within the main unit causes + -- an ABE. -- -- * Instantiation library level - A type of enclosing level. A scenario -- or target is at the instantiation library level if it appears in an -- instantiation library unit, ignoring enclosing packages. -- + -- * Invocation - The act of activating a task, calling a subprogram, or + -- instantiating a generic. + -- + -- * Invocation construct - An entry declaration, [single] protected type, + -- subprogram declaration, subprogram instantiation, or a [single] task + -- type declared in the visible, private, or body declarations of the + -- main unit. + -- + -- * Invocation relation - A flow link between two invocation constructs + -- + -- * Invocation signature - A set of attributes that uniquely identify an + -- invocation construct within the namespace of all ALI files. + -- -- * Library level - A type of enclosing level. A scenario or target is at -- the library level if it appears in a package library unit, ignoring -- enclosng packages. @@ -162,9 +190,9 @@ package body Sem_Elab is -- * Non-library-level encapsulator - A construct that cannot be elaborated -- on its own and requires elaboration by a top-level scenario. -- - -- * Scenario - A construct or context which may be elaborated or executed - -- by elaboration code. The scenarios recognized by the ABE mechanism are - -- as follows: + -- * Scenario - A construct or context which is invoked by elaboration code + -- or invocation construct. The scenarios recognized by the ABE mechanism + -- are as follows: -- -- - '[Unrestricted_]Access of entries, operators, and subprograms -- @@ -182,8 +210,8 @@ package body Sem_Elab is -- -- - Task activation -- - -- * Target - A construct referenced by a scenario. The targets recognized - -- by the ABE mechanism are as follows: + -- * Target - A construct invoked by a scenario. The targets recognized by + -- the ABE mechanism are as follows: -- -- - For '[Unrestricted_]Access of entries, operators, and subprograms, -- the target is the entry, operator, or subprogram. @@ -201,16 +229,84 @@ package body Sem_Elab is -- - For reads of variables, the target is the variable -- -- - For task activation, the target is the task body - -- - -- * Top-level scenario - A scenario which appears in a non-generic main - -- unit. Depending on the elaboration model is in effect, the following - -- addotional restrictions apply: - -- - -- - Dynamic model - No restrictions - -- - -- - SPARK model - Falls back to either the dynamic or static model - -- - -- - Static model - The scenario must be at the library level + + ------------------ + -- Architecture -- + ------------------ + + -- Analysis/Resolution + -- | + -- +- Build_Call_Marker + -- | + -- +- Build_Variable_Reference_Marker + -- | + -- +- | -------------------- Recording phase ---------------------------+ + -- | v | + -- | Record_Elaboration_Scenario | + -- | | | + -- | +--> Check_Preelaborated_Call | + -- | | | + -- | +--> Process_Guaranteed_ABE | + -- | | | | + -- | | +--> Process_Guaranteed_ABE_Activation | + -- | | +--> Process_Guaranteed_ABE_Call | + -- | | +--> Process_Guaranteed_ABE_Instantiation | + -- | | | + -- +- | ----------------------------------------------------------------+ + -- | + -- | + -- +--> Internal_Representation + -- | + -- +--> Scenario_Storage + -- | + -- End of Compilation + -- | + -- +- | --------------------- Processing phase -------------------------+ + -- | v | + -- | Check_Elaboration_Scenarios | + -- | | | + -- | +--> Check_Conditional_ABE_Scenarios | + -- | | | | + -- | | +--> Process_Conditional_ABE <----------------------+ | + -- | | | | | + -- | | +--> Process_Conditional_ABE_Activation | | + -- | | | | | | + -- | | | +-----------------------------+ | | + -- | | | | | | + -- | | +--> Process_Conditional_ABE_Call +---> Traverse_Body | + -- | | | | | | + -- | | | +-----------------------------+ | + -- | | | | + -- | | +--> Process_Conditional_ABE_Access_Taken | + -- | | +--> Process_Conditional_ABE_Instantiation | + -- | | +--> Process_Conditional_ABE_Variable_Assignment | + -- | | +--> Process_Conditional_ABE_Variable_Reference | + -- | | | + -- | +--> Check_SPARK_Scenario | + -- | | | | + -- | | +--> Process_SPARK_Scenario | + -- | | | | + -- | | +--> Process_SPARK_Derived_Type | + -- | | +--> Process_SPARK_Instantiation | + -- | | +--> Process_SPARK_Refined_State_Pragma | + -- | | | + -- | +--> Record_Invocation_Graph | + -- | | | + -- | +--> Process_Invocation_Body_Scenarios | + -- | +--> Process_Invocation_Spec_Scenarios | + -- | +--> Process_Main_Unit | + -- | | | + -- | +--> Process_Invocation_Scenario <-------------+ | + -- | | | | + -- | +--> Process_Invocation_Activation | | + -- | | | | | + -- | | +------------------------+ | | + -- | | | | | + -- | +--> Process_Invocation_Call +---> Traverse_Body | + -- | | | | + -- | +------------------------+ | + -- | | + -- +--------------------------------------------------------------------+ --------------------- -- Recording phase -- @@ -219,14 +315,14 @@ package body Sem_Elab is -- The Recording phase coincides with the analysis/resolution phase of the -- compiler. It has the following objectives: -- - -- * Record all top-level scenarios for examination by the Processing + -- * Record all suitable scenarios for examination by the Processing -- phase. -- -- Saving only a certain number of nodes improves the performance of -- the ABE mechanism. This eliminates the need to examine the whole -- tree in a separate pass. -- - -- * Record certain SPARK scenarios which are not necessarily executable + -- * Record certain SPARK scenarios which are not necessarily invoked -- during elaboration, but still require elaboration-related checks. -- -- Saving only a certain number of nodes improves the performance of @@ -240,8 +336,8 @@ package body Sem_Elab is -- does not need the heavy recursive traversal done by the Processing -- phase. -- - -- * Detect and diagnose guaranteed ABEs caused by instantiations, - -- calls, and task activation. + -- * Detect and diagnose guaranteed ABEs caused by instantiations, calls, + -- and task activation. -- -- The issues detected by the ABE mechanism are reported as warnings -- because they do not violate Ada semantics. Forward instantiations @@ -259,101 +355,34 @@ package body Sem_Elab is -- and/or inlining of bodies, but before the removal of Ghost code. It has -- the following objectives: -- - -- * Examine all top-level scenarios saved during the Recording phase + -- * Examine all scenarios saved during the Recording phase, and perform + -- the following actions: -- - -- The top-level scenarios act as roots for depth-first traversal of - -- the call/instantiation/task activation graph. The traversal stops - -- when an outgoing edge leaves the main unit. + -- - Dynamic model -- - -- * Examine all SPARK scenarios saved during the Recording phase + -- Diagnose conditional ABEs, and install run-time conditional ABE + -- checks for all scenarios. -- - -- * Depending on the elaboration model in effect, perform the following - -- actions: + -- - SPARK model -- - -- - Dynamic model - Install run-time conditional ABE checks. + -- Enforce the SPARK elaboration rules -- - -- - SPARK model - Enforce the SPARK elaboration rules + -- - Static model -- - -- - Static model - Diagnose conditional ABEs, install run-time - -- conditional ABE checks, and guarantee the elaboration of - -- external units. + -- Diagnose conditional ABEs, install run-time conditional ABE + -- checks only for scenarios are reachable from elaboration code, + -- and guarantee the elaboration of external units by creating + -- implicit with clauses subject to pragma Elaborate[_All]. -- - -- * Examine nested scenarios + -- * Examine library-level scenarios and invocation constructs, and + -- perform the following actions: -- - -- Nested scenarios discovered during the depth-first traversal are - -- in turn subjected to the same actions outlined above and examined - -- for the next level of nested scenarios. - - ------------------ - -- Architecture -- - ------------------ - - -- Analysis/Resolution - -- | - -- +- Build_Call_Marker - -- | - -- +- Build_Variable_Reference_Marker - -- | - -- +- | -------------------- Recording phase ---------------------------+ - -- | v | - -- | Record_Elaboration_Scenario | - -- | | | - -- | +--> Check_Preelaborated_Call | - -- | | | - -- | +--> Process_Guaranteed_ABE | - -- | | | | - -- | | +--> Process_Guaranteed_ABE_Activation | - -- | | | | - -- | | +--> Process_Guaranteed_ABE_Call | - -- | | | | - -- | | +--> Process_Guaranteed_ABE_Instantiation | - -- | | | - -- +- | ----------------------------------------------------------------+ - -- | - -- | - -- +--> SPARK_Scenarios - -- | +-----------+-----------+ .. +-----------+ - -- | | Scenario1 | Scenario2 | .. | ScenarioN | - -- | +-----------+-----------+ .. +-----------+ - -- | - -- +--> Top_Level_Scenarios - -- | +-----------+-----------+ .. +-----------+ - -- | | Scenario1 | Scenario2 | .. | ScenarioN | - -- | +-----------+-----------+ .. +-----------+ - -- | - -- End of Compilation - -- | - -- +- | --------------------- Processing phase -------------------------+ - -- | v | - -- | Check_Elaboration_Scenarios | - -- | | | - -- | +--> Check_SPARK_Scenario | - -- | | | | - -- | | +--> Check_SPARK_Derived_Type | - -- | | | | - -- | | +--> Check_SPARK_Instantiation | - -- | | | | - -- | | +--> Check_SPARK_Refined_State_Pragma | - -- | | | - -- | +--> Process_Conditional_ABE <---------------------------+ | - -- | | | | - -- | +--> Process_Conditional_ABE_Access Is_Suitable_Scenario | - -- | | ^ | - -- | +--> Process_Conditional_ABE_Activation | | - -- | | | | | - -- | | +-----------------------------+ | | - -- | | | | | - -- | +--> Process_Conditional_ABE_Call +--------> Traverse_Body | - -- | | | | | - -- | | +-----------------------------+ | - -- | | | - -- | +--> Process_Conditional_ABE_Instantiation | - -- | | | - -- | +--> Process_Conditional_ABE_Variable_Assignment | - -- | | | - -- | +--> Process_Conditional_ABE_Variable_Reference | - -- | | - -- +--------------------------------------------------------------------+ + -- - Determine whether the flow of execution reaches into an external + -- unit. If this is the case, encode the path in the ALI file of + -- the main unit. + -- + -- - Create declarations for invocation constructs in the ALI file of + -- the main unit. ---------------------- -- Important points -- @@ -364,11 +393,11 @@ package body Sem_Elab is -- available. The scope stack is empty, global flags such as In_Instance -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism -- must either save or recompute semantic information. - + -- -- Expansion heavily transforms calls and to some extent instantiations. To -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to -- capture the target and relevant attributes of the original call. - + -- -- The diagnostics of the ABE mechanism depend on accurate source locations -- to determine the spacial relation of nodes. @@ -453,6 +482,13 @@ package body Sem_Elab is -- The ABE mechanism considers scenarios which appear in internal -- units (Ada, GNAT, Interfaces, System). -- + -- -gnatd_F encode full invocation paths in ALI files + -- + -- The ABE mechanism encodes the full path from an elaboration + -- procedure or invocable construct to an external target. The + -- path contains all intermediate activations, instantiations, + -- and calls. + -- -- -gnatd.G ignore calls through generic formal parameters for elaboration -- -- The ABE mechanism does not generate N_Call_Marker nodes for @@ -460,6 +496,12 @@ package body Sem_Elab is -- actual subprograms through generic formal subprograms. As a -- result, the calls are not recorded or processed. -- + -- -gnatd_G encode invocation graph in ALI files + -- + -- The ABE mechanism encodes the invocation graph of the main + -- unit. This includes elaboration code, as well as invocation + -- constructs. + -- -- -gnatd_i ignore activations and calls to instances for elaboration -- -- The ABE mechanism ignores calls and task activations when they @@ -508,6 +550,11 @@ package body Sem_Elab is -- Ada.Synchronous_Barriers.Wait_For_Release -- Ada.Synchronous_Task_Control.Suspend_Until_True -- + -- -gnatd_T output trace information on invocation relation construction + -- + -- The ABE mechanism outputs text information concerning relation + -- construction to standard output. + -- -- -gnatd.U ignore indirect calls for static elaboration -- -- The ABE mechanism does not consider '[Unrestricted_]Access of @@ -589,66 +636,6 @@ package body Sem_Elab is -- -- The complementary switch for -gnatwl. - --------------------------- - -- Adding a new scenario -- - --------------------------- - - -- The following steps describe how to add a new elaboration scenario and - -- preserve the existing architecture. Note that not all of the steps may - -- need to be carried out. - -- - -- 1) Update predicate Is_Scenario - -- - -- 2) Add predicate Is_Suitable_xxx. Include a call to it in predicate - -- Is_Suitable_Scenario. - -- - -- 3) Update routine Record_Elaboration_Scenario - -- - -- 4) Add routine Process_Conditional_ABE_xxx. Include a call to it in - -- routine Process_Conditional_ABE. - -- - -- 5) Add routine Process_Guaranteed_ABE_xxx. Include a call to it in - -- routine Process_Guaranteed_ABE. - -- - -- 6) Add routine Check_SPARK_xxx. Include a call to it in routine - -- Check_SPARK_Scenario. - -- - -- 7) Add routine Info_xxx. Include a call to it in routine - -- Process_Conditional_ABE_xxx. - -- - -- 8) Add routine Output_xxx. Include a call to it in routine - -- Output_Active_Scenarios. - -- - -- 9) Add routine Extract_xxx_Attributes - -- - -- 10) Update routine Is_Potential_Scenario - - ------------------------- - -- Adding a new target -- - ------------------------- - - -- The following steps describe how to add a new elaboration target and - -- preserve the existing architecture. Note that not all of the steps may - -- need to be carried out. - -- - -- 1) Add predicate Is_xxx. - -- - -- 2) Update the following predicates - -- - -- Is_Ada_Semantic_Target - -- Is_Assertion_Pragma_Target - -- Is_Bridge_Target - -- Is_SPARK_Semantic_Target - -- - -- If necessary, create a new category. - -- - -- 3) Update the appropriate Info_xxx routine. - -- - -- 4) Update the appropriate Output_xxx routine. - -- - -- 5) Update routine Extract_Target_Attributes. If necessary, create a - -- new Extract_xxx routine. - -------------------------- -- Debugging ABE issues -- -------------------------- @@ -659,7 +646,7 @@ package body Sem_Elab is -- -- Build_Call_Marker -- Record_Elaboration_Scenario - + -- -- * If the issue involves an arbitrary scenario, ensure that the scenario -- is either recorded, or is successfully recognized while traversing a -- body. The routines of interest are @@ -668,7 +655,7 @@ package body Sem_Elab is -- Process_Conditional_ABE -- Process_Guaranteed_ABE -- Traverse_Body - + -- -- * If the issue involves a circularity in the elaboration order, examine -- the ALI files and look for the following encodings next to units: -- @@ -685,601 +672,1272 @@ package body Sem_Elab is -- -- Ensure_Prior_Elaboration - ---------------- - -- Attributes -- - ---------------- + ----------- + -- Kinds -- + ----------- - -- To minimize the amount of code within routines, the ABE mechanism relies - -- on "attribute" records to capture relevant information for a scenario or - -- a target. + -- The following type enumerates all subprogram body traversal modes - -- The following type captures relevant attributes which pertain to a call + type Body_Traversal_Kind is + (Deep_Traversal, + -- The traversal examines the internals of a subprogram - type Call_Attributes is record - Elab_Checks_OK : Boolean; - -- This flag is set when the call has elaboration checks enabled + No_Traversal); - Elab_Warnings_OK : Boolean; - -- This flag is set when the call has elaboration warnings elabled + -- The following type enumerates all operation modes - From_Source : Boolean; - -- This flag is set when the call comes from source + type Processing_Kind is + (Conditional_ABE_Processing, + -- The ABE mechanism detects and diagnoses conditional ABEs for library + -- and declaration-level scenarios. - Ghost_Mode_Ignore : Boolean; - -- This flag is set when the call appears in a region subject to pragma - -- Ghost with policy Ignore. + Dynamic_Model_Processing, + -- The ABE mechanism installs conditional ABE checks for all eligible + -- scenarios when the dynamic model is in effect. - In_Declarations : Boolean; - -- This flag is set when the call appears at the declaration level + Guaranteed_ABE_Processing, + -- The ABE mechanism detects and diagnoses guaranteed ABEs caused by + -- calls, instantiations, and task activations. - Is_Dispatching : Boolean; - -- This flag is set when the call is dispatching + Invocation_Construct_Processing, + -- The ABE mechanism locates all invocation constructs within the main + -- unit and utilizes them as roots of miltiple DFS traversals aimed at + -- detecting transitions from the main unit to an external unit. - SPARK_Mode_On : Boolean; - -- This flag is set when the call appears in a region subject to pragma - -- SPARK_Mode with value On. - end record; + Invocation_Body_Processing, + -- The ABE mechanism utilizes all library-level body scenarios as roots + -- of miltiple DFS traversals aimed at detecting transitions from the + -- main unit to an external unit. - -- The following type captures relevant attributes which pertain to the - -- prior elaboration of a unit. This type is coupled together with a unit - -- to form a key -> value relationship. - - type Elaboration_Attributes is record - Source_Pragma : Node_Id; - -- This attribute denotes a source Elaborate or Elaborate_All pragma - -- which guarantees the prior elaboration of some unit with respect - -- to the main unit. The pragma may come from the following contexts: - - -- * The main unit - -- * The spec of the main unit (if applicable) - -- * Any parent spec of the main unit (if applicable) - -- * Any parent subunit of the main unit (if applicable) - - -- The attribute remains Empty if no such pragma is available. Source - -- pragmas play a role in satisfying SPARK elaboration requirements. - - With_Clause : Node_Id; - -- This attribute denotes an internally generated or source with clause - -- for some unit withed by the main unit. With clauses carry flags which - -- represent implicit Elaborate or Elaborate_All pragmas. These clauses - -- play a role in supplying the elaboration dependencies to binde. - end record; + Invocation_Spec_Processing, + -- The ABE mechanism utilizes all library-level spec scenarios as roots + -- of miltiple DFS traversals aimed at detecting transitions from the + -- main unit to an external unit. - No_Elaboration_Attributes : constant Elaboration_Attributes := - (Source_Pragma => Empty, - With_Clause => Empty); + SPARK_Processing, + -- The ABE mechanism detects and diagnoses violations of the SPARK + -- elaboration rules for SPARK-specific scenarios. - -- The following type captures relevant attributes which pertain to an - -- instantiation. + No_Processing); - type Instantiation_Attributes is record - Elab_Checks_OK : Boolean; - -- This flag is set when the instantiation has elaboration checks - -- enabled. + -- The following type enumerates all possible scenario kinds - Elab_Warnings_OK : Boolean; - -- This flag is set when the instantiation has elaboration warnings - -- enabled. + type Scenario_Kind is + (Access_Taken_Scenario, + -- An attribute reference which takes 'Access or 'Unrestricted_Access of + -- an entry, operator, or subprogram. - Ghost_Mode_Ignore : Boolean; - -- This flag is set when the instantiation appears in a region subject - -- to pragma Ghost with policy ignore, or starts one such region. + Call_Scenario, + -- A call which invokes an entry, operator, or subprogram - In_Declarations : Boolean; - -- This flag is set when the instantiation appears at the declaration - -- level. + Derived_Type_Scenario, + -- A declaration of a derived type. This is a SPARK-specific scenario. - SPARK_Mode_On : Boolean; - -- This flag is set when the instantiation appears in a region subject - -- to pragma SPARK_Mode with value On, or starts one such region. - end record; + Instantiation_Scenario, + -- An instantiation which instantiates a generic package or subprogram. + -- This scenario is also subject to SPARK-specific rules. + + Refined_State_Pragma_Scenario, + -- A Refined_State pragma. This is a SPARK-specific scenario. + + Task_Activation_Scenario, + -- A call which activates objects of various task types + + Variable_Assignment_Scenario, + -- An assignment statement which modifies the value of some variable + + Variable_Reference_Scenario, + -- A reference to a variable. This is a SPARK-specific scenario. + + No_Scenario); + + -- The following type enumerates all possible consistency models of target + -- and scenario representations. + + type Representation_Kind is + (Inconsistent_Representation, + -- A representation is said to be "inconsistent" when it is created from + -- a partially analyzed tree. In such an environment, certain attributes + -- such as a completing body may not be available yet. + + Consistent_Representation, + -- A representation is said to be "consistent" when it is created from a + -- fully analyzed tree, where all attributes are available. + + No_Representation); + + -- The following type enumerates all possible target kinds + + type Target_Kind is + (Generic_Target, + -- A generic unit being instantiated + + Subprogram_Target, + -- An entry, operator, or subprogram being invoked, or aliased through + -- 'Access or 'Unrestricted_Access. + + Task_Target, + -- A task being activated by an activation call + + Variable_Target, + -- A variable being updated through an assignment statement, or read + -- through a variable reference. + + No_Target); + + ----------- + -- Types -- + ----------- + + procedure Destroy (NE : in out Node_Or_Entity_Id); + pragma Inline (Destroy); + -- Destroy node or entity NE + + function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type; + pragma Inline (Hash); + -- Obtain the hash value of key NE + + -- The following is a general purpose list for nodes and entities + + package NE_List is new Doubly_Linked_Lists + (Element_Type => Node_Or_Entity_Id, + "=" => "=", + Destroy_Element => Destroy); + + -- The following is a general purpose map which relates nodes and entities + -- to lists of nodes and entities. + + package NE_List_Map is new Dynamic_Hash_Tables + (Key_Type => Node_Or_Entity_Id, + Value_Type => NE_List.Doubly_Linked_List, + No_Value => NE_List.Nil, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => NE_List.Destroy, + Hash => Hash); + + -- The following is a general purpose membership set for nodes and entities + + package NE_Set is new Membership_Sets + (Element_Type => Node_Or_Entity_Id, + "=" => "=", + Hash => Hash); -- The following type captures relevant attributes which pertain to the - -- state of the Processing phase. + -- in state of the Processing phase. - type Processing_Attributes is record - Suppress_Implicit_Pragmas : Boolean; + type Processing_In_State is record + Processing : Processing_Kind := No_Processing; + -- Operation mode of the Processing phase. Once set, this value should + -- not be changed. + + Representation : Representation_Kind := No_Representation; + -- Required level of scenario and target representation. Once set, this + -- value should not be changed. + + Suppress_Checks : Boolean := False; + -- This flag is set when the Processing phase must not generate any ABE + -- checks. + + Suppress_Implicit_Pragmas : Boolean := False; -- This flag is set when the Processing phase must not generate any -- implicit Elaborate[_All] pragmas. - Suppress_Warnings : Boolean; + Suppress_Info_Messages : Boolean := False; + -- This flag is set when the Processing phase must not emit any info + -- messages. + + Suppress_Up_Level_Targets : Boolean := False; + -- This flag is set when the Processing phase must ignore up-level + -- targets. + + Suppress_Warnings : Boolean := False; -- This flag is set when the Processing phase must not emit any warnings -- on elaboration problems. - Within_Initial_Condition : Boolean; - -- This flag is set when the Processing phase is currently examining a - -- scenario which was reached from an initial condition procedure. + Traversal : Body_Traversal_Kind := No_Traversal; + -- The subprogram body traversal mode. Once set, this value should not + -- be changed. + + Within_Generic : Boolean := False; + -- This flag is set when the Processing phase is currently within a + -- generic unit. - Within_Instance : Boolean; + Within_Initial_Condition : Boolean := False; -- This flag is set when the Processing phase is currently examining a - -- scenario which was reached from a scenario defined in an instance. + -- scenario which was reached from an initial condition procedure. - Within_Partial_Finalization : Boolean; + Within_Partial_Finalization : Boolean := False; -- This flag is set when the Processing phase is currently examining a -- scenario which was reached from a partial finalization procedure. - Within_Task_Body : Boolean; + Within_Task_Body : Boolean := False; -- This flag is set when the Processing phase is currently examining a -- scenario which was reached from a task body. end record; - Initial_State : constant Processing_Attributes := - (Suppress_Implicit_Pragmas => False, - Suppress_Warnings => False, - Within_Initial_Condition => False, - Within_Instance => False, - Within_Partial_Finalization => False, - Within_Task_Body => False); + -- The following constants define the various operational states of the + -- Processing phase. - -- The following type captures relevant attributes which pertain to a - -- target. + -- The conditional ABE state is used when processing scenarios that appear + -- at the declaration, instantiation, and library levels to detect errors + -- and install conditional ABE checks. + + Conditional_ABE_State : constant Processing_In_State := + (Processing => Conditional_ABE_Processing, + Representation => Consistent_Representation, + Traversal => Deep_Traversal, + others => False); + + -- The dynamic model state is used to install conditional ABE checks when + -- switch -gnatE (dynamic elaboration checking mode enabled) is in effect. + + Dynamic_Model_State : constant Processing_In_State := + (Processing => Dynamic_Model_Processing, + Representation => Consistent_Representation, + Suppress_Implicit_Pragmas => True, + Suppress_Info_Messages => True, + Suppress_Up_Level_Targets => True, + Suppress_Warnings => True, + Traversal => No_Traversal, + others => False); + + -- The guaranteed ABE state is used when processing scenarios that appear + -- at the declaration, instantiation, and library levels to detect errors + -- and install guarateed ABE failures. + + Guaranteed_ABE_State : constant Processing_In_State := + (Processing => Guaranteed_ABE_Processing, + Representation => Inconsistent_Representation, + Suppress_Implicit_Pragmas => True, + Traversal => No_Traversal, + others => False); + + -- The invocation body state is used when processing scenarios that appear + -- at the body library level to encode paths that start from elaboration + -- code and ultimately reach into external units. + + Invocation_Body_State : constant Processing_In_State := + (Processing => Invocation_Body_Processing, + Representation => Consistent_Representation, + Suppress_Checks => True, + Suppress_Implicit_Pragmas => True, + Suppress_Info_Messages => True, + Suppress_Up_Level_Targets => True, + Suppress_Warnings => True, + Traversal => Deep_Traversal, + others => False); + + -- The invocation construct state is used when processing constructs that + -- appear within the spec and body of the main unit and eventually reach + -- into external units. + + Invocation_Construct_State : constant Processing_In_State := + (Processing => Invocation_Construct_Processing, + Representation => Consistent_Representation, + Suppress_Checks => True, + Suppress_Implicit_Pragmas => True, + Suppress_Info_Messages => True, + Suppress_Up_Level_Targets => True, + Suppress_Warnings => True, + Traversal => Deep_Traversal, + others => False); + + -- The invocation spec state is used when processing scenarios that appear + -- at the spec library level to encode paths that start from elaboration + -- code and ultimately reach into external units. + + Invocation_Spec_State : constant Processing_In_State := + (Processing => Invocation_Spec_Processing, + Representation => Consistent_Representation, + Suppress_Checks => True, + Suppress_Implicit_Pragmas => True, + Suppress_Info_Messages => True, + Suppress_Up_Level_Targets => True, + Suppress_Warnings => True, + Traversal => Deep_Traversal, + others => False); + + -- The SPARK state is used when verying SPARK-specific semantics of certain + -- scenarios. + + SPARK_State : constant Processing_In_State := + (Processing => SPARK_Processing, + Representation => Consistent_Representation, + Traversal => No_Traversal, + others => False); + + -- The following type identifies a scenario representation + + type Scenario_Rep_Id is new Natural; + + No_Scenario_Rep : constant Scenario_Rep_Id := Scenario_Rep_Id'First; + First_Scenario_Rep : constant Scenario_Rep_Id := No_Scenario_Rep + 1; + + -- The following type identifies a target representation + + type Target_Rep_Id is new Natural; + + No_Target_Rep : constant Target_Rep_Id := Target_Rep_Id'First; + First_Target_Rep : constant Target_Rep_Id := No_Target_Rep + 1; - type Target_Attributes is record - Elab_Checks_OK : Boolean; - -- This flag is set when the target has elaboration checks enabled + -------------- + -- Services -- + -------------- - Elab_Warnings_OK : Boolean; - -- This flag is set when the target has elaboration warnings enabled + -- The following package keeps track of all active scenarios during a DFS + -- traversal. - From_Source : Boolean; - -- This flag is set when the target comes from source + package Active_Scenarios is - Ghost_Mode_Ignore : Boolean; - -- This flag is set when the target appears in a region subject to - -- pragma Ghost with policy ignore, or starts one such region. + ----------- + -- Types -- + ----------- - SPARK_Mode_On : Boolean; - -- This flag is set when the target appears in a region subject to - -- pragma SPARK_Mode with value On, or starts one such region. + -- The following type defines the position within the active scenario + -- stack. - Spec_Decl : Node_Id; - -- This attribute denotes the declaration of Spec_Id + type Active_Scenario_Pos is new Natural; - Unit_Id : Entity_Id; - -- This attribute denotes the top unit where Spec_Id resides + --------------------- + -- Data structures -- + --------------------- - -- The semantics of the following attributes depend on the target + -- The following table stores all active scenarios in a DFS traversal. + -- This table must be maintained in a FIFO fashion. + + package Active_Scenario_Stack is new Table.Table + (Table_Index_Type => Active_Scenario_Pos, + Table_Component_Type => Node_Id, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Active_Scenario_Stack"); + + --------- + -- API -- + --------- + + procedure Output_Active_Scenarios + (Error_Nod : Node_Id; + In_State : Processing_In_State); + pragma Inline (Output_Active_Scenarios); + -- Output the contents of the active scenario stack from earliest to + -- latest to supplement an earlier error emitted for node Error_Nod. + -- In_State denotes the current state of the Processing phase. + + procedure Pop_Active_Scenario (N : Node_Id); + pragma Inline (Pop_Active_Scenario); + -- Pop the top of the scenario stack. A check is made to ensure that the + -- scenario being removed is the same as N. + + procedure Push_Active_Scenario (N : Node_Id); + pragma Inline (Push_Active_Scenario); + -- Push scenario N on top of the scenario stack + + function Root_Scenario return Node_Id; + pragma Inline (Root_Scenario); + -- Return the scenario which started a DFS traversal + + end Active_Scenarios; + use Active_Scenarios; + + -- The following package provides the main entry point for task activation + -- processing. - Body_Barf : Node_Id; - Body_Decl : Node_Id; - Spec_Id : Entity_Id; + package Activation_Processor is + + ----------- + -- Types -- + ----------- + + type Activation_Processor_Ptr is access procedure + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State); + -- Reference to a procedure that takes all attributes of an activation + -- and performs a desired action. Call is the activation call. Call_Rep + -- is the representation of the call. Obj_Id is the task object being + -- activated. Obj_Rep is the representation of the object. Task_Typ is + -- the task type whose body is being activated. Task_Rep denotes the + -- representation of the task type. In_State is the current state of + -- the Processing phase. + + --------- + -- API -- + --------- + + procedure Process_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Processor : Activation_Processor_Ptr; + In_State : Processing_In_State); + -- Find all task objects activated by activation call Call and invoke + -- Processor on them. Call_Rep denotes the representation of the call. + -- In_State is the current state of the Processing phase. + + end Activation_Processor; + use Activation_Processor; + + -- The following package profides functionality for traversing subprogram + -- bodies in DFS manner and processing of eligible scenarios within. + + package Body_Processor is + + ----------- + -- Types -- + ----------- + + type Scenario_Predicate_Ptr is access function + (N : Node_Id) return Boolean; + -- Reference to a function which determines whether arbitrary node N + -- denotes a suitable scenario for processing. + + type Scenario_Processor_Ptr is access procedure + (N : Node_Id; In_State : Processing_In_State); + -- Reference to a procedure which processes scenario N. In_State is the + -- current state of the Processing phase. + + --------- + -- API -- + --------- + + procedure Traverse_Body + (N : Node_Id; + Requires_Processing : Scenario_Predicate_Ptr; + Processor : Scenario_Processor_Ptr; + In_State : Processing_In_State); + pragma Inline (Traverse_Body); + -- Traverse the declarations and handled statements of subprogram body + -- N, looking for scenarios that satisfy predicate Requires_Processing. + -- Routine Processor is invoked for each such scenario. + + procedure Reset_Traversed_Bodies; + pragma Inline (Reset_Traversed_Bodies); + -- Reset the visited status of all subprogram bodies that have already + -- been processed by routine Traverse_Body. - -- The target is a generic package or a subprogram - -- - -- * Body_Barf - Empty - -- - -- * Body_Decl - This attribute denotes the generic or subprogram - -- body. - -- - -- * Spec_Id - This attribute denotes the entity of the generic - -- package or subprogram. + ----------------- + -- Maintenance -- + ----------------- - -- The target is a protected entry - -- - -- * Body_Barf - This attribute denotes the body of the barrier - -- function if expansion took place, otherwise it is Empty. - -- - -- * Body_Decl - This attribute denotes the body of the procedure - -- which emulates the entry if expansion took place, otherwise it - -- denotes the body of the protected entry. - -- - -- * Spec_Id - This attribute denotes the entity of the procedure - -- which emulates the entry if expansion took place, otherwise it - -- denotes the protected entry. + procedure Finalize_Body_Processor; + pragma Inline (Finalize_Body_Processor); + -- Finalize all internal data structures + + procedure Initialize_Body_Processor; + pragma Inline (Initialize_Body_Processor); + -- Initialize all internal data structures + + end Body_Processor; + use Body_Processor; + + -- The following package provides functionality for installing ABE-related + -- checks and failures. + + package Check_Installer is + + --------- + -- API -- + --------- + + function Check_Or_Failure_Generation_OK return Boolean; + pragma Inline (Check_Or_Failure_Generation_OK); + -- Determine whether a conditional ABE check or guaranteed ABE failure + -- can be generated. + + procedure Install_Dynamic_ABE_Checks; + pragma Inline (Install_Dynamic_ABE_Checks); + -- Install conditional ABE checks for all saved scenarios when the + -- dynamic model is in effect. + + procedure Install_Scenario_ABE_Check + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Scenario_Rep_Id); + pragma Inline (Install_Scenario_ABE_Check); + -- Install a conditional ABE check for scenario N to ensure that target + -- Targ_Id is properly elaborated. Targ_Rep is the representation of the + -- target. If the check is installed, disable the elaboration checks of + -- scenario Disable. + + procedure Install_Scenario_ABE_Check + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Target_Rep_Id); + pragma Inline (Install_Scenario_ABE_Check); + -- Install a conditional ABE check for scenario N to ensure that target + -- Targ_Id is properly elaborated. Targ_Rep is the representation of the + -- target. If the check is installed, disable the elaboration checks of + -- target Disable. + + procedure Install_Scenario_ABE_Failure + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Scenario_Rep_Id); + pragma Inline (Install_Scenario_ABE_Failure); + -- Install a guaranteed ABE failure for scenario N with target Targ_Id. + -- Targ_Rep denotes the representation of the target. If the failure is + -- installed, disable the elaboration checks of scenario Disable. + + procedure Install_Scenario_ABE_Failure + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Target_Rep_Id); + pragma Inline (Install_Scenario_ABE_Failure); + -- Install a guaranteed ABE failure for scenario N with target Targ_Id. + -- Targ_Rep denotes the representation of the target. If the failure is + -- installed, disable the elaboration checks of target Disable. + + procedure Install_Unit_ABE_Check + (N : Node_Id; + Unit_Id : Entity_Id; + Disable : Scenario_Rep_Id); + pragma Inline (Install_Unit_ABE_Check); + -- Install a conditional ABE check for scenario N to ensure that unit + -- Unit_Id is properly elaborated. If the check is installed, disable + -- the elaboration checks of scenario Disable. + + procedure Install_Unit_ABE_Check + (N : Node_Id; + Unit_Id : Entity_Id; + Disable : Target_Rep_Id); + pragma Inline (Install_Unit_ABE_Check); + -- Install a conditional ABE check for scenario N to ensure that unit + -- Unit_Id is properly elaborated. If the check is installed, disable + -- the elaboration checks of target Disable. + + end Check_Installer; + use Check_Installer; + + -- The following package provides the main entry point for conditional ABE + -- checks and diagnostics. + + package Conditional_ABE_Processor is + + --------- + -- API -- + --------- + + procedure Check_Conditional_ABE_Scenarios + (Iter : in out NE_Set.Iterator); + pragma Inline (Check_Conditional_ABE_Scenarios); + -- Perform conditional ABE checks and diagnostics for all scenarios + -- available through iterator Iter. + + procedure Process_Conditional_ABE + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE); + -- Perform conditional ABE checks and diagnostics for scenario N. + -- In_State denotes the current state of the Processing phase. + + end Conditional_ABE_Processor; + use Conditional_ABE_Processor; + + -- The following package provides functionality to emit errors, information + -- messages, and warnings. + + package Diagnostics is + + --------- + -- API -- + --------- + + procedure Elab_Msg_NE + (Msg : String; + N : Node_Id; + Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + pragma Inline (Elab_Msg_NE); + -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary + -- node N and entity. If flag Info_Msg is set, the routine emits an + -- information message, otherwise it emits an error. If flag In_SPARK + -- is set, then string " in SPARK" is added to the end of the message. + + procedure Info_Call + (Call : Node_Id; + Subp_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + pragma Inline (Info_Call); + -- Output information concerning call Call that invokes subprogram + -- Subp_Id. When flag Info_Msg is set, the routine emits an information + -- message, otherwise it emits an error. When flag In_SPARK is set, " in + -- SPARK" is added to the end of the message. + + procedure Info_Instantiation + (Inst : Node_Id; + Gen_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + pragma Inline (Info_Instantiation); + -- Output information concerning instantiation Inst which instantiates + -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an + -- information message, otherwise it emits an error. If flag In_SPARK + -- is set, then string " in SPARK" is added to the end of the message. + + procedure Info_Variable_Reference + (Ref : Node_Id; + Var_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + pragma Inline (Info_Variable_Reference); + -- Output information concerning reference Ref which mentions variable + -- Var_Id. If flag Info_Msg is set, the routine emits an information + -- message, otherwise it emits an error. If flag In_SPARK is set, then + -- string " in SPARK" is added to the end of the message. + + end Diagnostics; + use Diagnostics; + + -- The following package provides functionality to locate the early call + -- region of a subprogram body. + + package Early_Call_Region_Processor is + + --------- + -- API -- + --------- + + function Find_Early_Call_Region + (Body_Decl : Node_Id; + Assume_Elab_Body : Boolean := False; + Skip_Memoization : Boolean := False) return Node_Id; + pragma Inline (Find_Early_Call_Region); + -- Find the start of the early call region that belongs to subprogram + -- body Body_Decl as defined in SPARK RM 7.7. This routine finds the + -- early call region, memoizes it, and returns it, but this behavior + -- can be altered. Flag Assume_Elab_Body should be set when a package + -- spec may lack pragma Elaborate_Body, but the routine must still + -- examine that spec. Flag Skip_Memoization should be set when the + -- routine must avoid memoizing the region. + + ----------------- + -- Maintenance -- + ----------------- + + procedure Finalize_Early_Call_Region_Processor; + pragma Inline (Finalize_Early_Call_Region_Processor); + -- Finalize all internal data structures - -- The target is a protected subprogram + procedure Initialize_Early_Call_Region_Processor; + pragma Inline (Initialize_Early_Call_Region_Processor); + -- Initialize all internal data structures + + end Early_Call_Region_Processor; + use Early_Call_Region_Processor; + + -- The following package provides access to the elaboration statuses of all + -- units withed by the main unit. + + package Elaborated_Units is + + --------- + -- API -- + --------- + + procedure Collect_Elaborated_Units; + pragma Inline (Collect_Elaborated_Units); + -- Save the elaboration statuses of all units withed by the main unit + + procedure Ensure_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State); + pragma Inline (Ensure_Prior_Elaboration); + -- Guarantee the elaboration of unit Unit_Id with respect to the main + -- unit by either suggesting or installing an Elaborate[_All] pragma + -- denoted by Prag_Nam. N denotes the related scenario. In_State is the + -- current state of the Processing phase. + + function Has_Prior_Elaboration + (Unit_Id : Entity_Id; + Context_OK : Boolean := False; + Elab_Body_OK : Boolean := False; + Same_Unit_OK : Boolean := False) return Boolean; + pragma Inline (Has_Prior_Elaboration); + -- Determine whether unit Unit_Id is elaborated prior to the main unit. + -- If flag Context_OK is set, the routine considers the following case + -- as valid prior elaboration: -- - -- * Body_Barf - Empty + -- * Unit_Id is in the elaboration context of the main unit -- - -- * Body_Decl - This attribute denotes the body of the protected or - -- unprotected version of the protected subprogram if expansion took - -- place, otherwise it denotes the body of the protected subprogram. + -- If flag Elab_Body_OK is set, the routine considers the following case + -- as valid prior elaboration: -- - -- * Spec_Id - This attribute denotes the entity of the protected or - -- unprotected version of the protected subprogram if expansion took - -- place, otherwise it is the entity of the protected subprogram. - - -- The target is a task entry + -- * Unit_Id has pragma Elaborate_Body and is not the main unit -- - -- * Body_Barf - Empty + -- If flag Same_Unit_OK is set, the routine considers the following + -- cases as valid prior elaboration: -- - -- * Body_Decl - This attribute denotes the body of the procedure - -- which emulates the task body if expansion took place, otherwise - -- it denotes the body of the task type. + -- * Unit_Id is the main unit -- - -- * Spec_Id - This attribute denotes the entity of the procedure - -- which emulates the task body if expansion took place, otherwise - -- it denotes the entity of the task type. - end record; + -- * Unit_Id denotes the spec of the main unit body + + procedure Meet_Elaboration_Requirement + (N : Node_Id; + Targ_Id : Entity_Id; + Req_Nam : Name_Id; + In_State : Processing_In_State); + pragma Inline (Meet_Elaboration_Requirement); + -- Determine whether elaboration requirement Req_Nam for scenario N with + -- target Targ_Id is met by the context of the main unit using the SPARK + -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an + -- error if this is not the case. In_State denotes the current state of + -- the Processing phase. - -- The following type captures relevant attributes which pertain to a task - -- type. + ----------------- + -- Maintenance -- + ----------------- - type Task_Attributes is record - Body_Decl : Node_Id; - -- This attribute denotes the declaration of the procedure body which - -- emulates the behaviour of the task body. + procedure Finalize_Elaborated_Units; + pragma Inline (Finalize_Elaborated_Units); + -- Finalize all internal data structures - Elab_Checks_OK : Boolean; - -- This flag is set when the task type has elaboration checks enabled + procedure Initialize_Elaborated_Units; + pragma Inline (Initialize_Elaborated_Units); + -- Initialize all internal data structures - Elab_Warnings_OK : Boolean; - -- This flag is set when the task type has elaboration warnings enabled + end Elaborated_Units; + use Elaborated_Units; - Ghost_Mode_Ignore : Boolean; - -- This flag is set when the task type appears in a region subject to - -- pragma Ghost with policy ignore, or starts one such region. + -- The following package provides the main entry point for guaranteed ABE + -- checks and diagnostics. - SPARK_Mode_On : Boolean; - -- This flag is set when the task type appears in a region subject to - -- pragma SPARK_Mode with value On, or starts one such region. + package Guaranteed_ABE_Processor is - Spec_Id : Entity_Id; - -- This attribute denotes the entity of the initial declaration of the - -- procedure body which emulates the behaviour of the task body. + --------- + -- API -- + --------- - Task_Decl : Node_Id; - -- This attribute denotes the declaration of the task type + procedure Process_Guaranteed_ABE + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Guaranteed_ABE); + -- Perform guaranteed ABE checks and diagnostics for scenario N. + -- In_State is the current state of the Processing phase. - Unit_Id : Entity_Id; - -- This attribute denotes the entity of the compilation unit where the - -- task type resides. - end record; + end Guaranteed_ABE_Processor; + use Guaranteed_ABE_Processor; - -- The following type captures relevant attributes which pertain to a - -- variable. + -- The following package provides access to the internal representation of + -- scenarios and targets. - type Variable_Attributes is record - Unit_Id : Entity_Id; - -- This attribute denotes the entity of the compilation unit where the - -- variable resides. - end record; + package Internal_Representation is - --------------------- - -- Data structures -- - --------------------- + ----------- + -- Types -- + ----------- + + -- The following type enumerates all possible Ghost mode mode kinds + + type Extended_Ghost_Mode is + (Is_Ignored, + Is_Checked_Or_Not_Specified); + + -- The following type enumerates all possible SPARK mode kinds + + type Extended_SPARK_Mode is + (Is_On, + Is_Off_Or_Not_Specified); - -- The ABE mechanism employs lists and hash tables to store information - -- pertaining to scenarios and targets, as well as the Processing phase. - -- The need for data structures comes partly from the size limitation of - -- nodes. Note that the use of hash tables is conservative and operations - -- are carried out only when a particular hash table has at least one key - -- value pair (see xxx_In_Use flags). + -------------- + -- Builders -- + -------------- - -- The following table stores the early call regions of subprogram bodies + function Scenario_Representation_Of + (N : Node_Id; + In_State : Processing_In_State) return Scenario_Rep_Id; + pragma Inline (Scenario_Representation_Of); + -- Obtain the id of elaboration scenario N's representation. The routine + -- constructs the representation if it is not available. In_State is the + -- current state of the Processing phase. + + function Target_Representation_Of + (Id : Entity_Id; + In_State : Processing_In_State) return Target_Rep_Id; + pragma Inline (Target_Representation_Of); + -- Obtain the id of elaboration target Id's representation. The routine + -- constructs the representation if it is not available. In_State is the + -- current state of the Processing phase. - Early_Call_Regions_Max : constant := 101; + ------------------------- + -- Scenario attributes -- + ------------------------- - type Early_Call_Regions_Index is range 0 .. Early_Call_Regions_Max - 1; + function Activated_Task_Objects + (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List; + pragma Inline (Activated_Task_Objects); + -- For Task_Activation_Scenario S_Id, obtain the list of task objects + -- the scenario is activating. + + function Activated_Task_Type (S_Id : Scenario_Rep_Id) return Entity_Id; + pragma Inline (Activated_Task_Type); + -- For Task_Activation_Scenario S_Id, obtain the currently activated + -- task type. + + procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id); + pragma Inline (Disable_Elaboration_Checks); + -- Disable elaboration checks of scenario S_Id + + function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Elaboration_Checks_OK); + -- Determine whether scenario S_Id may be subjected to elaboration + -- checks. + + function Elaboration_Warnings_OK (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Elaboration_Warnings_OK); + -- Determine whether scenario S_Id may be subjected to elaboration + -- warnings. + + function Ghost_Mode_Of + (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode; + pragma Inline (Ghost_Mode_Of); + -- Obtain the Ghost mode of scenario S_Id + + function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Is_Dispatching_Call); + -- For Call_Scenario S_Id, determine whether the call is dispatching + + function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Is_Read_Reference); + -- For Variable_Reference_Scenario S_Id, determine whether the reference + -- is a read. + + function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind; + pragma Inline (Kind); + -- Obtain the nature of scenario S_Id + + function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind; + pragma Inline (Level); + -- Obtain the enclosing level of scenario S_Id + + procedure Set_Activated_Task_Objects + (S_Id : Scenario_Rep_Id; + Task_Objs : NE_List.Doubly_Linked_List); + pragma Inline (Set_Activated_Task_Objects); + -- For Task_Activation_Scenario S_Id, set the list of task objects + -- activated by the scenario to Task_Objs. + + procedure Set_Activated_Task_Type + (S_Id : Scenario_Rep_Id; + Task_Typ : Entity_Id); + pragma Inline (Set_Activated_Task_Type); + -- For Task_Activation_Scenario S_Id, set the currently activated task + -- type to Task_Typ. + + function SPARK_Mode_Of + (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode; + pragma Inline (SPARK_Mode_Of); + -- Obtain the SPARK mode of scenario S_Id + + function Target (S_Id : Scenario_Rep_Id) return Entity_Id; + pragma Inline (Target); + -- Obtain the target of scenario S_Id - function Early_Call_Regions_Hash - (Key : Entity_Id) return Early_Call_Regions_Index; - -- Obtain the hash value of entity Key + ----------------------- + -- Target attributes -- + ----------------------- - Early_Call_Regions_In_Use : Boolean := False; - -- This flag determines whether table Early_Call_Regions contains at least - -- least one key/value pair. + function Barrier_Body_Declaration (T_Id : Target_Rep_Id) return Node_Id; + pragma Inline (Barrier_Body_Declaration); + -- For Subprogram_Target T_Id, obtain the declaration of the barrier + -- function's body. - Early_Call_Regions_No_Element : constant Node_Id := Empty; + function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id; + pragma Inline (Body_Declaration); + -- Obtain the declaration of the body which belongs to target T_Id - package Early_Call_Regions is new Simple_HTable - (Header_Num => Early_Call_Regions_Index, - Element => Node_Id, - No_Element => Early_Call_Regions_No_Element, - Key => Entity_Id, - Hash => Early_Call_Regions_Hash, - Equal => "="); + procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id); + pragma Inline (Disable_Elaboration_Checks); + -- Disable elaboration checks of target T_Id - -- The following table stores the elaboration status of all units withed by - -- the main unit. + function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean; + pragma Inline (Elaboration_Checks_OK); + -- Determine whether target T_Id may be subjected to elaboration checks - Elaboration_Statuses_Max : constant := 1009; + function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean; + pragma Inline (Elaboration_Warnings_OK); + -- Determine whether target T_Id may be subjected to elaboration + -- warnings. - type Elaboration_Statuses_Index is range 0 .. Elaboration_Statuses_Max - 1; + function Ghost_Mode_Of (T_Id : Target_Rep_Id) return Extended_Ghost_Mode; + pragma Inline (Ghost_Mode_Of); + -- Obtain the Ghost mode of target T_Id - function Elaboration_Statuses_Hash - (Key : Entity_Id) return Elaboration_Statuses_Index; - -- Obtain the hash value of entity Key + function Kind (T_Id : Target_Rep_Id) return Target_Kind; + pragma Inline (Kind); + -- Obtain the nature of target T_Id - Elaboration_Statuses_In_Use : Boolean := False; - -- This flag flag determines whether table Elaboration_Statuses contains at - -- least one key/value pair. + function SPARK_Mode_Of (T_Id : Target_Rep_Id) return Extended_SPARK_Mode; + pragma Inline (SPARK_Mode_Of); + -- Obtain the SPARK mode of target T_Id - Elaboration_Statuses_No_Element : constant Elaboration_Attributes := - No_Elaboration_Attributes; + function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id; + pragma Inline (Spec_Declaration); + -- Obtain the declaration of the spec which belongs to target T_Id - package Elaboration_Statuses is new Simple_HTable - (Header_Num => Elaboration_Statuses_Index, - Element => Elaboration_Attributes, - No_Element => Elaboration_Statuses_No_Element, - Key => Entity_Id, - Hash => Elaboration_Statuses_Hash, - Equal => "="); + function Unit (T_Id : Target_Rep_Id) return Entity_Id; + pragma Inline (Unit); + -- Obtain the unit where the target is defined - -- The following table stores a status flag for each SPARK scenario saved - -- in table SPARK_Scenarios. + function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id; + pragma Inline (Variable_Declaration); + -- For Variable_Target T_Id, obtain the declaration of the variable - Recorded_SPARK_Scenarios_Max : constant := 127; + ----------------- + -- Maintenance -- + ----------------- - type Recorded_SPARK_Scenarios_Index is - range 0 .. Recorded_SPARK_Scenarios_Max - 1; + procedure Finalize_Internal_Representation; + pragma Inline (Finalize_Internal_Representation); + -- Finalize all internal data structures - function Recorded_SPARK_Scenarios_Hash - (Key : Node_Id) return Recorded_SPARK_Scenarios_Index; - -- Obtain the hash value of Key + procedure Initialize_Internal_Representation; + pragma Inline (Initialize_Internal_Representation); + -- Initialize all internal data structures - Recorded_SPARK_Scenarios_In_Use : Boolean := False; - -- This flag flag determines whether table Recorded_SPARK_Scenarios - -- contains at least one key/value pair. + end Internal_Representation; + use Internal_Representation; - Recorded_SPARK_Scenarios_No_Element : constant Boolean := False; + -- The following package provides functionality for recording pieces of the + -- invocation graph in the ALI file of the main unit. - package Recorded_SPARK_Scenarios is new Simple_HTable - (Header_Num => Recorded_SPARK_Scenarios_Index, - Element => Boolean, - No_Element => Recorded_SPARK_Scenarios_No_Element, - Key => Node_Id, - Hash => Recorded_SPARK_Scenarios_Hash, - Equal => "="); + package Invocation_Graph is - -- The following table stores a status flag for each top-level scenario - -- recorded in table Top_Level_Scenarios. + --------- + -- API -- + --------- - Recorded_Top_Level_Scenarios_Max : constant := 503; + procedure Record_Invocation_Graph; + pragma Inline (Record_Invocation_Graph); + -- Process all declaration, instantiation, and library level scenarios, + -- along with invocation construct within the spec and body of the main + -- unit to determine whether any of these reach into an external unit. + -- If such a path exists, encode in the ALI file of the main unit. - type Recorded_Top_Level_Scenarios_Index is - range 0 .. Recorded_Top_Level_Scenarios_Max - 1; + ----------------- + -- Maintenance -- + ----------------- - function Recorded_Top_Level_Scenarios_Hash - (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index; - -- Obtain the hash value of entity Key + procedure Finalize_Invocation_Graph; + pragma Inline (Finalize_Invocation_Graph); + -- Finalize all internal data structures - Recorded_Top_Level_Scenarios_In_Use : Boolean := False; - -- This flag flag determines whether table Recorded_Top_Level_Scenarios - -- contains at least one key/value pair. + procedure Initialize_Invocation_Graph; + pragma Inline (Initialize_Invocation_Graph); + -- Initialize all internal data structures - Recorded_Top_Level_Scenarios_No_Element : constant Boolean := False; + end Invocation_Graph; + use Invocation_Graph; - package Recorded_Top_Level_Scenarios is new Simple_HTable - (Header_Num => Recorded_Top_Level_Scenarios_Index, - Element => Boolean, - No_Element => Recorded_Top_Level_Scenarios_No_Element, - Key => Node_Id, - Hash => Recorded_Top_Level_Scenarios_Hash, - Equal => "="); + -- The following package stores scenarios - -- The following table stores all active scenarios in a recursive traversal - -- starting from a top-level scenario. This table must be maintained in a - -- FIFO fashion. + package Scenario_Storage is - package Scenario_Stack is new Table.Table - (Table_Component_Type => Node_Id, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 100, - Table_Name => "Scenario_Stack"); + --------- + -- API -- + --------- - -- The following table stores SPARK scenarios which are not necessarily - -- executable during elaboration, but still require elaboration-related - -- checks. + procedure Add_Declaration_Scenario (N : Node_Id); + pragma Inline (Add_Declaration_Scenario); + -- Save declaration level scenario N - package SPARK_Scenarios is new Table.Table - (Table_Component_Type => Node_Id, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 100, - Table_Name => "SPARK_Scenarios"); + procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id); + pragma Inline (Add_Dynamic_ABE_Check_Scenario); + -- Save scenario N for conditional ABE check installation purposes when + -- the dynamic model is in effect. - -- The following table stores all top-level scenario saved during the - -- Recording phase. The contents of this table act as traversal roots - -- later in the Processing phase. This table must be maintained in a - -- LIFO fashion. + procedure Add_Library_Body_Scenario (N : Node_Id); + pragma Inline (Add_Library_Body_Scenario); + -- Save library-level body scenario N - package Top_Level_Scenarios is new Table.Table - (Table_Component_Type => Node_Id, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 1000, - Table_Increment => 100, - Table_Name => "Top_Level_Scenarios"); + procedure Add_Library_Spec_Scenario (N : Node_Id); + pragma Inline (Add_Library_Spec_Scenario); + -- Save library-level spec scenario N + + procedure Add_SPARK_Scenario (N : Node_Id); + pragma Inline (Add_SPARK_Scenario); + -- Save SPARK scenario N + + procedure Delete_Scenario (N : Node_Id); + pragma Inline (Delete_Scenario); + -- Delete arbitrary scenario N + + function Iterate_Declaration_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Declaration_Scenarios); + -- Obtain an iterator over all declaration level scenarios + + function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Dynamic_ABE_Check_Scenarios); + -- Obtain an iterator over all scenarios that require a conditional ABE + -- check when the dynamic model is in effect. + + function Iterate_Library_Body_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Library_Body_Scenarios); + -- Obtain an iterator over all library level body scenarios + + function Iterate_Library_Spec_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_Library_Spec_Scenarios); + -- Obtain an iterator over all library level spec scenarios + + function Iterate_SPARK_Scenarios return NE_Set.Iterator; + pragma Inline (Iterate_SPARK_Scenarios); + -- Obtain an iterator over all SPARK scenarios + + procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id); + pragma Inline (Replace_Scenario); + -- Replace scenario Old_N with scenario New_N + + ----------------- + -- Maintenance -- + ----------------- + + procedure Finalize_Scenario_Storage; + pragma Inline (Finalize_Scenario_Storage); + -- Finalize all internal data structures + + procedure Initialize_Scenario_Storage; + pragma Inline (Initialize_Scenario_Storage); + -- Initialize all internal data structures + + end Scenario_Storage; + use Scenario_Storage; + + -- The following package provides various semantic predicates + + package Semantics is + + --------- + -- API -- + --------- + + function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Accept_Alternative_Proc); + -- Determine whether arbitrary entity Id denotes an internally generated + -- procedure which encapsulates the statements of an accept alternative. + + function Is_Activation_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Activation_Proc); + -- Determine whether arbitrary entity Id denotes a runtime procedure in + -- charge with activating tasks. + + function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Ada_Semantic_Target); + -- Determine whether arbitrary entity Id denodes a source or internally + -- generated subprogram which emulates Ada semantics. - -- The following table stores the bodies of all eligible scenarios visited - -- during a traversal starting from a top-level scenario. The contents of - -- this table must be reset upon each new traversal. + function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Assertion_Pragma_Target); + -- Determine whether arbitrary entity Id denotes a procedure which + -- varifies the run-time semantics of an assertion pragma. - Visited_Bodies_Max : constant := 511; + function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; + pragma Inline (Is_Bodiless_Subprogram); + -- Determine whether subprogram Subp_Id will never have a body - type Visited_Bodies_Index is range 0 .. Visited_Bodies_Max - 1; + function Is_Bridge_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Bridge_Target); + -- Determine whether arbitrary entity Id denotes a bridge target - function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index; - -- Obtain the hash value of node Key + function Is_Controlled_Proc + (Subp_Id : Entity_Id; + Subp_Nam : Name_Id) return Boolean; + pragma Inline (Is_Controlled_Proc); + -- Determine whether subprogram Subp_Id denotes controlled type + -- primitives Adjust, Finalize, or Initialize as denoted by name + -- Subp_Nam. + + function Is_Default_Initial_Condition_Proc + (Id : Entity_Id) return Boolean; + pragma Inline (Is_Default_Initial_Condition_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine Default_Initial_Condition. + + function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Finalizer_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine _Finalizer. + + function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Initial_Condition_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine Initial_Condition. + + function Is_Initialized (Obj_Decl : Node_Id) return Boolean; + pragma Inline (Is_Initialized); + -- Determine whether object declaration Obj_Decl is initialized + + function Is_Invariant_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Invariant_Proc); + -- Determine whether arbitrary entity Id denotes an invariant procedure + + function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; + pragma Inline (Is_Non_Library_Level_Encapsulator); + -- Determine whether arbitrary node N is a non-library encapsulator + + function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Partial_Invariant_Proc); + -- Determine whether arbitrary entity Id denotes a partial invariant + -- procedure. - Visited_Bodies_In_Use : Boolean := False; - -- This flag determines whether table Visited_Bodies contains at least one - -- key/value pair. + function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Postconditions_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine _Postconditions. - Visited_Bodies_No_Element : constant Boolean := False; + function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; + pragma Inline (Is_Preelaborated_Unit); + -- Determine whether arbitrary entity Id denotes a unit which is subject + -- to one of the following pragmas: + -- + -- * Preelaborable + -- * Pure + -- * Remote_Call_Interface + -- * Remote_Types + -- * Shared_Passive + + function Is_Protected_Entry (Id : Entity_Id) return Boolean; + pragma Inline (Is_Protected_Entry); + -- Determine whether arbitrary entity Id denotes a protected entry + + function Is_Protected_Subp (Id : Entity_Id) return Boolean; + pragma Inline (Is_Protected_Subp); + -- Determine whether entity Id denotes a protected subprogram + + function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; + pragma Inline (Is_Protected_Body_Subp); + -- Determine whether entity Id denotes the protected or unprotected + -- version of a protected subprogram. + + function Is_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Scenario); + -- Determine whether attribute node N denotes a scenario. The scenario + -- may not necessarily be eligible for ABE processing. + + function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_SPARK_Semantic_Target); + -- Determine whether arbitrary entity Id nodes a source or internally + -- generated subprogram which emulates SPARK semantics. + + function Is_Subprogram_Inst (Id : Entity_Id) return Boolean; + pragma Inline (Is_Subprogram_Inst); + -- Determine whether arbitrary entity Id denotes a subprogram instance + + function Is_Suitable_Access_Taken (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Access_Taken); + -- Determine whether arbitrary node N denotes a suitable attribute for + -- ABE processing. + + function Is_Suitable_Call (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Call); + -- Determine whether arbitrary node N denotes a suitable call for ABE + -- processing. - package Visited_Bodies is new Simple_HTable - (Header_Num => Visited_Bodies_Index, - Element => Boolean, - No_Element => Visited_Bodies_No_Element, - Key => Node_Id, - Hash => Visited_Bodies_Hash, - Equal => "="); + function Is_Suitable_Instantiation (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Instantiation); + -- Determine whether arbitrary node N is a suitable instantiation for + -- ABE processing. + + function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_SPARK_Derived_Type); + -- Determine whether arbitrary node N denotes a suitable derived type + -- declaration for ABE processing using the SPARK rules. + + function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_SPARK_Instantiation); + -- Determine whether arbitrary node N denotes a suitable instantiation + -- for ABE processing using the SPARK rules. + + function Is_Suitable_SPARK_Refined_State_Pragma + (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); + -- Determine whether arbitrary node N denotes a suitable Refined_State + -- pragma for ABE processing using the SPARK rules. + + function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Variable_Assignment); + -- Determine whether arbitrary node N denotes a suitable assignment for + -- ABE processing. + + function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Variable_Reference); + -- Determine whether arbitrary node N is a suitable variable reference + -- for ABE processing. + + function Is_Task_Entry (Id : Entity_Id) return Boolean; + pragma Inline (Is_Task_Entry); + -- Determine whether arbitrary entity Id denotes a task entry + + function Is_Up_Level_Target + (Targ_Decl : Node_Id; + In_State : Processing_In_State) return Boolean; + pragma Inline (Is_Up_Level_Target); + -- Determine whether the current root resides at the declaration level. + -- If this is the case, determine whether a target with by declaration + -- Target_Decl is within a context which encloses the current root or is + -- in a different unit. In_State is the current state of the Processing + -- phase. + + end Semantics; + use Semantics; + + -- The following package provides the main entry point for SPARK-related + -- checks and diagnostics. + + package SPARK_Processor is + + --------- + -- API -- + --------- + + procedure Check_SPARK_Model_In_Effect; + pragma Inline (Check_SPARK_Model_In_Effect); + -- Determine whether a suitable elaboration model is currently in effect + -- for verifying SPARK rules. Emit a warning if this is not the case. + + procedure Check_SPARK_Scenarios; + pragma Inline (Check_SPARK_Scenarios); + -- Examine SPARK scenarios which are not necessarily executable during + -- elaboration, but still requires elaboration-related checks. + + end SPARK_Processor; + use SPARK_Processor; ----------------------- -- Local subprograms -- ----------------------- - -- Multiple local subprograms are utilized to lower the semantic complexity - -- of the Recording and Processing phase. - - procedure Check_Preelaborated_Call (Call : Node_Id); - pragma Inline (Check_Preelaborated_Call); - -- Verify that entry, operator, or subprogram call Call does not appear at - -- the library level of a preelaborated unit. - - procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id); - pragma Inline (Check_SPARK_Derived_Type); - -- Verify that the freeze node of a derived type denoted by declaration - -- Typ_Decl is within the early call region of each overriding primitive - -- body that belongs to the derived type (SPARK RM 7.7(8)). - - procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id); - pragma Inline (Check_SPARK_Instantiation); - -- Verify that expanded instance Exp_Inst does not precede the generic body - -- it instantiates (SPARK RM 7.7(6)). - - procedure Check_SPARK_Model_In_Effect (N : Node_Id); - pragma Inline (Check_SPARK_Model_In_Effect); - -- Determine whether a suitable elaboration model is currently in effect - -- for verifying the SPARK rules of scenario N. Emit a warning if this is - -- not the case. - - procedure Check_SPARK_Scenario (N : Node_Id); - pragma Inline (Check_SPARK_Scenario); - -- Top-level dispatcher for verifying SPARK scenarios which are not always - -- executable during elaboration but still need elaboration-related checks. - - procedure Check_SPARK_Refined_State_Pragma (N : Node_Id); - pragma Inline (Check_SPARK_Refined_State_Pragma); - -- Verify that each constituent of Refined_State pragma N which belongs to - -- an abstract state mentioned in pragma Initializes has prior elaboration - -- with respect to the main unit (SPARK RM 7.7.1(7)). + function Assignment_Target (Asmt : Node_Id) return Node_Id; + pragma Inline (Assignment_Target); + -- Obtain the target of assignment statement Asmt + + function Call_Name (Call : Node_Id) return Node_Id; + pragma Inline (Call_Name); + -- Obtain the name of an entry, operator, or subprogram call Call + + function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id; + pragma Inline (Canonical_Subprogram); + -- Obtain the uniform canonical entity of subprogram Subp_Id function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id; pragma Inline (Compilation_Unit); -- Return the N_Compilation_Unit node of unit Unit_Id - function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; - pragma Inline (Early_Call_Region); - -- Return the early call region associated with entry or subprogram body - -- Body_Id. IMPORTANT: This routine does not find the early call region. - -- To compute it, use routine Find_Early_Call_Region. - - procedure Elab_Msg_NE - (Msg : String; - N : Node_Id; - Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean); - pragma Inline (Elab_Msg_NE); - -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary node - -- N and entity. If flag Info_Msg is set, the routine emits an information - -- message, otherwise it emits an error. If flag In_SPARK is set, then - -- string " in SPARK" is added to the end of the message. - - function Elaboration_Status - (Unit_Id : Entity_Id) return Elaboration_Attributes; - pragma Inline (Elaboration_Status); - -- Return the set of elaboration attributes associated with unit Unit_Id - - procedure Ensure_Prior_Elaboration - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id; - State : Processing_Attributes); - -- Guarantee the elaboration of unit Unit_Id with respect to the main unit - -- by installing pragma Elaborate or Elaborate_All denoted by Prag_Nam. N - -- denotes the related scenario. State denotes the current state of the - -- Processing phase. - - procedure Ensure_Prior_Elaboration_Dynamic - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id); - -- Guarantee the elaboration of unit Unit_Id with respect to the main unit - -- by suggesting the use of Elaborate[_All] with name Prag_Nam. N denotes - -- the related scenario. - - procedure Ensure_Prior_Elaboration_Static - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id); - -- Guarantee the elaboration of unit Unit_Id with respect to the main unit - -- by installing an implicit Elaborate[_All] pragma with name Prag_Nam. N - -- denotes the related scenario. - - function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id; - pragma Inline (Extract_Assignment_Name); - -- Obtain the Name attribute of assignment statement Asmt - - procedure Extract_Call_Attributes - (Call : Node_Id; - Target_Id : out Entity_Id; - Attrs : out Call_Attributes); - pragma Inline (Extract_Call_Attributes); - -- Obtain attributes Attrs associated with call Call. Target_Id is the - -- entity of the call target. - - function Extract_Call_Name (Call : Node_Id) return Node_Id; - pragma Inline (Extract_Call_Name); - -- Obtain the Name attribute of entry or subprogram call Call - - procedure Extract_Instance_Attributes - (Exp_Inst : Node_Id; - Inst_Body : out Node_Id; - Inst_Decl : out Node_Id); - pragma Inline (Extract_Instance_Attributes); - -- Obtain body Inst_Body and spec Inst_Decl of expanded instance Exp_Inst - - procedure Extract_Instantiation_Attributes - (Exp_Inst : Node_Id; - Inst : out Node_Id; - Inst_Id : out Entity_Id; - Gen_Id : out Entity_Id; - Attrs : out Instantiation_Attributes); - pragma Inline (Extract_Instantiation_Attributes); - -- Obtain attributes Attrs associated with expanded instantiation Exp_Inst. - -- Inst is the instantiation. Inst_Id is the entity of the instance. Gen_Id - -- is the entity of the generic unit being instantiated. - - procedure Extract_Target_Attributes - (Target_Id : Entity_Id; - Attrs : out Target_Attributes); - -- Obtain attributes Attrs associated with an entry, package, or subprogram - -- denoted by Target_Id. - - procedure Extract_Task_Attributes - (Typ : Entity_Id; - Attrs : out Task_Attributes); - pragma Inline (Extract_Task_Attributes); - -- Obtain attributes Attrs associated with task type Typ - - procedure Extract_Variable_Reference_Attributes - (Ref : Node_Id; - Var_Id : out Entity_Id; - Attrs : out Variable_Attributes); - pragma Inline (Extract_Variable_Reference_Attributes); - -- Obtain attributes Attrs associated with reference Ref that mentions - -- variable Var_Id. - - function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id; - pragma Inline (Find_Code_Unit); - -- Return the code unit which contains arbitrary node or entity N. This - -- is the unit of the file which physically contains the related construct - -- denoted by N except when N is within an instantiation. In that case the - -- unit is that of the top-level instantiation. - - function Find_Early_Call_Region - (Body_Decl : Node_Id; - Assume_Elab_Body : Boolean := False; - Skip_Memoization : Boolean := False) return Node_Id; - -- Find the start of the early call region which belongs to subprogram body - -- Body_Decl as defined in SPARK RM 7.7. The behavior of the routine is to - -- find the early call region, memoize it, and return it, but this behavior - -- can be altered. Flag Assume_Elab_Body should be set when a package spec - -- may lack pragma Elaborate_Body, but the routine must still examine that - -- spec. Flag Skip_Memoization should be set when the routine must avoid - -- memoizing the region. - - procedure Find_Elaborated_Units; - -- Populate table Elaboration_Statuses with all units which have prior - -- elaboration with respect to the main unit. - function Find_Enclosing_Instance (N : Node_Id) return Node_Id; pragma Inline (Find_Enclosing_Instance); -- Find the declaration or body of the nearest expanded instance which @@ -1301,33 +1959,10 @@ package body Sem_Elab is -- subprogram lacks formal parameters, return Empty. function Has_Body (Pack_Decl : Node_Id) return Boolean; + pragma Inline (Has_Body); -- Determine whether package declaration Pack_Decl has a corresponding body -- or would eventually have one. - function Has_Prior_Elaboration - (Unit_Id : Entity_Id; - Context_OK : Boolean := False; - Elab_Body_OK : Boolean := False; - Same_Unit_OK : Boolean := False) return Boolean; - pragma Inline (Has_Prior_Elaboration); - -- Determine whether unit Unit_Id is elaborated prior to the main unit. - -- If flag Context_OK is set, the routine considers the following case - -- as valid prior elaboration: - -- - -- * Unit_Id is in the elaboration context of the main unit - -- - -- If flag Elab_Body_OK is set, the routine considers the following case - -- as valid prior elaboration: - -- - -- * Unit_Id has pragma Elaborate_Body and is not the main unit - -- - -- If flag Same_Unit_OK is set, the routine considers the following cases - -- as valid prior elaboration: - -- - -- * Unit_Id is the main unit - -- - -- * Unit_Id denotes the spec of the main unit body - function In_External_Instance (N : Node_Id; Target_Decl : Node_Id) return Boolean; @@ -1344,204 +1979,38 @@ package body Sem_Elab is (N1 : Node_Id; N2 : Node_Id; Nested_OK : Boolean := False) return Boolean; + pragma Inline (In_Same_Context); -- Determine whether two arbitrary nodes N1 and N2 appear within the same -- context ignoring enclosing library levels. Nested_OK should be set when -- the context of N1 can enclose that of N2. - function In_Task_Body (N : Node_Id) return Boolean; - pragma Inline (In_Task_Body); - -- Determine whether arbitrary node N appears within a task body - - procedure Info_Call - (Call : Node_Id; - Target_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean); - -- Output information concerning call Call which invokes target Target_Id. - -- If flag Info_Msg is set, the routine emits an information message, - -- otherwise it emits an error. If flag In_SPARK is set, then the string - -- " in SPARK" is added to the end of the message. - - procedure Info_Instantiation - (Inst : Node_Id; - Gen_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean); - pragma Inline (Info_Instantiation); - -- Output information concerning instantiation Inst which instantiates - -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an - -- information message, otherwise it emits an error. If flag In_SPARK - -- is set, then string " in SPARK" is added to the end of the message. - - procedure Info_Variable_Reference - (Ref : Node_Id; - Var_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean); - pragma Inline (Info_Variable_Reference); - -- Output information concerning reference Ref which mentions variable - -- Var_Id. If flag Info_Msg is set, the routine emits an information - -- message, otherwise it emits an error. If flag In_SPARK is set, then - -- string " in SPARK" is added to the end of the message. - - function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id; - pragma Inline (Insertion_Node); - -- Obtain the proper insertion node of an ABE check or failure for scenario - -- N and candidate insertion node Ins_Nod. - - procedure Install_ABE_Check - (N : Node_Id; - Id : Entity_Id; - Ins_Nod : Node_Id); - -- Insert a run-time ABE check for elaboration scenario N which verifies - -- whether arbitrary entity Id is elaborated. The check in inserted prior - -- to node Ins_Nod. - - procedure Install_ABE_Check - (N : Node_Id; - Target_Id : Entity_Id; - Target_Decl : Node_Id; - Target_Body : Node_Id; - Ins_Nod : Node_Id); - -- Insert a run-time ABE check for elaboration scenario N which verifies - -- whether target Target_Id with initial declaration Target_Decl and body - -- Target_Body is elaborated. The check is inserted prior to node Ins_Nod. - - procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id); - -- Insert a Program_Error concerning a guaranteed ABE for elaboration - -- scenario N. The failure is inserted prior to node Node_Id. - - function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Accept_Alternative_Proc); - -- Determine whether arbitrary entity Id denotes an internally generated - -- procedure which encapsulates the statements of an accept alternative. - - function Is_Activation_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Activation_Proc); - -- Determine whether arbitrary entity Id denotes a runtime procedure in - -- charge with activating tasks. - - function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; - pragma Inline (Is_Ada_Semantic_Target); - -- Determine whether arbitrary entity Id denodes a source or internally - -- generated subprogram which emulates Ada semantics. - - function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; - pragma Inline (Is_Assertion_Pragma_Target); - -- Determine whether arbitrary entity Id denotes a procedure which varifies - -- the run-time semantics of an assertion pragma. - - function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; - pragma Inline (Is_Bodiless_Subprogram); - -- Determine whether subprogram Subp_Id will never have a body - - function Is_Controlled_Proc - (Subp_Id : Entity_Id; - Subp_Nam : Name_Id) return Boolean; - pragma Inline (Is_Controlled_Proc); - -- Determine whether subprogram Subp_Id denotes controlled type primitives - -- Adjust, Finalize, or Initialize as denoted by name Subp_Nam. - - function Is_Default_Initial_Condition_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Default_Initial_Condition_Proc); - -- Determine whether arbitrary entity Id denotes internally generated - -- routine Default_Initial_Condition. - - function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Finalizer_Proc); - -- Determine whether arbitrary entity Id denotes internally generated - -- routine _Finalizer. - - function Is_Guaranteed_ABE - (N : Node_Id; - Target_Decl : Node_Id; - Target_Body : Node_Id) return Boolean; - pragma Inline (Is_Guaranteed_ABE); - -- Determine whether scenario N with a target described by its initial - -- declaration Target_Decl and body Target_Decl results in a guaranteed - -- ABE. - - function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Initial_Condition_Proc); - -- Determine whether arbitrary entity Id denotes internally generated - -- routine Initial_Condition. - - function Is_Initialized (Obj_Decl : Node_Id) return Boolean; - pragma Inline (Is_Initialized); - -- Determine whether object declaration Obj_Decl is initialized - - function Is_Invariant_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Invariant_Proc); - -- Determine whether arbitrary entity Id denotes an invariant procedure - - function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; - pragma Inline (Is_Non_Library_Level_Encapsulator); - -- Determine whether arbitrary node N is a non-library encapsulator - - function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Partial_Invariant_Proc); - -- Determine whether arbitrary entity Id denotes a partial invariant - -- procedure. - - function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Postconditions_Proc); - -- Determine whether arbitrary entity Id denotes internally generated - -- routine _Postconditions. - - function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; - pragma Inline (Is_Preelaborated_Unit); - -- Determine whether arbitrary entity Id denotes a unit which is subject to - -- one of the following pragmas: - -- - -- * Preelaborable - -- * Pure - -- * Remote_Call_Interface - -- * Remote_Types - -- * Shared_Passive - - function Is_Protected_Entry (Id : Entity_Id) return Boolean; - pragma Inline (Is_Protected_Entry); - -- Determine whether arbitrary entity Id denotes a protected entry - - function Is_Protected_Subp (Id : Entity_Id) return Boolean; - pragma Inline (Is_Protected_Subp); - -- Determine whether entity Id denotes a protected subprogram - - function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; - pragma Inline (Is_Protected_Body_Subp); - -- Determine whether entity Id denotes the protected or unprotected version - -- of a protected subprogram. - - function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean; - pragma Inline (Is_Recorded_SPARK_Scenario); - -- Determine whether arbitrary node N is a recorded SPARK scenario which - -- appears in table SPARK_Scenarios. - - function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean; - pragma Inline (Is_Recorded_Top_Level_Scenario); - -- Determine whether arbitrary node N is a recorded top-level scenario - -- which appears in table Top_Level_Scenarios. + function Instantiated_Generic (Inst : Node_Id) return Entity_Id; + pragma Inline (Instantiated_Generic); + -- Obtain the generic instantiated by instance Inst function Is_Safe_Activation - (Call : Node_Id; - Task_Decl : Node_Id) return Boolean; + (Call : Node_Id; + Task_Rep : Target_Rep_Id) return Boolean; pragma Inline (Is_Safe_Activation); - -- Determine whether call Call which activates a task object described by - -- declaration Task_Decl is always ABE-safe. + -- Determine whether activation call Call which activates an object of a + -- task type described by representation Task_Rep is always ABE-safe. function Is_Safe_Call - (Call : Node_Id; - Target_Attrs : Target_Attributes) return Boolean; + (Call : Node_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id) return Boolean; pragma Inline (Is_Safe_Call); - -- Determine whether call Call which invokes a target described by - -- attributes Target_Attrs is always ABE-safe. + -- Determine whether call Call which invokes entry, operator, or subprogram + -- Subp_Id is always ABE-safe. Subp_Rep is the representation of the entry, + -- operator, or subprogram. function Is_Safe_Instantiation - (Inst : Node_Id; - Gen_Attrs : Target_Attributes) return Boolean; + (Inst : Node_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id) return Boolean; pragma Inline (Is_Safe_Instantiation); - -- Determine whether instance Inst which instantiates a generic unit - -- described by attributes Gen_Attrs is always ABE-safe. + -- Determine whether instantiation Inst which instantiates generic Gen_Id + -- is always ABE-safe. Gen_Rep is the representation of the generic. function Is_Same_Unit (Unit_1 : Entity_Id; @@ -1549,332 +2018,1374 @@ package body Sem_Elab is pragma Inline (Is_Same_Unit); -- Determine whether entities Unit_1 and Unit_2 denote the same unit - function Is_Scenario (N : Node_Id) return Boolean; - pragma Inline (Is_Scenario); - -- Determine whether attribute node N denotes a scenario. The scenario may - -- not necessarily be eligible for ABE processing. + function Non_Private_View (Typ : Entity_Id) return Entity_Id; + pragma Inline (Non_Private_View); + -- Return the full view of private type Typ if available, otherwise return + -- type Typ. - function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; - pragma Inline (Is_SPARK_Semantic_Target); - -- Determine whether arbitrary entity Id nodes a source or internally - -- generated subprogram which emulates SPARK semantics. + function Scenario (N : Node_Id) return Node_Id; + pragma Inline (Scenario); + -- Return the appropriate scenario node for scenario N - function Is_Suitable_Access (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Access); - -- Determine whether arbitrary node N denotes a suitable attribute for ABE - -- processing. + procedure Spec_And_Body_From_Entity + (Id : Node_Id; + Spec_Decl : out Node_Id; + Body_Decl : out Node_Id); + pragma Inline (Spec_And_Body_From_Entity); + -- Given arbitrary entity Id representing a construct with a spec and body, + -- retrieve declaration of the spec in Spec_Decl and the declaration of the + -- body in Body_Decl. - function Is_Suitable_Call (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Call); - -- Determine whether arbitrary node N denotes a suitable call for ABE - -- processing. + procedure Spec_And_Body_From_Node + (N : Node_Id; + Spec_Decl : out Node_Id; + Body_Decl : out Node_Id); + pragma Inline (Spec_And_Body_From_Node); + -- Given arbitrary node N representing a construct with a spec and body, + -- retrieve declaration of the spec in Spec_Decl and the declaration of + -- the body in Body_Decl. - function Is_Suitable_Instantiation (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Instantiation); - -- Determine whether arbitrary node N is a suitable instantiation for ABE - -- processing. + function Static_Elaboration_Checks return Boolean; + pragma Inline (Static_Elaboration_Checks); + -- Determine whether the static model is in effect - function Is_Suitable_Scenario (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Scenario); - -- Determine whether arbitrary node N is a suitable scenario for ABE - -- processing. + function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; + pragma Inline (Unit_Entity); + -- Return the entity of the initial declaration for unit Unit_Id - function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_SPARK_Derived_Type); - -- Determine whether arbitrary node N denotes a suitable derived type - -- declaration for ABE processing using the SPARK rules. - - function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_SPARK_Instantiation); - -- Determine whether arbitrary node N denotes a suitable instantiation for - -- ABE processing using the SPARK rules. - - function Is_Suitable_SPARK_Refined_State_Pragma - (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); - -- Determine whether arbitrary node N denotes a suitable Refined_State - -- pragma for ABE processing using the SPARK rules. - - function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Variable_Assignment); - -- Determine whether arbitrary node N denotes a suitable assignment for ABE - -- processing. + procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); + pragma Inline (Update_Elaboration_Scenario); + -- Update all relevant internal data structures when scenario Old_N is + -- transformed into scenario New_N by Atree.Rewrite. - function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Variable_Reference); - -- Determine whether arbitrary node N is a suitable variable reference for - -- ABE processing. + ---------------------- + -- Active_Scenarios -- + ---------------------- - function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean; - pragma Inline (Is_Synchronous_Suspension_Call); - -- Determine whether arbitrary node N denotes a call to one the following - -- routines: - -- - -- Ada.Synchronous_Barriers.Wait_For_Release - -- Ada.Synchronous_Task_Control.Suspend_Until_True + package body Active_Scenarios is - function Is_Task_Entry (Id : Entity_Id) return Boolean; - pragma Inline (Is_Task_Entry); - -- Determine whether arbitrary entity Id denotes a task entry + ----------------------- + -- Local subprograms -- + ----------------------- - function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean; - pragma Inline (Is_Up_Level_Target); - -- Determine whether the current root resides at the declaration level. If - -- this is the case, determine whether a target described by declaration - -- Target_Decl is within a context which encloses the current root or is in - -- a different unit. + procedure Output_Access_Taken + (Attr : Node_Id; + Attr_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Access_Taken); + -- Emit a specific diagnostic message for 'Access attribute reference + -- Attr with representation Attr_Rep. The message is associated with + -- node Error_Nod. - function Is_Visited_Body (Body_Decl : Node_Id) return Boolean; - pragma Inline (Is_Visited_Body); - -- Determine whether subprogram body Body_Decl is already visited during a - -- recursive traversal started from a top-level scenario. + procedure Output_Active_Scenario + (N : Node_Id; + Error_Nod : Node_Id; + In_State : Processing_In_State); + pragma Inline (Output_Active_Scenario); + -- Top level dispatcher for outputting a scenario. Emit a specific + -- diagnostic message for scenario N. The message is associated with + -- node Error_Nod. In_State is the current state of the Processing + -- phase. + + procedure Output_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Call); + -- Emit a diagnostic message for call Call with representation Call_Rep. + -- The message is associated with node Error_Nod. + + procedure Output_Header (Error_Nod : Node_Id); + pragma Inline (Output_Header); + -- Emit a specific diagnostic message for the unit of the root scenario. + -- The message is associated with node Error_Nod. + + procedure Output_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Instantiation); + -- Emit a specific diagnostic message for instantiation Inst with + -- representation Inst_Rep. The message is associated with node + -- Error_Nod. + + procedure Output_Refined_State_Pragma + (Prag : Node_Id; + Prag_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Refined_State_Pragma); + -- Emit a specific diagnostic message for Refined_State pragma Prag + -- with representation Prag_Rep. The message is associated with node + -- Error_Nod. + + procedure Output_Task_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Task_Activation); + -- Emit a specific diagnostic message for activation call Call + -- with representation Call_Rep. The message is associated with + -- node Error_Nod. + + procedure Output_Variable_Assignment + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Variable_Assignment); + -- Emit a specific diagnostic message for assignment statement Asmt + -- with representation Asmt_Rep. The message is associated with node + -- Error_Nod. + + procedure Output_Variable_Reference + (Ref : Node_Id; + Ref_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id); + pragma Inline (Output_Variable_Reference); + -- Emit a specific diagnostic message for read reference Ref with + -- representation Ref_Rep. The message is associated with node + -- Error_Nod. - procedure Meet_Elaboration_Requirement - (N : Node_Id; - Target_Id : Entity_Id; - Req_Nam : Name_Id); - -- Determine whether elaboration requirement Req_Nam for scenario N with - -- target Target_Id is met by the context of the main unit using the SPARK - -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an - -- error if this is not the case. + ------------------- + -- Output_Access -- + ------------------- - function Non_Private_View (Typ : Entity_Id) return Entity_Id; - pragma Inline (Non_Private_View); - -- Return the full view of private type Typ if available, otherwise return - -- type Typ. + procedure Output_Access_Taken + (Attr : Node_Id; + Attr_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + Subp_Id : constant Entity_Id := Target (Attr_Rep); - procedure Output_Active_Scenarios (Error_Nod : Node_Id); - -- Output the contents of the active scenario stack from earliest to latest - -- to supplement an earlier error emitted for node Error_Nod. - - procedure Pop_Active_Scenario (N : Node_Id); - pragma Inline (Pop_Active_Scenario); - -- Pop the top of the scenario stack. A check is made to ensure that the - -- scenario being removed is the same as N. - - generic - with procedure Process_Single_Activation - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for task activation call Call - -- which activates task Obj_Id. Call_Attrs are the attributes of the - -- activation call. Task_Attrs are the attributes of the task type. - -- State is the current state of the Processing phase. - - procedure Process_Activation_Generic - (Call : Node_Id; - Call_Attrs : Call_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for activation call Call by invoking - -- routine Process_Single_Activation on each task object being activated. - -- Call_Attrs are the attributes of the activation call. State is the - -- current state of the Processing phase. - - procedure Process_Conditional_ABE - (N : Node_Id; - State : Processing_Attributes := Initial_State); - -- Top-level dispatcher for processing of various elaboration scenarios. - -- Perform conditional ABE checks and diagnostics for scenario N. State - -- is the current state of the Processing phase. - - procedure Process_Conditional_ABE_Access - (Attr : Node_Id; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for 'Access to entry, operator, or - -- subprogram denoted by Attr. State is the current state of the Processing - -- phase. + begin + Error_Msg_Name_1 := Attribute_Name (Attr); + Error_Msg_Sloc := Sloc (Attr); + Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); + end Output_Access_Taken; - procedure Process_Conditional_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - State : Processing_Attributes); - -- Perform common conditional ABE checks and diagnostics for call Call - -- which activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs - -- are the attributes of the activation call. Task_Attrs are the attributes - -- of the task type. State is the current state of the Processing phase. - - procedure Process_Conditional_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - State : Processing_Attributes); - -- Top-level dispatcher for processing of calls. Perform ABE checks and - -- diagnostics for call Call which invokes target Target_Id. Call_Attrs - -- are the attributes of the call. State is the current state of the - -- Processing phase. + ---------------------------- + -- Output_Active_Scenario -- + ---------------------------- - procedure Process_Conditional_ABE_Call_Ada - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for call Call which invokes target - -- Target_Id using the Ada rules. Call_Attrs are the attributes of the - -- call. Target_Attrs are attributes of the target. State is the current - -- state of the Processing phase. - - procedure Process_Conditional_ABE_Call_SPARK - (Call : Node_Id; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for call Call which invokes target - -- Target_Id using the SPARK rules. Target_Attrs denotes the attributes of - -- the target. State is the current state of the Processing phase. - - procedure Process_Conditional_ABE_Instantiation - (Exp_Inst : Node_Id; - State : Processing_Attributes); - -- Top-level dispatcher for processing of instantiations. Perform ABE - -- checks and diagnostics for expanded instantiation Exp_Inst. State is - -- the current state of the Processing phase. - - procedure Process_Conditional_ABE_Instantiation_Ada - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst - -- of generic Gen_Id using the Ada rules. Inst is the instantiation node. - -- Inst_Attrs are the attributes of the instance. Gen_Attrs denotes the - -- attributes of the generic. State is the current state of the Processing - -- phase. + procedure Output_Active_Scenario + (N : Node_Id; + Error_Nod : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); + Scen_Rep : Scenario_Rep_Id; - procedure Process_Conditional_ABE_Instantiation_SPARK - (Inst : Node_Id; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - State : Processing_Attributes); - -- Perform ABE checks and diagnostics for instantiation Inst of generic - -- Gen_Id using the SPARK rules. Gen_Attrs denotes the attributes of the - -- generic. State is the current state of the Processing phase. - - procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id); - -- Top-level dispatcher for processing of variable assignments. Perform ABE - -- checks and diagnostics for assignment statement Asmt. - - procedure Process_Conditional_ABE_Variable_Assignment_Ada - (Asmt : Node_Id; - Var_Id : Entity_Id); - -- Perform ABE checks and diagnostics for assignment statement Asmt that - -- updates the value of variable Var_Id using the Ada rules. - - procedure Process_Conditional_ABE_Variable_Assignment_SPARK - (Asmt : Node_Id; - Var_Id : Entity_Id); - -- Perform ABE checks and diagnostics for assignment statement Asmt that - -- updates the value of variable Var_Id using the SPARK rules. - - procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id); - -- Top-level dispatcher for processing of variable references. Perform ABE - -- checks and diagnostics for variable reference Ref. - - procedure Process_Conditional_ABE_Variable_Reference_Read - (Ref : Node_Id; - Var_Id : Entity_Id; - Attrs : Variable_Attributes); - -- Perform ABE checks and diagnostics for reference Ref described by its - -- attributes Attrs, that reads variable Var_Id. - - procedure Process_Guaranteed_ABE (N : Node_Id); - -- Top-level dispatcher for processing of scenarios which result in a - -- guaranteed ABE. - - procedure Process_Guaranteed_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - State : Processing_Attributes); - -- Perform common guaranteed ABE checks and diagnostics for call Call which - -- activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs are - -- the attributes of the activation call. Task_Attrs are the attributes of - -- the task type. State is provided for compatibility and is not used. - - procedure Process_Guaranteed_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id); - -- Perform common guaranteed ABE checks and diagnostics for call Call which - -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are - -- the attributes of the call. - - procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id); - -- Perform common guaranteed ABE checks and diagnostics for expanded - -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK - -- rules. - - procedure Push_Active_Scenario (N : Node_Id); - pragma Inline (Push_Active_Scenario); - -- Push scenario N on top of the scenario stack - - procedure Record_SPARK_Elaboration_Scenario (N : Node_Id); - pragma Inline (Record_SPARK_Elaboration_Scenario); - -- Save SPARK scenario N in table SPARK_Scenarios for later processing - - procedure Reset_Visited_Bodies; - pragma Inline (Reset_Visited_Bodies); - -- Clear the contents of table Visited_Bodies - - function Root_Scenario return Node_Id; - pragma Inline (Root_Scenario); - -- Return the top-level scenario which started a recursive search for other - -- scenarios. It is assumed that there is a valid top-level scenario on the - -- active scenario stack. - - procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); - pragma Inline (Set_Early_Call_Region); - -- Associate an early call region with begins at construct Start with entry - -- or subprogram body Body_Id. - - procedure Set_Elaboration_Status - (Unit_Id : Entity_Id; - Val : Elaboration_Attributes); - pragma Inline (Set_Elaboration_Status); - -- Associate an set of elaboration attributes with unit Unit_Id - - procedure Set_Is_Recorded_SPARK_Scenario - (N : Node_Id; - Val : Boolean := True); - pragma Inline (Set_Is_Recorded_SPARK_Scenario); - -- Mark scenario N as being recorded in table SPARK_Scenarios - - procedure Set_Is_Recorded_Top_Level_Scenario - (N : Node_Id; - Val : Boolean := True); - pragma Inline (Set_Is_Recorded_Top_Level_Scenario); - -- Mark scenario N as being recorded in table Top_Level_Scenarios - - procedure Set_Is_Visited_Body (Subp_Body : Node_Id); - pragma Inline (Set_Is_Visited_Body); - -- Mark subprogram body Subp_Body as being visited during a recursive - -- traversal started from a top-level scenario. + begin + -- 'Access - function Static_Elaboration_Checks return Boolean; - pragma Inline (Static_Elaboration_Checks); - -- Determine whether the static model is in effect + if Is_Suitable_Access_Taken (Scen) then + Output_Access_Taken + (Attr => Scen, + Attr_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); - procedure Traverse_Body (N : Node_Id; State : Processing_Attributes); - -- Inspect the declarative and statement lists of subprogram body N for - -- suitable elaboration scenarios and process them. State is the current - -- state of the Processing phase. + -- Call or task activation - function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; - pragma Inline (Unit_Entity); - -- Return the entity of the initial declaration for unit Unit_Id + elsif Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); - pragma Inline (Update_Elaboration_Scenario); - -- Update all relevant internal data structures when scenario Old_N is - -- transformed into scenario New_N by Atree.Rewrite. + if Kind (Scen_Rep) = Call_Scenario then + Output_Call + (Call => Scen, + Call_Rep => Scen_Rep, + Error_Nod => Error_Nod); + + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); + + Output_Task_Activation + (Call => Scen, + Call_Rep => Scen_Rep, + Error_Nod => Error_Nod); + end if; + + -- Instantiation + + elsif Is_Suitable_Instantiation (Scen) then + Output_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); + + -- Pragma Refined_State + + elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then + Output_Refined_State_Pragma + (Prag => Scen, + Prag_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); + + -- Variable assignment + + elsif Is_Suitable_Variable_Assignment (Scen) then + Output_Variable_Assignment + (Asmt => Scen, + Asmt_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); + + -- Variable reference + + elsif Is_Suitable_Variable_Reference (Scen) then + Output_Variable_Reference + (Ref => Scen, + Ref_Rep => Scenario_Representation_Of (Scen, In_State), + Error_Nod => Error_Nod); + end if; + end Output_Active_Scenario; + + ----------------------------- + -- Output_Active_Scenarios -- + ----------------------------- + + procedure Output_Active_Scenarios + (Error_Nod : Node_Id; + In_State : Processing_In_State) + is + package Scenarios renames Active_Scenario_Stack; + + Header_Posted : Boolean := False; + + begin + -- Output the contents of the active scenario stack starting from the + -- bottom, or the least recent scenario. + + for Index in Scenarios.First .. Scenarios.Last loop + if not Header_Posted then + Output_Header (Error_Nod); + Header_Posted := True; + end if; + + Output_Active_Scenario + (N => Scenarios.Table (Index), + Error_Nod => Error_Nod, + In_State => In_State); + end loop; + end Output_Active_Scenarios; + + ----------------- + -- Output_Call -- + ----------------- + + procedure Output_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + procedure Output_Accept_Alternative (Alt_Id : Entity_Id); + pragma Inline (Output_Accept_Alternative); + -- Emit a specific diagnostic message concerning accept alternative + -- with entity Alt_Id. + + procedure Output_Call (Subp_Id : Entity_Id; Kind : String); + pragma Inline (Output_Call); + -- Emit a specific diagnostic message concerning a call of kind Kind + -- which invokes subprogram Subp_Id. + + procedure Output_Type_Actions (Subp_Id : Entity_Id; Action : String); + pragma Inline (Output_Type_Actions); + -- Emit a specific diagnostic message concerning action Action of a + -- type performed by subprogram Subp_Id. + + procedure Output_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String); + pragma Inline (Output_Verification_Call); + -- Emit a specific diagnostic message concerning the verification of + -- predicate Pred applied to related entity Id with kind Id_Kind. + + ------------------------------- + -- Output_Accept_Alternative -- + ------------------------------- + + procedure Output_Accept_Alternative (Alt_Id : Entity_Id) is + Entry_Id : constant Entity_Id := Receiving_Entry (Alt_Id); + + begin + pragma Assert (Present (Entry_Id)); + + Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); + end Output_Accept_Alternative; + + ----------------- + -- Output_Call -- + ----------------- + + procedure Output_Call (Subp_Id : Entity_Id; Kind : String) is + begin + Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Subp_Id); + end Output_Call; + + ------------------------- + -- Output_Type_Actions -- + ------------------------- + + procedure Output_Type_Actions + (Subp_Id : Entity_Id; + Action : String) + is + Typ : constant Entity_Id := First_Formal_Type (Subp_Id); + + begin + pragma Assert (Present (Typ)); + + Error_Msg_NE + ("\\ " & Action & " actions for type & #", Error_Nod, Typ); + end Output_Type_Actions; + + ------------------------------ + -- Output_Verification_Call -- + ------------------------------ + + procedure Output_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String) + is + begin + pragma Assert (Present (Id)); + + Error_Msg_NE + ("\\ " & Pred & " of " & Id_Kind & " & verified #", + Error_Nod, Id); + end Output_Verification_Call; + + -- Local variables + + Subp_Id : constant Entity_Id := Target (Call_Rep); + + -- Start of processing for Output_Call + + begin + Error_Msg_Sloc := Sloc (Call); + + -- Accept alternative + + if Is_Accept_Alternative_Proc (Subp_Id) then + Output_Accept_Alternative (Subp_Id); + + -- Adjustment + + elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then + Output_Type_Actions (Subp_Id, "adjustment"); + + -- Default_Initial_Condition + + elsif Is_Default_Initial_Condition_Proc (Subp_Id) then + Output_Verification_Call + (Pred => "Default_Initial_Condition", + Id => First_Formal_Type (Subp_Id), + Id_Kind => "type"); + + -- Entries + + elsif Is_Protected_Entry (Subp_Id) then + Output_Call (Subp_Id, "entry"); + + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. A + -- task entry call appears in the stack of active scenarios for the + -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and + -- nothing more. + + elsif Is_Task_Entry (Subp_Id) then + null; + + -- Finalization + + elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then + Output_Type_Actions (Subp_Id, "finalization"); + + -- Calls to _Finalizer procedures must not appear in the output + -- because this creates confusing noise. + + elsif Is_Finalizer_Proc (Subp_Id) then + null; + + -- Initial_Condition + + elsif Is_Initial_Condition_Proc (Subp_Id) then + Output_Verification_Call + (Pred => "Initial_Condition", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "package"); + + -- Initialization + + elsif Is_Init_Proc (Subp_Id) + or else Is_TSS (Subp_Id, TSS_Deep_Initialize) + then + Output_Type_Actions (Subp_Id, "initialization"); + + -- Invariant + + elsif Is_Invariant_Proc (Subp_Id) then + Output_Verification_Call + (Pred => "invariants", + Id => First_Formal_Type (Subp_Id), + Id_Kind => "type"); + + -- Partial invariant calls must not appear in the output because this + -- creates confusing noise. Note that a partial invariant is always + -- invoked by the "full" invariant which is already placed on the + -- stack. + + elsif Is_Partial_Invariant_Proc (Subp_Id) then + null; + + -- _Postconditions + + elsif Is_Postconditions_Proc (Subp_Id) then + Output_Verification_Call + (Pred => "postconditions", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "subprogram"); + + -- Subprograms must come last because some of the previous cases fall + -- under this category. + + elsif Ekind (Subp_Id) = E_Function then + Output_Call (Subp_Id, "function"); + + elsif Ekind (Subp_Id) = E_Procedure then + Output_Call (Subp_Id, "procedure"); + + else + pragma Assert (False); + return; + end if; + end Output_Call; + + ------------------- + -- Output_Header -- + ------------------- + + procedure Output_Header (Error_Nod : Node_Id) is + Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); + + begin + if Ekind (Unit_Id) = E_Package then + Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); + + elsif Ekind (Unit_Id) = E_Package_Body then + Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); + + else + Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); + end if; + end Output_Header; + + -------------------------- + -- Output_Instantiation -- + -------------------------- + + procedure Output_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); + pragma Inline (Output_Instantiation); + -- Emit a specific diagnostic message concerning an instantiation of + -- generic unit Gen_Id. Kind denotes the kind of the instantiation. + + -------------------------- + -- Output_Instantiation -- + -------------------------- + + procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is + begin + Error_Msg_NE + ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); + end Output_Instantiation; + + -- Local variables + + Gen_Id : constant Entity_Id := Target (Inst_Rep); + + -- Start of processing for Output_Instantiation + + begin + Error_Msg_Node_2 := Defining_Entity (Inst); + Error_Msg_Sloc := Sloc (Inst); + + if Nkind (Inst) = N_Function_Instantiation then + Output_Instantiation (Gen_Id, "function"); + + elsif Nkind (Inst) = N_Package_Instantiation then + Output_Instantiation (Gen_Id, "package"); + + elsif Nkind (Inst) = N_Procedure_Instantiation then + Output_Instantiation (Gen_Id, "procedure"); + + else + pragma Assert (False); + return; + end if; + end Output_Instantiation; + + --------------------------------- + -- Output_Refined_State_Pragma -- + --------------------------------- + + procedure Output_Refined_State_Pragma + (Prag : Node_Id; + Prag_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + pragma Unreferenced (Prag_Rep); + + begin + Error_Msg_Sloc := Sloc (Prag); + Error_Msg_N ("\\ refinement constituents read #", Error_Nod); + end Output_Refined_State_Pragma; + + ---------------------------- + -- Output_Task_Activation -- + ---------------------------- + + procedure Output_Task_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + pragma Unreferenced (Call_Rep); + + function Find_Activator return Entity_Id; + -- Find the nearest enclosing construct which houses call Call + + -------------------- + -- Find_Activator -- + -------------------- + + function Find_Activator return Entity_Id is + Par : Node_Id; + + begin + -- Climb the parent chain looking for a package [body] or a + -- construct with a statement sequence. + + Par := Parent (Call); + while Present (Par) loop + if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then + return Defining_Entity (Par); + + elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then + return Defining_Entity (Parent (Par)); + end if; + + Par := Parent (Par); + end loop; + + return Empty; + end Find_Activator; + + -- Local variables + + Activator : constant Entity_Id := Find_Activator; + + -- Start of processing for Output_Task_Activation + + begin + pragma Assert (Present (Activator)); + + Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); + end Output_Task_Activation; + + -------------------------------- + -- Output_Variable_Assignment -- + -------------------------------- + + procedure Output_Variable_Assignment + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + Var_Id : constant Entity_Id := Target (Asmt_Rep); + + begin + Error_Msg_Sloc := Sloc (Asmt); + Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); + end Output_Variable_Assignment; + + ------------------------------- + -- Output_Variable_Reference -- + ------------------------------- + + procedure Output_Variable_Reference + (Ref : Node_Id; + Ref_Rep : Scenario_Rep_Id; + Error_Nod : Node_Id) + is + Var_Id : constant Entity_Id := Target (Ref_Rep); + + begin + Error_Msg_Sloc := Sloc (Ref); + Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); + end Output_Variable_Reference; + + ------------------------- + -- Pop_Active_Scenario -- + ------------------------- + + procedure Pop_Active_Scenario (N : Node_Id) is + package Scenarios renames Active_Scenario_Stack; + Top : Node_Id renames Scenarios.Table (Scenarios.Last); + + begin + pragma Assert (Top = N); + Scenarios.Decrement_Last; + end Pop_Active_Scenario; + + -------------------------- + -- Push_Active_Scenario -- + -------------------------- + + procedure Push_Active_Scenario (N : Node_Id) is + begin + Active_Scenario_Stack.Append (N); + end Push_Active_Scenario; + + ------------------- + -- Root_Scenario -- + ------------------- + + function Root_Scenario return Node_Id is + package Scenarios renames Active_Scenario_Stack; + + begin + -- Ensure that the scenario stack has at least one active scenario in + -- it. The one at the bottom (index First) is the root scenario. + + pragma Assert (Scenarios.Last >= Scenarios.First); + return Scenarios.Table (Scenarios.First); + end Root_Scenario; + end Active_Scenarios; + + -------------------------- + -- Activation_Processor -- + -------------------------- + + package body Activation_Processor is + + ------------------------ + -- Process_Activation -- + ------------------------ + + procedure Process_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Processor : Activation_Processor_Ptr; + In_State : Processing_In_State) + is + procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); + pragma Inline (Process_Task_Object); + -- Invoke Processor for task object Obj_Id of type Typ + + procedure Process_Task_Objects + (Task_Objs : NE_List.Doubly_Linked_List); + pragma Inline (Process_Task_Objects); + -- Invoke Processor for all task objects found in list Task_Objs + + procedure Traverse_List + (List : List_Id; + Task_Objs : NE_List.Doubly_Linked_List); + pragma Inline (Traverse_List); + -- Traverse declarative or statement list List while searching for + -- objects of a task type, or containing task components. If such an + -- object is found, first save it in list Task_Objs and then invoke + -- Processor on it. + + ------------------------- + -- Process_Task_Object -- + ------------------------- + + procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is + Root_Typ : constant Entity_Id := + Non_Private_View (Root_Type (Typ)); + Comp_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Root_Rep : Target_Rep_Id; + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state + + begin + if Is_Task_Type (Typ) then + Obj_Rep := Target_Representation_Of (Obj_Id, New_In_State); + Root_Rep := Target_Representation_Of (Root_Typ, New_In_State); + + -- Warnings are suppressed when a prior scenario is already in + -- that mode, or when the object, activation call, or task type + -- have warnings suppressed. Update the state of the Processing + -- phase to reflect this. + + New_In_State.Suppress_Warnings := + New_In_State.Suppress_Warnings + or else not Elaboration_Warnings_OK (Call_Rep) + or else not Elaboration_Warnings_OK (Obj_Rep) + or else not Elaboration_Warnings_OK (Root_Rep); + + -- Update the state of the Processing phase to indicate that + -- any further traversal is now within a task body. + + New_In_State.Within_Task_Body := True; + + -- Associate the current task type with the activation call + + Set_Activated_Task_Type (Call_Rep, Root_Typ); + + -- Process the activation of the current task object by calling + -- the supplied processor. + + Processor.all + (Call => Call, + Call_Rep => Call_Rep, + Obj_Id => Obj_Id, + Obj_Rep => Obj_Rep, + Task_Typ => Root_Typ, + Task_Rep => Root_Rep, + In_State => New_In_State); + + -- Reset the association between the current task and the + -- activtion call. + + Set_Activated_Task_Type (Call_Rep, Empty); + + -- Examine the component type when the object is an array + + elsif Is_Array_Type (Typ) and then Has_Task (Root_Typ) then + Process_Task_Object + (Obj_Id => Obj_Id, + Typ => Component_Type (Typ)); + + -- Examine individual component types when the object is a record + + elsif Is_Record_Type (Typ) and then Has_Task (Root_Typ) then + Comp_Id := First_Component (Typ); + while Present (Comp_Id) loop + Process_Task_Object + (Obj_Id => Obj_Id, + Typ => Etype (Comp_Id)); + + Next_Component (Comp_Id); + end loop; + end if; + end Process_Task_Object; + + -------------------------- + -- Process_Task_Objects -- + -------------------------- + + procedure Process_Task_Objects + (Task_Objs : NE_List.Doubly_Linked_List) + is + Iter : NE_List.Iterator; + Obj_Id : Entity_Id; + + begin + Iter := NE_List.Iterate (Task_Objs); + while NE_List.Has_Next (Iter) loop + NE_List.Next (Iter, Obj_Id); + + Process_Task_Object + (Obj_Id => Obj_Id, + Typ => Etype (Obj_Id)); + end loop; + end Process_Task_Objects; + + ------------------- + -- Traverse_List -- + ------------------- + + procedure Traverse_List + (List : List_Id; + Task_Objs : NE_List.Doubly_Linked_List) + is + Item : Node_Id; + Item_Id : Entity_Id; + Item_Typ : Entity_Id; + + begin + -- Examine the contents of the list looking for an object + -- declaration of a task type or one that contains a task + -- within. + + Item := First (List); + while Present (Item) loop + if Nkind (Item) = N_Object_Declaration then + Item_Id := Defining_Entity (Item); + Item_Typ := Etype (Item_Id); + + if Has_Task (Item_Typ) then + + -- The object is either of a task type, or contains a + -- task component. Save it in the list of task objects + -- associated with the activation call. + + NE_List.Append (Task_Objs, Item_Id); + + Process_Task_Object + (Obj_Id => Item_Id, + Typ => Item_Typ); + end if; + end if; + + Next (Item); + end loop; + end Traverse_List; + + -- Local variables + + Context : Node_Id; + Spec : Node_Id; + Task_Objs : NE_List.Doubly_Linked_List; + + -- Start of processing for Process_Activation + + begin + -- Nothing to do when the activation is a guaranteed ABE + + if Is_Known_Guaranteed_ABE (Call) then + return; + end if; + + Task_Objs := Activated_Task_Objects (Call_Rep); + + -- The activation call has been processed at least once, and all + -- task objects have already been collected. Directly process the + -- objects without having to reexamine the context of the call. + + if NE_List.Present (Task_Objs) then + Process_Task_Objects (Task_Objs); + + -- Otherwise the activation call is being processed for the first + -- time. Collect all task objects in case the call is reprocessed + -- multiple times. + + else + Task_Objs := NE_List.Create; + Set_Activated_Task_Objects (Call_Rep, Task_Objs); + + -- Find the context of the activation call where all task objects + -- being activated are declared. This is usually the parent of the + -- call. + + Context := Parent (Call); + + -- Handle the case where the activation call appears within the + -- handled statements of a block or a body. + + if Nkind (Context) = N_Handled_Sequence_Of_Statements then + Context := Parent (Context); + end if; + + -- Process all task objects in both the spec and body when the + -- activation call appears in a package body. + + if Nkind (Context) = N_Package_Body then + Spec := + Specification + (Unit_Declaration_Node (Corresponding_Spec (Context))); + + Traverse_List + (List => Visible_Declarations (Spec), + Task_Objs => Task_Objs); + + Traverse_List + (List => Private_Declarations (Spec), + Task_Objs => Task_Objs); + + Traverse_List + (List => Declarations (Context), + Task_Objs => Task_Objs); + + -- Process all task objects in the spec when the activation call + -- appears in a package spec. + + elsif Nkind (Context) = N_Package_Specification then + Traverse_List + (List => Visible_Declarations (Context), + Task_Objs => Task_Objs); + + Traverse_List + (List => Private_Declarations (Context), + Task_Objs => Task_Objs); + + -- Otherwise the context must be a block or a body. Process all + -- task objects found in the declarations. + + else + pragma Assert (Nkind_In (Context, N_Block_Statement, + N_Entry_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body)); + + Traverse_List + (List => Declarations (Context), + Task_Objs => Task_Objs); + end if; + end if; + end Process_Activation; + end Activation_Processor; + + ----------------------- + -- Assignment_Target -- + ----------------------- + + function Assignment_Target (Asmt : Node_Id) return Node_Id is + Nam : Node_Id; + + begin + Nam := Name (Asmt); + + -- When the name denotes an array or record component, find the whole + -- object. + + while Nkind_In (Nam, N_Explicit_Dereference, + N_Indexed_Component, + N_Selected_Component, + N_Slice) + loop + Nam := Prefix (Nam); + end loop; + + return Nam; + end Assignment_Target; + + -------------------- + -- Body_Processor -- + -------------------- + + package body Body_Processor is + + --------------------- + -- Data structures -- + --------------------- + + -- The following map relates scenario lists to subprogram bodies + + Nested_Scenarios_Map : NE_List_Map.Dynamic_Hash_Table := NE_List_Map.Nil; + + -- The following set contains all subprogram bodies that have been + -- processed by routine Traverse_Body. + + Traversed_Bodies_Set : NE_Set.Membership_Set := NE_Set.Nil; + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Is_Traversed_Body (N : Node_Id) return Boolean; + pragma Inline (Is_Traversed_Body); + -- Determine whether subprogram body N has already been traversed + + function Nested_Scenarios + (N : Node_Id) return NE_List.Doubly_Linked_List; + pragma Inline (Nested_Scenarios); + -- Obtain the list of scenarios associated with subprogram body N + + procedure Set_Is_Traversed_Body + (N : Node_Id; + Val : Boolean := True); + pragma Inline (Set_Is_Traversed_Body); + -- Mark subprogram body N as traversed depending on value Val + + procedure Set_Nested_Scenarios + (N : Node_Id; + Scenarios : NE_List.Doubly_Linked_List); + pragma Inline (Set_Nested_Scenarios); + -- Associate scenario list Scenarios with subprogram body N + + ----------------------------- + -- Finalize_Body_Processor -- + ----------------------------- + + procedure Finalize_Body_Processor is + begin + NE_List_Map.Destroy (Nested_Scenarios_Map); + NE_Set.Destroy (Traversed_Bodies_Set); + end Finalize_Body_Processor; + + ------------------------------- + -- Initialize_Body_Processor -- + ------------------------------- + + procedure Initialize_Body_Processor is + begin + Nested_Scenarios_Map := NE_List_Map.Create (250); + Traversed_Bodies_Set := NE_Set.Create (250); + end Initialize_Body_Processor; + + ----------------------- + -- Is_Traversed_Body -- + ----------------------- + + function Is_Traversed_Body (N : Node_Id) return Boolean is + pragma Assert (Present (N)); + begin + return NE_Set.Contains (Traversed_Bodies_Set, N); + end Is_Traversed_Body; + + ---------------------- + -- Nested_Scenarios -- + ---------------------- + + function Nested_Scenarios + (N : Node_Id) return NE_List.Doubly_Linked_List + is + pragma Assert (Present (N)); + pragma Assert (Nkind (N) = N_Subprogram_Body); + + begin + return NE_List_Map.Get (Nested_Scenarios_Map, N); + end Nested_Scenarios; + + ---------------------------- + -- Reset_Traversed_Bodies -- + ---------------------------- + + procedure Reset_Traversed_Bodies is + begin + NE_Set.Reset (Traversed_Bodies_Set); + end Reset_Traversed_Bodies; + + --------------------------- + -- Set_Is_Traversed_Body -- + --------------------------- + + procedure Set_Is_Traversed_Body + (N : Node_Id; + Val : Boolean := True) + is + pragma Assert (Present (N)); + + begin + if Val then + NE_Set.Insert (Traversed_Bodies_Set, N); + else + NE_Set.Delete (Traversed_Bodies_Set, N); + end if; + end Set_Is_Traversed_Body; + + -------------------------- + -- Set_Nested_Scenarios -- + -------------------------- + + procedure Set_Nested_Scenarios + (N : Node_Id; + Scenarios : NE_List.Doubly_Linked_List) + is + pragma Assert (Present (N)); + begin + NE_List_Map.Put (Nested_Scenarios_Map, N, Scenarios); + end Set_Nested_Scenarios; + + ------------------- + -- Traverse_Body -- + ------------------- + + procedure Traverse_Body + (N : Node_Id; + Requires_Processing : Scenario_Predicate_Ptr; + Processor : Scenario_Processor_Ptr; + In_State : Processing_In_State) + is + Scenarios : NE_List.Doubly_Linked_List := NE_List.Nil; + -- The list of scenarios that appear within the declarations and + -- statement of subprogram body N. The variable is intentionally + -- global because Is_Potential_Scenario needs to populate it. + + function In_Task_Body (Nod : Node_Id) return Boolean; + pragma Inline (In_Task_Body); + -- Determine whether arbitrary node Nod appears within a task body + + function Is_Synchronous_Suspension_Call + (Nod : Node_Id) return Boolean; + pragma Inline (Is_Synchronous_Suspension_Call); + -- Determine whether arbitrary node Nod denotes a call to one of + -- these routines: + -- + -- Ada.Synchronous_Barriers.Wait_For_Release + -- Ada.Synchronous_Task_Control.Suspend_Until_True + + procedure Traverse_Collected_Scenarios; + pragma Inline (Traverse_Collected_Scenarios); + -- Traverse the already collected scenarios in list Scenarios by + -- invoking Processor on each individual one. + + procedure Traverse_List (List : List_Id); + pragma Inline (Traverse_List); + -- Invoke Traverse_Potential_Scenarios on each node in list List + + function Traverse_Potential_Scenario + (Scen : Node_Id) return Traverse_Result; + pragma Inline (Traverse_Potential_Scenario); + -- Determine whether arbitrary node Scen is a suitable scenario using + -- predicate Is_Scenario and traverse it by invoking Processor on it. + + procedure Traverse_Potential_Scenarios is + new Traverse_Proc (Traverse_Potential_Scenario); + + ------------------ + -- In_Task_Body -- + ------------------ + + function In_Task_Body (Nod : Node_Id) return Boolean is + Par : Node_Id; + + begin + -- Climb the parent chain looking for a task body [procedure] + + Par := Nod; + while Present (Par) loop + if Nkind (Par) = N_Task_Body then + return True; + + elsif Nkind (Par) = N_Subprogram_Body + and then Is_Task_Body_Procedure (Par) + then + return True; + + -- Prevent the search from going too far. Note that this test + -- shares nodes with the two cases above, and must come last. + + elsif Is_Body_Or_Package_Declaration (Par) then + return False; + end if; + + Par := Parent (Par); + end loop; + + return False; + end In_Task_Body; + + ------------------------------------ + -- Is_Synchronous_Suspension_Call -- + ------------------------------------ + + function Is_Synchronous_Suspension_Call + (Nod : Node_Id) return Boolean + is + Subp_Id : Entity_Id; + + begin + -- To qualify, the call must invoke one of the runtime routines + -- which perform synchronous suspension. + + if Is_Suitable_Call (Nod) then + Subp_Id := Target (Nod); + + return + Is_RTE (Subp_Id, RE_Suspend_Until_True) + or else + Is_RTE (Subp_Id, RE_Wait_For_Release); + end if; + + return False; + end Is_Synchronous_Suspension_Call; + + ---------------------------------- + -- Traverse_Collected_Scenarios -- + ---------------------------------- + + procedure Traverse_Collected_Scenarios is + Iter : NE_List.Iterator; + Scen : Node_Id; + + begin + Iter := NE_List.Iterate (Scenarios); + while NE_List.Has_Next (Iter) loop + NE_List.Next (Iter, Scen); + + -- The current scenario satisfies the input predicate, process + -- it. + + if Requires_Processing.all (Scen) then + Processor.all (Scen, In_State); + end if; + end loop; + end Traverse_Collected_Scenarios; + + ------------------- + -- Traverse_List -- + ------------------- + + procedure Traverse_List (List : List_Id) is + Scen : Node_Id; + + begin + Scen := First (List); + while Present (Scen) loop + Traverse_Potential_Scenarios (Scen); + Next (Scen); + end loop; + end Traverse_List; + + --------------------------------- + -- Traverse_Potential_Scenario -- + --------------------------------- + + function Traverse_Potential_Scenario + (Scen : Node_Id) return Traverse_Result + is + begin + -- Special cases + + -- Skip constructs which do not have elaboration of their own and + -- need to be elaborated by other means such as invocation, task + -- activation, etc. + + if Is_Non_Library_Level_Encapsulator (Scen) then + return Skip; + + -- Terminate the traversal of a task body when encountering an + -- accept or select statement, and + -- + -- * Entry calls during elaboration are not allowed. In this + -- case the accept or select statement will cause the task + -- to block at elaboration time because there are no entry + -- calls to unblock it. + -- + -- or + -- + -- * Switch -gnatd_a (stop elaboration checks on accept or + -- select statement) is in effect. + + elsif (Debug_Flag_Underscore_A + or else Restriction_Active + (No_Entry_Calls_In_Elaboration_Code)) + and then Nkind_In (Original_Node (Scen), N_Accept_Statement, + N_Selective_Accept) + then + return Abandon; + + -- Terminate the traversal of a task body when encountering a + -- suspension call, and + -- + -- * Entry calls during elaboration are not allowed. In this + -- case the suspension call emulates an entry call and will + -- cause the task to block at elaboration time. + -- + -- or + -- + -- * Switch -gnatd_s (stop elaboration checks on synchronous + -- suspension) is in effect. + -- + -- Note that the guard should not be checking the state of flag + -- Within_Task_Body because only suspension calls which appear + -- immediately within the statements of the task are supported. + -- Flag Within_Task_Body carries over to deeper levels of the + -- traversal. + + elsif (Debug_Flag_Underscore_S + or else Restriction_Active + (No_Entry_Calls_In_Elaboration_Code)) + and then Is_Synchronous_Suspension_Call (Scen) + and then In_Task_Body (Scen) + then + return Abandon; + + -- Certain nodes carry semantic lists which act as repositories + -- until expansion transforms the node and relocates the contents. + -- Examine these lists in case expansion is disabled. + + elsif Nkind_In (Scen, N_And_Then, N_Or_Else) then + Traverse_List (Actions (Scen)); + + elsif Nkind_In (Scen, N_Elsif_Part, N_Iteration_Scheme) then + Traverse_List (Condition_Actions (Scen)); + + elsif Nkind (Scen) = N_If_Expression then + Traverse_List (Then_Actions (Scen)); + Traverse_List (Else_Actions (Scen)); + + elsif Nkind_In (Scen, N_Component_Association, + N_Iterated_Component_Association) + then + Traverse_List (Loop_Actions (Scen)); + + -- General case + + -- The current node satisfies the input predicate, process it + + elsif Requires_Processing.all (Scen) then + Processor.all (Scen, In_State); + end if; + + -- Save a general scenario regardless of whether it satisfies the + -- input predicate. This allows for quick subsequent traversals of + -- general scenarios, even with different predicates. + + if Is_Suitable_Access_Taken (Scen) + or else Is_Suitable_Call (Scen) + or else Is_Suitable_Instantiation (Scen) + or else Is_Suitable_Variable_Assignment (Scen) + or else Is_Suitable_Variable_Reference (Scen) + then + NE_List.Append (Scenarios, Scen); + end if; + + return OK; + end Traverse_Potential_Scenario; + + -- Start of processing for Traverse_Body + + begin + -- Nothing to do when the traversal is suppressed + + if In_State.Traversal = No_Traversal then + return; + + -- Nothing to do when there is no input + + elsif No (N) then + return; + + -- Nothing to do when the input is not a subprogram body + + elsif Nkind (N) /= N_Subprogram_Body then + return; + + -- Nothing to do if the subprogram body was already traversed + + elsif Is_Traversed_Body (N) then + return; + end if; + + -- Mark the subprogram body as traversed + + Set_Is_Traversed_Body (N); + + Scenarios := Nested_Scenarios (N); + + -- The subprogram body has been traversed at least once, and all + -- scenarios that appear within its declarations and statements + -- have already been collected. Directly retraverse the scenarios + -- without having to retraverse the subprogram body subtree. + + if NE_List.Present (Scenarios) then + Traverse_Collected_Scenarios; + + -- Otherwise the subprogram body is being traversed for the first + -- time. Collect all scenarios that appear within its declarations + -- and statements in case the subprogram body has to be retraversed + -- multiple times. + + else + Scenarios := NE_List.Create; + Set_Nested_Scenarios (N, Scenarios); + + Traverse_List (Declarations (N)); + Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); + end if; + end Traverse_Body; + end Body_Processor; ----------------------- -- Build_Call_Marker -- @@ -1882,19 +3393,16 @@ package body Sem_Elab is procedure Build_Call_Marker (N : Node_Id) is function In_External_Context - (Call : Node_Id; - Target_Attrs : Target_Attributes) return Boolean; + (Call : Node_Id; + Subp_Id : Entity_Id) return Boolean; pragma Inline (In_External_Context); - -- Determine whether a target described by attributes Target_Attrs is - -- external to call Call which must reside within an instance. + -- Determine whether entry, operator, or subprogram Subp_Id is external + -- to call Call which must reside within an instance. function In_Premature_Context (Call : Node_Id) return Boolean; + pragma Inline (In_Premature_Context); -- Determine whether call Call appears within a premature context - function Is_Bridge_Target (Id : Entity_Id) return Boolean; - pragma Inline (Is_Bridge_Target); - -- Determine whether arbitrary entity Id denotes a bridge target - function Is_Default_Expression (Call : Node_Id) return Boolean; pragma Inline (Is_Default_Expression); -- Determine whether call Call acts as the expression of a defaulted @@ -1910,16 +3418,16 @@ package body Sem_Elab is ------------------------- function In_External_Context - (Call : Node_Id; - Target_Attrs : Target_Attributes) return Boolean + (Call : Node_Id; + Subp_Id : Entity_Id) return Boolean is + Spec_Decl : constant Entity_Id := Unit_Declaration_Node (Subp_Id); + Inst : Node_Id; Inst_Body : Node_Id; - Inst_Decl : Node_Id; + Inst_Spec : Node_Id; begin - -- Performance note: parent traversal - Inst := Find_Enclosing_Instance (Call); -- The call appears within an instance @@ -1929,7 +3437,7 @@ package body Sem_Elab is -- The call comes from the main unit and the target does not if In_Extended_Main_Code_Unit (Call) - and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl) + and then not In_Extended_Main_Code_Unit (Spec_Decl) then return True; @@ -1937,16 +3445,14 @@ package body Sem_Elab is -- instance spec or body. else - Extract_Instance_Attributes - (Exp_Inst => Inst, - Inst_Decl => Inst_Decl, - Inst_Body => Inst_Body); - - -- Performance note: parent traversal + Spec_And_Body_From_Node + (N => Inst, + Spec_Decl => Inst_Spec, + Body_Decl => Inst_Body); return not In_Subtree - (N => Target_Attrs.Spec_Decl, - Root1 => Inst_Decl, + (N => Spec_Decl, + Root1 => Inst_Spec, Root2 => Inst_Body); end if; end if; @@ -1988,22 +3494,6 @@ package body Sem_Elab is return False; end In_Premature_Context; - ---------------------- - -- Is_Bridge_Target -- - ---------------------- - - function Is_Bridge_Target (Id : Entity_Id) return Boolean is - begin - return - Is_Accept_Alternative_Proc (Id) - or else Is_Finalizer_Proc (Id) - or else Is_Partial_Invariant_Proc (Id) - or else Is_Postconditions_Proc (Id) - or else Is_TSS (Id, TSS_Deep_Adjust) - or else Is_TSS (Id, TSS_Deep_Finalize) - or else Is_TSS (Id, TSS_Deep_Initialize); - end Is_Bridge_Target; - --------------------------- -- Is_Default_Expression -- --------------------------- @@ -2021,7 +3511,7 @@ package body Sem_Elab is N_Procedure_Call_Statement) and then Comes_From_Source (Outer_Call) then - Outer_Nam := Extract_Call_Name (Outer_Call); + Outer_Nam := Call_Name (Outer_Call); return Is_Entity_Name (Outer_Nam) @@ -2056,11 +3546,9 @@ package body Sem_Elab is -- Local variables - Call_Attrs : Call_Attributes; - Call_Nam : Node_Id; - Marker : Node_Id; - Target_Attrs : Target_Attributes; - Target_Id : Entity_Id; + Call_Nam : Node_Id; + Marker : Node_Id; + Subp_Id : Entity_Id; -- Start of processing for Build_Call_Marker @@ -2101,9 +3589,16 @@ package body Sem_Elab is and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) then return; + + -- Nothing to do when the call is analyzed/resolved too early within an + -- intermediate context. This check is saved for last because it incurs + -- a performance penalty. + + elsif In_Premature_Context (N) then + return; end if; - Call_Nam := Extract_Call_Name (N); + Call_Nam := Call_Name (N); -- Nothing to do when the call is erroneous or left in a bad state @@ -2112,6 +3607,9 @@ package body Sem_Elab is and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) then return; + end if; + + Subp_Id := Canonical_Subprogram (Entity (Call_Nam)); -- Nothing to do when the call invokes a generic formal subprogram and -- switch -gnatd.G (ignore calls through generic formal parameters for @@ -2119,44 +3617,24 @@ package body Sem_Elab is -- direct target of the call to avoid the side effects of mapping -- actuals to formals using renamings. - elsif Debug_Flag_Dot_GG + if Debug_Flag_Dot_GG and then Is_Generic_Formal_Subp (Entity (Call_Nam)) then return; - -- Nothing to do when the call is analyzed/resolved too early within an - -- intermediate context. This check is saved for last because it incurs - -- a performance penalty. - - -- Performance note: parent traversal - - elsif In_Premature_Context (N) then - return; - end if; - - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); - - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); - -- Nothing to do when the call appears within the expanded spec or -- body of an instantiated generic, the call does not invoke a generic -- formal subprogram, the target is external to the instance, and switch -- -gnatdL (ignore external calls from instances for elaboration) is in - -- effect. + -- effect. This check must be performed with the direct target of the + -- call to avoid the side effects of mapping actuals to formals using + -- renamings. - if Debug_Flag_LL + elsif Debug_Flag_LL and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) - - -- Performance note: parent traversal - and then In_External_Context - (Call => N, - Target_Attrs => Target_Attrs) + (Call => N, + Subp_Id => Subp_Id) then return; @@ -2165,20 +3643,20 @@ package body Sem_Elab is -- in effect. elsif Debug_Flag_Underscore_P - and then Is_Assertion_Pragma_Target (Target_Id) + and then Is_Assertion_Pragma_Target (Subp_Id) then return; -- Source calls to source targets are always considered because they -- reflect the original call graph. - elsif Target_Attrs.From_Source and then Call_Attrs.From_Source then + elsif Comes_From_Source (N) and then Comes_From_Source (Subp_Id) then null; -- A call to a source function which acts as the default expression in -- another call requires special detection. - elsif Target_Attrs.From_Source + elsif Comes_From_Source (Subp_Id) and then Nkind (N) = N_Function_Call and then Is_Default_Expression (N) then @@ -2186,17 +3664,17 @@ package body Sem_Elab is -- The target emulates Ada semantics - elsif Is_Ada_Semantic_Target (Target_Id) then + elsif Is_Ada_Semantic_Target (Subp_Id) then null; -- The target acts as a link between scenarios - elsif Is_Bridge_Target (Target_Id) then + elsif Is_Bridge_Target (Subp_Id) then null; -- The target emulates SPARK semantics - elsif Is_SPARK_Semantic_Target (Target_Id) then + elsif Is_SPARK_Semantic_Target (Subp_Id) then null; -- Otherwise the call is not suitable for ABE processing. This prevents @@ -2215,16 +3693,23 @@ package body Sem_Elab is -- Inherit the attributes of the original call - Set_Target (Marker, Target_Id); - Set_Is_Declaration_Level_Node (Marker, Call_Attrs.In_Declarations); - Set_Is_Dispatching_Call (Marker, Call_Attrs.Is_Dispatching); + Set_Is_Declaration_Level_Node + (Marker, Find_Enclosing_Level (N) = Declaration_Level); + + Set_Is_Dispatching_Call + (Marker, Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + and then Present (Controlling_Argument (N))); + Set_Is_Elaboration_Checks_OK_Node - (Marker, Call_Attrs.Elab_Checks_OK); + (Marker, Is_Elaboration_Checks_OK_Node (N)); + Set_Is_Elaboration_Warnings_OK_Node - (Marker, Call_Attrs.Elab_Warnings_OK); - Set_Is_Ignored_Ghost_Node (Marker, Call_Attrs.Ghost_Mode_Ignore); - Set_Is_Source_Call (Marker, Call_Attrs.From_Source); - Set_Is_SPARK_Mode_On_Node (Marker, Call_Attrs.SPARK_Mode_On); + (Marker, Is_Elaboration_Warnings_OK_Node (N)); + + Set_Is_Ignored_Ghost_Node (Marker, Is_Ignored_Ghost_Node (N)); + Set_Is_Source_Call (Marker, Comes_From_Source (N)); + Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); + Set_Target (Marker, Subp_Id); -- The marker is inserted prior to the original call. This placement has -- several desirable effects: @@ -2274,23 +3759,50 @@ package body Sem_Elab is Read : Boolean; Write : Boolean) is - Marker : Node_Id; - Var_Attrs : Variable_Attributes; - Var_Id : Entity_Id; + function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id; + pragma Inline (Ultimate_Variable); + -- Obtain the ultimate renamed variable of variable Var_Id - begin - Extract_Variable_Reference_Attributes - (Ref => N, - Var_Id => Var_Id, - Attrs => Var_Attrs); + ----------------------- + -- Ultimate_Variable -- + ----------------------- + + function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id is + Ren_Id : Entity_Id; + + begin + Ren_Id := Var_Id; + while Present (Renamed_Entity (Ren_Id)) + and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity + loop + Ren_Id := Renamed_Entity (Ren_Id); + end loop; + return Ren_Id; + end Ultimate_Variable; + + -- Local variables + + Var_Id : constant Entity_Id := Ultimate_Variable (Entity (N)); + Marker : Node_Id; + + -- Start of processing for Build_Variable_Reference_Marker + + begin Marker := Make_Variable_Reference_Marker (Sloc (N)); -- Inherit the attributes of the original variable reference - Set_Target (Marker, Var_Id); - Set_Is_Read (Marker, Read); - Set_Is_Write (Marker, Write); + Set_Is_Elaboration_Checks_OK_Node + (Marker, Is_Elaboration_Checks_OK_Node (N)); + + Set_Is_Elaboration_Warnings_OK_Node + (Marker, Is_Elaboration_Warnings_OK_Node (N)); + + Set_Is_Read (Marker, Read); + Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); + Set_Is_Write (Marker, Write); + Set_Target (Marker, Var_Id); -- The marker is inserted prior to the original variable reference. The -- insertion must take place even when the reference does not occur in @@ -2306,11 +3818,69 @@ package body Sem_Elab is Record_Elaboration_Scenario (Marker); end Build_Variable_Reference_Marker; + --------------- + -- Call_Name -- + --------------- + + function Call_Name (Call : Node_Id) return Node_Id is + Nam : Node_Id; + + begin + Nam := Name (Call); + + -- When the call invokes an entry family, the name appears as an indexed + -- component. + + if Nkind (Nam) = N_Indexed_Component then + Nam := Prefix (Nam); + end if; + + -- When the call employs the object.operation form, the name appears as + -- a selected component. + + if Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); + end if; + + return Nam; + end Call_Name; + + -------------------------- + -- Canonical_Subprogram -- + -------------------------- + + function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id is + Canon_Id : Entity_Id; + + begin + Canon_Id := Subp_Id; + + -- Use the original protected subprogram when dealing with one of the + -- specialized lock-manipulating versions. + + if Is_Protected_Body_Subp (Canon_Id) then + Canon_Id := Protected_Subprogram (Canon_Id); + end if; + + -- Obtain the original subprogram except when the subprogram is also + -- an instantiation. In this case the alias is the internally generated + -- subprogram which appears within the anonymous package created for the + -- instantiation, making it unuitable. + + if not Is_Generic_Instance (Canon_Id) then + Canon_Id := Get_Renamed_Entity (Canon_Id); + end if; + + return Canon_Id; + end Canonical_Subprogram; + --------------------------------- -- Check_Elaboration_Scenarios -- --------------------------------- procedure Check_Elaboration_Scenarios is + Iter : NE_Set.Iterator; + begin -- Nothing to do when switch -gnatH (legacy elaboration checking mode -- enabled) is in effect because the legacy ABE mechanism does not need @@ -2326,6 +3896,15 @@ package body Sem_Elab is return; end if; + -- Create all internal data structures + + Initialize_Body_Processor; + Initialize_Early_Call_Region_Processor; + Initialize_Elaborated_Units; + Initialize_Internal_Representation; + Initialize_Invocation_Graph; + Initialize_Scenario_Storage; + -- Restore the original elaboration model which was in effect when the -- scenarios were first recorded. The model may be specified by pragma -- Elaboration_Checks which appears on the initial declaration of the @@ -2336,2996 +3915,4910 @@ package body Sem_Elab is -- Examine the context of the main unit and record all units with prior -- elaboration with respect to it. - Find_Elaborated_Units; + Collect_Elaborated_Units; - -- Examine each top-level scenario saved during the Recording phase for - -- conditional ABEs and perform various actions depending on the model - -- in effect. The table of visited bodies is created for each new top- - -- level scenario. + -- Examine all scenarios saved during the Recording phase applying the + -- Ada or SPARK elaboration rules in order to detect and diagnose ABE + -- issues, install conditional ABE checks, and ensure the elaboration + -- of units. - for Index in Top_Level_Scenarios.First .. Top_Level_Scenarios.Last loop - Reset_Visited_Bodies; + Iter := Iterate_Declaration_Scenarios; + Check_Conditional_ABE_Scenarios (Iter); - Process_Conditional_ABE (Top_Level_Scenarios.Table (Index)); - end loop; + Iter := Iterate_Library_Body_Scenarios; + Check_Conditional_ABE_Scenarios (Iter); + + Iter := Iterate_Library_Spec_Scenarios; + Check_Conditional_ABE_Scenarios (Iter); -- Examine each SPARK scenario saved during the Recording phase which -- is not necessarily executable during elaboration, but still requires -- elaboration-related checks. - for Index in SPARK_Scenarios.First .. SPARK_Scenarios.Last loop - Check_SPARK_Scenario (SPARK_Scenarios.Table (Index)); - end loop; + Check_SPARK_Scenarios; + + -- Add conditional ABE checks for all scenarios that require one when + -- the dynamic model is in effect. + + Install_Dynamic_ABE_Checks; + + -- Examine all scenarios saved during the Recording phase along with + -- invocation constructs within the spec and body of the main unit. + -- Record the declarations and paths that reach into an external unit + -- in the ALI file of the main unit. + + Record_Invocation_Graph; + + -- Destroy all internal data structures + + Finalize_Body_Processor; + Finalize_Early_Call_Region_Processor; + Finalize_Elaborated_Units; + Finalize_Internal_Representation; + Finalize_Invocation_Graph; + Finalize_Scenario_Storage; end Check_Elaboration_Scenarios; - ------------------------------ - -- Check_Preelaborated_Call -- - ------------------------------ + --------------------- + -- Check_Installer -- + --------------------- - procedure Check_Preelaborated_Call (Call : Node_Id) is - function In_Preelaborated_Context (N : Node_Id) return Boolean; - -- Determine whether arbitrary node appears in a preelaborated context + package body Check_Installer is - ------------------------------ - -- In_Preelaborated_Context -- - ------------------------------ + ----------------------- + -- Local subprograms -- + ----------------------- - function In_Preelaborated_Context (N : Node_Id) return Boolean is - Body_Id : constant Entity_Id := Find_Code_Unit (N); - Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); + function ABE_Check_Or_Failure_OK + (N : Node_Id; + Targ_Id : Entity_Id; + Unit_Id : Entity_Id) return Boolean; + pragma Inline (ABE_Check_Or_Failure_OK); + -- Determine whether a conditional ABE check or guaranteed ABE failure + -- can be installed for scenario N with target Targ_Id which resides in + -- unit Unit_Id. + + function Insertion_Node (N : Node_Id) return Node_Id; + pragma Inline (Insertion_Node); + -- Obtain the proper insertion node of an ABE check or failure for + -- scenario N. + + procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id); + pragma Inline (Insert_ABE_Check_Or_Failure); + -- Insert conditional ABE check or guaranteed ABE failure Check prior to + -- scenario N. + + procedure Install_Scenario_ABE_Check_Common + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id); + pragma Inline (Install_Scenario_ABE_Check_Common); + -- Install a conditional ABE check for scenario N to ensure that target + -- Targ_Id is properly elaborated. Targ_Rep is the representation of the + -- target. + + procedure Install_Scenario_ABE_Failure_Common (N : Node_Id); + pragma Inline (Install_Scenario_ABE_Failure_Common); + -- Install a guaranteed ABE failure for scenario N + + procedure Install_Unit_ABE_Check_Common + (N : Node_Id; + Unit_Id : Entity_Id); + pragma Inline (Install_Unit_ABE_Check_Common); + -- Install a conditional ABE check for scenario N to ensure that unit + -- Unit_Id is properly elaborated. + + ----------------------------- + -- ABE_Check_Or_Failure_OK -- + ----------------------------- + + function ABE_Check_Or_Failure_OK + (N : Node_Id; + Targ_Id : Entity_Id; + Unit_Id : Entity_Id) return Boolean + is + pragma Unreferenced (Targ_Id); + + Ins_Node : constant Node_Id := Insertion_Node (N); begin - -- The node appears within a package body whose corresponding spec is - -- subject to pragma Remote_Call_Interface or Remote_Types. This does - -- not result in a preelaborated context because the package body may - -- be on another machine. + if not Check_Or_Failure_Generation_OK then + return False; - if Ekind (Body_Id) = E_Package_Body - and then Ekind_In (Spec_Id, E_Generic_Package, E_Package) - and then (Is_Remote_Call_Interface (Spec_Id) - or else Is_Remote_Types (Spec_Id)) + -- Nothing to do when the scenario denots a compilation unit because + -- there is no executable environment at that level. + + elsif Nkind (Parent (Ins_Node)) = N_Compilation_Unit then + return False; + + -- An ABE check or failure is not needed when the target is defined + -- in a unit which is elaborated prior to the main unit. This check + -- must also consider the following cases: + -- + -- * The unit of the target appears in the context of the main unit + -- + -- * The unit of the target is subject to pragma Elaborate_Body. An + -- ABE check MUST NOT be generated because the unit is always + -- elaborated prior to the main unit. + -- + -- * The unit of the target is the main unit. An ABE check MUST be + -- added in this case because a conditional ABE may be raised + -- depending on the flow of execution within the main unit (flag + -- Same_Unit_OK is False). + + elsif Has_Prior_Elaboration + (Unit_Id => Unit_Id, + Context_OK => True, + Elab_Body_OK => True) then return False; + end if; - -- Otherwise the node appears within a preelaborated context when the - -- associated unit is preelaborated. + return True; + end ABE_Check_Or_Failure_OK; - else - return Is_Preelaborated_Unit (Spec_Id); - end if; - end In_Preelaborated_Context; + ------------------------------------ + -- Check_Or_Failure_Generation_OK -- + ------------------------------------ - -- Local variables + function Check_Or_Failure_Generation_OK return Boolean is + begin + -- An ABE check or failure is not needed when the compilation will + -- not produce an executable. - Call_Attrs : Call_Attributes; - Level : Enclosing_Level_Kind; - Target_Id : Entity_Id; + if Serious_Errors_Detected > 0 then + return False; - -- Start of processing for Check_Preelaborated_Call + -- An ABE check or failure must not be installed when compiling for + -- GNATprove because raise statements are not supported. - begin - Extract_Call_Attributes - (Call => Call, - Target_Id => Target_Id, - Attrs => Call_Attrs); + elsif GNATprove_Mode then + return False; + end if; - -- Nothing to do when the call is internally generated because it is - -- assumed that it will never violate preelaboration. + return True; + end Check_Or_Failure_Generation_OK; - if not Call_Attrs.From_Source then - return; - end if; + -------------------- + -- Insertion_Node -- + -------------------- - -- Performance note: parent traversal + function Insertion_Node (N : Node_Id) return Node_Id is + begin + -- When the scenario denotes an instantiation, the proper insertion + -- node is the instance spec. This ensures that the generic actuals + -- will not be evaluated prior to a potential ABE. - Level := Find_Enclosing_Level (Call); + if Nkind (N) in N_Generic_Instantiation + and then Present (Instance_Spec (N)) + then + return Instance_Spec (N); - -- Library-level calls are always considered because they are part of - -- the associated unit's elaboration actions. + -- Otherwise the proper insertion node is the scenario itself - if Level in Library_Level then - null; + else + return N; + end if; + end Insertion_Node; - -- Calls at the library level of a generic package body must be checked - -- because they would render an instantiation illegal if the template is - -- marked as preelaborated. Note that this does not apply to calls at - -- the library level of a generic package spec. + --------------------------------- + -- Insert_ABE_Check_Or_Failure -- + --------------------------------- - elsif Level = Generic_Package_Body then - null; + procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id) is + Ins_Nod : constant Node_Id := Insertion_Node (N); + Scop_Id : constant Entity_Id := Find_Enclosing_Scope (Ins_Nod); - -- Otherwise the call does not appear at the proper level and must not - -- be considered for this check. + begin + -- Install the nearest enclosing scope of the scenario as there must + -- be something on the scope stack. - else - return; - end if; + Push_Scope (Scop_Id); - -- The call appears within a preelaborated unit. Emit a warning only for - -- internal uses, otherwise this is an error. + Insert_Action (Ins_Nod, Check); - if In_Preelaborated_Context (Call) then - Error_Msg_Warn := GNAT_Mode; - Error_Msg_N - ("<<non-static call not allowed in preelaborated unit", Call); - end if; - end Check_Preelaborated_Call; + Pop_Scope; + end Insert_ABE_Check_Or_Failure; - ------------------------------ - -- Check_SPARK_Derived_Type -- - ------------------------------ + -------------------------------- + -- Install_Dynamic_ABE_Checks -- + -------------------------------- - procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id) is - Typ : constant Entity_Id := Defining_Entity (Typ_Decl); + procedure Install_Dynamic_ABE_Checks is + Iter : NE_Set.Iterator; + N : Node_Id; - -- NOTE: The routines within Check_SPARK_Derived_Type are intentionally - -- unnested to avoid deep indentation of code. + begin + if not Check_Or_Failure_Generation_OK then + return; - Stop_Check : exception; - -- This exception is raised when the freeze node violates the placement - -- rules. + -- Nothing to do if the dynamic model is not in effect - procedure Check_Overriding_Primitive - (Prim : Entity_Id; - FNode : Node_Id); - pragma Inline (Check_Overriding_Primitive); - -- Verify that freeze node FNode is within the early call region of - -- overriding primitive Prim's body. + elsif not Dynamic_Elaboration_Checks then + return; + end if; - function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; - pragma Inline (Freeze_Node_Location); - -- Return a more accurate source location associated with freeze node - -- FNode. + -- Install a conditional ABE check for each saved scenario - function Precedes_Source_Construct (N : Node_Id) return Boolean; - pragma Inline (Precedes_Source_Construct); - -- Determine whether arbitrary node N appears prior to some source - -- construct. + Iter := Iterate_Dynamic_ABE_Check_Scenarios; + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - procedure Suggest_Elaborate_Body - (N : Node_Id; - Body_Decl : Node_Id; - Error_Nod : Node_Id); - pragma Inline (Suggest_Elaborate_Body); - -- Suggest the use of pragma Elaborate_Body when the pragma will allow - -- for node N to appear within the early call region of subprogram body - -- Body_Decl. The suggestion is attached to Error_Nod as a continuation - -- error. + Process_Conditional_ABE + (N => N, + In_State => Dynamic_Model_State); + end loop; + end Install_Dynamic_ABE_Checks; -------------------------------- - -- Check_Overriding_Primitive -- + -- Install_Scenario_ABE_Check -- -------------------------------- - procedure Check_Overriding_Primitive - (Prim : Entity_Id; - FNode : Node_Id) + procedure Install_Scenario_ABE_Check + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Scenario_Rep_Id) is - Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); - Body_Decl : Node_Id; - Body_Id : Entity_Id; - Region : Node_Id; - begin - -- Nothing to do for predefined primitives because they are artifacts - -- of tagged type expansion and cannot override source primitives. + -- Nothing to do when the scenario does not need an ABE check - if Is_Predefined_Dispatching_Operation (Prim) then + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Targ_Id, + Unit_Id => Unit (Targ_Rep)) + then return; end if; - Body_Id := Corresponding_Body (Prim_Decl); + -- Prevent multiple attempts to install the same ABE check - -- Nothing to do when the primitive does not have a corresponding - -- body. This can happen when the unit with the bodies is not the - -- main unit subjected to ABE checks. + Disable_Elaboration_Checks (Disable); - if No (Body_Id) then + Install_Scenario_ABE_Check_Common + (N => N, + Targ_Id => Targ_Id, + Targ_Rep => Targ_Rep); + end Install_Scenario_ABE_Check; + + -------------------------------- + -- Install_Scenario_ABE_Check -- + -------------------------------- + + procedure Install_Scenario_ABE_Check + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Target_Rep_Id) + is + begin + -- Nothing to do when the scenario does not need an ABE check + + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Targ_Id, + Unit_Id => Unit (Targ_Rep)) + then return; + end if; - -- The primitive overrides a parent or progenitor primitive + -- Prevent multiple attempts to install the same ABE check - elsif Present (Overridden_Operation (Prim)) then + Disable_Elaboration_Checks (Disable); - -- Nothing to do when overriding an interface primitive happens by - -- inheriting a non-interface primitive as the check would be done - -- on the parent primitive. + Install_Scenario_ABE_Check_Common + (N => N, + Targ_Id => Targ_Id, + Targ_Rep => Targ_Rep); + end Install_Scenario_ABE_Check; - if Present (Alias (Prim)) then + --------------------------------------- + -- Install_Scenario_ABE_Check_Common -- + --------------------------------------- + + procedure Install_Scenario_ABE_Check_Common + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id) + is + Targ_Body : constant Node_Id := Body_Declaration (Targ_Rep); + Targ_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); + + pragma Assert (Present (Targ_Body)); + pragma Assert (Present (Targ_Decl)); + + procedure Build_Elaboration_Entity; + pragma Inline (Build_Elaboration_Entity); + -- Create a new elaboration flag for Targ_Id, insert it prior to + -- Targ_Decl, and set it after Targ_Body. + + ------------------------------ + -- Build_Elaboration_Entity -- + ------------------------------ + + procedure Build_Elaboration_Entity is + Loc : constant Source_Ptr := Sloc (Targ_Id); + Flag_Id : Entity_Id; + + begin + -- Nothing to do if the target has an elaboration flag + + if Present (Elaboration_Entity (Targ_Id)) then return; end if; - -- Nothing to do when the primitive is not overriding. The body of - -- such a primitive cannot be targeted by a dispatching call which - -- is executable during elaboration, and cannot cause an ABE. + -- Create the declaration of the elaboration flag. The name + -- carries a unique counter in case the name is overloaded. - else - return; - end if; + Flag_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Targ_Id), 'E', -1)); - Body_Decl := Unit_Declaration_Node (Body_Id); - Region := Find_Early_Call_Region (Body_Decl); + Set_Elaboration_Entity (Targ_Id, Flag_Id); + Set_Elaboration_Entity_Required (Targ_Id); - -- The freeze node appears prior to the early call region of the - -- primitive body. + Push_Scope (Scope (Targ_Id)); - -- IMPORTANT: This check must always be performed even when -gnatd.v - -- (enforce SPARK elaboration rules in SPARK code) is not specified - -- because the static model cannot guarantee the absence of ABEs in - -- in the presence of dispatching calls. + -- Generate: + -- Enn : Short_Integer := 0; - if Earlier_In_Extended_Unit (FNode, Region) then - Error_Msg_Node_2 := Prim; - Error_Msg_NE - ("first freezing point of type & must appear within early call " - & "region of primitive body & (SPARK RM 7.7(8))", - Typ_Decl, Typ); + Insert_Action (Targ_Decl, + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Occurrence_Of (Standard_Short_Integer, Loc), + Expression => Make_Integer_Literal (Loc, Uint_0))); - Error_Msg_Sloc := Sloc (Region); - Error_Msg_N ("\region starts #", Typ_Decl); + -- Generate: + -- Enn := 1; - Error_Msg_Sloc := Sloc (Body_Decl); - Error_Msg_N ("\region ends #", Typ_Decl); + Set_Elaboration_Flag (Targ_Body, Targ_Id); + + Pop_Scope; + end Build_Elaboration_Entity; - Error_Msg_Sloc := Freeze_Node_Location (FNode); - Error_Msg_N ("\first freezing point #", Typ_Decl); + -- Local variables - -- If applicable, suggest the use of pragma Elaborate_Body in the - -- associated package spec. + Loc : constant Source_Ptr := Sloc (N); - Suggest_Elaborate_Body - (N => FNode, - Body_Decl => Body_Decl, - Error_Nod => Typ_Decl); + -- Start for processing for Install_Scenario_ABE_Check_Common - raise Stop_Check; - end if; - end Check_Overriding_Primitive; + begin + -- Create an elaboration flag for the target when it does not have + -- one. - -------------------------- - -- Freeze_Node_Location -- - -------------------------- + Build_Elaboration_Entity; - function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is - Context : constant Node_Id := Parent (FNode); - Loc : constant Source_Ptr := Sloc (FNode); + -- Generate: + -- if not Targ_Id'Elaborated then + -- raise Program_Error with "access before elaboration"; + -- end if; + + Insert_ABE_Check_Or_Failure + (N => N, + Check => + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Targ_Id, Loc), + Attribute_Name => Name_Elaborated)), + Reason => PE_Access_Before_Elaboration)); + end Install_Scenario_ABE_Check_Common; - Prv_Decls : List_Id; - Vis_Decls : List_Id; + ---------------------------------- + -- Install_Scenario_ABE_Failure -- + ---------------------------------- + procedure Install_Scenario_ABE_Failure + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Scenario_Rep_Id) + is begin - -- In general, the source location of the freeze node is as close as - -- possible to the real freeze point, except when the freeze node is - -- at the "bottom" of a package spec. + -- Nothing to do when the scenario does not require an ABE failure - if Nkind (Context) = N_Package_Specification then - Prv_Decls := Private_Declarations (Context); - Vis_Decls := Visible_Declarations (Context); + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Targ_Id, + Unit_Id => Unit (Targ_Rep)) + then + return; + end if; - -- The freeze node appears in the private declarations of the - -- package. + -- Prevent multiple attempts to install the same ABE check - if Present (Prv_Decls) - and then List_Containing (FNode) = Prv_Decls - then - null; + Disable_Elaboration_Checks (Disable); - -- The freeze node appears in the visible declarations of the - -- package and there are no private declarations. + Install_Scenario_ABE_Failure_Common (N); + end Install_Scenario_ABE_Failure; - elsif Present (Vis_Decls) - and then List_Containing (FNode) = Vis_Decls - and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) - then - null; + ---------------------------------- + -- Install_Scenario_ABE_Failure -- + ---------------------------------- - -- Otherwise the freeze node is not in the "last" declarative list - -- of the package. Use the existing source location of the freeze - -- node. + procedure Install_Scenario_ABE_Failure + (N : Node_Id; + Targ_Id : Entity_Id; + Targ_Rep : Target_Rep_Id; + Disable : Target_Rep_Id) + is + begin + -- Nothing to do when the scenario does not require an ABE failure - else - return Loc; - end if; + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Targ_Id, + Unit_Id => Unit (Targ_Rep)) + then + return; + end if; - -- The freeze node appears at the "bottom" of the package when it - -- is in the "last" declarative list and is either the last in the - -- list or is followed by internal constructs only. In that case - -- the more appropriate source location is that of the package end - -- label. + -- Prevent multiple attempts to install the same ABE check - if not Precedes_Source_Construct (FNode) then - return Sloc (End_Label (Context)); - end if; - end if; + Disable_Elaboration_Checks (Disable); - return Loc; - end Freeze_Node_Location; + Install_Scenario_ABE_Failure_Common (N); + end Install_Scenario_ABE_Failure; - ------------------------------- - -- Precedes_Source_Construct -- - ------------------------------- + ----------------------------------------- + -- Install_Scenario_ABE_Failure_Common -- + ----------------------------------------- - function Precedes_Source_Construct (N : Node_Id) return Boolean is - Decl : Node_Id; + procedure Install_Scenario_ABE_Failure_Common (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); begin - Decl := Next (N); - while Present (Decl) loop - if Comes_From_Source (Decl) then - return True; + -- Generate: + -- raise Program_Error with "access before elaboration"; - -- A generated body for a source expression function is treated as - -- a source construct. + Insert_ABE_Check_Or_Failure + (N => N, + Check => + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration)); + end Install_Scenario_ABE_Failure_Common; - elsif Nkind (Decl) = N_Subprogram_Body - and then Was_Expression_Function (Decl) - and then Comes_From_Source (Original_Node (Decl)) - then - return True; - end if; + ---------------------------- + -- Install_Unit_ABE_Check -- + ---------------------------- - Next (Decl); - end loop; + procedure Install_Unit_ABE_Check + (N : Node_Id; + Unit_Id : Entity_Id; + Disable : Scenario_Rep_Id) + is + Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); - return False; - end Precedes_Source_Construct; + begin + -- Nothing to do when the scenario does not require an ABE check + + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Empty, + Unit_Id => Spec_Id) + then + return; + end if; + + -- Prevent multiple attempts to install the same ABE check + + Disable_Elaboration_Checks (Disable); + + Install_Unit_ABE_Check_Common + (N => N, + Unit_Id => Unit_Id); + end Install_Unit_ABE_Check; ---------------------------- - -- Suggest_Elaborate_Body -- + -- Install_Unit_ABE_Check -- ---------------------------- - procedure Suggest_Elaborate_Body - (N : Node_Id; - Body_Decl : Node_Id; - Error_Nod : Node_Id) + procedure Install_Unit_ABE_Check + (N : Node_Id; + Unit_Id : Entity_Id; + Disable : Target_Rep_Id) is - Unt : constant Node_Id := Unit (Cunit (Main_Unit)); - Region : Node_Id; + Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); begin - -- The suggestion applies only when the subprogram body resides in a - -- compilation package body, and a pragma Elaborate_Body would allow - -- for the node to appear in the early call region of the subprogram - -- body. This implies that all code from the subprogram body up to - -- the node is preelaborable. + -- Nothing to do when the scenario does not require an ABE check - if Nkind (Unt) = N_Package_Body then + if not ABE_Check_Or_Failure_OK + (N => N, + Targ_Id => Empty, + Unit_Id => Spec_Id) + then + return; + end if; - -- Find the start of the early call region again assuming that the - -- package spec has pragma Elaborate_Body. Note that the internal - -- data structures are intentionally not updated because this is a - -- speculative search. + -- Prevent multiple attempts to install the same ABE check - Region := - Find_Early_Call_Region - (Body_Decl => Body_Decl, - Assume_Elab_Body => True, - Skip_Memoization => True); + Disable_Elaboration_Checks (Disable); - -- If the node appears within the early call region, assuming that - -- the package spec carries pragma Elaborate_Body, then it is safe - -- to suggest the pragma. + Install_Unit_ABE_Check_Common + (N => N, + Unit_Id => Unit_Id); + end Install_Unit_ABE_Check; - if Earlier_In_Extended_Unit (Region, N) then - Error_Msg_Name_1 := Name_Elaborate_Body; - Error_Msg_NE - ("\consider adding pragma % in spec of unit &", - Error_Nod, Defining_Entity (Unt)); - end if; - end if; - end Suggest_Elaborate_Body; + ----------------------------------- + -- Install_Unit_ABE_Check_Common -- + ----------------------------------- - -- Local variables + procedure Install_Unit_ABE_Check_Common + (N : Node_Id; + Unit_Id : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); - FNode : constant Node_Id := Freeze_Node (Typ); - Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); + begin + -- Generate: + -- if not Spec_Id'Elaborated then + -- raise Program_Error with "access before elaboration"; + -- end if; + + Insert_ABE_Check_Or_Failure + (N => N, + Check => + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Spec_Id, Loc), + Attribute_Name => Name_Elaborated)), + Reason => PE_Access_Before_Elaboration)); + end Install_Unit_ABE_Check_Common; + end Check_Installer; - Prim_Elmt : Elmt_Id; + ---------------------- + -- Compilation_Unit -- + ---------------------- - -- Start of processing for Check_SPARK_Derived_Type + function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is + Comp_Unit : Node_Id; begin - -- A type should have its freeze node set by the time SPARK scenarios - -- are being verified. + Comp_Unit := Parent (Unit_Id); - pragma Assert (Present (FNode)); + -- Handle the case where a concurrent subunit is rewritten as a null + -- statement due to expansion activities. - -- Verify that the freeze node of the derived type is within the early - -- call region of each overriding primitive body (SPARK RM 7.7(8)). + if Nkind (Comp_Unit) = N_Null_Statement + and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body, + N_Task_Body) + then + Comp_Unit := Parent (Comp_Unit); + pragma Assert (Nkind (Comp_Unit) = N_Subunit); - if Present (Prims) then - Prim_Elmt := First_Elmt (Prims); - while Present (Prim_Elmt) loop - Check_Overriding_Primitive - (Prim => Node (Prim_Elmt), - FNode => FNode); + -- Otherwise use the declaration node of the unit - Next_Elmt (Prim_Elmt); - end loop; + else + Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); end if; - exception - when Stop_Check => - null; - end Check_SPARK_Derived_Type; + -- Handle the case where a subprogram instantiation which acts as a + -- compilation unit is expanded into an anonymous package that wraps + -- the instantiated subprogram. + + if Nkind (Comp_Unit) = N_Package_Specification + and then Nkind_In (Original_Node (Parent (Comp_Unit)), + N_Function_Instantiation, + N_Procedure_Instantiation) + then + Comp_Unit := Parent (Parent (Comp_Unit)); + + -- Handle the case where the compilation unit is a subunit + + elsif Nkind (Comp_Unit) = N_Subunit then + Comp_Unit := Parent (Comp_Unit); + end if; + + pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); + + return Comp_Unit; + end Compilation_Unit; ------------------------------- - -- Check_SPARK_Instantiation -- + -- Conditional_ABE_Processor -- ------------------------------- - procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id) is - Gen_Attrs : Target_Attributes; - Gen_Id : Entity_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; + package body Conditional_ABE_Processor is - begin - Extract_Instantiation_Attributes - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + ----------------------- + -- Local subprograms -- + ----------------------- - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Conditional_ABE_Scenario); + -- Determine whether node N is a suitable scenario for conditional ABE + -- checks and diagnostics. + + procedure Process_Conditional_ABE_Access_Taken + (Attr : Node_Id; + Attr_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Access_Taken); + -- Perform ABE checks and diagnostics for attribute reference Attr with + -- representation Attr_Rep which takes 'Access of an entry, operator, or + -- subprogram. In_State is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Activation); + -- Perform common conditional ABE checks and diagnostics for activation + -- call Call which activates object Obj_Id of task type Task_Typ. Formal + -- Call_Rep denotes the representation of the call. Obj_Rep denotes the + -- representation of the object. Task_Rep denotes the representation of + -- the task type. In_State is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Call); + -- Top-level dispatcher for processing of calls. Perform ABE checks and + -- diagnostics for call Call with representation Call_Rep. In_State is + -- the current state of the Processing phase. + + procedure Process_Conditional_ABE_Call_Ada + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Call_Ada); + -- Perform ABE checks and diagnostics for call Call which invokes entry, + -- operator, or subprogram Subp_Id using the Ada rules. Call_Rep denotes + -- the representation of the call. Subp_Rep denotes the representation + -- of the subprogram. In_State is the current state of the Processing + -- phase. + + procedure Process_Conditional_ABE_Call_SPARK + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Call_SPARK); + -- Perform ABE checks and diagnostics for call Call which invokes entry, + -- operator, or subprogram Subp_Id using the SPARK rules. Call_Rep is + -- the representation of the call. Subp_Rep denotes the representation + -- of the subprogram. In_State is the current state of the Processing + -- phase. + + procedure Process_Conditional_ABE_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Instantiation); + -- Top-level dispatcher for processing of instantiations. Perform ABE + -- checks and diagnostics for instantiation Inst with representation + -- Inst_Rep. In_State is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Instantiation_Ada + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Instantiation_Ada); + -- Perform ABE checks and diagnostics for instantiation Inst of generic + -- Gen_Id using the Ada rules. Inst_Rep denotes the representation of + -- the instnace. Gen_Rep is the representation of the generic. In_State + -- is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Instantiation_SPARK + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Instantiation_SPARK); + -- Perform ABE checks and diagnostics for instantiation Inst of generic + -- Gen_Id using the SPARK rules. Inst_Rep denotes the representation of + -- the instnace. Gen_Rep is the representation of the generic. In_State + -- is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Variable_Assignment + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Variable_Assignment); + -- Top-level dispatcher for processing of variable assignments. Perform + -- ABE checks and diagnostics for assignment Asmt with representation + -- Asmt_Rep. In_State denotes the current state of the Processing phase. + + procedure Process_Conditional_ABE_Variable_Assignment_Ada + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Var_Id : Entity_Id; + Var_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Variable_Assignment_Ada); + -- Perform ABE checks and diagnostics for assignment statement Asmt that + -- modifies the value of variable Var_Id using the Ada rules. Asmt_Rep + -- denotes the representation of the assignment. Var_Rep denotes the + -- representation of the variable. In_State is the current state of the + -- Processing phase. + + procedure Process_Conditional_ABE_Variable_Assignment_SPARK + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Var_Id : Entity_Id; + Var_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Variable_Assignment_SPARK); + -- Perform ABE checks and diagnostics for assignment statement Asmt that + -- modifies the value of variable Var_Id using the SPARK rules. Asmt_Rep + -- denotes the representation of the assignment. Var_Rep denotes the + -- representation of the variable. In_State is the current state of the + -- Processing phase. + + procedure Process_Conditional_ABE_Variable_Reference + (Ref : Node_Id; + Ref_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Conditional_ABE_Variable_Reference); + -- Perform ABE checks and diagnostics for variable reference Ref with + -- representation Ref_Rep. In_State denotes the current state of the + -- Processing phase. + + procedure Traverse_Conditional_ABE_Body + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Traverse_Conditional_ABE_Body); + -- Traverse subprogram body N looking for suitable scenarios that need + -- to be processed for conditional ABE checks and diagnostics. In_State + -- is the current state of the Processing phase. + + ------------------------------------- + -- Check_Conditional_ABE_Scenarios -- + ------------------------------------- + + procedure Check_Conditional_ABE_Scenarios + (Iter : in out NE_Set.Iterator) + is + N : Node_Id; - -- The instantiation and the generic body are both in the main unit + begin + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - if Present (Gen_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) + -- Reset the traversed status of all subprogram bodies because the + -- current conditional scenario acts as a new DFS traversal root. - -- If the instantiation appears prior to the generic body, then the - -- instantiation is illegal (SPARK RM 7.7(6)). + Reset_Traversed_Bodies; - -- IMPORTANT: This check must always be performed even when -gnatd.v - -- (enforce SPARK elaboration rules in SPARK code) is not specified - -- because the rule prevents use-before-declaration of objects that - -- may precede the generic body. + Process_Conditional_ABE + (N => N, + In_State => Conditional_ABE_State); + end loop; + end Check_Conditional_ABE_Scenarios; - and then Earlier_In_Extended_Unit (Inst, Gen_Attrs.Body_Decl) - then - Error_Msg_NE ("cannot instantiate & before body seen", Inst, Gen_Id); - end if; - end Check_SPARK_Instantiation; + --------------------------------- + -- Is_Conditional_ABE_Scenario -- + --------------------------------- - --------------------------------- - -- Check_SPARK_Model_In_Effect -- - --------------------------------- + function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean is + begin + return + Is_Suitable_Access_Taken (N) + or else Is_Suitable_Call (N) + or else Is_Suitable_Instantiation (N) + or else Is_Suitable_Variable_Assignment (N) + or else Is_Suitable_Variable_Reference (N); + end Is_Conditional_ABE_Scenario; - SPARK_Model_Warning_Posted : Boolean := False; - -- This flag prevents the same SPARK model-related warning from being - -- emitted multiple times. + ----------------------------- + -- Process_Conditional_ABE -- + ----------------------------- - procedure Check_SPARK_Model_In_Effect (N : Node_Id) is - begin - -- Do not emit the warning multiple times as this creates useless noise + procedure Process_Conditional_ABE + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); + Scen_Rep : Scenario_Rep_Id; - if SPARK_Model_Warning_Posted then - null; + begin + -- Add the current scenario to the stack of active scenarios - -- SPARK rule verification requires the "strict" static model + Push_Active_Scenario (Scen); - elsif Static_Elaboration_Checks and not Relaxed_Elaboration_Checks then - null; + -- 'Access - -- Any other combination of models does not guarantee the absence of ABE - -- problems for SPARK rule verification purposes. Note that there is no - -- need to check for the legacy ABE mechanism because the legacy code - -- has its own orthogonal processing for SPARK rules. + if Is_Suitable_Access_Taken (Scen) then + Process_Conditional_ABE_Access_Taken + (Attr => Scen, + Attr_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - else - SPARK_Model_Warning_Posted := True; + -- Call or task activation - Error_Msg_N - ("??SPARK elaboration checks require static elaboration model", N); + elsif Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - if Dynamic_Elaboration_Checks then - Error_Msg_N ("\dynamic elaboration model is in effect", N); - else - pragma Assert (Relaxed_Elaboration_Checks); - Error_Msg_N ("\relaxed elaboration model is in effect", N); - end if; - end if; - end Check_SPARK_Model_In_Effect; + -- Routine Build_Call_Marker creates call markers regardless of + -- whether the call occurs within the main unit or not. This way + -- the serialization of internal names is kept consistent. Only + -- call markers found within the main unit must be processed. - -------------------------- - -- Check_SPARK_Scenario -- - -------------------------- + if In_Main_Context (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - procedure Check_SPARK_Scenario (N : Node_Id) is - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + if Kind (Scen_Rep) = Call_Scenario then + Process_Conditional_ABE_Call + (Call => Scen, + Call_Rep => Scen_Rep, + In_State => In_State); - Check_SPARK_Model_In_Effect (N); + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); - -- Add the current scenario to the stack of active scenarios + Process_Activation + (Call => Scen, + Call_Rep => Scen_Rep, + Processor => Process_Conditional_ABE_Activation'Access, + In_State => In_State); + end if; + end if; - Push_Active_Scenario (N); + -- Instantiation - if Is_Suitable_SPARK_Derived_Type (N) then - Check_SPARK_Derived_Type (N); + elsif Is_Suitable_Instantiation (Scen) then + Process_Conditional_ABE_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - elsif Is_Suitable_SPARK_Instantiation (N) then - Check_SPARK_Instantiation (N); + -- Variable assignments - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Check_SPARK_Refined_State_Pragma (N); - end if; + elsif Is_Suitable_Variable_Assignment (Scen) then + Process_Conditional_ABE_Variable_Assignment + (Asmt => Scen, + Asmt_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - -- Remove the current scenario from the stack of active scenarios once - -- all ABE diagnostics and checks have been performed. + -- Variable references - Pop_Active_Scenario (N); - end Check_SPARK_Scenario; + elsif Is_Suitable_Variable_Reference (Scen) then - -------------------------------------- - -- Check_SPARK_Refined_State_Pragma -- - -------------------------------------- + -- Routine Build_Variable_Reference_Marker makes variable markers + -- regardless of whether the reference occurs within the main unit + -- or not. This way the serialization of internal names is kept + -- consistent. Only variable markers within the main unit must be + -- processed. - procedure Check_SPARK_Refined_State_Pragma (N : Node_Id) is + if In_Main_Context (Scen) then + Process_Conditional_ABE_Variable_Reference + (Ref => Scen, + Ref_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); + end if; + end if; - -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are - -- intentionally unnested to avoid deep indentation of code. + -- Remove the current scenario from the stack of active scenarios + -- once all ABE diagnostics and checks have been performed. - procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); - pragma Inline (Check_SPARK_Constituent); - -- Ensure that a single constituent Constit_Id is elaborated prior to - -- the main unit. + Pop_Active_Scenario (Scen); + end Process_Conditional_ABE; - procedure Check_SPARK_Constituents (Constits : Elist_Id); - pragma Inline (Check_SPARK_Constituents); - -- Ensure that all constituents found in list Constits are elaborated - -- prior to the main unit. + ------------------------------------------ + -- Process_Conditional_ABE_Access_Taken -- + ------------------------------------------ - procedure Check_SPARK_Initialized_State (State : Node_Id); - pragma Inline (Check_SPARK_Initialized_State); - -- Ensure that the constituents of single abstract state State are - -- elaborated prior to the main unit. + procedure Process_Conditional_ABE_Access_Taken + (Attr : Node_Id; + Attr_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id; + pragma Inline (Build_Access_Marker); + -- Create a suitable call marker which invokes subprogram Subp_Id - procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); - pragma Inline (Check_SPARK_Initialized_States); - -- Ensure that the constituents of all abstract states which appear in - -- the Initializes pragma of package Pack_Id are elaborated prior to the - -- main unit. + ------------------------- + -- Build_Access_Marker -- + ------------------------- - ----------------------------- - -- Check_SPARK_Constituent -- - ----------------------------- + function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id is + Marker : Node_Id; - procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is - Prag : Node_Id; + begin + Marker := Make_Call_Marker (Sloc (Attr)); - begin - -- Nothing to do for "null" constituents + -- Inherit relevant attributes from the attribute - if Nkind (Constit_Id) = N_Null then - return; + Set_Target (Marker, Subp_Id); + Set_Is_Declaration_Level_Node + (Marker, Level (Attr_Rep) = Declaration_Level); + Set_Is_Dispatching_Call + (Marker, False); + Set_Is_Elaboration_Checks_OK_Node + (Marker, Elaboration_Checks_OK (Attr_Rep)); + Set_Is_Elaboration_Warnings_OK_Node + (Marker, Elaboration_Warnings_OK (Attr_Rep)); + Set_Is_Source_Call + (Marker, Comes_From_Source (Attr)); + Set_Is_SPARK_Mode_On_Node + (Marker, SPARK_Mode_Of (Attr_Rep) = Is_On); - -- Nothing to do for illegal constituents + -- Partially insert the call marker into the tree by setting its + -- parent pointer. - elsif Error_Posted (Constit_Id) then - return; - end if; + Set_Parent (Marker, Attr); + + return Marker; + end Build_Access_Marker; + + -- Local variables + + Root : constant Node_Id := Root_Scenario; + Subp_Id : constant Entity_Id := Target (Attr_Rep); + Subp_Rep : constant Target_Rep_Id := + Target_Representation_Of (Subp_Id, In_State); + Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state - Prag := SPARK_Pragma (Constit_Id); + -- Start of processing for Process_Conditional_ABE_Access - -- The check applies only when the constituent is subject to pragma - -- SPARK_Mode On. + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - if Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On + if Elab_Info_Messages + and then not New_In_State.Suppress_Info_Messages then - -- An external constituent of an abstract state which appears in - -- the Initializes pragma of a package spec imposes an Elaborate - -- requirement on the context of the main unit. Determine whether - -- the context has a pragma strong enough to meet the requirement. + Error_Msg_NE + ("info: access to & during elaboration", Attr, Subp_Id); + end if; - -- IMPORTANT: This check is performed only when -gnatd.v (enforce - -- SPARK elaboration rules in SPARK code) is in effect because the - -- static model can ensure the prior elaboration of the unit which - -- contains a constituent by installing implicit Elaborate pragma. + -- Warnings are suppressed when a prior scenario is already in that + -- mode or when the attribute or the target have warnings suppressed. + -- Update the state of the Processing phase to reflect this. - if Debug_Flag_Dot_V then - Meet_Elaboration_Requirement - (N => N, - Target_Id => Constit_Id, - Req_Nam => Name_Elaborate); + New_In_State.Suppress_Warnings := + New_In_State.Suppress_Warnings + or else not Elaboration_Warnings_OK (Attr_Rep) + or else not Elaboration_Warnings_OK (Subp_Rep); - -- Otherwise ensure that the unit with the external constituent is - -- elaborated prior to the main unit. + -- Do not emit any ABE diagnostics when the current or previous + -- scenario in this traversal has suppressed elaboration warnings. - else - Ensure_Prior_Elaboration - (N => N, - Unit_Id => Find_Top_Unit (Constit_Id), - Prag_Nam => Name_Elaborate, - State => Initial_State); - end if; + if New_In_State.Suppress_Warnings then + null; + + -- Both the attribute and the corresponding subprogram body are in + -- the same unit. The body must appear prior to the root scenario + -- which started the recursive search. If this is not the case, then + -- there is a potential ABE if the access value is used to call the + -- subprogram. Emit a warning only when switch -gnatw.f (warnings on + -- suspucious 'Access) is in effect. + + elsif Warn_On_Elab_Access + and then Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + and then Earlier_In_Extended_Unit (Root, Body_Decl) + then + Error_Msg_Name_1 := Attribute_Name (Attr); + Error_Msg_NE + ("??% attribute of & before body seen", Attr, Subp_Id); + Error_Msg_N ("\possible Program_Error on later references", Attr); + + Output_Active_Scenarios (Attr, New_In_State); end if; - end Check_SPARK_Constituent; - ------------------------------ - -- Check_SPARK_Constituents -- - ------------------------------ + -- Treat the attribute an an immediate invocation of the target when + -- switch -gnatd.o (conservative elaboration order for indirect + -- calls) is in effect. This has the following desirable effects: + -- + -- * Ensure that the unit with the corresponding body is elaborated + -- prior to the main unit. + -- + -- * Perform conditional ABE checks and diagnostics + -- + -- * Traverse the body of the target (if available) - procedure Check_SPARK_Constituents (Constits : Elist_Id) is - Constit_Elmt : Elmt_Id; + if Debug_Flag_Dot_O then + Process_Conditional_ABE + (N => Build_Access_Marker (Subp_Id), + In_State => New_In_State); - begin - if Present (Constits) then - Constit_Elmt := First_Elmt (Constits); - while Present (Constit_Elmt) loop - Check_SPARK_Constituent (Node (Constit_Elmt)); - Next_Elmt (Constit_Elmt); - end loop; + -- Otherwise ensure that the unit with the corresponding body is + -- elaborated prior to the main unit. + + else + Ensure_Prior_Elaboration + (N => Attr, + Unit_Id => Unit (Subp_Rep), + Prag_Nam => Name_Elaborate_All, + In_State => New_In_State); end if; - end Check_SPARK_Constituents; + end Process_Conditional_ABE_Access_Taken; - ----------------------------------- - -- Check_SPARK_Initialized_State -- - ----------------------------------- + ---------------------------------------- + -- Process_Conditional_ABE_Activation -- + ---------------------------------------- - procedure Check_SPARK_Initialized_State (State : Node_Id) is - Prag : Node_Id; - State_Id : Entity_Id; + procedure Process_Conditional_ABE_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Task_Typ); + + Body_Decl : constant Node_Id := Body_Declaration (Task_Rep); + Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); + Root : constant Node_Id := Root_Scenario; + Unit_Id : constant Node_Id := Unit (Task_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Obj_Rep) + and then Elaboration_Checks_OK (Task_Rep); + -- A run-time ABE check may be installed only when the object and the + -- task type have active elaboration checks, and both are not ignored + -- Ghost constructs. + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state begin - -- Nothing to do for "null" initialization items + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - if Nkind (State) = N_Null then - return; + if Elab_Info_Messages + and then not New_In_State.Suppress_Info_Messages + then + Error_Msg_NE + ("info: activation of & during elaboration", Call, Obj_Id); + end if; - -- Nothing to do for illegal states + -- Nothing to do when the call activates a task whose type is defined + -- within an instance and switch -gnatd_i (ignore activations and + -- calls to instances for elaboration) is in effect. - elsif Error_Posted (State) then + if Debug_Flag_Underscore_I + and then In_External_Instance + (N => Call, + Target_Decl => Spec_Decl) + then return; - end if; - - State_Id := Entity_Of (State); - -- Sanitize the state + -- Nothing to do when the activation is a guaranteed ABE - if No (State_Id) then + elsif Is_Known_Guaranteed_ABE (Call) then return; - elsif Error_Posted (State_Id) then + -- Nothing to do when the root scenario appears at the declaration + -- level and the task is in the same unit, but outside this context. + -- + -- task type Task_Typ; -- task declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- T : Task_Typ; + -- begin + -- <activation call> -- activation site + -- end; + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- task body Task_Typ is + -- ... + -- end Task_Typ; + -- + -- In the example above, the context of X is the declarative list of + -- Proc. The "elaboration" of X may reach the activation of T whose + -- body is defined outside of X's context. The task body is relevant + -- only when Proc is invoked, but this happens only during "normal" + -- elaboration, therefore the task body must not be considered if + -- this is not the case. + + elsif Is_Up_Level_Target + (Targ_Decl => Spec_Decl, + In_State => New_In_State) + then return; - elsif Ekind (State_Id) /= E_Abstract_State then - return; - end if; + -- Nothing to do when the activation is ABE-safe + -- + -- generic + -- package Gen is + -- task type Task_Typ; + -- end Gen; + -- + -- package body Gen is + -- task body Task_Typ is + -- begin + -- ... + -- end Task_Typ; + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- package Nested is + -- package Inst is new Gen; + -- T : Inst.Task_Typ; + -- <activation call> -- safe activation + -- end Nested; + -- ... + + elsif Is_Safe_Activation (Call, Task_Rep) then - -- The check is performed only when the abstract state is subject to - -- SPARK_Mode On. + -- Note that the task body must still be examined for any nested + -- scenarios. - Prag := SPARK_Pragma (State_Id); + null; - if Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On + -- The activation call and the task body are both in the main unit + -- + -- If the root scenario appears prior to the task body, then this is + -- a possible ABE with respect to the root scenario. + -- + -- task type Task_Typ; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Pack is + -- T : Task_Typ; + -- end Pack; -- activation of T + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- + -- task body Task_Typ is -- task body + -- ... + -- end Task_Typ; + -- + -- Y : ... := A; -- root scenario + -- + -- IMPORTANT: The activation of T is a possible ABE for X, but + -- not for Y. Intalling an unconditional ABE raise prior to the + -- activation call would be wrong as it will fail for Y as well + -- but in Y's case the activation of T is never an ABE. + + elsif Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) then - Check_SPARK_Constituents (Refinement_Constituents (State_Id)); - end if; - end Check_SPARK_Initialized_State; + if Earlier_In_Extended_Unit (Root, Body_Decl) then - ------------------------------------ - -- Check_SPARK_Initialized_States -- - ------------------------------------ + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is - Prag : constant Node_Id := Get_Pragma (Pack_Id, Pragma_Initializes); - Init : Node_Id; - Inits : Node_Id; + if New_In_State.Suppress_Warnings then + null; - begin - if Present (Prag) then - Inits := Expression (Get_Argument (Prag, Pack_Id)); + -- Do not emit any ABE diagnostics when the activation occurs + -- in a partial finalization context because this action leads + -- to confusing noise. - -- Avoid processing a "null" initialization list. The only other - -- alternative is an aggregate. + elsif New_In_State.Within_Partial_Finalization then + null; - if Nkind (Inits) = N_Aggregate then + -- Otherwise emit the ABE disgnostic - -- The initialization items appear in list form: - -- - -- (state1, state2) - - if Present (Expressions (Inits)) then - Init := First (Expressions (Inits)); - while Present (Init) loop - Check_SPARK_Initialized_State (Init); - Next (Init); - end loop; + else + Error_Msg_Sloc := Sloc (Call); + Error_Msg_N + ("??task & will be activated # before elaboration of its " + & "body", Obj_Id); + Error_Msg_N + ("\Program_Error may be raised at run time", Obj_Id); + + Output_Active_Scenarios (Obj_Id, New_In_State); end if; - -- The initialization items appear in associated form: - -- - -- (state1 => item1, - -- state2 => (item2, item3)) - - if Present (Component_Associations (Inits)) then - Init := First (Component_Associations (Inits)); - while Present (Init) loop - Check_SPARK_Initialized_State (Init); - Next (Init); - end loop; + -- Install a conditional run-time ABE check to verify that the + -- task body has been elaborated prior to the activation call. + + if Check_OK then + Install_Scenario_ABE_Check + (N => Call, + Targ_Id => Defining_Entity (Spec_Decl), + Targ_Rep => Task_Rep, + Disable => Obj_Rep); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragma must be generated from + -- this point on. + -- + -- task type Task_Typ; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Pack is + -- <ABE check> + -- T : Task_Typ; + -- end Pack; -- activation of T + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- task body Task_Typ is + -- begin + -- External.Subp; -- imparts Elaborate_All + -- end Task_Typ; + -- + -- If Some_Condition is True, then the ABE check will fail + -- at runtime and the call to External.Subp will never take + -- place, rendering the implicit Elaborate_All useless. + -- + -- If the value of Some_Condition is False, then the call + -- to External.Subp will never take place, rendering the + -- implicit Elaborate_All useless. + + New_In_State.Suppress_Implicit_Pragmas := True; end if; end if; + + -- Otherwise the task body is not available in this compilation or + -- it resides in an external unit. Install a run-time ABE check to + -- verify that the task body has been elaborated prior to the + -- activation call when the dynamic model is in effect. + + elsif Check_OK + and then New_In_State.Processing = Dynamic_Model_Processing + then + Install_Unit_ABE_Check + (N => Call, + Unit_Id => Unit_Id, + Disable => Obj_Rep); end if; - end Check_SPARK_Initialized_States; - -- Local variables + -- Both the activation call and task type are subject to SPARK_Mode + -- On, this triggers the SPARK rules for task activation. Compared + -- to calls and instantiations, task activation in SPARK does not + -- require the presence of Elaborate[_All] pragmas in case the task + -- type is defined outside the main unit. This is because SPARK uses + -- a special policy which activates all tasks after the main unit has + -- finished its elaboration. - Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (N); + if SPARK_Mode_Of (Call_Rep) = Is_On + and then SPARK_Mode_Of (Task_Rep) = Is_On + then + null; - -- Start of processing for Check_SPARK_Refined_State_Pragma + -- Otherwise the Ada rules are in effect. Ensure that the unit with + -- the task body is elaborated prior to the main unit. - begin - -- Pragma Refined_State must be associated with a package body + else + Ensure_Prior_Elaboration + (N => Call, + Unit_Id => Unit_Id, + Prag_Nam => Name_Elaborate_All, + In_State => New_In_State); + end if; - pragma Assert - (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); + Traverse_Conditional_ABE_Body + (N => Body_Decl, + In_State => New_In_State); + end Process_Conditional_ABE_Activation; - -- Verify that each external contitunent of an abstract state mentioned - -- in pragma Initializes is properly elaborated. + ---------------------------------- + -- Process_Conditional_ABE_Call -- + ---------------------------------- - Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); - end Check_SPARK_Refined_State_Pragma; + procedure Process_Conditional_ABE_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + function In_Initialization_Context (N : Node_Id) return Boolean; + pragma Inline (In_Initialization_Context); + -- Determine whether arbitrary node N appears within a type init + -- proc, primitive [Deep_]Initialize, or a block created for + -- initialization purposes. + + function Is_Partial_Finalization_Proc + (Subp_Id : Entity_Id) return Boolean; + pragma Inline (Is_Partial_Finalization_Proc); + -- Determine whether subprogram Subp_Id is a partial finalization + -- procedure. - ---------------------- - -- Compilation_Unit -- - ---------------------- + ------------------------------- + -- In_Initialization_Context -- + ------------------------------- - function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is - Comp_Unit : Node_Id; + function In_Initialization_Context (N : Node_Id) return Boolean is + Par : Node_Id; + Spec_Id : Entity_Id; - begin - Comp_Unit := Parent (Unit_Id); + begin + -- Climb the parent chain looking for initialization actions - -- Handle the case where a concurrent subunit is rewritten as a null - -- statement due to expansion activities. + Par := Parent (N); + while Present (Par) loop - if Nkind (Comp_Unit) = N_Null_Statement - and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body, - N_Task_Body) - then - Comp_Unit := Parent (Comp_Unit); - pragma Assert (Nkind (Comp_Unit) = N_Subunit); + -- A block may be part of the initialization actions of a + -- default initialized object. - -- Otherwise use the declaration node of the unit + if Nkind (Par) = N_Block_Statement + and then Is_Initialization_Block (Par) + then + return True; - else - Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); - end if; + -- A subprogram body may denote an initialization routine - -- Handle the case where a subprogram instantiation which acts as a - -- compilation unit is expanded into an anonymous package that wraps - -- the instantiated subprogram. + elsif Nkind (Par) = N_Subprogram_Body then + Spec_Id := Unique_Defining_Entity (Par); - if Nkind (Comp_Unit) = N_Package_Specification - and then Nkind_In (Original_Node (Parent (Comp_Unit)), - N_Function_Instantiation, - N_Procedure_Instantiation) - then - Comp_Unit := Parent (Parent (Comp_Unit)); + -- The current subprogram body denotes a type init proc or + -- primitive [Deep_]Initialize. - -- Handle the case where the compilation unit is a subunit + if Is_Init_Proc (Spec_Id) + or else Is_Controlled_Proc (Spec_Id, Name_Initialize) + or else Is_TSS (Spec_Id, TSS_Deep_Initialize) + then + return True; + end if; - elsif Nkind (Comp_Unit) = N_Subunit then - Comp_Unit := Parent (Comp_Unit); - end if; + -- Prevent the search from going too far - pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; - return Comp_Unit; - end Compilation_Unit; + Par := Parent (Par); + end loop; - ----------------------- - -- Early_Call_Region -- - ----------------------- + return False; + end In_Initialization_Context; - function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is - begin - pragma Assert (Ekind_In (Body_Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure, - E_Subprogram_Body)); - - if Early_Call_Regions_In_Use then - return Early_Call_Regions.Get (Body_Id); - end if; + ---------------------------------- + -- Is_Partial_Finalization_Proc -- + ---------------------------------- - return Early_Call_Regions_No_Element; - end Early_Call_Region; + function Is_Partial_Finalization_Proc + (Subp_Id : Entity_Id) return Boolean + is + begin + -- To qualify, the subprogram must denote a finalizer procedure + -- or primitive [Deep_]Finalize, and the call must appear within + -- an initialization context. - ----------------------------- - -- Early_Call_Regions_Hash -- - ----------------------------- + return + (Is_Controlled_Proc (Subp_Id, Name_Finalize) + or else Is_Finalizer_Proc (Subp_Id) + or else Is_TSS (Subp_Id, TSS_Deep_Finalize)) + and then In_Initialization_Context (Call); + end Is_Partial_Finalization_Proc; - function Early_Call_Regions_Hash - (Key : Entity_Id) return Early_Call_Regions_Index - is - begin - return Early_Call_Regions_Index (Key mod Early_Call_Regions_Max); - end Early_Call_Regions_Hash; + -- Local variables - ----------------- - -- Elab_Msg_NE -- - ----------------- + Subp_Id : constant Entity_Id := Target (Call_Rep); + Subp_Rep : constant Target_Rep_Id := + Target_Representation_Of (Subp_Id, In_State); + Subp_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); - procedure Elab_Msg_NE - (Msg : String; - N : Node_Id; - Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean) - is - function Prefix return String; - -- Obtain the prefix of the message + SPARK_Rules_On : constant Boolean := + SPARK_Mode_Of (Call_Rep) = Is_On + and then SPARK_Mode_Of (Subp_Rep) = Is_On; - function Suffix return String; - -- Obtain the suffix of the message + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state - ------------ - -- Prefix -- - ------------ + -- Start of processing for Process_Conditional_ABE_Call - function Prefix return String is begin - if Info_Msg then - return "info: "; - else - return ""; + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. + + if Elab_Info_Messages + and then not New_In_State.Suppress_Info_Messages + then + Info_Call + (Call => Call, + Subp_Id => Subp_Id, + Info_Msg => True, + In_SPARK => SPARK_Rules_On); end if; - end Prefix; - ------------ - -- Suffix -- - ------------ + -- Check whether the invocation of an entry clashes with an existing + -- restriction. This check is relevant only when the processing was + -- started from some library-level scenario. - function Suffix return String is - begin - if In_SPARK then - return " in SPARK"; - else - return ""; + if Is_Protected_Entry (Subp_Id) then + Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); + + elsif Is_Task_Entry (Subp_Id) then + Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); + + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. + + return; end if; - end Suffix; - -- Start of processing for Elab_Msg_NE + -- Nothing to do when the call invokes a target defined within an + -- instance and switch -gnatd_i (ignore activations and calls to + -- instances for elaboration) is in effect. - begin - Error_Msg_NE (Prefix & Msg & Suffix, N, Id); - end Elab_Msg_NE; + if Debug_Flag_Underscore_I + and then In_External_Instance + (N => Call, + Target_Decl => Subp_Decl) + then + return; - ------------------------ - -- Elaboration_Status -- - ------------------------ + -- Nothing to do when the call is a guaranteed ABE - function Elaboration_Status - (Unit_Id : Entity_Id) return Elaboration_Attributes - is - begin - if Elaboration_Statuses_In_Use then - return Elaboration_Statuses.Get (Unit_Id); - end if; + elsif Is_Known_Guaranteed_ABE (Call) then + return; - return Elaboration_Statuses_No_Element; - end Elaboration_Status; + -- Nothing to do when the root scenario appears at the declaration + -- level and the target is in the same unit but outside this context. + -- + -- function B ...; -- target declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- function B ... is + -- ... + -- end B; + -- + -- In the example above, the context of X is the declarative region + -- of Proc. The "elaboration" of X may eventually reach B which is + -- defined outside of X's context. B is relevant only when Proc is + -- invoked, but this happens only by means of "normal" elaboration, + -- therefore B must not be considered if this is not the case. + + elsif Is_Up_Level_Target + (Targ_Decl => Subp_Decl, + In_State => New_In_State) + then + return; + end if; - ------------------------------- - -- Elaboration_Statuses_Hash -- - ------------------------------- + -- Warnings are suppressed when a prior scenario is already in that + -- mode, or the call or target have warnings suppressed. Update the + -- state of the Processing phase to reflect this. - function Elaboration_Statuses_Hash - (Key : Entity_Id) return Elaboration_Statuses_Index - is - begin - return Elaboration_Statuses_Index (Key mod Elaboration_Statuses_Max); - end Elaboration_Statuses_Hash; + New_In_State.Suppress_Warnings := + New_In_State.Suppress_Warnings + or else not Elaboration_Warnings_OK (Call_Rep) + or else not Elaboration_Warnings_OK (Subp_Rep); - ------------------------------ - -- Ensure_Prior_Elaboration -- - ------------------------------ + -- The call occurs in an initial condition context when a prior + -- scenario is already in that mode, or when the target is an + -- Initial_Condition procedure. Update the state of the Processing + -- phase to reflect this. - procedure Ensure_Prior_Elaboration - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id; - State : Processing_Attributes) - is - begin - pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); + New_In_State.Within_Initial_Condition := + New_In_State.Within_Initial_Condition + or else Is_Initial_Condition_Proc (Subp_Id); - -- Nothing to do when the caller has suppressed the generation of - -- implicit Elaborate[_All] pragmas. + -- The call occurs in a partial finalization context when a prior + -- scenario is already in that mode, or when the target denotes a + -- [Deep_]Finalize primitive or a finalizer within an initialization + -- context. Update the state of the Processing phase to reflect this. - if State.Suppress_Implicit_Pragmas then - return; + New_In_State.Within_Partial_Finalization := + New_In_State.Within_Partial_Finalization + or else Is_Partial_Finalization_Proc (Subp_Id); - -- Nothing to do when the need for prior elaboration came from a partial - -- finalization routine which occurs in an initialization context. This - -- behaviour parallels that of the old ABE mechanism. + -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK + -- elaboration rules in SPARK code) is intentionally not taken into + -- account here because Process_Conditional_ABE_Call_SPARK has two + -- separate modes of operation. - elsif State.Within_Partial_Finalization then - return; + if SPARK_Rules_On then + Process_Conditional_ABE_Call_SPARK + (Call => Call, + Call_Rep => Call_Rep, + Subp_Id => Subp_Id, + Subp_Rep => Subp_Rep, + In_State => New_In_State); - -- Nothing to do when the need for prior elaboration came from a task - -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on - -- task bodies) is in effect. + -- Otherwise the Ada rules are in effect - elsif Debug_Flag_Dot_Y and then State.Within_Task_Body then - return; + else + Process_Conditional_ABE_Call_Ada + (Call => Call, + Call_Rep => Call_Rep, + Subp_Id => Subp_Id, + Subp_Rep => Subp_Rep, + In_State => New_In_State); + end if; - -- Nothing to do when the unit is elaborated prior to the main unit. - -- This check must also consider the following cases: - - -- * No check is made against the context of the main unit because this - -- is specific to the elaboration model in effect and requires custom - -- handling (see Ensure_xxx_Prior_Elaboration). - - -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma - -- Elaborate[_All] MUST be generated even though Unit_Id is always - -- elaborated prior to the main unit. This is a conservative strategy - -- which ensures that other units withed by Unit_Id will not lead to - -- an ABE. - - -- package A is package body A is - -- procedure ABE; procedure ABE is ... end ABE; - -- end A; end A; - - -- with A; - -- package B is package body B is - -- pragma Elaborate_Body; procedure Proc is - -- begin - -- procedure Proc; A.ABE; - -- package B; end Proc; - -- end B; - - -- with B; - -- package C is package body C is - -- ... ... - -- end C; begin - -- B.Proc; - -- end C; - - -- In the example above, the elaboration of C invokes B.Proc. B is - -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is - -- generated for B in C, then the following elaboratio order will lead - -- to an ABE: - - -- spec of A elaborated - -- spec of B elaborated - -- body of B elaborated - -- spec of C elaborated - -- body of C elaborated <-- calls B.Proc which calls A.ABE - -- body of A elaborated <-- problem - - -- The generation of an implicit pragma Elaborate_All (B) ensures that - -- the elaboration order mechanism will not pick the above order. - - -- An implicit Elaborate is NOT generated when the unit is subject to - -- Elaborate_Body because both pragmas have the exact same effect. - - -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST - -- NOT be generated in this case because a unit cannot depend on its - -- own elaboration. This case is therefore treated as valid prior - -- elaboration. - - elsif Has_Prior_Elaboration - (Unit_Id => Unit_Id, - Same_Unit_OK => True, - Elab_Body_OK => Prag_Nam = Name_Elaborate) - then - return; + -- Inspect the target body (and barried function) for other suitable + -- elaboration scenarios. - -- Suggest the use of pragma Prag_Nam when the dynamic model is in - -- effect. + Traverse_Conditional_ABE_Body + (N => Barrier_Body_Declaration (Subp_Rep), + In_State => New_In_State); - elsif Dynamic_Elaboration_Checks then - Ensure_Prior_Elaboration_Dynamic - (N => N, - Unit_Id => Unit_Id, - Prag_Nam => Prag_Nam); + Traverse_Conditional_ABE_Body + (N => Body_Declaration (Subp_Rep), + In_State => New_In_State); + end Process_Conditional_ABE_Call; - -- Install an implicit pragma Prag_Nam when the static model is in - -- effect. + -------------------------------------- + -- Process_Conditional_ABE_Call_Ada -- + -------------------------------------- - else - pragma Assert (Static_Elaboration_Checks); + procedure Process_Conditional_ABE_Call_Ada + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); + Root : constant Node_Id := Root_Scenario; + Unit_Id : constant Node_Id := Unit (Subp_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Call_Rep) + and then Elaboration_Checks_OK (Subp_Rep); + -- A run-time ABE check may be installed only when both the call + -- and the target have active elaboration checks, and both are not + -- ignored Ghost constructs. + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state - Ensure_Prior_Elaboration_Static - (N => N, - Unit_Id => Unit_Id, - Prag_Nam => Prag_Nam); - end if; - end Ensure_Prior_Elaboration; + begin + -- Nothing to do for an Ada dispatching call because there are no + -- ABE diagnostics for either models. ABE checks for the dynamic + -- model are handled by Install_Primitive_Elaboration_Check. - -------------------------------------- - -- Ensure_Prior_Elaboration_Dynamic -- - -------------------------------------- + if Is_Dispatching_Call (Call_Rep) then + return; - procedure Ensure_Prior_Elaboration_Dynamic - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id) - is - procedure Info_Missing_Pragma; - pragma Inline (Info_Missing_Pragma); - -- Output information concerning missing Elaborate or Elaborate_All - -- pragma with name Prag_Nam for scenario N, which would ensure the - -- prior elaboration of Unit_Id. + -- Nothing to do when the call is ABE-safe + -- + -- generic + -- function Gen ...; + -- + -- function Gen ... is + -- begin + -- ... + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- function Inst is new Gen; + -- X : ... := Inst; -- safe call + -- ... - ------------------------- - -- Info_Missing_Pragma -- - ------------------------- + elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then + return; - procedure Info_Missing_Pragma is - begin - -- Internal units are ignored as they cause unnecessary noise + -- The call and the target body are both in the main unit + -- + -- If the root scenario appears prior to the target body, then this + -- is a possible ABE with respect to the root scenario. + -- + -- function B ...; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- + -- function B ... is -- target body + -- ... + -- end B; + -- + -- Y : ... := A; -- root scenario + -- + -- IMPORTANT: The call to B from A is a possible ABE for X, but + -- not for Y. Installing an unconditional ABE raise prior to the + -- call to B would be wrong as it will fail for Y as well, but in + -- Y's case the call to B is never an ABE. - if not In_Internal_Unit (Unit_Id) then + elsif Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + then + if Earlier_In_Extended_Unit (Root, Body_Decl) then - -- The name of the unit subjected to the elaboration pragma is - -- fully qualified to improve the clarity of the info message. + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - Error_Msg_Name_1 := Prag_Nam; - Error_Msg_Qual_Level := Nat'Last; + if New_In_State.Suppress_Warnings then + null; - Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); - Error_Msg_Qual_Level := 0; - end if; - end Info_Missing_Pragma; + -- Do not emit any ABE diagnostics when the call occurs in a + -- partial finalization context because this leads to confusing + -- noise. - -- Local variables + elsif New_In_State.Within_Partial_Finalization then + null; - Elab_Attrs : Elaboration_Attributes; - Level : Enclosing_Level_Kind; + -- Otherwise emit the ABE diagnostic - -- Start of processing for Ensure_Prior_Elaboration_Dynamic + else + Error_Msg_NE + ("??cannot call & before body seen", Call, Subp_Id); + Error_Msg_N + ("\Program_Error may be raised at run time", Call); - begin - Elab_Attrs := Elaboration_Status (Unit_Id); + Output_Active_Scenarios (Call, New_In_State); + end if; - -- Nothing to do when the unit is guaranteed prior elaboration by means - -- of a source Elaborate[_All] pragma. + -- Install a conditional run-time ABE check to verify that the + -- target body has been elaborated prior to the call. + + if Check_OK then + Install_Scenario_ABE_Check + (N => Call, + Targ_Id => Subp_Id, + Targ_Rep => Subp_Rep, + Disable => Call_Rep); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragma must be generated from + -- this point on. + -- + -- function B ...; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- <ABE check> + -- return B; + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- function B ... is + -- External.Subp; -- imparts Elaborate_All + -- end B; + -- + -- If Some_Condition is True, then the ABE check will fail + -- at runtime and the call to External.Subp will never take + -- place, rendering the implicit Elaborate_All useless. + -- + -- If the value of Some_Condition is False, then the call + -- to External.Subp will never take place, rendering the + -- implicit Elaborate_All useless. + + New_In_State.Suppress_Implicit_Pragmas := True; + end if; + end if; - if Present (Elab_Attrs.Source_Pragma) then - return; - end if; + -- Otherwise the target body is not available in this compilation or + -- it resides in an external unit. Install a run-time ABE check to + -- verify that the target body has been elaborated prior to the call + -- site when the dynamic model is in effect. - -- Output extra information on a missing Elaborate[_All] pragma when - -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas - -- is in effect. + elsif Check_OK + and then New_In_State.Processing = Dynamic_Model_Processing + then + Install_Unit_ABE_Check + (N => Call, + Unit_Id => Unit_Id, + Disable => Call_Rep); + end if; - if Elab_Info_Messages then + -- Ensure that the unit with the target body is elaborated prior to + -- the main unit. The implicit Elaborate[_All] is generated only when + -- the call has elaboration checks enabled. This behaviour parallels + -- that of the old ABE mechanism. + + if Elaboration_Checks_OK (Call_Rep) then + Ensure_Prior_Elaboration + (N => Call, + Unit_Id => Unit_Id, + Prag_Nam => Name_Elaborate_All, + In_State => New_In_State); + end if; + end Process_Conditional_ABE_Call_Ada; - -- Performance note: parent traversal + ---------------------------------------- + -- Process_Conditional_ABE_Call_SPARK -- + ---------------------------------------- + + procedure Process_Conditional_ABE_Call_SPARK + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Call_Rep); - Level := Find_Enclosing_Level (N); + Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); + Region : Node_Id; - -- Declaration-level scenario + begin + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) - and then Level = Declaration_Level + Check_SPARK_Model_In_Effect; + + -- The call and the target body are both in the main unit + + if Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + and then Earlier_In_Extended_Unit (Call, Body_Decl) then - null; + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. - -- Library-level scenario + if In_State.Suppress_Warnings then + null; - elsif Level in Library_Level then - null; + -- Do not emit any ABE diagnostics when the call occurs in an + -- initial condition context because this leads to incorrect + -- diagnostics. - -- Instantiation library-level scenario + elsif In_State.Within_Initial_Condition then + null; - elsif Level = Instantiation then - null; + -- Do not emit any ABE diagnostics when the call occurs in a + -- partial finalization context because this leads to confusing + -- noise. - -- Otherwise the scenario does not appear at the proper level and - -- cannot possibly act as a top-level scenario. + elsif In_State.Within_Partial_Finalization then + null; + + -- Ensure that a call that textually precedes the subprogram body + -- it invokes appears within the early call region of the body. + -- + -- IMPORTANT: This check must always be performed even when switch + -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not + -- specified because the static model cannot guarantee the absence + -- of elaboration issues when dispatching calls are involved. + + else + Region := Find_Early_Call_Region (Body_Decl); + + if Earlier_In_Extended_Unit (Call, Region) then + Error_Msg_NE + ("call must appear within early call region of subprogram " + & "body & (SPARK RM 7.7(3))", + Call, Subp_Id); + + Error_Msg_Sloc := Sloc (Region); + Error_Msg_N ("\region starts #", Call); + + Error_Msg_Sloc := Sloc (Body_Decl); + Error_Msg_N ("\region ends #", Call); + + Output_Active_Scenarios (Call, In_State); + end if; + end if; + end if; + + -- A call to a source target or to a target which emulates Ada + -- or SPARK semantics imposes an Elaborate_All requirement on the + -- context of the main unit. Determine whether the context has a + -- pragma strong enough to meet the requirement. + -- + -- IMPORTANT: This check must be performed only when switch -gnatd.v + -- (enforce SPARK elaboration rules in SPARK code) is active because + -- the static model can ensure the prior elaboration of the unit + -- which contains a body by installing an implicit Elaborate[_All] + -- pragma. + + if Debug_Flag_Dot_V then + if Comes_From_Source (Subp_Id) + or else Is_Ada_Semantic_Target (Subp_Id) + or else Is_SPARK_Semantic_Target (Subp_Id) + then + Meet_Elaboration_Requirement + (N => Call, + Targ_Id => Subp_Id, + Req_Nam => Name_Elaborate_All, + In_State => In_State); + end if; + + -- Otherwise ensure that the unit with the target body is elaborated + -- prior to the main unit. else + Ensure_Prior_Elaboration + (N => Call, + Unit_Id => Unit (Subp_Rep), + Prag_Nam => Name_Elaborate_All, + In_State => In_State); + end if; + end Process_Conditional_ABE_Call_SPARK; + + ------------------------------------------- + -- Process_Conditional_ABE_Instantiation -- + ------------------------------------------- + + procedure Process_Conditional_ABE_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + Gen_Id : constant Entity_Id := Target (Inst_Rep); + Gen_Rep : constant Target_Rep_Id := + Target_Representation_Of (Gen_Id, In_State); + + SPARK_Rules_On : constant Boolean := + SPARK_Mode_Of (Inst_Rep) = Is_On + and then SPARK_Mode_Of (Gen_Rep) = Is_On; + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state + + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. + + if Elab_Info_Messages + and then not New_In_State.Suppress_Info_Messages + then + Info_Instantiation + (Inst => Inst, + Gen_Id => Gen_Id, + Info_Msg => True, + In_SPARK => SPARK_Rules_On); + end if; + + -- Nothing to do when the instantiation is a guaranteed ABE + + if Is_Known_Guaranteed_ABE (Inst) then + return; + + -- Nothing to do when the root scenario appears at the declaration + -- level and the generic is in the same unit, but outside this + -- context. + -- + -- generic + -- procedure Gen is ...; -- generic declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- procedure I is new Gen; -- instantiation site + -- ... + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- procedure Gen is + -- ... + -- end Gen; + -- + -- In the example above, the context of X is the declarative region + -- of Proc. The "elaboration" of X may eventually reach Gen which + -- appears outside of X's context. Gen is relevant only when Proc is + -- invoked, but this happens only by means of "normal" elaboration, + -- therefore Gen must not be considered if this is not the case. + + elsif Is_Up_Level_Target + (Targ_Decl => Spec_Declaration (Gen_Rep), + In_State => New_In_State) + then return; end if; - Info_Missing_Pragma; - end if; - end Ensure_Prior_Elaboration_Dynamic; + -- Warnings are suppressed when a prior scenario is already in that + -- mode, or when the instantiation has warnings suppressed. Update + -- the state of the processing phase to reflect this. - ------------------------------------- - -- Ensure_Prior_Elaboration_Static -- - ------------------------------------- + New_In_State.Suppress_Warnings := + New_In_State.Suppress_Warnings + or else not Elaboration_Warnings_OK (Inst_Rep); - procedure Ensure_Prior_Elaboration_Static - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id) - is - function Find_With_Clause - (Items : List_Id; - Withed_Id : Entity_Id) return Node_Id; - pragma Inline (Find_With_Clause); - -- Find a nonlimited with clause in the list of context items Items - -- that withs unit Withed_Id. Return Empty if no such clause is found. - - procedure Info_Implicit_Pragma; - pragma Inline (Info_Implicit_Pragma); - -- Output information concerning an implicitly generated Elaborate or - -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures - -- the prior elaboration of unit Unit_Id. + -- The SPARK rules are in effect - ---------------------- - -- Find_With_Clause -- - ---------------------- + if SPARK_Rules_On then + Process_Conditional_ABE_Instantiation_SPARK + (Inst => Inst, + Inst_Rep => Inst_Rep, + Gen_Id => Gen_Id, + Gen_Rep => Gen_Rep, + In_State => New_In_State); + + -- Otherwise the Ada rules are in effect, or SPARK code is allowed to + -- violate the SPARK rules. - function Find_With_Clause - (Items : List_Id; - Withed_Id : Entity_Id) return Node_Id + else + Process_Conditional_ABE_Instantiation_Ada + (Inst => Inst, + Inst_Rep => Inst_Rep, + Gen_Id => Gen_Id, + Gen_Rep => Gen_Rep, + In_State => New_In_State); + end if; + end Process_Conditional_ABE_Instantiation; + + ----------------------------------------------- + -- Process_Conditional_ABE_Instantiation_Ada -- + ----------------------------------------------- + + procedure Process_Conditional_ABE_Instantiation_Ada + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id; + In_State : Processing_In_State) is - Item : Node_Id; + Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); + Root : constant Node_Id := Root_Scenario; + Unit_Id : constant Entity_Id := Unit (Gen_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Inst_Rep) + and then Elaboration_Checks_OK (Gen_Rep); + -- A run-time ABE check may be installed only when both the instance + -- and the generic have active elaboration checks and both are not + -- ignored Ghost constructs. + + New_In_State : Processing_In_State := In_State; + -- Each step of the Processing phase constitutes a new state begin - -- Examine the context clauses looking for a suitable with. Note that - -- limited clauses do not affect the elaboration order. + -- Nothing to do when the instantiation is ABE-safe + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- package body Gen is + -- ... + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- package Inst is new Gen (ABE); -- safe instantiation + -- ... - Item := First (Items); - while Present (Item) loop - if Nkind (Item) = N_With_Clause - and then not Error_Posted (Item) - and then not Limited_Present (Item) - and then Entity (Name (Item)) = Withed_Id - then - return Item; + if Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then + return; + + -- The instantiation and the generic body are both in the main unit + -- + -- If the root scenario appears prior to the generic body, then this + -- is a possible ABE with respect to the root scenario. + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Inst is new Gen; -- instantiation site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- + -- package body Gen is -- generic body + -- ... + -- end Gen; + -- + -- Y : ... := A; -- root scenario + -- + -- IMPORTANT: The instantiation of Gen is a possible ABE for X, + -- but not for Y. Installing an unconditional ABE raise prior to + -- the instance site would be wrong as it will fail for Y as well, + -- but in Y's case the instantiation of Gen is never an ABE. + + elsif Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) + then + if Earlier_In_Extended_Unit (Root, Body_Decl) then + + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if New_In_State.Suppress_Warnings then + null; + + -- Do not emit any ABE diagnostics when the instantiation + -- occurs in partial finalization context because this leads + -- to unwanted noise. + + elsif New_In_State.Within_Partial_Finalization then + null; + + -- Otherwise output the diagnostic + + else + Error_Msg_NE + ("??cannot instantiate & before body seen", Inst, Gen_Id); + Error_Msg_N + ("\Program_Error may be raised at run time", Inst); + + Output_Active_Scenarios (Inst, New_In_State); + end if; + + -- Install a conditional run-time ABE check to verify that the + -- generic body has been elaborated prior to the instantiation. + + if Check_OK then + Install_Scenario_ABE_Check + (N => Inst, + Targ_Id => Gen_Id, + Targ_Rep => Gen_Rep, + Disable => Inst_Rep); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragma must be generated from + -- this point on. + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- <ABE check> + -- declare Inst is new Gen; + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- package body Gen is + -- begin + -- External.Subp; -- imparts Elaborate_All + -- end Gen; + -- + -- If Some_Condition is True, then the ABE check will fail + -- at runtime and the call to External.Subp will never take + -- place, rendering the implicit Elaborate_All useless. + -- + -- If the value of Some_Condition is False, then the call + -- to External.Subp will never take place, rendering the + -- implicit Elaborate_All useless. + + New_In_State.Suppress_Implicit_Pragmas := True; + end if; end if; - Next (Item); - end loop; + -- Otherwise the generic body is not available in this compilation + -- or it resides in an external unit. Install a run-time ABE check + -- to verify that the generic body has been elaborated prior to the + -- instantiation when the dynamic model is in effect. - return Empty; - end Find_With_Clause; + elsif Check_OK + and then New_In_State.Processing = Dynamic_Model_Processing + then + Install_Unit_ABE_Check + (N => Inst, + Unit_Id => Unit_Id, + Disable => Inst_Rep); + end if; - -------------------------- - -- Info_Implicit_Pragma -- - -------------------------- + -- Ensure that the unit with the generic body is elaborated prior + -- to the main unit. No implicit pragma has to be generated if the + -- instantiation has elaboration checks suppressed. This behaviour + -- parallels that of the old ABE mechanism. + + if Elaboration_Checks_OK (Inst_Rep) then + Ensure_Prior_Elaboration + (N => Inst, + Unit_Id => Unit_Id, + Prag_Nam => Name_Elaborate, + In_State => New_In_State); + end if; + end Process_Conditional_ABE_Instantiation_Ada; + + ------------------------------------------------- + -- Process_Conditional_ABE_Instantiation_SPARK -- + ------------------------------------------------- + + procedure Process_Conditional_ABE_Instantiation_SPARK + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Inst_Rep); + + Req_Nam : Name_Id; - procedure Info_Implicit_Pragma is begin - -- Internal units are ignored as they cause unnecessary noise + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - if not In_Internal_Unit (Unit_Id) then + Check_SPARK_Model_In_Effect; - -- The name of the unit subjected to the elaboration pragma is - -- fully qualified to improve the clarity of the info message. + -- A source instantiation imposes an Elaborate[_All] requirement + -- on the context of the main unit. Determine whether the context + -- has a pragma strong enough to meet the requirement. The check + -- is orthogonal to the ABE ramifications of the instantiation. + -- + -- IMPORTANT: This check must be performed only when switch -gnatd.v + -- (enforce SPARK elaboration rules in SPARK code) is active because + -- the static model can ensure the prior elaboration of the unit + -- which contains a body by installing an implicit Elaborate[_All] + -- pragma. + + if Debug_Flag_Dot_V then + if Nkind (Inst) = N_Package_Instantiation then + Req_Nam := Name_Elaborate_All; + else + Req_Nam := Name_Elaborate; + end if; - Error_Msg_Name_1 := Prag_Nam; - Error_Msg_Qual_Level := Nat'Last; + Meet_Elaboration_Requirement + (N => Inst, + Targ_Id => Gen_Id, + Req_Nam => Req_Nam, + In_State => In_State); - Error_Msg_NE - ("info: implicit pragma % generated for unit &", N, Unit_Id); + -- Otherwise ensure that the unit with the target body is elaborated + -- prior to the main unit. - Error_Msg_Qual_Level := 0; - Output_Active_Scenarios (N); + else + Ensure_Prior_Elaboration + (N => Inst, + Unit_Id => Unit (Gen_Rep), + Prag_Nam => Name_Elaborate, + In_State => In_State); end if; - end Info_Implicit_Pragma; + end Process_Conditional_ABE_Instantiation_SPARK; - -- Local variables + ------------------------------------------------- + -- Process_Conditional_ABE_Variable_Assignment -- + ------------------------------------------------- - Main_Cunit : constant Node_Id := Cunit (Main_Unit); - Loc : constant Source_Ptr := Sloc (Main_Cunit); - Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); + procedure Process_Conditional_ABE_Variable_Assignment + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is - Clause : Node_Id; - Elab_Attrs : Elaboration_Attributes; - Items : List_Id; + Var_Id : constant Entity_Id := Target (Asmt_Rep); + Var_Rep : constant Target_Rep_Id := + Target_Representation_Of (Var_Id, In_State); - -- Start of processing for Ensure_Prior_Elaboration_Static + SPARK_Rules_On : constant Boolean := + SPARK_Mode_Of (Asmt_Rep) = Is_On + and then SPARK_Mode_Of (Var_Rep) = Is_On; - begin - Elab_Attrs := Elaboration_Status (Unit_Id); + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. + + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + Elab_Msg_NE + (Msg => "assignment to & during elaboration", + N => Asmt, + Id => Var_Id, + Info_Msg => True, + In_SPARK => SPARK_Rules_On); + end if; - -- Nothing to do when the unit is guaranteed prior elaboration by means - -- of a source Elaborate[_All] pragma. + -- The SPARK rules are in effect. These rules are applied regardless + -- of whether switch -gnatd.v (enforce SPARK elaboration rules in + -- SPARK code) is in effect because the static model cannot ensure + -- safe assignment of variables. - if Present (Elab_Attrs.Source_Pragma) then - return; + if SPARK_Rules_On then + Process_Conditional_ABE_Variable_Assignment_SPARK + (Asmt => Asmt, + Asmt_Rep => Asmt_Rep, + Var_Id => Var_Id, + Var_Rep => Var_Rep, + In_State => In_State); - -- Nothing to do when the unit has an existing implicit Elaborate[_All] - -- pragma installed by a previous scenario. + -- Otherwise the Ada rules are in effect - elsif Present (Elab_Attrs.With_Clause) then + else + Process_Conditional_ABE_Variable_Assignment_Ada + (Asmt => Asmt, + Asmt_Rep => Asmt_Rep, + Var_Id => Var_Id, + Var_Rep => Var_Rep, + In_State => In_State); + end if; + end Process_Conditional_ABE_Variable_Assignment; + + ----------------------------------------------------- + -- Process_Conditional_ABE_Variable_Assignment_Ada -- + ----------------------------------------------------- + + procedure Process_Conditional_ABE_Variable_Assignment_Ada + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Var_Id : Entity_Id; + Var_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Asmt_Rep); - -- The unit is already guaranteed prior elaboration by means of an - -- implicit Elaborate pragma, however the current scenario imposes - -- a stronger requirement of Elaborate_All. "Upgrade" the existing - -- pragma to match this new requirement. + Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); + Unit_Id : constant Entity_Id := Unit (Var_Rep); - if Elaborate_Desirable (Elab_Attrs.With_Clause) - and then Prag_Nam = Name_Elaborate_All + begin + -- Emit a warning when an uninitialized variable declared in a + -- package spec without a pragma Elaborate_Body is initialized + -- by elaboration code within the corresponding body. + + if Is_Elaboration_Warnings_OK_Id (Var_Id) + and then not Is_Initialized (Var_Decl) + and then not Has_Pragma_Elaborate_Body (Unit_Id) then - Set_Elaborate_All_Desirable (Elab_Attrs.With_Clause); - Set_Elaborate_Desirable (Elab_Attrs.With_Clause, False); + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if not In_State.Suppress_Warnings then + Error_Msg_NE + ("??variable & can be accessed by clients before this " + & "initialization", Asmt, Var_Id); + + Error_Msg_NE + ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " + & "initialization", Asmt, Unit_Id); + + Output_Active_Scenarios (Asmt, In_State); + end if; + + -- Generate an implicit Elaborate_Body in the spec + + Set_Elaborate_Body_Desirable (Unit_Id); end if; + end Process_Conditional_ABE_Variable_Assignment_Ada; + + ------------------------------------------------------- + -- Process_Conditional_ABE_Variable_Assignment_SPARK -- + ------------------------------------------------------- + + procedure Process_Conditional_ABE_Variable_Assignment_SPARK + (Asmt : Node_Id; + Asmt_Rep : Scenario_Rep_Id; + Var_Id : Entity_Id; + Var_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Asmt_Rep); - return; - end if; + Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); + Unit_Id : constant Entity_Id := Unit (Var_Rep); - -- At this point it is known that the unit has no prior elaboration - -- according to pragmas and hierarchical relationships. + begin + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - Items := Context_Items (Main_Cunit); + Check_SPARK_Model_In_Effect; - if No (Items) then - Items := New_List; - Set_Context_Items (Main_Cunit, Items); - end if; + -- Do not emit any ABE diagnostics when a previous scenario in this + -- traversal has suppressed elaboration warnings. - -- Locate the with clause for the unit. Note that there may not be a - -- clause if the unit is visible through a subunit-body, body-spec, or - -- spec-parent relationship. + if In_State.Suppress_Warnings then + null; - Clause := - Find_With_Clause - (Items => Items, - Withed_Id => Unit_Id); + -- Emit an error when an initialized variable declared in a package + -- spec that is missing pragma Elaborate_Body is further modified by + -- elaboration code within the corresponding body. - -- Generate: - -- with Id; + elsif Is_Elaboration_Warnings_OK_Id (Var_Id) + and then Is_Initialized (Var_Decl) + and then not Has_Pragma_Elaborate_Body (Unit_Id) + then + Error_Msg_NE + ("variable & modified by elaboration code in package body", + Asmt, Var_Id); - -- Note that adding implicit with clauses is safe because analysis, - -- resolution, and expansion have already taken place and it is not - -- possible to interfere with visibility. + Error_Msg_NE + ("\add pragma ""Elaborate_Body"" to spec & to ensure full " + & "initialization", Asmt, Unit_Id); - if No (Clause) then - Clause := - Make_With_Clause (Loc, - Name => New_Occurrence_Of (Unit_Id, Loc)); + Output_Active_Scenarios (Asmt, In_State); + end if; + end Process_Conditional_ABE_Variable_Assignment_SPARK; - Set_Implicit_With (Clause); - Set_Library_Unit (Clause, Unit_Cunit); + ------------------------------------------------ + -- Process_Conditional_ABE_Variable_Reference -- + ------------------------------------------------ - Append_To (Items, Clause); - end if; + procedure Process_Conditional_ABE_Variable_Reference + (Ref : Node_Id; + Ref_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + Var_Id : constant Entity_Id := Target (Ref); + Var_Rep : Target_Rep_Id; + Unit_Id : Entity_Id; - -- Mark the with clause depending on the pragma required + begin + -- Nothing to do when the variable reference is not a read - if Prag_Nam = Name_Elaborate then - Set_Elaborate_Desirable (Clause); - else - Set_Elaborate_All_Desirable (Clause); - end if; + if not Is_Read_Reference (Ref_Rep) then + return; + end if; - -- The implicit Elaborate[_All] ensures the prior elaboration of the - -- unit. Include the unit in the elaboration context of the main unit. + Var_Rep := Target_Representation_Of (Var_Id, In_State); + Unit_Id := Unit (Var_Rep); - Set_Elaboration_Status - (Unit_Id => Unit_Id, - Val => Elaboration_Attributes'(Source_Pragma => Empty, - With_Clause => Clause)); + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - -- Output extra information on an implicit Elaborate[_All] pragma when - -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is - -- in effect. + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + Elab_Msg_NE + (Msg => "read of variable & during elaboration", + N => Ref, + Id => Var_Id, + Info_Msg => True, + In_SPARK => True); + end if; - if Elab_Info_Messages then - Info_Implicit_Pragma; - end if; - end Ensure_Prior_Elaboration_Static; + -- Nothing to do when the variable appears within the main unit + -- because diagnostics on reads are relevant only for external + -- variables. - ----------------------------- - -- Extract_Assignment_Name -- - ----------------------------- + if Is_Same_Unit (Unit_Id, Cunit_Entity (Main_Unit)) then + null; - function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is - Nam : Node_Id; + -- Nothing to do when the variable is already initialized. Note that + -- the variable may be further modified by the external unit. - begin - Nam := Name (Asmt); + elsif Is_Initialized (Variable_Declaration (Var_Rep)) then + null; - -- When the name denotes an array or record component, find the whole - -- object. + -- Nothing to do when the external unit guarantees the initialization + -- of the variable by means of pragma Elaborate_Body. - while Nkind_In (Nam, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) - loop - Nam := Prefix (Nam); - end loop; + elsif Has_Pragma_Elaborate_Body (Unit_Id) then + null; - return Nam; - end Extract_Assignment_Name; + -- A variable read imposes an Elaborate requirement on the context of + -- the main unit. Determine whether the context has a pragma strong + -- enough to meet the requirement. - ----------------------------- - -- Extract_Call_Attributes -- - ----------------------------- + else + Meet_Elaboration_Requirement + (N => Ref, + Targ_Id => Var_Id, + Req_Nam => Name_Elaborate, + In_State => In_State); + end if; + end Process_Conditional_ABE_Variable_Reference; - procedure Extract_Call_Attributes - (Call : Node_Id; - Target_Id : out Entity_Id; - Attrs : out Call_Attributes) - is - From_Source : Boolean; - In_Declarations : Boolean; - Is_Dispatching : Boolean; + ----------------------------------- + -- Traverse_Conditional_ABE_Body -- + ----------------------------------- + procedure Traverse_Conditional_ABE_Body + (N : Node_Id; + In_State : Processing_In_State) + is + begin + Traverse_Body + (N => N, + Requires_Processing => Is_Conditional_ABE_Scenario'Access, + Processor => Process_Conditional_ABE'Access, + In_State => In_State); + end Traverse_Conditional_ABE_Body; + end Conditional_ABE_Processor; + + ------------- + -- Destroy -- + ------------- + + procedure Destroy (NE : in out Node_Or_Entity_Id) is + pragma Unreferenced (NE); begin - -- Extraction for call markers + null; + end Destroy; - if Nkind (Call) = N_Call_Marker then - Target_Id := Target (Call); - From_Source := Is_Source_Call (Call); - In_Declarations := Is_Declaration_Level_Node (Call); - Is_Dispatching := Is_Dispatching_Call (Call); + ----------------- + -- Diagnostics -- + ----------------- - -- Extraction for entry calls, requeue, and subprogram calls + package body Diagnostics is - else - pragma Assert (Nkind_In (Call, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement, - N_Requeue_Statement)); + ----------------- + -- Elab_Msg_NE -- + ----------------- - Target_Id := Entity (Extract_Call_Name (Call)); - From_Source := Comes_From_Source (Call); + procedure Elab_Msg_NE + (Msg : String; + N : Node_Id; + Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is + function Prefix return String; + pragma Inline (Prefix); + -- Obtain the prefix of the message - -- Performance note: parent traversal + function Suffix return String; + pragma Inline (Suffix); + -- Obtain the suffix of the message - In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level; - Is_Dispatching := - Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement) - and then Present (Controlling_Argument (Call)); - end if; + ------------ + -- Prefix -- + ------------ - -- Obtain the original entry or subprogram which the target may rename - -- except when the target is an instantiation. In this case the alias - -- is the internally generated subprogram which appears within the the - -- anonymous package created for the instantiation. Such an alias is not - -- a suitable target. + function Prefix return String is + begin + if Info_Msg then + return "info: "; + else + return ""; + end if; + end Prefix; - if not (Is_Subprogram (Target_Id) - and then Is_Generic_Instance (Target_Id)) - then - Target_Id := Get_Renamed_Entity (Target_Id); - end if; + ------------ + -- Suffix -- + ------------ - -- Set all attributes + function Suffix return String is + begin + if In_SPARK then + return " in SPARK"; + else + return ""; + end if; + end Suffix; - Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); - Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); - Attrs.From_Source := From_Source; - Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call); - Attrs.In_Declarations := In_Declarations; - Attrs.Is_Dispatching := Is_Dispatching; - Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call); - end Extract_Call_Attributes; + -- Start of processing for Elab_Msg_NE - ----------------------- - -- Extract_Call_Name -- - ----------------------- + begin + Error_Msg_NE (Prefix & Msg & Suffix, N, Id); + end Elab_Msg_NE; - function Extract_Call_Name (Call : Node_Id) return Node_Id is - Nam : Node_Id; + --------------- + -- Info_Call -- + --------------- - begin - Nam := Name (Call); + procedure Info_Call + (Call : Node_Id; + Subp_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is + procedure Info_Accept_Alternative; + pragma Inline (Info_Accept_Alternative); + -- Output information concerning an accept alternative - -- When the call invokes an entry family, the name appears as an indexed - -- component. + procedure Info_Simple_Call; + pragma Inline (Info_Simple_Call); + -- Output information concerning the call - if Nkind (Nam) = N_Indexed_Component then - Nam := Prefix (Nam); - end if; + procedure Info_Type_Actions (Action : String); + pragma Inline (Info_Type_Actions); + -- Output information concerning action Action of a type - -- When the call employs the object.operation form, the name appears as - -- a selected component. + procedure Info_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String); + pragma Inline (Info_Verification_Call); + -- Output information concerning the verification of predicate Pred + -- applied to related entity Id with kind Id_Kind. - if Nkind (Nam) = N_Selected_Component then - Nam := Selector_Name (Nam); - end if; + ----------------------------- + -- Info_Accept_Alternative -- + ----------------------------- - return Nam; - end Extract_Call_Name; + procedure Info_Accept_Alternative is + Entry_Id : constant Entity_Id := Receiving_Entry (Subp_Id); + pragma Assert (Present (Entry_Id)); - --------------------------------- - -- Extract_Instance_Attributes -- - --------------------------------- + begin + Elab_Msg_NE + (Msg => "accept for entry & during elaboration", + N => Call, + Id => Entry_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Accept_Alternative; + + ---------------------- + -- Info_Simple_Call -- + ---------------------- + + procedure Info_Simple_Call is + begin + Elab_Msg_NE + (Msg => "call to & during elaboration", + N => Call, + Id => Subp_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Simple_Call; + + ----------------------- + -- Info_Type_Actions -- + ----------------------- + + procedure Info_Type_Actions (Action : String) is + Typ : constant Entity_Id := First_Formal_Type (Subp_Id); + pragma Assert (Present (Typ)); - procedure Extract_Instance_Attributes - (Exp_Inst : Node_Id; - Inst_Body : out Node_Id; - Inst_Decl : out Node_Id) - is - Body_Id : Entity_Id; + begin + Elab_Msg_NE + (Msg => Action & " actions for type & during elaboration", + N => Call, + Id => Typ, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Type_Actions; + + ---------------------------- + -- Info_Verification_Call -- + ---------------------------- + + procedure Info_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String) + is + pragma Assert (Present (Id)); - begin - -- Assume that the attributes are unavailable + begin + Elab_Msg_NE + (Msg => + "verification of " & Pred & " of " & Id_Kind & " & during " + & "elaboration", + N => Call, + Id => Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Verification_Call; + + -- Start of processing for Info_Call - Inst_Body := Empty; - Inst_Decl := Empty; + begin + -- Do not output anything for targets defined in internal units + -- because this creates noise. - -- Generic package or subprogram spec + if not In_Internal_Unit (Subp_Id) then - if Nkind_In (Exp_Inst, N_Package_Declaration, - N_Subprogram_Declaration) - then - Inst_Decl := Exp_Inst; - Body_Id := Corresponding_Body (Inst_Decl); + -- Accept alternative - if Present (Body_Id) then - Inst_Body := Unit_Declaration_Node (Body_Id); - end if; + if Is_Accept_Alternative_Proc (Subp_Id) then + Info_Accept_Alternative; - -- Generic package or subprogram body + -- Adjustment - else - pragma Assert - (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body)); + elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then + Info_Type_Actions ("adjustment"); - Inst_Body := Exp_Inst; - Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body)); - end if; - end Extract_Instance_Attributes; + -- Default_Initial_Condition - -------------------------------------- - -- Extract_Instantiation_Attributes -- - -------------------------------------- + elsif Is_Default_Initial_Condition_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "Default_Initial_Condition", + Id => First_Formal_Type (Subp_Id), + Id_Kind => "type"); - procedure Extract_Instantiation_Attributes - (Exp_Inst : Node_Id; - Inst : out Node_Id; - Inst_Id : out Entity_Id; - Gen_Id : out Entity_Id; - Attrs : out Instantiation_Attributes) - is - begin - Inst := Original_Node (Exp_Inst); - Inst_Id := Defining_Entity (Inst); + -- Entries - -- Traverse a possible chain of renamings to obtain the original generic - -- being instantiatied. + elsif Is_Protected_Entry (Subp_Id) then + Info_Simple_Call; - Gen_Id := Get_Renamed_Entity (Entity (Name (Inst))); + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. - -- Set all attributes + elsif Is_Task_Entry (Subp_Id) then + null; - Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); - Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); - Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst); - Attrs.In_Declarations := Is_Declaration_Level_Node (Inst); - Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst); - end Extract_Instantiation_Attributes; + -- Finalization - ------------------------------- - -- Extract_Target_Attributes -- - ------------------------------- + elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then + Info_Type_Actions ("finalization"); - procedure Extract_Target_Attributes - (Target_Id : Entity_Id; - Attrs : out Target_Attributes) - is - procedure Extract_Package_Or_Subprogram_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id); - -- Obtain the attributes associated with a package or a subprogram. - -- Spec_Id is the package or subprogram. Body_Decl is the declaration - -- of the corresponding package or subprogram body. - - procedure Extract_Protected_Entry_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id; - Body_Barf : out Node_Id); - -- Obtain the attributes associated with a protected entry [family]. - -- Spec_Id is the entity of the protected body subprogram. Body_Decl - -- is the declaration of Spec_Id's corresponding body. Body_Barf is - -- the declaration of the barrier function body. - - procedure Extract_Protected_Subprogram_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id); - -- Obtain the attributes associated with a protected subprogram. Formal - -- Spec_Id is the entity of the protected body subprogram. Body_Decl is - -- the declaration of Spec_Id's corresponding body. - - procedure Extract_Task_Entry_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id); - -- Obtain the attributes associated with a task entry [family]. Formal - -- Spec_Id is the entity of the task body procedure. Body_Decl is the - -- declaration of Spec_Id's corresponding body. - - ---------------------------------------------- - -- Extract_Package_Or_Subprogram_Attributes -- - ---------------------------------------------- - - procedure Extract_Package_Or_Subprogram_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id) - is - Body_Id : Entity_Id; - Init_Id : Entity_Id; - Spec_Decl : Node_Id; + -- Calls to _Finalizer procedures must not appear in the output + -- because this creates confusing noise. - begin - -- Assume that the body is not available + elsif Is_Finalizer_Proc (Subp_Id) then + null; - Body_Decl := Empty; - Spec_Id := Target_Id; + -- Initial_Condition - -- For body retrieval purposes, the entity of the initial declaration - -- is that of the spec. + elsif Is_Initial_Condition_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "Initial_Condition", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "package"); - Init_Id := Spec_Id; + -- Initialization - -- The only exception to the above is a function which returns a - -- constrained array type in a SPARK-to-C compilation. In this case - -- the function receives a corresponding procedure which has an out - -- parameter. The proper body for ABE checks and diagnostics is that - -- of the procedure. + elsif Is_Init_Proc (Subp_Id) + or else Is_TSS (Subp_Id, TSS_Deep_Initialize) + then + Info_Type_Actions ("initialization"); - if Ekind (Init_Id) = E_Function - and then Rewritten_For_C (Init_Id) - then - Init_Id := Corresponding_Procedure (Init_Id); - end if; + -- Invariant - -- Extract the attributes of the body + elsif Is_Invariant_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "invariants", + Id => First_Formal_Type (Subp_Id), + Id_Kind => "type"); - Spec_Decl := Unit_Declaration_Node (Init_Id); + -- Partial invariant calls must not appear in the output because + -- this creates confusing noise. - -- The initial declaration is a stand alone subprogram body + elsif Is_Partial_Invariant_Proc (Subp_Id) then + null; - if Nkind (Spec_Decl) = N_Subprogram_Body then - Body_Decl := Spec_Decl; + -- _Postconditions - -- Otherwise the package or subprogram has a spec and a completing - -- body. + elsif Is_Postconditions_Proc (Subp_Id) then + Info_Verification_Call + (Pred => "postconditions", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "subprogram"); - elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Subprogram_Body_Stub, - N_Subprogram_Declaration) - then - Body_Id := Corresponding_Body (Spec_Decl); + -- Subprograms must come last because some of the previous cases + -- fall under this category. - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); + elsif Ekind (Subp_Id) = E_Function then + Info_Simple_Call; + + elsif Ekind (Subp_Id) = E_Procedure then + Info_Simple_Call; + + else + pragma Assert (False); + return; end if; end if; - end Extract_Package_Or_Subprogram_Attributes; + end Info_Call; - ---------------------------------------- - -- Extract_Protected_Entry_Attributes -- - ---------------------------------------- + ------------------------ + -- Info_Instantiation -- + ------------------------ - procedure Extract_Protected_Entry_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id; - Body_Barf : out Node_Id) + procedure Info_Instantiation + (Inst : Node_Id; + Gen_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) is - Barf_Id : Entity_Id; - Body_Id : Entity_Id; + begin + Elab_Msg_NE + (Msg => "instantiation of & during elaboration", + N => Inst, + Id => Gen_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Instantiation; + ----------------------------- + -- Info_Variable_Reference -- + ----------------------------- + + procedure Info_Variable_Reference + (Ref : Node_Id; + Var_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is begin - -- Assume that the bodies are not available + if Is_Read (Ref) then + Elab_Msg_NE + (Msg => "read of variable & during elaboration", + N => Ref, + Id => Var_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end if; + end Info_Variable_Reference; + end Diagnostics; - Body_Barf := Empty; - Body_Decl := Empty; + --------------------------------- + -- Early_Call_Region_Processor -- + --------------------------------- - -- When the entry [family] has already been expanded, it carries both - -- the procedure which emulates the behavior of the entry [family] as - -- well as the barrier function. + package body Early_Call_Region_Processor is - if Present (Protected_Body_Subprogram (Target_Id)) then - Spec_Id := Protected_Body_Subprogram (Target_Id); + --------------------- + -- Data structures -- + --------------------- - -- Extract the attributes of the barrier function + -- The following map relates early call regions to subprogram bodies - Barf_Id := - Corresponding_Body - (Unit_Declaration_Node (Barrier_Function (Target_Id))); + procedure Destroy (N : in out Node_Id); + -- Destroy node N - if Present (Barf_Id) then - Body_Barf := Unit_Declaration_Node (Barf_Id); - end if; + package ECR_Map is new Dynamic_Hash_Tables + (Key_Type => Entity_Id, + Value_Type => Node_Id, + No_Value => Empty, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy, + Hash => Hash); - -- Otherwise no expansion took place + Early_Call_Regions_Map : ECR_Map.Dynamic_Hash_Table := ECR_Map.Nil; - else - Spec_Id := Target_Id; - end if; + ----------------------- + -- Local subprograms -- + ----------------------- - -- Extract the attributes of the entry body + function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; + pragma Inline (Early_Call_Region); + -- Obtain the early call region associated with entry or subprogram body + -- Body_Id. - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); + pragma Inline (Set_Early_Call_Region); + -- Associate an early call region with begins at construct Start with + -- entry or subprogram body Body_Id. - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; - end Extract_Protected_Entry_Attributes; + ------------- + -- Destroy -- + ------------- - --------------------------------------------- - -- Extract_Protected_Subprogram_Attributes -- - --------------------------------------------- + procedure Destroy (N : in out Node_Id) is + pragma Unreferenced (N); + begin + null; + end Destroy; - procedure Extract_Protected_Subprogram_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id) - is - Body_Id : Entity_Id; + ----------------------- + -- Early_Call_Region -- + ----------------------- + function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is + pragma Assert (Present (Body_Id)); begin - -- Assume that the body is not available + return ECR_Map.Get (Early_Call_Regions_Map, Body_Id); + end Early_Call_Region; - Body_Decl := Empty; + ------------------------------------------ + -- Finalize_Early_Call_Region_Processor -- + ------------------------------------------ - -- When the protected subprogram has already been expanded, it - -- carries the subprogram which seizes the lock and invokes the - -- original statements. + procedure Finalize_Early_Call_Region_Processor is + begin + ECR_Map.Destroy (Early_Call_Regions_Map); + end Finalize_Early_Call_Region_Processor; - if Present (Protected_Subprogram (Target_Id)) then - Spec_Id := - Protected_Body_Subprogram (Protected_Subprogram (Target_Id)); + ---------------------------- + -- Find_Early_Call_Region -- + ---------------------------- - -- Otherwise no expansion took place + function Find_Early_Call_Region + (Body_Decl : Node_Id; + Assume_Elab_Body : Boolean := False; + Skip_Memoization : Boolean := False) return Node_Id + is + -- NOTE: The routines within Find_Early_Call_Region are intentionally + -- unnested to avoid deep indentation of code. + + ECR_Found : exception; + -- This exception is raised when the early call region has been found + + Start : Node_Id := Empty; + -- The start of the early call region. This variable is updated by + -- the various nested routines. Due to the use of exceptions, the + -- variable must be global to the nested routines. + + -- The algorithm implemented in this routine attempts to find the + -- early call region of a subprogram body by inspecting constructs + -- in reverse declarative order, while navigating the tree. The + -- algorithm consists of an Inspection phase and Advancement phase. + -- The pseudocode is as follows: + -- + -- loop + -- inspection phase + -- advancement phase + -- end loop + -- + -- The infinite loop is terminated by raising exception ECR_Found. + -- The algorithm utilizes two pointers, Curr and Start, to represent + -- the current construct to inspect and the start of the early call + -- region. + -- + -- IMPORTANT: The algorithm must maintain the following invariant at + -- all time for it to function properly: + -- + -- A nested construct is entered only when it contains suitable + -- constructs. + -- + -- This guarantees that leaving a nested or encapsulating construct + -- functions properly. + -- + -- The Inspection phase determines whether the current construct is + -- non-preelaborable, and if it is, the algorithm terminates. + -- + -- The Advancement phase walks the tree in reverse declarative order, + -- while entering and leaving nested and encapsulating constructs. It + -- may also terminate the elaborithm. There are several special cases + -- of advancement. + -- + -- 1) General case: + -- + -- <construct 1> + -- ... + -- <construct N-1> <- Curr + -- <construct N> <- Start + -- <subprogram body> + -- + -- In the general case, a declarative or statement list is traversed + -- in reverse order where Curr is the lead pointer, and Start is the + -- last preelaborable construct. + -- + -- 2) Entering handled bodies + -- + -- package body Nested is <- Curr (2.3) + -- <declarations> <- Curr (2.2) + -- begin + -- <statements> <- Curr (2.1) + -- end Nested; + -- <construct> <- Start + -- + -- In this case, the algorithm enters a handled body by starting from + -- the last statement (2.1), or the last declaration (2.2), or the + -- body is consumed (2.3) because it is empty and thus preelaborable. + -- + -- 3) Entering package declarations + -- + -- package Nested is <- Curr (2.3) + -- <visible declarations> <- Curr (2.2) + -- private + -- <private declarations> <- Curr (2.1) + -- end Nested; + -- <construct> <- Start + -- + -- In this case, the algorithm enters a package declaration by + -- starting from the last private declaration (2.1), the last visible + -- declaration (2.2), or the package is consumed (2.3) because it is + -- empty and thus preelaborable. + -- + -- 4) Transitioning from list to list of the same construct + -- + -- Certain constructs have two eligible lists. The algorithm must + -- thus transition from the second to the first list when the second + -- list is exhausted. + -- + -- declare <- Curr (4.2) + -- <declarations> <- Curr (4.1) + -- begin + -- <statements> <- Start + -- end; + -- + -- In this case, the algorithm has exhausted the second list (the + -- statements in the example above), and continues with the last + -- declaration (4.1) or the construct is consumed (4.2) because it + -- contains only preelaborable code. + -- + -- 5) Transitioning from list to construct + -- + -- tack body Task is <- Curr (5.1) + -- <- Curr (Empty) + -- <construct 1> <- Start + -- + -- In this case, the algorithm has exhausted a list, Curr is Empty, + -- and the owner of the list is consumed (5.1). + -- + -- 6) Transitioning from unit to unit + -- + -- A package body with a spec subject to pragma Elaborate_Body + -- extends the possible range of the early call region to the package + -- spec. + -- + -- package Pack is <- Curr (6.3) + -- pragma Elaborate_Body; <- Curr (6.2) + -- <visible declarations> <- Curr (6.2) + -- private + -- <private declarations> <- Curr (6.1) + -- end Pack; + -- + -- package body Pack is <- Curr, Start + -- + -- In this case, the algorithm has reached a package body compilation + -- unit whose spec is subject to pragma Elaborate_Body, or the caller + -- of the algorithm has specified this behavior. This transition is + -- equivalent to 3). + -- + -- 7) Transitioning from unit to termination + -- + -- Reaching a compilation unit always terminates the algorithm as + -- there are no more lists to examine. This must take case 6) into + -- account. + -- + -- 8) Transitioning from subunit to stub + -- + -- package body Pack is separate; <- Curr (8.1) + -- + -- separate (...) + -- package body Pack is <- Curr, Start + -- + -- Reaching a subunit continues the search from the corresponding + -- stub (8.1). + + procedure Advance (Curr : in out Node_Id); + pragma Inline (Advance); + -- Update the Curr and Start pointers depending on their location + -- in the tree to the next eligible construct. This routine raises + -- ECR_Found. + + procedure Enter_Handled_Body (Curr : in out Node_Id); + pragma Inline (Enter_Handled_Body); + -- Update the Curr and Start pointers to enter a nested handled body + -- if applicable. This routine raises ECR_Found. + + procedure Enter_Package_Declaration (Curr : in out Node_Id); + pragma Inline (Enter_Package_Declaration); + -- Update the Curr and Start pointers to enter a nested package spec + -- if applicable. This routine raises ECR_Found. + + function Find_ECR (N : Node_Id) return Node_Id; + pragma Inline (Find_ECR); + -- Find an early call region starting from arbitrary node N + + function Has_Suitable_Construct (List : List_Id) return Boolean; + pragma Inline (Has_Suitable_Construct); + -- Determine whether list List contains a suitable construct for + -- inclusion into an early call region. + + procedure Include (N : Node_Id; Curr : out Node_Id); + pragma Inline (Include); + -- Update the Curr and Start pointers to include arbitrary construct + -- N in the early call region. This routine raises ECR_Found. + + function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; + pragma Inline (Is_OK_Preelaborable_Construct); + -- Determine whether arbitrary node N denotes a preelaboration-safe + -- construct. + + function Is_Suitable_Construct (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Construct); + -- Determine whether arbitrary node N denotes a suitable construct + -- for inclusion into the early call region. + + procedure Transition_Body_Declarations + (Bod : Node_Id; + Curr : out Node_Id); + pragma Inline (Transition_Body_Declarations); + -- Update the Curr and Start pointers when construct Bod denotes a + -- block statement or a suitable body. This routine raises ECR_Found. + + procedure Transition_Handled_Statements + (HSS : Node_Id; + Curr : out Node_Id); + pragma Inline (Transition_Handled_Statements); + -- Update the Curr and Start pointers when node HSS denotes a handled + -- sequence of statements. This routine raises ECR_Found. + + procedure Transition_Spec_Declarations + (Spec : Node_Id; + Curr : out Node_Id); + pragma Inline (Transition_Spec_Declarations); + -- Update the Curr and Start pointers when construct Spec denotes + -- a concurrent definition or a package spec. This routine raises + -- ECR_Found. + + procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); + pragma Inline (Transition_Unit); + -- Update the Curr and Start pointers when node Unit denotes a + -- potential compilation unit. This routine raises ECR_Found. + + ------------- + -- Advance -- + ------------- + + procedure Advance (Curr : in out Node_Id) is + Context : Node_Id; - else - Spec_Id := Target_Id; - end if; + begin + -- Curr denotes one of the following cases upon entry into this + -- routine: + -- + -- * Empty - There is no current construct when a declarative or + -- a statement list has been exhausted. This does not indicate + -- that the early call region has been computed as it is still + -- possible to transition to another list. + -- + -- * Encapsulator - The current construct wraps declarations + -- and/or statements. This indicates that the early call + -- region may extend within the nested construct. + -- + -- * Preelaborable - The current construct is preelaborable + -- because Find_ECR would not invoke Advance if this was not + -- the case. - -- Extract the attributes of the body + -- The current construct is an encapsulator or is preelaborable - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + if Present (Curr) then - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; - end Extract_Protected_Subprogram_Attributes; + -- Enter encapsulators by inspecting their declarations and/or + -- statements. - ----------------------------------- - -- Extract_Task_Entry_Attributes -- - ----------------------------------- + if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then + Enter_Handled_Body (Curr); - procedure Extract_Task_Entry_Attributes - (Spec_Id : out Entity_Id; - Body_Decl : out Node_Id) - is - Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id)); - Body_Id : Entity_Id; + elsif Nkind (Curr) = N_Package_Declaration then + Enter_Package_Declaration (Curr); - begin - -- Assume that the body is not available + -- Early call regions have a property which can be exploited to + -- optimize the algorithm. + -- + -- <preceding subprogram body> + -- <preelaborable construct 1> + -- ... + -- <preelaborable construct N> + -- <initiating subprogram body> + -- + -- If a traversal initiated from a subprogram body reaches a + -- preceding subprogram body, then both bodies share the same + -- early call region. + -- + -- The property results in the following desirable effects: + -- + -- * If the preceding body already has an early call region, + -- then the initiating body can reuse it. This minimizes the + -- amount of processing performed by the algorithm. + -- + -- * If the preceding body lack an early call region, then the + -- algorithm can compute the early call region, and reuse it + -- for the initiating body. This processing performs the same + -- amount of work, but has the beneficial effect of computing + -- the early call regions of all preceding bodies. - Body_Decl := Empty; + elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then + Start := + Find_Early_Call_Region + (Body_Decl => Curr, + Assume_Elab_Body => Assume_Elab_Body, + Skip_Memoization => Skip_Memoization); - -- The the task type has already been expanded, it carries the - -- procedure which emulates the behavior of the task body. + raise ECR_Found; - if Present (Task_Body_Procedure (Task_Typ)) then - Spec_Id := Task_Body_Procedure (Task_Typ); + -- Otherwise current construct is preelaborable. Unpdate the + -- early call region to include it. - -- Otherwise no expansion took place + else + Include (Curr, Curr); + end if; - else - Spec_Id := Task_Typ; - end if; + -- Otherwise the current construct is missing, indicating that the + -- current list has been exhausted. Depending on the context of + -- the list, several transitions are possible. - -- Extract the attributes of the body + else + -- The invariant of the algorithm ensures that Curr and Start + -- are at the same level of nesting at the point of transition. + -- The algorithm can determine which list the traversal came + -- from by examining Start. - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + Context := Parent (Start); - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; - end Extract_Task_Entry_Attributes; + -- Attempt the following transitions: + -- + -- private declarations -> visible declarations + -- private declarations -> upper level + -- private declarations -> terminate + -- visible declarations -> upper level + -- visible declarations -> terminate + + if Nkind_In (Context, N_Package_Specification, + N_Protected_Definition, + N_Task_Definition) + then + Transition_Spec_Declarations (Context, Curr); - -- Local variables + -- Attempt the following transitions: + -- + -- statements -> declarations + -- statements -> upper level + -- statements -> corresponding package spec (Elab_Body) + -- statements -> terminate - Prag : constant Node_Id := SPARK_Pragma (Target_Id); - Body_Barf : Node_Id; - Body_Decl : Node_Id; - Spec_Id : Entity_Id; + elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then + Transition_Handled_Statements (Context, Curr); - -- Start of processing for Extract_Target_Attributes + -- Attempt the following transitions: + -- + -- declarations -> upper level + -- declarations -> corresponding package spec (Elab_Body) + -- declarations -> terminate + + elsif Nkind_In (Context, N_Block_Statement, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) + then + Transition_Body_Declarations (Context, Curr); - begin - -- Assume that the body of the barrier function is not available + -- Otherwise it is not possible to transition. Stop the search + -- because there are no more declarations or statements to + -- check. - Body_Barf := Empty; + else + raise ECR_Found; + end if; + end if; + end Advance; - -- The target is a protected entry [family] + -------------------------- + -- Enter_Handled_Body -- + -------------------------- - if Is_Protected_Entry (Target_Id) then - Extract_Protected_Entry_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl, - Body_Barf => Body_Barf); + procedure Enter_Handled_Body (Curr : in out Node_Id) is + Decls : constant List_Id := Declarations (Curr); + HSS : constant Node_Id := Handled_Statement_Sequence (Curr); + Stmts : List_Id := No_List; - -- The target is a protected subprogram + begin + if Present (HSS) then + Stmts := Statements (HSS); + end if; - elsif Is_Protected_Subp (Target_Id) - or else Is_Protected_Body_Subp (Target_Id) - then - Extract_Protected_Subprogram_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl); + -- The handled body has a non-empty statement sequence. The + -- construct to inspect is the last statement. - -- The target is a task entry [family] + if Has_Suitable_Construct (Stmts) then + Curr := Last (Stmts); - elsif Is_Task_Entry (Target_Id) then - Extract_Task_Entry_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl); + -- The handled body lacks statements, but has non-empty + -- declarations. The construct to inspect is the last declaration. - -- Otherwise the target is a package or a subprogram + elsif Has_Suitable_Construct (Decls) then + Curr := Last (Decls); - else - Extract_Package_Or_Subprogram_Attributes - (Spec_Id => Spec_Id, - Body_Decl => Body_Decl); - end if; + -- Otherwise the handled body lacks both declarations and + -- statements. The construct to inspect is the node which precedes + -- the handled body. Update the early call region to include the + -- handled body. - -- Set all attributes + else + Include (Curr, Curr); + end if; + end Enter_Handled_Body; - Attrs.Body_Barf := Body_Barf; - Attrs.Body_Decl := Body_Decl; - Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id); - Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Target_Id); - Attrs.From_Source := Comes_From_Source (Target_Id); - Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id); - Attrs.SPARK_Mode_On := - Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; - Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id); - Attrs.Spec_Id := Spec_Id; - Attrs.Unit_Id := Find_Top_Unit (Target_Id); + ------------------------------- + -- Enter_Package_Declaration -- + ------------------------------- - -- At this point certain attributes should always be available + procedure Enter_Package_Declaration (Curr : in out Node_Id) is + Pack_Spec : constant Node_Id := Specification (Curr); + Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); + Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); - pragma Assert (Present (Attrs.Spec_Decl)); - pragma Assert (Present (Attrs.Spec_Id)); - pragma Assert (Present (Attrs.Unit_Id)); - end Extract_Target_Attributes; + begin + -- The package has a non-empty private declarations. The construct + -- to inspect is the last private declaration. - ----------------------------- - -- Extract_Task_Attributes -- - ----------------------------- + if Has_Suitable_Construct (Prv_Decls) then + Curr := Last (Prv_Decls); - procedure Extract_Task_Attributes - (Typ : Entity_Id; - Attrs : out Task_Attributes) - is - Task_Typ : constant Entity_Id := Non_Private_View (Typ); + -- The package lacks private declarations, but has non-empty + -- visible declarations. In this case the construct to inspect + -- is the last visible declaration. - Body_Decl : Node_Id; - Body_Id : Entity_Id; - Prag : Node_Id; - Spec_Id : Entity_Id; + elsif Has_Suitable_Construct (Vis_Decls) then + Curr := Last (Vis_Decls); - begin - -- Assume that the body of the task procedure is not available + -- Otherwise the package lacks any declarations. The construct + -- to inspect is the node which precedes the package. Update the + -- early call region to include the package declaration. - Body_Decl := Empty; + else + Include (Curr, Curr); + end if; + end Enter_Package_Declaration; - -- The initial declaration is that of the task body procedure + -------------- + -- Find_ECR -- + -------------- - Spec_Id := Get_Task_Body_Procedure (Task_Typ); - Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + function Find_ECR (N : Node_Id) return Node_Id is + Curr : Node_Id; - if Present (Body_Id) then - Body_Decl := Unit_Declaration_Node (Body_Id); - end if; + begin + -- The early call region starts at N - Prag := SPARK_Pragma (Task_Typ); + Curr := Prev (N); + Start := N; - -- Set all attributes + -- Inspect each node in reverse declarative order while going in + -- and out of nested and enclosing constructs. Note that the only + -- way to terminate this infinite loop is to raise ECR_Found. - Attrs.Body_Decl := Body_Decl; - Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ); - Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Task_Typ); - Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ); - Attrs.SPARK_Mode_On := - Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; - Attrs.Spec_Id := Spec_Id; - Attrs.Task_Decl := Declaration_Node (Task_Typ); - Attrs.Unit_Id := Find_Top_Unit (Task_Typ); + loop + -- The current construct is not preelaboration-safe. Terminate + -- the traversal. - -- At this point certain attributes should always be available + if Present (Curr) + and then not Is_OK_Preelaborable_Construct (Curr) + then + raise ECR_Found; + end if; - pragma Assert (Present (Attrs.Spec_Id)); - pragma Assert (Present (Attrs.Task_Decl)); - pragma Assert (Present (Attrs.Unit_Id)); - end Extract_Task_Attributes; + -- Advance to the next suitable construct. This may terminate + -- the traversal by raising ECR_Found. - ------------------------------------------- - -- Extract_Variable_Reference_Attributes -- - ------------------------------------------- + Advance (Curr); + end loop; - procedure Extract_Variable_Reference_Attributes - (Ref : Node_Id; - Var_Id : out Entity_Id; - Attrs : out Variable_Attributes) - is - function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id; - -- Obtain the ultimate renamed variable of variable Id + exception + when ECR_Found => + return Start; + end Find_ECR; - -------------------------- - -- Get_Renamed_Variable -- - -------------------------- + ---------------------------- + -- Has_Suitable_Construct -- + ---------------------------- - function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is - Ren_Id : Entity_Id; + function Has_Suitable_Construct (List : List_Id) return Boolean is + Item : Node_Id; - begin - Ren_Id := Id; - while Present (Renamed_Entity (Ren_Id)) - and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity - loop - Ren_Id := Renamed_Entity (Ren_Id); - end loop; + begin + -- Examine the list in reverse declarative order, looking for a + -- suitable construct. + + if Present (List) then + Item := Last (List); + while Present (Item) loop + if Is_Suitable_Construct (Item) then + return True; + end if; - return Ren_Id; - end Get_Renamed_Variable; + Prev (Item); + end loop; + end if; - -- Start of processing for Extract_Variable_Reference_Attributes + return False; + end Has_Suitable_Construct; - begin - -- Extraction for variable reference markers + ------------- + -- Include -- + ------------- - if Nkind (Ref) = N_Variable_Reference_Marker then - Var_Id := Target (Ref); + procedure Include (N : Node_Id; Curr : out Node_Id) is + begin + Start := N; - -- Extraction for expanded names and identifiers + -- The input node is a compilation unit. This terminates the + -- search because there are no more lists to inspect and there are + -- no more enclosing constructs to climb up to. The transitions + -- are: + -- + -- private declarations -> terminate + -- visible declarations -> terminate + -- statements -> terminate + -- declarations -> terminate - else - Var_Id := Entity (Ref); - end if; + if Nkind (Parent (Start)) = N_Compilation_Unit then + raise ECR_Found; - -- Obtain the original variable which the reference mentions + -- Otherwise the input node is still within some list - Var_Id := Get_Renamed_Variable (Var_Id); - Attrs.Unit_Id := Find_Top_Unit (Var_Id); + else + Curr := Prev (Start); + end if; + end Include; - -- At this point certain attributes should always be available + ----------------------------------- + -- Is_OK_Preelaborable_Construct -- + ----------------------------------- - pragma Assert (Present (Attrs.Unit_Id)); - end Extract_Variable_Reference_Attributes; + function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is + begin + -- Assignment statements are acceptable as long as they were + -- produced by the ABE mechanism to update elaboration flags. - -------------------- - -- Find_Code_Unit -- - -------------------- + if Nkind (N) = N_Assignment_Statement then + return Is_Elaboration_Code (N); - function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is - begin - return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N)))); - end Find_Code_Unit; + -- Block statements are acceptable even though they directly + -- violate preelaborability. The intention is not to penalize + -- the early call region when a block contains only preelaborable + -- constructs. + -- + -- declare + -- Val : constant Integer := 1; + -- begin + -- pragma Assert (Val = 1); + -- null; + -- end; + -- + -- Note that the Advancement phase does enter blocks, and will + -- detect any non-preelaborable declarations or statements within. - ---------------------------- - -- Find_Early_Call_Region -- - ---------------------------- + elsif Nkind (N) = N_Block_Statement then + return True; + end if; - function Find_Early_Call_Region - (Body_Decl : Node_Id; - Assume_Elab_Body : Boolean := False; - Skip_Memoization : Boolean := False) return Node_Id - is - -- NOTE: The routines within Find_Early_Call_Region are intentionally - -- unnested to avoid deep indentation of code. - - ECR_Found : exception; - -- This exception is raised when the early call region has been found - - Start : Node_Id := Empty; - -- The start of the early call region. This variable is updated by the - -- various nested routines. Due to the use of exceptions, the variable - -- must be global to the nested routines. - - -- The algorithm implemented in this routine attempts to find the early - -- call region of a subprogram body by inspecting constructs in reverse - -- declarative order, while navigating the tree. The algorithm consists - -- of an Inspection phase and an Advancement phase. The pseudocode is as - -- follows: - -- - -- loop - -- inspection phase - -- advancement phase - -- end loop - -- - -- The infinite loop is terminated by raising exception ECR_Found. The - -- algorithm utilizes two pointers, Curr and Start, to represent the - -- current construct to inspect and the start of the early call region. - -- - -- IMPORTANT: The algorithm must maintain the following invariant at all - -- time for it to function properly - a nested construct is entered only - -- when it contains suitable constructs. This guarantees that leaving a - -- nested or encapsulating construct functions properly. - -- - -- The Inspection phase determines whether the current construct is non- - -- preelaborable, and if it is, the algorithm terminates. - -- - -- The Advancement phase walks the tree in reverse declarative order, - -- while entering and leaving nested and encapsulating constructs. It - -- may also terminate the elaborithm. There are several special cases - -- of advancement. - -- - -- 1) General case: - -- - -- <construct 1> - -- ... - -- <construct N-1> <- Curr - -- <construct N> <- Start - -- <subprogram body> - -- - -- In the general case, a declarative or statement list is traversed in - -- reverse order where Curr is the lead pointer, and Start indicates the - -- last preelaborable construct. - -- - -- 2) Entering handled bodies - -- - -- package body Nested is <- Curr (2.3) - -- <declarations> <- Curr (2.2) - -- begin - -- <statements> <- Curr (2.1) - -- end Nested; - -- <construct> <- Start - -- - -- In this case, the algorithm enters a handled body by starting from - -- the last statement (2.1), or the last declaration (2.2), or the body - -- is consumed (2.3) because it is empty and thus preelaborable. - -- - -- 3) Entering package declarations - -- - -- package Nested is <- Curr (2.3) - -- <visible declarations> <- Curr (2.2) - -- private - -- <private declarations> <- Curr (2.1) - -- end Nested; - -- <construct> <- Start - -- - -- In this case, the algorithm enters a package declaration by starting - -- from the last private declaration (2.1), the last visible declaration - -- (2.2), or the package is consumed (2.3) because it is empty and thus - -- preelaborable. - -- - -- 4) Transitioning from list to list of the same construct - -- - -- Certain constructs have two eligible lists. The algorithm must thus - -- transition from the second to the first list when the second list is - -- exhausted. - -- - -- declare <- Curr (4.2) - -- <declarations> <- Curr (4.1) - -- begin - -- <statements> <- Start - -- end; - -- - -- In this case, the algorithm has exhausted the second list (statements - -- in the example), and continues with the last declaration (4.1) or the - -- construct is consumed (4.2) because it contains only preelaborable - -- code. - -- - -- 5) Transitioning from list to construct - -- - -- tack body Task is <- Curr (5.1) - -- <- Curr (Empty) - -- <construct 1> <- Start - -- - -- In this case, the algorithm has exhausted a list, Curr is Empty, and - -- the owner of the list is consumed (5.1). - -- - -- 6) Transitioning from unit to unit - -- - -- A package body with a spec subject to pragma Elaborate_Body extends - -- the possible range of the early call region to the package spec. - -- - -- package Pack is <- Curr (6.3) - -- pragma Elaborate_Body; <- Curr (6.2) - -- <visible declarations> <- Curr (6.2) - -- private - -- <private declarations> <- Curr (6.1) - -- end Pack; - -- - -- package body Pack is <- Curr, Start - -- - -- In this case, the algorithm has reached a package body compilation - -- unit whose spec is subject to pragma Elaborate_Body, or the caller - -- of the algorithm has specified this behavior. This transition is - -- equivalent to 3). - -- - -- 7) Transitioning from unit to termination - -- - -- Reaching a compilation unit always terminates the algorithm as there - -- are no more lists to examine. This must take 6) into account. - -- - -- 8) Transitioning from subunit to stub - -- - -- package body Pack is separate; <- Curr (8.1) - -- - -- separate (...) - -- package body Pack is <- Curr, Start - -- - -- Reaching a subunit continues the search from the corresponding stub - -- (8.1). - - procedure Advance (Curr : in out Node_Id); - pragma Inline (Advance); - -- Update the Curr and Start pointers depending on their location in the - -- tree to the next eligible construct. This routine raises ECR_Found. - - procedure Enter_Handled_Body (Curr : in out Node_Id); - pragma Inline (Enter_Handled_Body); - -- Update the Curr and Start pointers to enter a nested handled body if - -- applicable. This routine raises ECR_Found. - - procedure Enter_Package_Declaration (Curr : in out Node_Id); - pragma Inline (Enter_Package_Declaration); - -- Update the Curr and Start pointers to enter a nested package spec if - -- applicable. This routine raises ECR_Found. - - function Find_ECR (N : Node_Id) return Node_Id; - pragma Inline (Find_ECR); - -- Find an early call region starting from arbitrary node N - - function Has_Suitable_Construct (List : List_Id) return Boolean; - pragma Inline (Has_Suitable_Construct); - -- Determine whether list List contains at least one suitable construct - -- for inclusion into an early call region. - - procedure Include (N : Node_Id; Curr : out Node_Id); - pragma Inline (Include); - -- Update the Curr and Start pointers to include arbitrary construct N - -- in the early call region. This routine raises ECR_Found. - - function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; - pragma Inline (Is_OK_Preelaborable_Construct); - -- Determine whether arbitrary node N denotes a preelaboration-safe - -- construct. - - function Is_Suitable_Construct (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Construct); - -- Determine whether arbitrary node N denotes a suitable construct for - -- inclusion into the early call region. - - procedure Transition_Body_Declarations - (Bod : Node_Id; - Curr : out Node_Id); - pragma Inline (Transition_Body_Declarations); - -- Update the Curr and Start pointers when construct Bod denotes a block - -- statement or a suitable body. This routine raises ECR_Found. - - procedure Transition_Handled_Statements - (HSS : Node_Id; - Curr : out Node_Id); - pragma Inline (Transition_Handled_Statements); - -- Update the Curr and Start pointers when node HSS denotes a handled - -- sequence of statements. This routine raises ECR_Found. - - procedure Transition_Spec_Declarations - (Spec : Node_Id; - Curr : out Node_Id); - pragma Inline (Transition_Spec_Declarations); - -- Update the Curr and Start pointers when construct Spec denotes - -- a concurrent definition or a package spec. This routine raises - -- ECR_Found. - - procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); - pragma Inline (Transition_Unit); - -- Update the Curr and Start pointers when node Unit denotes a potential - -- compilation unit. This routine raises ECR_Found. + -- Otherwise the construct must be preelaborable. The check must + -- take the syntactic and semantic structure of the construct. DO + -- NOT use Is_Preelaborable_Construct here. - ------------- - -- Advance -- - ------------- + return not Is_Non_Preelaborable_Construct (N); + end Is_OK_Preelaborable_Construct; - procedure Advance (Curr : in out Node_Id) is - Context : Node_Id; + --------------------------- + -- Is_Suitable_Construct -- + --------------------------- - begin - -- Curr denotes one of the following cases upon entry into this - -- routine: - -- - -- * Empty - There is no current construct when a declarative or a - -- statement list has been exhausted. This does not necessarily - -- indicate that the early call region has been computed as it - -- may still be possible to transition to another list. - -- - -- * Encapsulator - The current construct encapsulates declarations - -- and/or statements. This indicates that the early call region - -- may extend within the nested construct. - -- - -- * Preelaborable - The current construct is always preelaborable - -- because Find_ECR would not invoke Advance if this was not the - -- case. + function Is_Suitable_Construct (N : Node_Id) return Boolean is + Context : constant Node_Id := Parent (N); - -- The current construct is an encapsulator or is preelaborable + begin + -- An internally-generated statement sequence which contains only + -- a single null statement is not a suitable construct because it + -- is a byproduct of the parser. Such a null statement should be + -- excluded from the early call region because it carries the + -- source location of the "end" keyword, and may lead to confusing + -- diagnistics. + + if Nkind (N) = N_Null_Statement + and then not Comes_From_Source (N) + and then Present (Context) + and then Nkind (Context) = N_Handled_Sequence_Of_Statements + then + return False; + end if; - if Present (Curr) then + -- Otherwise only constructs which correspond to pure Ada + -- constructs are considered suitable. + + case Nkind (N) is + when N_Call_Marker + | N_Freeze_Entity + | N_Freeze_Generic_Entity + | N_Implicit_Label_Declaration + | N_Itype_Reference + | N_Pop_Constraint_Error_Label + | N_Pop_Program_Error_Label + | N_Pop_Storage_Error_Label + | N_Push_Constraint_Error_Label + | N_Push_Program_Error_Label + | N_Push_Storage_Error_Label + | N_SCIL_Dispatch_Table_Tag_Init + | N_SCIL_Dispatching_Call + | N_SCIL_Membership_Test + | N_Variable_Reference_Marker + => + return False; - -- Enter encapsulators by inspecting their declarations and/or - -- statements. + when others => + return True; + end case; + end Is_Suitable_Construct; - if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then - Enter_Handled_Body (Curr); + ---------------------------------- + -- Transition_Body_Declarations -- + ---------------------------------- - elsif Nkind (Curr) = N_Package_Declaration then - Enter_Package_Declaration (Curr); + procedure Transition_Body_Declarations + (Bod : Node_Id; + Curr : out Node_Id) + is + Decls : constant List_Id := Declarations (Bod); - -- Early call regions have a property which can be exploited to - -- optimize the algorithm. - -- - -- <preceding subprogram body> - -- <preelaborable construct 1> - -- ... - -- <preelaborable construct N> - -- <initiating subprogram body> - -- - -- If a traversal initiated from a subprogram body reaches a - -- preceding subprogram body, then both bodies share the same - -- early call region. - -- - -- The property results in the following desirable effects: - -- - -- * If the preceding body already has an early call region, then - -- the initiating body can reuse it. This minimizes the amount - -- of processing performed by the algorithm. + begin + -- The search must come from the declarations of the body + + pragma Assert + (Is_Non_Empty_List (Decls) + and then List_Containing (Start) = Decls); + + -- The search finished inspecting the declarations. The construct + -- to inspect is the node which precedes the handled body, unless + -- the body is a compilation unit. The transitions are: -- - -- * If the preceding body lack an early call region, then the - -- algorithm can compute the early call region, and reuse it - -- for the initiating body. This processing performs the same - -- amount of work, but has the beneficial effect of computing - -- the early call regions of all preceding bodies. - - elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then - Start := - Find_Early_Call_Region - (Body_Decl => Curr, - Assume_Elab_Body => Assume_Elab_Body, - Skip_Memoization => Skip_Memoization); + -- declarations -> upper level + -- declarations -> corresponding package spec (Elab_Body) + -- declarations -> terminate - raise ECR_Found; + Transition_Unit (Bod, Curr); + end Transition_Body_Declarations; - -- Otherwise current construct is preelaborable. Unpdate the early - -- call region to include it. + ----------------------------------- + -- Transition_Handled_Statements -- + ----------------------------------- - else - Include (Curr, Curr); - end if; + procedure Transition_Handled_Statements + (HSS : Node_Id; + Curr : out Node_Id) + is + Bod : constant Node_Id := Parent (HSS); + Decls : constant List_Id := Declarations (Bod); + Stmts : constant List_Id := Statements (HSS); - -- Otherwise the current construct is missing, indicating that the - -- current list has been exhausted. Depending on the context of the - -- list, several transitions are possible. + begin + -- The search must come from the statements of certain bodies or + -- statements. - else - -- The invariant of the algorithm ensures that Curr and Start are - -- at the same level of nesting at the point of a transition. The - -- algorithm can determine which list the traversal came from by - -- examining Start. + pragma Assert (Nkind_In (Bod, N_Block_Statement, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body)); - Context := Parent (Start); + -- The search must come from the statements of the handled + -- sequence. - -- Attempt the following transitions: + pragma Assert + (Is_Non_Empty_List (Stmts) + and then List_Containing (Start) = Stmts); + + -- The search finished inspecting the statements. The handled body + -- has non-empty declarations. The construct to inspect is the + -- last declaration. The transitions are: -- - -- private declarations -> visible declarations - -- private declarations -> upper level - -- private declarations -> terminate - -- visible declarations -> upper level - -- visible declarations -> terminate + -- statements -> declarations - if Nkind_In (Context, N_Package_Specification, - N_Protected_Definition, - N_Task_Definition) - then - Transition_Spec_Declarations (Context, Curr); + if Has_Suitable_Construct (Decls) then + Curr := Last (Decls); - -- Attempt the following transitions: + -- Otherwise the handled body lacks declarations. The construct to + -- inspect is the node which precedes the handled body, unless the + -- body is a compilation unit. The transitions are: -- - -- statements -> declarations -- statements -> upper level -- statements -> corresponding package spec (Elab_Body) -- statements -> terminate - elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then - Transition_Handled_Statements (Context, Curr); + else + Transition_Unit (Bod, Curr); + end if; + end Transition_Handled_Statements; + + ---------------------------------- + -- Transition_Spec_Declarations -- + ---------------------------------- + + procedure Transition_Spec_Declarations + (Spec : Node_Id; + Curr : out Node_Id) + is + Prv_Decls : constant List_Id := Private_Declarations (Spec); + Vis_Decls : constant List_Id := Visible_Declarations (Spec); + + begin + pragma Assert (Present (Start) and then Is_List_Member (Start)); - -- Attempt the following transitions: + -- The search came from the private declarations and finished + -- their inspection. + + if Has_Suitable_Construct (Prv_Decls) + and then List_Containing (Start) = Prv_Decls + then + -- The context has non-empty visible declarations. The node to + -- inspect is the last visible declaration. The transitions + -- are: + -- + -- private declarations -> visible declarations + + if Has_Suitable_Construct (Vis_Decls) then + Curr := Last (Vis_Decls); + + -- Otherwise the context lacks visible declarations. The + -- construct to inspect is the node which precedes the context + -- unless the context is a compilation unit. The transitions + -- are: + -- + -- private declarations -> upper level + -- private declarations -> terminate + + else + Transition_Unit (Parent (Spec), Curr); + end if; + + -- The search came from the visible declarations and finished + -- their inspections. The construct to inspect is the node which + -- precedes the context, unless the context is a compilaton unit. + -- The transitions are: -- - -- declarations -> upper level - -- declarations -> corresponding package spec (Elab_Body) - -- declarations -> terminate + -- visible declarations -> upper level + -- visible declarations -> terminate - elsif Nkind_In (Context, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) + elsif Has_Suitable_Construct (Vis_Decls) + and then List_Containing (Start) = Vis_Decls then - Transition_Body_Declarations (Context, Curr); + Transition_Unit (Parent (Spec), Curr); - -- Otherwise it is not possible to transition. Stop the search - -- because there are no more declarations or statements to check. + -- At this point both declarative lists are empty, but the + -- traversal still came from within the spec. This indicates + -- that the invariant of the algorithm has been violated. else + pragma Assert (False); raise ECR_Found; end if; - end if; - end Advance; + end Transition_Spec_Declarations; - -------------------------- - -- Enter_Handled_Body -- - -------------------------- + --------------------- + -- Transition_Unit -- + --------------------- - procedure Enter_Handled_Body (Curr : in out Node_Id) is - Decls : constant List_Id := Declarations (Curr); - HSS : constant Node_Id := Handled_Statement_Sequence (Curr); - Stmts : List_Id := No_List; + procedure Transition_Unit + (Unit : Node_Id; + Curr : out Node_Id) + is + Context : constant Node_Id := Parent (Unit); - begin - if Present (HSS) then - Stmts := Statements (HSS); - end if; + begin + -- The unit is a compilation unit. This terminates the search + -- because there are no more lists to inspect and there are no + -- more enclosing constructs to climb up to. + + if Nkind (Context) = N_Compilation_Unit then + + -- A package body with a corresponding spec subject to pragma + -- Elaborate_Body is an exception to the above. The annotation + -- allows the search to continue into the package declaration. + -- The transitions are: + -- + -- statements -> corresponding package spec (Elab_Body) + -- declarations -> corresponding package spec (Elab_Body) + + if Nkind (Unit) = N_Package_Body + and then (Assume_Elab_Body + or else Has_Pragma_Elaborate_Body + (Corresponding_Spec (Unit))) + then + Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); + Enter_Package_Declaration (Curr); - -- The handled body has a non-empty statement sequence. The construct - -- to inspect is the last statement. + -- Otherwise terminate the search. The transitions are: + -- + -- private declarations -> terminate + -- visible declarations -> terminate + -- statements -> terminate + -- declarations -> terminate - if Has_Suitable_Construct (Stmts) then - Curr := Last (Stmts); + else + raise ECR_Found; + end if; - -- The handled body lacks statements, but has non-empty declarations. - -- The construct to inspect is the last declaration. + -- The unit is a subunit. The construct to inspect is the node + -- which precedes the corresponding stub. Update the early call + -- region to include the unit. - elsif Has_Suitable_Construct (Decls) then - Curr := Last (Decls); + elsif Nkind (Context) = N_Subunit then + Start := Unit; + Curr := Corresponding_Stub (Context); - -- Otherwise the handled body lacks both declarations and statements. - -- The construct to inspect is the node which precedes the handled - -- body. Update the early call region to include the handled body. + -- Otherwise the unit is nested. The construct to inspect is the + -- node which precedes the unit. Update the early call region to + -- include the unit. - else - Include (Curr, Curr); - end if; - end Enter_Handled_Body; + else + Include (Unit, Curr); + end if; + end Transition_Unit; - ------------------------------- - -- Enter_Package_Declaration -- - ------------------------------- + -- Local variables + + Body_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl); + Region : Node_Id; - procedure Enter_Package_Declaration (Curr : in out Node_Id) is - Pack_Spec : constant Node_Id := Specification (Curr); - Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); - Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); + -- Start of processing for Find_Early_Call_Region begin - -- The package has a non-empty private declarations. The construct to - -- inspect is the last private declaration. + -- The caller demands the start of the early call region without + -- saving or retrieving it to/from internal data structures. - if Has_Suitable_Construct (Prv_Decls) then - Curr := Last (Prv_Decls); + if Skip_Memoization then + Region := Find_ECR (Body_Decl); - -- The package lacks private declarations, but has non-empty visible - -- declarations. In this case the construct to inspect is the last - -- visible declaration. + -- Default behavior - elsif Has_Suitable_Construct (Vis_Decls) then - Curr := Last (Vis_Decls); + else + -- Check whether the early call region of the subprogram body is + -- available. - -- Otherwise the package lacks any declarations. The construct to - -- inspect is the node which precedes the package. Update the early - -- call region to include the package declaration. + Region := Early_Call_Region (Body_Id); - else - Include (Curr, Curr); + if No (Region) then + Region := Find_ECR (Body_Decl); + + -- Associate the early call region with the subprogram body in + -- case other scenarios need it. + + Set_Early_Call_Region (Body_Id, Region); + end if; end if; - end Enter_Package_Declaration; - -------------- - -- Find_ECR -- - -------------- + -- A subprogram body must always have an early call region + + pragma Assert (Present (Region)); - function Find_ECR (N : Node_Id) return Node_Id is - Curr : Node_Id; + return Region; + end Find_Early_Call_Region; + -------------------------------------------- + -- Initialize_Early_Call_Region_Processor -- + -------------------------------------------- + + procedure Initialize_Early_Call_Region_Processor is begin - -- The early call region starts at N + Early_Call_Regions_Map := ECR_Map.Create (100); + end Initialize_Early_Call_Region_Processor; - Curr := Prev (N); - Start := N; + --------------------------- + -- Set_Early_Call_Region -- + --------------------------- - -- Inspect each node in reverse declarative order while going in and - -- out of nested and enclosing constructs. Note that the only way to - -- terminate this infinite loop is to raise exception ECR_Found. + procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is + pragma Assert (Present (Body_Id)); + pragma Assert (Present (Start)); - loop - -- The current construct is not preelaboration-safe. Terminate the - -- traversal. + begin + ECR_Map.Put (Early_Call_Regions_Map, Body_Id, Start); + end Set_Early_Call_Region; + end Early_Call_Region_Processor; - if Present (Curr) - and then not Is_OK_Preelaborable_Construct (Curr) - then - raise ECR_Found; + ---------------------- + -- Elaborated_Units -- + ---------------------- + + package body Elaborated_Units is + + ----------- + -- Types -- + ----------- + + -- The following type idenfities the elaboration attributes of a unit + + type Elaboration_Attributes_Id is new Natural; + + No_Elaboration_Attributes : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Id'First; + First_Elaboration_Attributes : constant Elaboration_Attributes_Id := + No_Elaboration_Attributes + 1; + + -- The following type represents the elaboration attributes of a unit + + type Elaboration_Attributes_Record is record + Elab_Pragma : Node_Id := Empty; + -- This attribute denotes a source Elaborate or Elaborate_All pragma + -- which guarantees the prior elaboration of some unit with respect + -- to the main unit. The pragma may come from the following contexts: + -- + -- * The main unit + -- * The spec of the main unit (if applicable) + -- * Any parent spec of the main unit (if applicable) + -- * Any parent subunit of the main unit (if applicable) + -- + -- The attribute remains Empty if no such pragma is available. Source + -- pragmas play a role in satisfying SPARK elaboration requirements. + + With_Clause : Node_Id := Empty; + -- This attribute denotes an internally-generated or a source with + -- clause for some unit withed by the main unit. With clauses carry + -- flags which represent implicit Elaborate or Elaborate_All pragmas. + -- These clauses play a role in supplying elaboration dependencies to + -- binde. + end record; + + --------------------- + -- Data structures -- + --------------------- + + -- The following table stores all elaboration attributes + + package Elaboration_Attributes is new Table.Table + (Table_Index_Type => Elaboration_Attributes_Id, + Table_Component_Type => Elaboration_Attributes_Record, + Table_Low_Bound => First_Elaboration_Attributes, + Table_Initial => 250, + Table_Increment => 200, + Table_Name => "Elaboration_Attributes"); + + procedure Destroy (EA_Id : in out Elaboration_Attributes_Id); + -- Destroy elaboration attributes EA_Id + + package UA_Map is new Dynamic_Hash_Tables + (Key_Type => Entity_Id, + Value_Type => Elaboration_Attributes_Id, + No_Value => No_Elaboration_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy, + Hash => Hash); + + -- The following map relates an elaboration attributes of a unit to the + -- unit. + + Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := + UA_Map.Create (250); + + ------------------ + -- Constructors -- + ------------------ + + function Elaboration_Attributes_Of + (Unit_Id : Entity_Id) return Elaboration_Attributes_Id; + pragma Inline (Elaboration_Attributes_Of); + -- Obtain the elaboration attributes of unit Unit_Id + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Elab_Pragma (EA_Id : Elaboration_Attributes_Id) return Node_Id; + pragma Inline (Elab_Pragma); + -- Obtain the Elaborate[_All] pragma of elaboration attributes EA_Id + + procedure Ensure_Prior_Elaboration_Dynamic + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State); + pragma Inline (Ensure_Prior_Elaboration_Dynamic); + -- Guarantee the elaboration of unit Unit_Id with respect to the main + -- unit by suggesting the use of Elaborate[_All] with name Prag_Nam. N + -- denotes the related scenario. In_State is the current state of the + -- Processing phase. + + procedure Ensure_Prior_Elaboration_Static + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State); + pragma Inline (Ensure_Prior_Elaboration_Static); + -- Guarantee the elaboration of unit Unit_Id with respect to the main + -- unit by installing an implicit Elaborate[_All] pragma with name + -- Prag_Nam. N denotes the related scenario. In_State is the current + -- state of the Processing phase. + + function Present (EA_Id : Elaboration_Attributes_Id) return Boolean; + pragma Inline (Present); + -- Determine whether elaboration attributes UA_Id exist + + procedure Set_Elab_Pragma + (EA_Id : Elaboration_Attributes_Id; + Prag : Node_Id); + pragma Inline (Set_Elab_Pragma); + -- Set the Elaborate[_All] pragma of elaboration attributes EA_Id to + -- Prag. + + procedure Set_With_Clause + (EA_Id : Elaboration_Attributes_Id; + Clause : Node_Id); + pragma Inline (Set_With_Clause); + -- Set the with clause of elaboration attributes EA_Id to Clause + + function With_Clause (EA_Id : Elaboration_Attributes_Id) return Node_Id; + pragma Inline (With_Clause); + -- Obtain the implicit or source with clause of elaboration attributes + -- EA_Id. + + ------------------------------ + -- Collect_Elaborated_Units -- + ------------------------------ + + procedure Collect_Elaborated_Units is + procedure Add_Pragma (Prag : Node_Id); + pragma Inline (Add_Pragma); + -- Determine whether pragma Prag denotes a legal Elaborate[_All] + -- pragma. If this is the case, add the related unit to the context. + -- For pragma Elaborate_All, include recursively all units withed by + -- the related unit. + + procedure Add_Unit + (Unit_Id : Entity_Id; + Prag : Node_Id; + Full_Context : Boolean); + pragma Inline (Add_Unit); + -- Add unit Unit_Id to the elaboration context. Prag denotes the + -- pragma which prompted the inclusion of the unit to the context. + -- If flag Full_Context is set, examine the nonlimited clauses of + -- unit Unit_Id and add each withed unit to the context. + + procedure Find_Elaboration_Context (Comp_Unit : Node_Id); + pragma Inline (Find_Elaboration_Context); + -- Examine the context items of compilation unit Comp_Unit for + -- suitable elaboration-related pragmas and add all related units + -- to the context. + + ---------------- + -- Add_Pragma -- + ---------------- + + procedure Add_Pragma (Prag : Node_Id) is + Prag_Args : constant List_Id := + Pragma_Argument_Associations (Prag); + Prag_Nam : constant Name_Id := Pragma_Name (Prag); + Unit_Arg : Node_Id; + + begin + -- Nothing to do if the pragma is not related to elaboration + + if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then + return; + + -- Nothing to do when the pragma is illegal + + elsif Error_Posted (Prag) then + return; end if; - -- Advance to the next suitable construct. This may terminate the - -- traversal by raising ECR_Found. + Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); - Advance (Curr); - end loop; + -- The argument of the pragma may appear in package.package form - exception - when ECR_Found => - return Start; - end Find_ECR; + if Nkind (Unit_Arg) = N_Selected_Component then + Unit_Arg := Selector_Name (Unit_Arg); + end if; - ---------------------------- - -- Has_Suitable_Construct -- - ---------------------------- + Add_Unit + (Unit_Id => Entity (Unit_Arg), + Prag => Prag, + Full_Context => Prag_Nam = Name_Elaborate_All); + end Add_Pragma; - function Has_Suitable_Construct (List : List_Id) return Boolean is - Item : Node_Id; + -------------- + -- Add_Unit -- + -------------- - begin - -- Examine the list in reverse declarative order, looking for a - -- suitable construct. + procedure Add_Unit + (Unit_Id : Entity_Id; + Prag : Node_Id; + Full_Context : Boolean) + is + Clause : Node_Id; + EA_Id : Elaboration_Attributes_Id; + Unit_Prag : Node_Id; - if Present (List) then - Item := Last (List); - while Present (Item) loop - if Is_Suitable_Construct (Item) then - return True; + begin + -- Nothing to do when some previous error left a with clause or a + -- pragma in a bad state. + + if No (Unit_Id) then + return; + end if; + + EA_Id := Elaboration_Attributes_Of (Unit_Id); + Unit_Prag := Elab_Pragma (EA_Id); + + -- The unit is already included in the context by means of pragma + -- Elaborate[_All]. + + if Present (Unit_Prag) then + + -- Upgrade an existing pragma Elaborate when the unit is + -- subject to Elaborate_All because the new pragma covers a + -- larger set of units. + + if Pragma_Name (Unit_Prag) = Name_Elaborate + and then Pragma_Name (Prag) = Name_Elaborate_All + then + Set_Elab_Pragma (EA_Id, Prag); + + -- Otherwise the unit retains its existing pragma and does not + -- need to be included in the context again. + + else + return; end if; - Prev (Item); - end loop; - end if; + -- Otherwise the current unit is not included in the context - return False; - end Has_Suitable_Construct; + else + Set_Elab_Pragma (EA_Id, Prag); + end if; - ------------- - -- Include -- - ------------- + -- Includes all units withed by the current one when computing the + -- full context. - procedure Include (N : Node_Id; Curr : out Node_Id) is - begin - Start := N; + if Full_Context then - -- The input node is a compilation unit. This terminates the search - -- because there are no more lists to inspect and there are no more - -- enclosing constructs to climb up to. The transitions are: - -- - -- private declarations -> terminate - -- visible declarations -> terminate - -- statements -> terminate - -- declarations -> terminate + -- Process all nonlimited with clauses found in the context of + -- the current unit. Note that limited clauses do not impose an + -- elaboration order. - if Nkind (Parent (Start)) = N_Compilation_Unit then - raise ECR_Found; + Clause := First (Context_Items (Compilation_Unit (Unit_Id))); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then not Error_Posted (Clause) + and then not Limited_Present (Clause) + then + Add_Unit + (Unit_Id => Entity (Name (Clause)), + Prag => Prag, + Full_Context => Full_Context); + end if; - -- Otherwise the input node is still within some list + Next (Clause); + end loop; + end if; + end Add_Unit; - else - Curr := Prev (Start); - end if; - end Include; + ------------------------------ + -- Find_Elaboration_Context -- + ------------------------------ - ----------------------------------- - -- Is_OK_Preelaborable_Construct -- - ----------------------------------- + procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is + pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); - function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is - begin - -- Assignment statements are acceptable as long as they were produced - -- by the ABE mechanism to update elaboration flags. + Prag : Node_Id; - if Nkind (N) = N_Assignment_Statement then - return Is_Elaboration_Code (N); + begin + -- Process all elaboration-related pragmas found in the context of + -- the compilation unit. + + Prag := First (Context_Items (Comp_Unit)); + while Present (Prag) loop + if Nkind (Prag) = N_Pragma then + Add_Pragma (Prag); + end if; - -- Block statements are acceptable even though they directly violate - -- preelaborability. The intention is not to penalize the early call - -- region when a block contains only preelaborable constructs. + Next (Prag); + end loop; + end Find_Elaboration_Context; + + -- Local variables + + Par_Id : Entity_Id; + Unit_Id : Node_Id; + + -- Start of processing for Collect_Elaborated_Units + + begin + -- Perform a traversal to examines the context of the main unit. The + -- traversal performs the following jumps: -- - -- declare - -- Val : constant Integer := 1; - -- begin - -- pragma Assert (Val = 1); - -- null; - -- end; + -- subunit -> parent subunit + -- parent subunit -> body + -- body -> spec + -- spec -> parent spec + -- parent spec -> grandparent spec and so on -- - -- Note that the Advancement phase does enter blocks, and will detect - -- any non-preelaborable declarations or statements within. + -- The traversal relies on units rather than scopes because the scope + -- of a subunit is some spec, while this traversal must process the + -- body as well. Given that protected and task bodies can also be + -- subunits, this complicates the scope approach even further. - elsif Nkind (N) = N_Block_Statement then - return True; - end if; + Unit_Id := Unit (Cunit (Main_Unit)); - -- Otherwise the construct must be preelaborable. The check must take - -- the syntactic and semantic structure of the construct. DO NOT use - -- Is_Preelaborable_Construct here. + -- Perform the following traversals when the main unit is a subunit + -- + -- subunit -> parent subunit + -- parent subunit -> body - return not Is_Non_Preelaborable_Construct (N); - end Is_OK_Preelaborable_Construct; + while Present (Unit_Id) and then Nkind (Unit_Id) = N_Subunit loop + Find_Elaboration_Context (Parent (Unit_Id)); - --------------------------- - -- Is_Suitable_Construct -- - --------------------------- + -- Continue the traversal by going to the unit which contains the + -- corresponding stub. - function Is_Suitable_Construct (N : Node_Id) return Boolean is - Context : constant Node_Id := Parent (N); + if Present (Corresponding_Stub (Unit_Id)) then + Unit_Id := + Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unit_Id)))); - begin - -- An internally-generated statement sequence which contains only a - -- single null statement is not a suitable construct because it is a - -- byproduct of the parser. Such a null statement should be excluded - -- from the early call region because it carries the source location - -- of the "end" keyword, and may lead to confusing diagnistics. + -- Otherwise the subunit may be erroneous or left in a bad state + + else + exit; + end if; + end loop; + + -- Perform the following traversal now that subunits have been taken + -- care of, or the main unit is a body. + -- + -- body -> spec - if Nkind (N) = N_Null_Statement - and then not Comes_From_Source (N) - and then Present (Context) - and then Nkind (Context) = N_Handled_Sequence_Of_Statements + if Present (Unit_Id) + and then Nkind_In (Unit_Id, N_Package_Body, N_Subprogram_Body) then - return False; + Find_Elaboration_Context (Parent (Unit_Id)); + + -- Continue the traversal by going to the unit which contains the + -- corresponding spec. + + if Present (Corresponding_Spec (Unit_Id)) then + Unit_Id := + Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unit_Id)))); + end if; end if; - -- Otherwise only constructs which correspond to pure Ada constructs - -- are considered suitable. + -- Perform the following traversals now that the body has been taken + -- care of, or the main unit is a spec. + -- + -- spec -> parent spec + -- parent spec -> grandparent spec and so on + + if Present (Unit_Id) + and then Nkind_In (Unit_Id, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Subprogram_Declaration) + then + Find_Elaboration_Context (Parent (Unit_Id)); - case Nkind (N) is - when N_Call_Marker - | N_Freeze_Entity - | N_Freeze_Generic_Entity - | N_Implicit_Label_Declaration - | N_Itype_Reference - | N_Pop_Constraint_Error_Label - | N_Pop_Program_Error_Label - | N_Pop_Storage_Error_Label - | N_Push_Constraint_Error_Label - | N_Push_Program_Error_Label - | N_Push_Storage_Error_Label - | N_SCIL_Dispatch_Table_Tag_Init - | N_SCIL_Dispatching_Call - | N_SCIL_Membership_Test - | N_Variable_Reference_Marker - => - return False; + -- Process a potential chain of parent units which ends with the + -- main unit spec. The traversal can now safely rely on the scope + -- chain. - when others => - return True; - end case; - end Is_Suitable_Construct; + Par_Id := Scope (Defining_Entity (Unit_Id)); + while Present (Par_Id) and then Par_Id /= Standard_Standard loop + Find_Elaboration_Context (Compilation_Unit (Par_Id)); - ---------------------------------- - -- Transition_Body_Declarations -- - ---------------------------------- + Par_Id := Scope (Par_Id); + end loop; + end if; + end Collect_Elaborated_Units; - procedure Transition_Body_Declarations - (Bod : Node_Id; - Curr : out Node_Id) + ------------- + -- Destroy -- + ------------- + + procedure Destroy (EA_Id : in out Elaboration_Attributes_Id) is + pragma Unreferenced (EA_Id); + begin + null; + end Destroy; + + ----------------- + -- Elab_Pragma -- + ----------------- + + function Elab_Pragma + (EA_Id : Elaboration_Attributes_Id) return Node_Id is - Decls : constant List_Id := Declarations (Bod); + pragma Assert (Present (EA_Id)); + begin + return Elaboration_Attributes.Table (EA_Id).Elab_Pragma; + end Elab_Pragma; + + ------------------------------- + -- Elaboration_Attributes_Of -- + ------------------------------- + + function Elaboration_Attributes_Of + (Unit_Id : Entity_Id) return Elaboration_Attributes_Id + is + EA_Id : Elaboration_Attributes_Id; begin - -- The search must come from the declarations of the body + EA_Id := UA_Map.Get (Unit_To_Attributes_Map, Unit_Id); - pragma Assert - (Is_Non_Empty_List (Decls) - and then List_Containing (Start) = Decls); + -- The unit lacks elaboration attributes. This indicates that the + -- unit is encountered for the first time. Create the elaboration + -- attributes for it. - -- The search finished inspecting the declarations. The construct - -- to inspect is the node which precedes the handled body, unless - -- the body is a compilation unit. The transitions are: - -- - -- declarations -> upper level - -- declarations -> corresponding package spec (Elab_Body) - -- declarations -> terminate + if not Present (EA_Id) then + Elaboration_Attributes.Append + ((Elab_Pragma => Empty, + With_Clause => Empty)); + EA_Id := Elaboration_Attributes.Last; - Transition_Unit (Bod, Curr); - end Transition_Body_Declarations; + -- Associate the elaboration attributes with the unit - ----------------------------------- - -- Transition_Handled_Statements -- - ----------------------------------- + UA_Map.Put (Unit_To_Attributes_Map, Unit_Id, EA_Id); + end if; + + pragma Assert (Present (EA_Id)); + + return EA_Id; + end Elaboration_Attributes_Of; - procedure Transition_Handled_Statements - (HSS : Node_Id; - Curr : out Node_Id) + ------------------------------ + -- Ensure_Prior_Elaboration -- + ------------------------------ + + procedure Ensure_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State) is - Bod : constant Node_Id := Parent (HSS); - Decls : constant List_Id := Declarations (Bod); - Stmts : constant List_Id := Statements (HSS); + pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); begin - -- The search must come from the statements of certain bodies or - -- statements. + -- Nothing to do when the need for prior elaboration came from a + -- partial finalization routine which occurs in an initialization + -- context. This behaviour parallels that of the old ABE mechanism. - pragma Assert (Nkind_In (Bod, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body)); + if In_State.Within_Partial_Finalization then + return; - -- The search must come from the statements of the handled sequence + -- Nothing to do when the need for prior elaboration came from a task + -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on + -- task bodies) is in effect. - pragma Assert - (Is_Non_Empty_List (Stmts) - and then List_Containing (Start) = Stmts); + elsif Debug_Flag_Dot_Y and then In_State.Within_Task_Body then + return; - -- The search finished inspecting the statements. The handled body - -- has non-empty declarations. The construct to inspect is the last - -- declaration. The transitions are: + -- Nothing to do when the unit is elaborated prior to the main unit. + -- This check must also consider the following cases: + -- + -- * No check is made against the context of the main unit because + -- this is specific to the elaboration model in effect and requires + -- custom handling (see Ensure_xxx_Prior_Elaboration). + -- + -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma + -- Elaborate[_All] MUST be generated even though Unit_Id is always + -- elaborated prior to the main unit. This conservative strategy + -- ensures that other units withed by Unit_Id will not lead to an + -- ABE. + -- + -- package A is package body A is + -- procedure ABE; procedure ABE is ... end ABE; + -- end A; end A; + -- + -- with A; + -- package B is package body B is + -- pragma Elaborate_Body; procedure Proc is + -- begin + -- procedure Proc; A.ABE; + -- package B; end Proc; + -- end B; -- - -- statements -> declarations + -- with B; + -- package C is package body C is + -- ... ... + -- end C; begin + -- B.Proc; + -- end C; + -- + -- In the example above, the elaboration of C invokes B.Proc. B is + -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] + -- is gnerated for B in C, then the following elaboratio order will + -- lead to an ABE: + -- + -- spec of A elaborated + -- spec of B elaborated + -- body of B elaborated + -- spec of C elaborated + -- body of C elaborated <-- calls B.Proc which calls A.ABE + -- body of A elaborated <-- problem + -- + -- The generation of an implicit pragma Elaborate_All (B) ensures + -- that the elaboration order mechanism will not pick the above + -- order. + -- + -- An implicit Elaborate is NOT generated when the unit is subject + -- to Elaborate_Body because both pragmas have the same effect. + -- + -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] + -- MUST NOT be generated in this case because a unit cannot depend + -- on its own elaboration. This case is therefore treated as valid + -- prior elaboration. + + elsif Has_Prior_Elaboration + (Unit_Id => Unit_Id, + Same_Unit_OK => True, + Elab_Body_OK => Prag_Nam = Name_Elaborate) + then + return; + end if; - if Has_Suitable_Construct (Decls) then - Curr := Last (Decls); + -- Suggest the use of pragma Prag_Nam when the dynamic model is in + -- effect. - -- Otherwise the handled body lacks declarations. The construct to - -- inspect is the node which precedes the handled body, unless the - -- body is a compilation unit. The transitions are: - -- - -- statements -> upper level - -- statements -> corresponding package spec (Elab_Body) - -- statements -> terminate + if Dynamic_Elaboration_Checks then + Ensure_Prior_Elaboration_Dynamic + (N => N, + Unit_Id => Unit_Id, + Prag_Nam => Prag_Nam, + In_State => In_State); + + -- Install an implicit pragma Prag_Nam when the static model is in + -- effect. else - Transition_Unit (Bod, Curr); + pragma Assert (Static_Elaboration_Checks); + + Ensure_Prior_Elaboration_Static + (N => N, + Unit_Id => Unit_Id, + Prag_Nam => Prag_Nam, + In_State => In_State); end if; - end Transition_Handled_Statements; + end Ensure_Prior_Elaboration; - ---------------------------------- - -- Transition_Spec_Declarations -- - ---------------------------------- + -------------------------------------- + -- Ensure_Prior_Elaboration_Dynamic -- + -------------------------------------- - procedure Transition_Spec_Declarations - (Spec : Node_Id; - Curr : out Node_Id) + procedure Ensure_Prior_Elaboration_Dynamic + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State) is - Prv_Decls : constant List_Id := Private_Declarations (Spec); - Vis_Decls : constant List_Id := Visible_Declarations (Spec); + procedure Info_Missing_Pragma; + pragma Inline (Info_Missing_Pragma); + -- Output information concerning missing Elaborate or Elaborate_All + -- pragma with name Prag_Nam for scenario N, which would ensure the + -- prior elaboration of Unit_Id. - begin - pragma Assert (Present (Start) and then Is_List_Member (Start)); + ------------------------- + -- Info_Missing_Pragma -- + ------------------------- - -- The search came from the private declarations and finished their - -- inspection. + procedure Info_Missing_Pragma is + begin + -- Internal units are ignored as they cause unnecessary noise - if Has_Suitable_Construct (Prv_Decls) - and then List_Containing (Start) = Prv_Decls - then - -- The context has non-empty visible declarations. The node to - -- inspect is the last visible declaration. The transitions are: - -- - -- private declarations -> visible declarations + if not In_Internal_Unit (Unit_Id) then - if Has_Suitable_Construct (Vis_Decls) then - Curr := Last (Vis_Decls); + -- The name of the unit subjected to the elaboration pragma is + -- fully qualified to improve the clarity of the info message. - -- Otherwise the context lacks visible declarations. The construct - -- to inspect is the node which precedes the context unless the - -- context is a compilation unit. The transitions are: - -- - -- private declarations -> upper level - -- private declarations -> terminate + Error_Msg_Name_1 := Prag_Nam; + Error_Msg_Qual_Level := Nat'Last; - else - Transition_Unit (Parent (Spec), Curr); + Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); + Error_Msg_Qual_Level := 0; end if; + end Info_Missing_Pragma; - -- The search came from the visible declarations and finished their - -- inspections. The construct to inspect is the node which precedes - -- the context, unless the context is a compilaton unit. The - -- transitions are: - -- - -- visible declarations -> upper level - -- visible declarations -> terminate + -- Local variables - elsif Has_Suitable_Construct (Vis_Decls) - and then List_Containing (Start) = Vis_Decls - then - Transition_Unit (Parent (Spec), Curr); + EA_Id : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Of (Unit_Id); + N_Lvl : Enclosing_Level_Kind; + N_Rep : Scenario_Rep_Id; - -- At this point both declarative lists are empty, but the traversal - -- still came from within the spec. This indicates that the invariant - -- of the algorithm has been violated. + -- Start of processing for Ensure_Prior_Elaboration_Dynamic - else - pragma Assert (False); - raise ECR_Found; + begin + -- Nothing to do when the unit is guaranteed prior elaboration by + -- means of a source Elaborate[_All] pragma. + + if Present (Elab_Pragma (EA_Id)) then + return; end if; - end Transition_Spec_Declarations; - --------------------- - -- Transition_Unit -- - --------------------- + -- Output extra information on a missing Elaborate[_All] pragma when + -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas + -- is in effect. - procedure Transition_Unit - (Unit : Node_Id; - Curr : out Node_Id) - is - Context : constant Node_Id := Parent (Unit); + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + N_Rep := Scenario_Representation_Of (N, In_State); + N_Lvl := Level (N_Rep); - begin - -- The unit is a compilation unit. This terminates the search because - -- there are no more lists to inspect and there are no more enclosing - -- constructs to climb up to. + -- Declaration-level scenario - if Nkind (Context) = N_Compilation_Unit then + if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) + and then N_Lvl = Declaration_Level + then + null; - -- A package body with a corresponding spec subject to pragma - -- Elaborate_Body is an exception to the above. The annotation - -- allows the search to continue into the package declaration. - -- The transitions are: - -- - -- statements -> corresponding package spec (Elab_Body) - -- declarations -> corresponding package spec (Elab_Body) + -- Library-level scenario - if Nkind (Unit) = N_Package_Body - and then (Assume_Elab_Body - or else Has_Pragma_Elaborate_Body - (Corresponding_Spec (Unit))) - then - Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); - Enter_Package_Declaration (Curr); + elsif N_Lvl in Library_Level then + null; - -- Otherwise terminate the search. The transitions are: - -- - -- private declarations -> terminate - -- visible declarations -> terminate - -- statements -> terminate - -- declarations -> terminate + -- Instantiation library-level scenario + + elsif N_Lvl = Instantiation_Level then + null; + + -- Otherwise the scenario does not appear at the proper level else - raise ECR_Found; + return; end if; - -- The unit is a subunit. The construct to inspect is the node which - -- precedes the corresponding stub. Update the early call region to - -- include the unit. + Info_Missing_Pragma; + end if; + end Ensure_Prior_Elaboration_Dynamic; - elsif Nkind (Context) = N_Subunit then - Start := Unit; - Curr := Corresponding_Stub (Context); + ------------------------------------- + -- Ensure_Prior_Elaboration_Static -- + ------------------------------------- - -- Otherwise the unit is nested. The construct to inspect is the node - -- which precedes the unit. Update the early call region to include - -- the unit. + procedure Ensure_Prior_Elaboration_Static + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + In_State : Processing_In_State) + is + function Find_With_Clause + (Items : List_Id; + Withed_Id : Entity_Id) return Node_Id; + pragma Inline (Find_With_Clause); + -- Find a nonlimited with clause in the list of context items Items + -- that withs unit Withed_Id. Return Empty if no such clause exists. + + procedure Info_Implicit_Pragma; + pragma Inline (Info_Implicit_Pragma); + -- Output information concerning an implicitly generated Elaborate + -- or Elaborate_All pragma with name Prag_Nam for scenario N which + -- ensures the prior elaboration of unit Unit_Id. + + ---------------------- + -- Find_With_Clause -- + ---------------------- + + function Find_With_Clause + (Items : List_Id; + Withed_Id : Entity_Id) return Node_Id + is + Item : Node_Id; - else - Include (Unit, Curr); - end if; - end Transition_Unit; + begin + -- Examine the context clauses looking for a suitable with. Note + -- that limited clauses do not affect the elaboration order. - -- Local variables + Item := First (Items); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then not Error_Posted (Item) + and then not Limited_Present (Item) + and then Entity (Name (Item)) = Withed_Id + then + return Item; + end if; - Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); - Region : Node_Id; + Next (Item); + end loop; - -- Start of processing for Find_Early_Call_Region + return Empty; + end Find_With_Clause; - begin - -- The caller demands the start of the early call region without saving - -- or retrieving it to/from internal data structures. + -------------------------- + -- Info_Implicit_Pragma -- + -------------------------- - if Skip_Memoization then - Region := Find_ECR (Body_Decl); + procedure Info_Implicit_Pragma is + begin + -- Internal units are ignored as they cause unnecessary noise - -- Default behavior + if not In_Internal_Unit (Unit_Id) then - else - -- Check whether the early call region of the subprogram body is - -- available. + -- The name of the unit subjected to the elaboration pragma is + -- fully qualified to improve the clarity of the info message. - Region := Early_Call_Region (Body_Id); + Error_Msg_Name_1 := Prag_Nam; + Error_Msg_Qual_Level := Nat'Last; - if No (Region) then + Error_Msg_NE + ("info: implicit pragma % generated for unit &", N, Unit_Id); - -- Traverse the declarations in reverse order, starting from the - -- subprogram body, searching for the nearest non-preelaborable - -- construct. The early call region starts after this construct - -- and ends at the subprogram body. + Error_Msg_Qual_Level := 0; + Output_Active_Scenarios (N, In_State); + end if; + end Info_Implicit_Pragma; - Region := Find_ECR (Body_Decl); + -- Local variables - -- Associate the early call region with the subprogram body in - -- case other scenarios need it. + EA_Id : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Of (Unit_Id); - Set_Early_Call_Region (Body_Id, Region); - end if; - end if; + Main_Cunit : constant Node_Id := Cunit (Main_Unit); + Loc : constant Source_Ptr := Sloc (Main_Cunit); + Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); + Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); + Unit_With : constant Node_Id := With_Clause (EA_Id); - -- A subprogram body must always have an early call region + Clause : Node_Id; + Items : List_Id; - pragma Assert (Present (Region)); + -- Start of processing for Ensure_Prior_Elaboration_Static - return Region; - end Find_Early_Call_Region; + begin + -- Nothing to do when the caller has suppressed the generation of + -- implicit Elaborate[_All] pragmas. - --------------------------- - -- Find_Elaborated_Units -- - --------------------------- + if In_State.Suppress_Implicit_Pragmas then + return; - procedure Find_Elaborated_Units is - procedure Add_Pragma (Prag : Node_Id); - -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma. - -- If this is the case, add the related unit to the elaboration context. - -- For pragma Elaborate_All, include recursively all units withed by the - -- related unit. + -- Nothing to do when the unit is guaranteed prior elaboration by + -- means of a source Elaborate[_All] pragma. - procedure Add_Unit - (Unit_Id : Entity_Id; - Prag : Node_Id; - Full_Context : Boolean); - -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma - -- which prompted the inclusion of the unit to the elaboration context. - -- If flag Full_Context is set, examine the nonlimited clauses of unit - -- Unit_Id and add each withed unit to the context. + elsif Present (Unit_Prag) then + return; - procedure Find_Elaboration_Context (Comp_Unit : Node_Id); - -- Examine the context items of compilation unit Comp_Unit for suitable - -- elaboration-related pragmas and add all related units to the context. + -- Nothing to do when the unit has an existing implicit Elaborate or + -- Elaborate_All pragma installed by a previous scenario. - ---------------- - -- Add_Pragma -- - ---------------- + elsif Present (Unit_With) then - procedure Add_Pragma (Prag : Node_Id) is - Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag); - Prag_Nam : constant Name_Id := Pragma_Name (Prag); - Unit_Arg : Node_Id; + -- The unit is already guaranteed prior elaboration by means of an + -- implicit Elaborate pragma, however the current scenario imposes + -- a stronger requirement of Elaborate_All. "Upgrade" the existing + -- pragma to match this new requirement. - begin - -- Nothing to do if the pragma is not related to elaboration + if Elaborate_Desirable (Unit_With) + and then Prag_Nam = Name_Elaborate_All + then + Set_Elaborate_All_Desirable (Unit_With); + Set_Elaborate_Desirable (Unit_With, False); + end if; - if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then return; + end if; - -- Nothing to do when the pragma is illegal + -- At this point it is known that the unit has no prior elaboration + -- according to pragmas and hierarchical relationships. - elsif Error_Posted (Prag) then - return; + Items := Context_Items (Main_Cunit); + + if No (Items) then + Items := New_List; + Set_Context_Items (Main_Cunit, Items); end if; - Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); + -- Locate the with clause for the unit. Note that there may not be a + -- clause if the unit is visible through a subunit-body, body-spec, + -- or spec-parent relationship. - -- The argument of the pragma may appear in package.package form + Clause := + Find_With_Clause + (Items => Items, + Withed_Id => Unit_Id); + + -- Generate: + -- with Id; - if Nkind (Unit_Arg) = N_Selected_Component then - Unit_Arg := Selector_Name (Unit_Arg); + -- Note that adding implicit with clauses is safe because analysis, + -- resolution, and expansion have already taken place and it is not + -- possible to interfere with visibility. + + if No (Clause) then + Clause := + Make_With_Clause (Loc, + Name => New_Occurrence_Of (Unit_Id, Loc)); + + Set_Implicit_With (Clause); + Set_Library_Unit (Clause, Unit_Cunit); + + Append_To (Items, Clause); end if; - Add_Unit - (Unit_Id => Entity (Unit_Arg), - Prag => Prag, - Full_Context => Prag_Nam = Name_Elaborate_All); - end Add_Pragma; + -- Mark the with clause depending on the pragma required - -------------- - -- Add_Unit -- - -------------- + if Prag_Nam = Name_Elaborate then + Set_Elaborate_Desirable (Clause); + else + Set_Elaborate_All_Desirable (Clause); + end if; + + -- The implicit Elaborate[_All] ensures the prior elaboration of + -- the unit. Include the unit in the elaboration context of the + -- main unit. + + Set_With_Clause (EA_Id, Clause); + + -- Output extra information on an implicit Elaborate[_All] pragma + -- when switch -gnatel (info messages on implicit Elaborate[_All] + -- pragmas is in effect. + + if Elab_Info_Messages then + Info_Implicit_Pragma; + end if; + end Ensure_Prior_Elaboration_Static; + + ------------------------------- + -- Finalize_Elaborated_Units -- + ------------------------------- + + procedure Finalize_Elaborated_Units is + begin + UA_Map.Destroy (Unit_To_Attributes_Map); + end Finalize_Elaborated_Units; - procedure Add_Unit + --------------------------- + -- Has_Prior_Elaboration -- + --------------------------- + + function Has_Prior_Elaboration (Unit_Id : Entity_Id; - Prag : Node_Id; - Full_Context : Boolean) + Context_OK : Boolean := False; + Elab_Body_OK : Boolean := False; + Same_Unit_OK : Boolean := False) return Boolean is - Clause : Node_Id; - Elab_Attrs : Elaboration_Attributes; + EA_Id : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Of (Unit_Id); + + Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); + Unit_With : constant Node_Id := With_Clause (EA_Id); begin - -- Nothing to do when some previous error left a with clause or a - -- pragma in a bad state. + -- A preelaborated unit is always elaborated prior to the main unit - if No (Unit_Id) then - return; + if Is_Preelaborated_Unit (Unit_Id) then + return True; + + -- An internal unit is always elaborated prior to a non-internal main + -- unit. + + elsif In_Internal_Unit (Unit_Id) + and then not In_Internal_Unit (Main_Id) + then + return True; + + -- A unit has prior elaboration if it appears within the context + -- of the main unit. Consider this case only when requested by the + -- caller. + + elsif Context_OK + and then (Present (Unit_Prag) or else Present (Unit_With)) + then + return True; + + -- A unit whose body is elaborated together with its spec has prior + -- elaboration except with respect to itself. Consider this case only + -- when requested by the caller. + + elsif Elab_Body_OK + and then Has_Pragma_Elaborate_Body (Unit_Id) + and then not Is_Same_Unit (Unit_Id, Main_Id) + then + return True; + + -- A unit has no prior elaboration with respect to itself, but does + -- not require any means of ensuring its own elaboration either. + -- Treat this case as valid prior elaboration only when requested by + -- the caller. + + elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then + return True; end if; - Elab_Attrs := Elaboration_Status (Unit_Id); + return False; + end Has_Prior_Elaboration; - -- The unit is already included in the context by means of pragma - -- Elaborate[_All]. + --------------------------------- + -- Initialize_Elaborated_Units -- + --------------------------------- - if Present (Elab_Attrs.Source_Pragma) then + procedure Initialize_Elaborated_Units is + begin + null; + end Initialize_Elaborated_Units; - -- Upgrade an existing pragma Elaborate when the unit is subject - -- to Elaborate_All because the new pragma covers a larger set of - -- units. + ---------------------------------- + -- Meet_Elaboration_Requirement -- + ---------------------------------- - if Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate - and then Pragma_Name (Prag) = Name_Elaborate_All - then - Elab_Attrs.Source_Pragma := Prag; + procedure Meet_Elaboration_Requirement + (N : Node_Id; + Targ_Id : Entity_Id; + Req_Nam : Name_Id; + In_State : Processing_In_State) + is + pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); + + Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id); - -- Otherwise the unit retains its existing pragma and does not - -- need to be included in the context again. + procedure Elaboration_Requirement_Error; + pragma Inline (Elaboration_Requirement_Error); + -- Emit an error concerning scenario N which has failed to meet the + -- elaboration requirement. + + function Find_Preelaboration_Pragma + (Prag_Nam : Name_Id) return Node_Id; + pragma Inline (Find_Preelaboration_Pragma); + -- Traverse the visible declarations of unit Unit_Id and locate a + -- source preelaboration-related pragma with name Prag_Nam. + + procedure Info_Requirement_Met (Prag : Node_Id); + pragma Inline (Info_Requirement_Met); + -- Output information concerning pragma Prag which meets requirement + -- Req_Nam. + + ----------------------------------- + -- Elaboration_Requirement_Error -- + ----------------------------------- + + procedure Elaboration_Requirement_Error is + begin + if Is_Suitable_Call (N) then + Info_Call + (Call => N, + Subp_Id => Targ_Id, + Info_Msg => False, + In_SPARK => True); + + elsif Is_Suitable_Instantiation (N) then + Info_Instantiation + (Inst => N, + Gen_Id => Targ_Id, + Info_Msg => False, + In_SPARK => True); + + elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then + Error_Msg_N + ("read of refinement constituents during elaboration in " + & "SPARK", N); + + elsif Is_Suitable_Variable_Reference (N) then + Info_Variable_Reference + (Ref => N, + Var_Id => Targ_Id, + Info_Msg => False, + In_SPARK => True); + + -- No other scenario may impose a requirement on the context of + -- the main unit. else + pragma Assert (False); return; end if; - -- The current unit is not part of the context. Prepare a new set of - -- attributes. + Error_Msg_Name_1 := Req_Nam; + Error_Msg_Node_2 := Unit_Id; + Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); - else - Elab_Attrs := - Elaboration_Attributes'(Source_Pragma => Prag, - With_Clause => Empty); - end if; + Output_Active_Scenarios (N, In_State); + end Elaboration_Requirement_Error; - -- Add or update the attributes of the unit + -------------------------------- + -- Find_Preelaboration_Pragma -- + -------------------------------- - Set_Elaboration_Status (Unit_Id, Elab_Attrs); + function Find_Preelaboration_Pragma + (Prag_Nam : Name_Id) return Node_Id + is + Spec : constant Node_Id := Parent (Unit_Id); + Decl : Node_Id; - -- Includes all units withed by the current one when computing the - -- full context. + begin + -- A preelaboration-related pragma comes from source and appears + -- at the top of the visible declarations of a package. - if Full_Context then + if Nkind (Spec) = N_Package_Specification then + Decl := First (Visible_Declarations (Spec)); + while Present (Decl) loop + if Comes_From_Source (Decl) then + if Nkind (Decl) = N_Pragma + and then Pragma_Name (Decl) = Prag_Nam + then + return Decl; - -- Process all nonlimited with clauses found in the context of - -- the current unit. Note that limited clauses do not impose an - -- elaboration order. + -- Otherwise the construct terminates the region where + -- the preelaboration-related pragma may appear. - Clause := First (Context_Items (Compilation_Unit (Unit_Id))); - while Present (Clause) loop - if Nkind (Clause) = N_With_Clause - and then not Error_Posted (Clause) - and then not Limited_Present (Clause) - then - Add_Unit - (Unit_Id => Entity (Name (Clause)), - Prag => Prag, - Full_Context => Full_Context); - end if; + else + exit; + end if; + end if; - Next (Clause); - end loop; - end if; - end Add_Unit; + Next (Decl); + end loop; + end if; - ------------------------------ - -- Find_Elaboration_Context -- - ------------------------------ + return Empty; + end Find_Preelaboration_Pragma; - procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is - Prag : Node_Id; + -------------------------- + -- Info_Requirement_Met -- + -------------------------- + + procedure Info_Requirement_Met (Prag : Node_Id) is + pragma Assert (Present (Prag)); + + begin + Error_Msg_Name_1 := Req_Nam; + Error_Msg_Sloc := Sloc (Prag); + Error_Msg_NE + ("\\% requirement for unit & met by pragma #", N, Unit_Id); + end Info_Requirement_Met; + + -- Local variables + + EA_Id : Elaboration_Attributes_Id; + Elab_Nam : Name_Id; + Req_Met : Boolean; + Unit_Prag : Node_Id; + + -- Start of processing for Meet_Elaboration_Requirement begin - pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); + -- Assume that the requirement has not been met - -- Process all elaboration-related pragmas found in the context of - -- the compilation unit. + Req_Met := False; - Prag := First (Context_Items (Comp_Unit)); - while Present (Prag) loop - if Nkind (Prag) = N_Pragma then - Add_Pragma (Prag); - end if; + -- If the target is within the main unit, either at the source level + -- or through an instantiation, then there is no real requirement to + -- meet because the main unit cannot force its own elaboration by + -- means of an Elaborate[_All] pragma. Treat this case as valid + -- coverage. - Next (Prag); - end loop; - end Find_Elaboration_Context; + if In_Extended_Main_Code_Unit (Targ_Id) then + Req_Met := True; - -- Local variables + -- Otherwise the target resides in an external unit - Par_Id : Entity_Id; - Unt : Node_Id; + -- The requirement is met when the target comes from an internal unit + -- because such a unit is elaborated prior to a non-internal unit. - -- Start of processing for Find_Elaborated_Units + elsif In_Internal_Unit (Unit_Id) + and then not In_Internal_Unit (Main_Id) + then + Req_Met := True; - begin - -- Perform a traversal which examines the context of the main unit and - -- populates the Elaboration_Context table with all units elaborated - -- prior to the main unit. The traversal performs the following jumps: + -- The requirement is met when the target comes from a preelaborated + -- unit. This portion must parallel predicate Is_Preelaborated_Unit. - -- subunit -> parent subunit - -- parent subunit -> body - -- body -> spec - -- spec -> parent spec - -- parent spec -> grandparent spec and so on + elsif Is_Preelaborated_Unit (Unit_Id) then + Req_Met := True; - -- The traversal relies on units rather than scopes because the scope of - -- a subunit is some spec, while this traversal must process the body as - -- well. Given that protected and task bodies can also be subunits, this - -- complicates the scope approach even further. + -- Output extra information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas. - Unt := Unit (Cunit (Main_Unit)); + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + if Is_Preelaborated (Unit_Id) then + Elab_Nam := Name_Preelaborate; - -- Perform the following traversals when the main unit is a subunit + elsif Is_Pure (Unit_Id) then + Elab_Nam := Name_Pure; - -- subunit -> parent subunit - -- parent subunit -> body + elsif Is_Remote_Call_Interface (Unit_Id) then + Elab_Nam := Name_Remote_Call_Interface; - while Present (Unt) and then Nkind (Unt) = N_Subunit loop - Find_Elaboration_Context (Parent (Unt)); + elsif Is_Remote_Types (Unit_Id) then + Elab_Nam := Name_Remote_Types; - -- Continue the traversal by going to the unit which contains the - -- corresponding stub. + else + pragma Assert (Is_Shared_Passive (Unit_Id)); + Elab_Nam := Name_Shared_Passive; + end if; - if Present (Corresponding_Stub (Unt)) then - Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unt)))); + Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); + end if; - -- Otherwise the subunit may be erroneous or left in a bad state + -- Determine whether the context of the main unit has a pragma strong + -- enough to meet the requirement. else - exit; - end if; - end loop; + EA_Id := Elaboration_Attributes_Of (Unit_Id); + Unit_Prag := Elab_Pragma (EA_Id); - -- Perform the following traversal now that subunits have been taken - -- care of, or the main unit is a body. + -- The pragma must be either Elaborate_All or be as strong as the + -- requirement. - -- body -> spec + if Present (Unit_Prag) + and then Nam_In (Pragma_Name (Unit_Prag), Name_Elaborate_All, + Req_Nam) + then + Req_Met := True; - if Present (Unt) - and then Nkind_In (Unt, N_Package_Body, N_Subprogram_Body) - then - Find_Elaboration_Context (Parent (Unt)); + -- Output extra information when switch -gnatel (info messages + -- on implicit Elaborate[_All] pragmas. - -- Continue the traversal by going to the unit which contains the - -- corresponding spec. + if Elab_Info_Messages + and then not In_State.Suppress_Info_Messages + then + Info_Requirement_Met (Unit_Prag); + end if; + end if; + end if; + + -- The requirement was not met by the context of the main unit, issue + -- an error. - if Present (Corresponding_Spec (Unt)) then - Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unt)))); + if not Req_Met then + Elaboration_Requirement_Error; end if; - end if; + end Meet_Elaboration_Requirement; - -- Perform the following traversals now that the body has been taken - -- care of, or the main unit is a spec. + ------------- + -- Present -- + ------------- - -- spec -> parent spec - -- parent spec -> grandparent spec and so on + function Present (EA_Id : Elaboration_Attributes_Id) return Boolean is + begin + return EA_Id /= No_Elaboration_Attributes; + end Present; - if Present (Unt) - and then Nkind_In (Unt, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Subprogram_Declaration) - then - Find_Elaboration_Context (Parent (Unt)); + --------------------- + -- Set_Elab_Pragma -- + --------------------- - -- Process a potential chain of parent units which ends with the - -- main unit spec. The traversal can now safely rely on the scope - -- chain. + procedure Set_Elab_Pragma + (EA_Id : Elaboration_Attributes_Id; + Prag : Node_Id) + is + pragma Assert (Present (EA_Id)); + begin + Elaboration_Attributes.Table (EA_Id).Elab_Pragma := Prag; + end Set_Elab_Pragma; - Par_Id := Scope (Defining_Entity (Unt)); - while Present (Par_Id) and then Par_Id /= Standard_Standard loop - Find_Elaboration_Context (Compilation_Unit (Par_Id)); + --------------------- + -- Set_With_Clause -- + --------------------- - Par_Id := Scope (Par_Id); - end loop; - end if; - end Find_Elaborated_Units; + procedure Set_With_Clause + (EA_Id : Elaboration_Attributes_Id; + Clause : Node_Id) + is + pragma Assert (Present (EA_Id)); + begin + Elaboration_Attributes.Table (EA_Id).With_Clause := Clause; + end Set_With_Clause; + + ----------------- + -- With_Clause -- + ----------------- + + function With_Clause + (EA_Id : Elaboration_Attributes_Id) return Node_Id + is + pragma Assert (Present (EA_Id)); + begin + return Elaboration_Attributes.Table (EA_Id).With_Clause; + end With_Clause; + end Elaborated_Units; ----------------------------- -- Find_Enclosing_Instance -- ----------------------------- function Find_Enclosing_Instance (N : Node_Id) return Node_Id is - Par : Node_Id; - Spec_Id : Entity_Id; + Par : Node_Id; begin -- Climb the parent chain looking for an enclosing instance spec or body Par := N; while Present (Par) loop - - -- Generic package or subprogram spec - - if Nkind_In (Par, N_Package_Declaration, + if Nkind_In (Par, N_Package_Body, + N_Package_Declaration, + N_Subprogram_Body, N_Subprogram_Declaration) - and then Is_Generic_Instance (Defining_Entity (Par)) + and then Is_Generic_Instance (Unique_Defining_Entity (Par)) then return Par; - - -- Generic package or subprogram body - - elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then - Spec_Id := Corresponding_Spec (Par); - - if Present (Spec_Id) and then Is_Generic_Instance (Spec_Id) then - return Par; - end if; end if; Par := Parent (Par); @@ -5340,6 +8833,7 @@ package body Sem_Elab is function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind; + pragma Inline (Level_Of); -- Obtain the corresponding level of unit Unit -------------- @@ -5351,13 +8845,13 @@ package body Sem_Elab is begin if Nkind (Unit) in N_Generic_Instantiation then - return Instantiation; + return Instantiation_Level; elsif Nkind (Unit) = N_Generic_Package_Declaration then - return Generic_Package_Spec; + return Generic_Spec_Level; elsif Nkind (Unit) = N_Package_Declaration then - return Package_Spec; + return Library_Spec_Level; elsif Nkind (Unit) = N_Package_Body then Spec_Id := Corresponding_Spec (Unit); @@ -5367,14 +8861,14 @@ package body Sem_Elab is if Present (Spec_Id) and then Ekind (Spec_Id) = E_Generic_Package then - return Generic_Package_Body; + return Generic_Body_Level; -- Otherwise the body belongs to a non-generic package. This also -- treats an illegal package body without a corresponding spec as -- a non-generic package body. else - return Package_Body; + return Library_Body_Level; end if; end if; @@ -5472,9 +8966,9 @@ package body Sem_Elab is end if; -- The current construct is a non-library-level encapsulator which - -- indicates that the node cannot possibly appear at any level. - -- Note that this check must come after the declaration-level check - -- because both predicates share certain nodes. + -- indicates that the node cannot possibly appear at any level. Note + -- that the check must come after the declaration-level check because + -- both predicates share certain nodes. elsif Is_Non_Library_Level_Encapsulator (Curr) then Context := Parent (Curr); @@ -5591,22 +9085,554 @@ package body Sem_Elab is return Empty; end First_Formal_Type; + ------------------------------ + -- Guaranteed_ABE_Processor -- + ------------------------------ + + package body Guaranteed_ABE_Processor is + function Is_Guaranteed_ABE + (N : Node_Id; + Target_Decl : Node_Id; + Target_Body : Node_Id) return Boolean; + pragma Inline (Is_Guaranteed_ABE); + -- Determine whether scenario N with a target described by its initial + -- declaration Target_Decl and body Target_Decl results in a guaranteed + -- ABE. + + procedure Process_Guaranteed_ABE_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Guaranteed_ABE_Activation); + -- Perform common guaranteed ABE checks and diagnostics for activation + -- call Call which activates object Obj_Id of task type Task_Typ. Formal + -- Call_Rep denotes the representation of the call. Obj_Rep denotes the + -- representation of the object. Task_Rep denotes the representation of + -- the task type. In_State is the current state of the Processing phase. + + procedure Process_Guaranteed_ABE_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Guaranteed_ABE_Call); + -- Perform common guaranteed ABE checks and diagnostics for call Call + -- with representation Call_Rep. In_State denotes the current state of + -- the Processing phase. + + procedure Process_Guaranteed_ABE_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Guaranteed_ABE_Instantiation); + -- Perform common guaranteed ABE checks and diagnostics for instance + -- Inst with representation Inst_Rep. In_State is the current state of + -- the Processing phase. + + ----------------------- + -- Is_Guaranteed_ABE -- + ----------------------- + + function Is_Guaranteed_ABE + (N : Node_Id; + Target_Decl : Node_Id; + Target_Body : Node_Id) return Boolean + is + begin + -- Avoid cascaded errors if there were previous serious infractions. + -- As a result the scenario will not be treated as a guaranteed ABE. + -- This behaviour parallels that of the old ABE mechanism. + + if Serious_Errors_Detected > 0 then + return False; + + -- The scenario and the target appear in the same context ignoring + -- enclosing library levels. + + elsif In_Same_Context (N, Target_Decl) then + + -- The target body has already been encountered. The scenario + -- results in a guaranteed ABE if it appears prior to the body. + + if Present (Target_Body) then + return Earlier_In_Extended_Unit (N, Target_Body); + + -- Otherwise the body has not been encountered yet. The scenario + -- is a guaranteed ABE since the body will appear later. It is + -- assumed that the caller has already ensured that the scenario + -- is ABE-safe because optional bodies are not considered here. + + else + return True; + end if; + end if; + + return False; + end Is_Guaranteed_ABE; + + ---------------------------- + -- Process_Guaranteed_ABE -- + ---------------------------- + + procedure Process_Guaranteed_ABE + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); + Scen_Rep : Scenario_Rep_Id; + + begin + -- Add the current scenario to the stack of active scenarios + + Push_Active_Scenario (Scen); + + -- Only calls, instantiations, and task activations may result in a + -- guaranteed ABE. + + -- Call or task activation + + if Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); + + if Kind (Scen_Rep) = Call_Scenario then + Process_Guaranteed_ABE_Call + (Call => Scen, + Call_Rep => Scen_Rep, + In_State => In_State); + + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); + + Process_Activation + (Call => Scen, + Call_Rep => Scenario_Representation_Of (Scen, In_State), + Processor => Process_Guaranteed_ABE_Activation'Access, + In_State => In_State); + end if; + + -- Instantiation + + elsif Is_Suitable_Instantiation (Scen) then + Process_Guaranteed_ABE_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); + end if; + + -- Remove the current scenario from the stack of active scenarios + -- once all ABE diagnostics and checks have been performed. + + Pop_Active_Scenario (Scen); + end Process_Guaranteed_ABE; + + --------------------------------------- + -- Process_Guaranteed_ABE_Activation -- + --------------------------------------- + + procedure Process_Guaranteed_ABE_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Obj_Rep) + and then Elaboration_Checks_OK (Task_Rep); + -- A run-time ABE check may be installed only when the object and the + -- task type have active elaboration checks, and both are not ignored + -- Ghost constructs. + + begin + -- Nothing to do when the root scenario appears at the declaration + -- level and the task is in the same unit, but outside this context. + -- + -- task type Task_Typ; -- task declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- T : Task_Typ; + -- begin + -- <activation call> -- activation site + -- end; + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- task body Task_Typ is + -- ... + -- end Task_Typ; + -- + -- In the example above, the context of X is the declarative list + -- of Proc. The "elaboration" of X may reach the activation of T + -- whose body is defined outside of X's context. The task body is + -- relevant only when Proc is invoked, but this happens only in + -- "normal" elaboration, therefore the task body must not be + -- considered if this is not the case. + + if Is_Up_Level_Target + (Targ_Decl => Spec_Decl, + In_State => In_State) + then + return; + + -- Nothing to do when the activation is ABE-safe + -- + -- generic + -- package Gen is + -- task type Task_Typ; + -- end Gen; + -- + -- package body Gen is + -- task body Task_Typ is + -- begin + -- ... + -- end Task_Typ; + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- package Nested is + -- package Inst is new Gen; + -- T : Inst.Task_Typ; + -- end Nested; -- safe activation + -- ... + + elsif Is_Safe_Activation (Call, Task_Rep) then + return; + + -- An activation call leads to a guaranteed ABE when the activation + -- call and the task appear within the same context ignoring library + -- levels, and the body of the task has not been seen yet or appears + -- after the activation call. + -- + -- procedure Guaranteed_ABE is + -- task type Task_Typ; + -- + -- package Nested is + -- T : Task_Typ; + -- <activation call> -- guaranteed ABE + -- end Nested; + -- + -- task body Task_Typ is + -- ... + -- end Task_Typ; + -- ... + + elsif Is_Guaranteed_ABE + (N => Call, + Target_Decl => Spec_Decl, + Target_Body => Body_Declaration (Task_Rep)) + then + if Elaboration_Warnings_OK (Call_Rep) then + Error_Msg_Sloc := Sloc (Call); + Error_Msg_N + ("??task & will be activated # before elaboration of its " + & "body", Obj_Id); + Error_Msg_N + ("\Program_Error will be raised at run time", Obj_Id); + end if; + + -- Mark the activation call as a guaranteed ABE + + Set_Is_Known_Guaranteed_ABE (Call); + + -- Install a run-time ABE failue because this activation call will + -- always result in an ABE. + + if Check_OK then + Install_Scenario_ABE_Failure + (N => Call, + Targ_Id => Task_Typ, + Targ_Rep => Task_Rep, + Disable => Obj_Rep); + end if; + end if; + end Process_Guaranteed_ABE_Activation; + + --------------------------------- + -- Process_Guaranteed_ABE_Call -- + --------------------------------- + + procedure Process_Guaranteed_ABE_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + Subp_Id : constant Entity_Id := Target (Call_Rep); + Subp_Rep : constant Target_Rep_Id := + Target_Representation_Of (Subp_Id, In_State); + Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Call_Rep) + and then Elaboration_Checks_OK (Subp_Rep); + -- A run-time ABE check may be installed only when both the call + -- and the target have active elaboration checks, and both are not + -- ignored Ghost constructs. + + begin + -- Nothing to do when the root scenario appears at the declaration + -- level and the target is in the same unit but outside this context. + -- + -- function B ...; -- target declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- function B ... is + -- ... + -- end B; + -- + -- In the example above, the context of X is the declarative region + -- of Proc. The "elaboration" of X may eventually reach B which is + -- defined outside of X's context. B is relevant only when Proc is + -- invoked, but this happens only by means of "normal" elaboration, + -- therefore B must not be considered if this is not the case. + + if Is_Up_Level_Target + (Targ_Decl => Spec_Decl, + In_State => In_State) + then + return; + + -- Nothing to do when the call is ABE-safe + -- + -- generic + -- function Gen ...; + -- + -- function Gen ... is + -- begin + -- ... + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- function Inst is new Gen; + -- X : ... := Inst; -- safe call + -- ... + + elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then + return; + + -- A call leads to a guaranteed ABE when the call and the target + -- appear within the same context ignoring library levels, and the + -- body of the target has not been seen yet or appears after the + -- call. + -- + -- procedure Guaranteed_ABE is + -- function Func ...; + -- + -- package Nested is + -- Obj : ... := Func; -- guaranteed ABE + -- end Nested; + -- + -- function Func ... is + -- ... + -- end Func; + -- ... + + elsif Is_Guaranteed_ABE + (N => Call, + Target_Decl => Spec_Decl, + Target_Body => Body_Declaration (Subp_Rep)) + then + if Elaboration_Warnings_OK (Call_Rep) then + Error_Msg_NE + ("??cannot call & before body seen", Call, Subp_Id); + Error_Msg_N ("\Program_Error will be raised at run time", Call); + end if; + + -- Mark the call as a guarnateed ABE + + Set_Is_Known_Guaranteed_ABE (Call); + + -- Install a run-time ABE failure because the call will always + -- result in an ABE. + + if Check_OK then + Install_Scenario_ABE_Failure + (N => Call, + Targ_Id => Subp_Id, + Targ_Rep => Subp_Rep, + Disable => Call_Rep); + end if; + end if; + end Process_Guaranteed_ABE_Call; + + ------------------------------------------ + -- Process_Guaranteed_ABE_Instantiation -- + ------------------------------------------ + + procedure Process_Guaranteed_ABE_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + Gen_Id : constant Entity_Id := Target (Inst_Rep); + Gen_Rep : constant Target_Rep_Id := + Target_Representation_Of (Gen_Id, In_State); + Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); + + Check_OK : constant Boolean := + not In_State.Suppress_Checks + and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored + and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored + and then Elaboration_Checks_OK (Inst_Rep) + and then Elaboration_Checks_OK (Gen_Rep); + -- A run-time ABE check may be installed only when both the instance + -- and the generic have active elaboration checks and both are not + -- ignored Ghost constructs. + + begin + -- Nothing to do when the root scenario appears at the declaration + -- level and the generic is in the same unit, but outside this + -- context. + -- + -- generic + -- procedure Gen is ...; -- generic declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- procedure I is new Gen; -- instantiation site + -- ... + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- procedure Gen is + -- ... + -- end Gen; + -- + -- In the example above, the context of X is the declarative region + -- of Proc. The "elaboration" of X may eventually reach Gen which + -- appears outside of X's context. Gen is relevant only when Proc is + -- invoked, but this happens only by means of "normal" elaboration, + -- therefore Gen must not be considered if this is not the case. + + if Is_Up_Level_Target + (Targ_Decl => Spec_Decl, + In_State => In_State) + then + return; + + -- Nothing to do when the instantiation is ABE-safe + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- package body Gen is + -- ... + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- package Inst is new Gen (ABE); -- safe instantiation + -- ... + + elsif Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then + return; + + -- An instantiation leads to a guaranteed ABE when the instantiation + -- and the generic appear within the same context ignoring library + -- levels, and the body of the generic has not been seen yet or + -- appears after the instantiation. + -- + -- procedure Guaranteed_ABE is + -- generic + -- procedure Gen; + -- + -- package Nested is + -- procedure Inst is new Gen; -- guaranteed ABE + -- end Nested; + -- + -- procedure Gen is + -- ... + -- end Gen; + -- ... + + elsif Is_Guaranteed_ABE + (N => Inst, + Target_Decl => Spec_Decl, + Target_Body => Body_Declaration (Gen_Rep)) + then + if Elaboration_Warnings_OK (Inst_Rep) then + Error_Msg_NE + ("??cannot instantiate & before body seen", Inst, Gen_Id); + Error_Msg_N ("\Program_Error will be raised at run time", Inst); + end if; + + -- Mark the instantiation as a guarantee ABE. This automatically + -- suppresses the instantiation of the generic body. + + Set_Is_Known_Guaranteed_ABE (Inst); + + -- Install a run-time ABE failure because the instantiation will + -- always result in an ABE. + + if Check_OK then + Install_Scenario_ABE_Failure + (N => Inst, + Targ_Id => Gen_Id, + Targ_Rep => Gen_Rep, + Disable => Inst_Rep); + end if; + end if; + end Process_Guaranteed_ABE_Instantiation; + end Guaranteed_ABE_Processor; + -------------- -- Has_Body -- -------------- function Has_Body (Pack_Decl : Node_Id) return Boolean is function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id; + pragma Inline (Find_Corresponding_Body); -- Try to locate the corresponding body of spec Spec_Id. If no body is -- found, return Empty. function Find_Body (Spec_Id : Entity_Id; From : Node_Id) return Node_Id; + pragma Inline (Find_Body); -- Try to locate the corresponding body of spec Spec_Id in the node list -- which follows arbitrary node From. If no body is found, return Empty. function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id; + pragma Inline (Load_Package_Body); -- Attempt to load the body of unit Unit_Nam. If the load failed, return -- Empty. If the compilation will not generate code, return Empty. @@ -5823,60 +9849,15 @@ package body Sem_Elab is end if; end Has_Body; - --------------------------- - -- Has_Prior_Elaboration -- - --------------------------- - - function Has_Prior_Elaboration - (Unit_Id : Entity_Id; - Context_OK : Boolean := False; - Elab_Body_OK : Boolean := False; - Same_Unit_OK : Boolean := False) return Boolean - is - Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + ---------- + -- Hash -- + ---------- + function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type is + pragma Assert (Present (NE)); begin - -- A preelaborated unit is always elaborated prior to the main unit - - if Is_Preelaborated_Unit (Unit_Id) then - return True; - - -- An internal unit is always elaborated prior to a non-internal main - -- unit. - - elsif In_Internal_Unit (Unit_Id) - and then not In_Internal_Unit (Main_Id) - then - return True; - - -- A unit has prior elaboration if it appears within the context of the - -- main unit. Consider this case only when requested by the caller. - - elsif Context_OK - and then Elaboration_Status (Unit_Id) /= No_Elaboration_Attributes - then - return True; - - -- A unit whose body is elaborated together with its spec has prior - -- elaboration except with respect to itself. Consider this case only - -- when requested by the caller. - - elsif Elab_Body_OK - and then Has_Pragma_Elaborate_Body (Unit_Id) - and then not Is_Same_Unit (Unit_Id, Main_Id) - then - return True; - - -- A unit has no prior elaboration with respect to itself, but does not - -- require any means of ensuring its own elaboration either. Treat this - -- case as valid prior elaboration only when requested by the caller. - - elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then - return True; - end if; - - return False; - end Has_Prior_Elaboration; + return Bucket_Range_Type (NE); + end Hash; -------------------------- -- In_External_Instance -- @@ -5886,26 +9867,23 @@ package body Sem_Elab is (N : Node_Id; Target_Decl : Node_Id) return Boolean is - Dummy : Node_Id; + Inst : Node_Id; Inst_Body : Node_Id; - Inst_Decl : Node_Id; + Inst_Spec : Node_Id; begin - -- Performance note: parent traversal - - Inst_Decl := Find_Enclosing_Instance (Target_Decl); + Inst := Find_Enclosing_Instance (Target_Decl); -- The target declaration appears within an instance spec. Visibility is -- ignored because internally generated primitives for private types may -- reside in the private declarations and still be invoked from outside. - if Present (Inst_Decl) - and then Nkind (Inst_Decl) = N_Package_Declaration - then + if Present (Inst) and then Nkind (Inst) = N_Package_Declaration then + -- The scenario comes from the main unit and the instance does not if In_Extended_Main_Code_Unit (N) - and then not In_Extended_Main_Code_Unit (Inst_Decl) + and then not In_Extended_Main_Code_Unit (Inst) then return True; @@ -5913,16 +9891,14 @@ package body Sem_Elab is -- body. else - Extract_Instance_Attributes - (Exp_Inst => Inst_Decl, - Inst_Body => Inst_Body, - Inst_Decl => Dummy); - - -- Performance note: parent traversal + Spec_And_Body_From_Node + (N => Inst, + Spec_Decl => Inst_Spec, + Body_Decl => Inst_Body); return not In_Subtree (N => N, - Root1 => Inst_Decl, + Root1 => Inst_Spec, Root2 => Inst_Body); end if; end if; @@ -5962,6 +9938,7 @@ package body Sem_Elab is Nested_OK : Boolean := False) return Boolean is function Find_Enclosing_Context (N : Node_Id) return Node_Id; + pragma Inline (Find_Enclosing_Context); -- Return the nearest enclosing non-library-level or compilation unit -- node which which encapsulates arbitrary node N. Return Empty is no -- such context is available. @@ -5969,6 +9946,7 @@ package body Sem_Elab is function In_Nested_Context (Outer : Node_Id; Inner : Node_Id) return Boolean; + pragma Inline (In_Nested_Context); -- Determine whether arbitrary node Outer encapsulates arbitrary node -- Inner. @@ -6084,5123 +10062,5588 @@ package body Sem_Elab is return False; end In_Same_Context; - ------------------ - -- In_Task_Body -- - ------------------ + ---------------- + -- Initialize -- + ---------------- - function In_Task_Body (N : Node_Id) return Boolean is - Par : Node_Id; + procedure Initialize is + begin + -- Set the soft link which enables Atree.Rewrite to update a scenario + -- each time it is transformed into another node. + + Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); + end Initialize; + + -------------------------- + -- Instantiated_Generic -- + -------------------------- + function Instantiated_Generic (Inst : Node_Id) return Entity_Id is begin - -- Climb the parent chain looking for a task body [procedure] + -- Traverse a possible chain of renamings to obtain the original generic + -- being instantiatied. - Par := N; - while Present (Par) loop - if Nkind (Par) = N_Task_Body then - return True; + return Get_Renamed_Entity (Entity (Name (Inst))); + end Instantiated_Generic; - elsif Nkind (Par) = N_Subprogram_Body - and then Is_Task_Body_Procedure (Par) - then - return True; + ----------------------------- + -- Internal_Representation -- + ----------------------------- - -- Prevent the search from going too far. Note that this predicate - -- shares nodes with the two cases above, and must come last. + package body Internal_Representation is - elsif Is_Body_Or_Package_Declaration (Par) then - return False; - end if; + ----------- + -- Types -- + ----------- - Par := Parent (Par); - end loop; + -- The following type represents the contents of a scenario - return False; - end In_Task_Body; + type Scenario_Rep_Record is record + Elab_Checks_OK : Boolean := False; + -- The status of elaboration checks for the scenario - ---------------- - -- Initialize -- - ---------------- + Elab_Warnings_OK : Boolean := False; + -- The status of elaboration warnings for the scenario - procedure Initialize is - begin - -- Set the soft link which enables Atree.Rewrite to update a top-level - -- scenario each time it is transformed into another node. + GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; + -- The Ghost mode of the scenario - Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); - end Initialize; + Kind : Scenario_Kind := No_Scenario; + -- The nature of the scenario - --------------- - -- Info_Call -- - --------------- + Level : Enclosing_Level_Kind := No_Level; + -- The enclosing level where the scenario resides - procedure Info_Call - (Call : Node_Id; - Target_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean) - is - procedure Info_Accept_Alternative; - pragma Inline (Info_Accept_Alternative); - -- Output information concerning an accept alternative - - procedure Info_Simple_Call; - pragma Inline (Info_Simple_Call); - -- Output information concerning the call - - procedure Info_Type_Actions (Action : String); - pragma Inline (Info_Type_Actions); - -- Output information concerning action Action of a type - - procedure Info_Verification_Call - (Pred : String; - Id : Entity_Id; - Id_Kind : String); - pragma Inline (Info_Verification_Call); - -- Output information concerning the verification of predicate Pred - -- applied to related entity Id with kind Id_Kind. + SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; + -- The SPARK mode of the scenario - ----------------------------- - -- Info_Accept_Alternative -- - ----------------------------- + Target : Entity_Id := Empty; + -- The target of the scenario - procedure Info_Accept_Alternative is - Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); + -- The following attributes are multiplexed and depend on the Kind of + -- the scenario. They are mapped as follows: + -- + -- Call_Scenario + -- Is_Dispatching_Call (Flag_1) + -- + -- Task_Activation_Scenario + -- Activated_Task_Objects (List_1) + -- Activated_Task_Type (Field_1) + -- + -- Variable_Reference + -- Is_Read_Reference (Flag_1) - begin - pragma Assert (Present (Entry_Id)); + Flag_1 : Boolean := False; + Field_1 : Node_Or_Entity_Id := Empty; + List_1 : NE_List.Doubly_Linked_List := NE_List.Nil; + end record; - Elab_Msg_NE - (Msg => "accept for entry & during elaboration", - N => Call, - Id => Entry_Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Accept_Alternative; + -- The following type represents the contents of a target - ---------------------- - -- Info_Simple_Call -- - ---------------------- + type Target_Rep_Record is record + Body_Decl : Node_Id := Empty; + -- The declaration of the target body - procedure Info_Simple_Call is - begin - Elab_Msg_NE - (Msg => "call to & during elaboration", - N => Call, - Id => Target_Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Simple_Call; + Elab_Checks_OK : Boolean := False; + -- The status of elaboration checks for the target - ----------------------- - -- Info_Type_Actions -- - ----------------------- + Elab_Warnings_OK : Boolean := False; + -- The status of elaboration warnings for the target - procedure Info_Type_Actions (Action : String) is - Typ : constant Entity_Id := First_Formal_Type (Target_Id); + GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; + -- The Ghost mode of the target - begin - pragma Assert (Present (Typ)); + Kind : Target_Kind := No_Target; + -- The nature of the target - Elab_Msg_NE - (Msg => Action & " actions for type & during elaboration", - N => Call, - Id => Typ, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Type_Actions; + SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; + -- The SPARK mode of the target - ---------------------------- - -- Info_Verification_Call -- - ---------------------------- + Spec_Decl : Node_Id := Empty; + -- The declaration of the target spec - procedure Info_Verification_Call - (Pred : String; - Id : Entity_Id; - Id_Kind : String) - is - begin - pragma Assert (Present (Id)); + Unit : Entity_Id := Empty; + -- The top unit where the target is declared - Elab_Msg_NE - (Msg => - "verification of " & Pred & " of " & Id_Kind & " & during " - & "elaboration", - N => Call, - Id => Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Verification_Call; + Version : Representation_Kind := No_Representation; + -- The version of the target representation - -- Start of processing for Info_Call + -- The following attributes are multiplexed and depend on the Kind of + -- the target. They are mapped as follows: + -- + -- Subprogram_Target + -- Barrier_Body_Declaration (Field_1) + -- + -- Variable_Target + -- Variable_Declaration (Field_1) - begin - -- Do not output anything for targets defined in internal units because - -- this creates noise. + Field_1 : Node_Or_Entity_Id := Empty; + end record; - if not In_Internal_Unit (Target_Id) then + --------------------- + -- Data structures -- + --------------------- - -- Accept alternative + procedure Destroy (T_Id : in out Target_Rep_Id); + -- Destroy a target representation T_Id + + package ETT_Map is new Dynamic_Hash_Tables + (Key_Type => Entity_Id, + Value_Type => Target_Rep_Id, + No_Value => No_Target_Rep, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy, + Hash => Hash); + + -- The following map relates target representations to entities + + Entity_To_Target_Map : ETT_Map.Dynamic_Hash_Table := + ETT_Map.Create (500); + + procedure Destroy (S_Id : in out Scenario_Rep_Id); + -- Destroy a scenario representation S_Id + + package NTS_Map is new Dynamic_Hash_Tables + (Key_Type => Node_Id, + Value_Type => Scenario_Rep_Id, + No_Value => No_Scenario_Rep, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy, + Hash => Hash); + + -- The following map relates scenario representations to nodes + + Node_To_Scenario_Map : NTS_Map.Dynamic_Hash_Table := + NTS_Map.Create (500); + + -- The following table stores all scenario representations + + package Scenario_Reps is new Table.Table + (Table_Index_Type => Scenario_Rep_Id, + Table_Component_Type => Scenario_Rep_Record, + Table_Low_Bound => First_Scenario_Rep, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "Scenario_Reps"); + + -- The following table stores all target representations + + package Target_Reps is new Table.Table + (Table_Index_Type => Target_Rep_Id, + Table_Component_Type => Target_Rep_Record, + Table_Low_Bound => First_Target_Rep, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "Target_Reps"); - if Is_Accept_Alternative_Proc (Target_Id) then - Info_Accept_Alternative; + -------------- + -- Builders -- + -------------- - -- Adjustment + function Create_Access_Taken_Rep + (Attr : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Access_Taken_Rep); + -- Create the representation of 'Access attribute Attr + + function Create_Call_Or_Task_Activation_Rep + (Call : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Call_Or_Task_Activation_Rep); + -- Create the representation of call or task activation Call + + function Create_Derived_Type_Rep + (Typ_Decl : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Derived_Type_Rep); + -- Create the representation of a derived type described by declaration + -- Typ_Decl. + + function Create_Generic_Rep + (Gen_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Generic_Rep); + -- Create the representation of generic Gen_Id + + function Create_Instantiation_Rep + (Inst : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Instantiation_Rep); + -- Create the representation of instantiation Inst + + function Create_Protected_Entry_Rep + (PE_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Protected_Entry_Rep); + -- Create the representation of protected entry PE_Id + + function Create_Protected_Subprogram_Rep + (PS_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Protected_Subprogram_Rep); + -- Create the representation of protected subprogram PS_Id + + function Create_Refined_State_Pragma_Rep + (Prag : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Refined_State_Pragma_Rep); + -- Create the representation of Refined_State pragma Prag + + function Create_Scenario_Rep + (N : Node_Id; + In_State : Processing_In_State) return Scenario_Rep_Record; + pragma Inline (Create_Scenario_Rep); + -- Top level dispatcher. Create the representation of elaboration + -- scenario N. In_State is the current state of the Processing phase. + + function Create_Subprogram_Rep + (Subp_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Subprogram_Rep); + -- Create the representation of entry, operator, or subprogram Subp_Id + + function Create_Target_Rep + (Id : Entity_Id; + In_State : Processing_In_State) return Target_Rep_Record; + pragma Inline (Create_Target_Rep); + -- Top level dispatcher. Create the representation of elaboration target + -- Id. In_State is the current state of the Processing phase. + + function Create_Task_Entry_Rep + (TE_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Task_Entry_Rep); + -- Create the representation of task entry TE_Id + + function Create_Task_Rep (Task_Typ : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Task_Rep); + -- Create the representation of task type Typ + + function Create_Variable_Assignment_Rep + (Asmt : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Variable_Assignment_Rep); + -- Create the representation of variable assignment Asmt + + function Create_Variable_Reference_Rep + (Ref : Node_Id) return Scenario_Rep_Record; + pragma Inline (Create_Variable_Reference_Rep); + -- Create the representation of variable reference Ref + + function Create_Variable_Rep + (Var_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Variable_Rep); + -- Create the representation of variable Var_Id - elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then - Info_Type_Actions ("adjustment"); + ----------------------- + -- Local subprograms -- + ----------------------- - -- Default_Initial_Condition + function Ghost_Mode_Of_Entity + (Id : Entity_Id) return Extended_Ghost_Mode; + pragma Inline (Ghost_Mode_Of_Entity); + -- Obtain the extended Ghost mode of arbitrary entity Id - elsif Is_Default_Initial_Condition_Proc (Target_Id) then - Info_Verification_Call - (Pred => "Default_Initial_Condition", - Id => First_Formal_Type (Target_Id), - Id_Kind => "type"); + function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode; + pragma Inline (Ghost_Mode_Of_Node); + -- Obtain the extended Ghost mode of arbitrary node N - -- Entries + function Present (S_Id : Scenario_Rep_Id) return Boolean; + pragma Inline (Present); + -- Determine whether scenario representation S_Id exists - elsif Is_Protected_Entry (Target_Id) then - Info_Simple_Call; + function Present (T_Id : Target_Rep_Id) return Boolean; + pragma Inline (Present); + -- Determine whether target representation T_Id exists - -- Task entry calls are never processed because the entry being - -- invoked does not have a corresponding "body", it has a select. + function SPARK_Mode_Of_Entity + (Id : Entity_Id) return Extended_SPARK_Mode; + pragma Inline (SPARK_Mode_Of_Entity); + -- Obtain the extended SPARK mode of arbitrary entity Id - elsif Is_Task_Entry (Target_Id) then - null; + function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode; + pragma Inline (SPARK_Mode_Of_Node); + -- Obtain the extended SPARK mode of arbitrary node N - -- Finalization + function To_Ghost_Mode + (Ignored_Status : Boolean) return Extended_Ghost_Mode; + pragma Inline (To_Ghost_Mode); + -- Convert a Ghost mode indicated by Ignored_Status into its extended + -- equivalent. - elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then - Info_Type_Actions ("finalization"); + function To_SPARK_Mode (On_Status : Boolean) return Extended_SPARK_Mode; + pragma Inline (To_SPARK_Mode); + -- Convert a SPARK mode indicated by On_Status into its extended + -- equivalent. - -- Calls to _Finalizer procedures must not appear in the output - -- because this creates confusing noise. + function Version (T_Id : Target_Rep_Id) return Representation_Kind; + pragma Inline (Version); + -- Obtain the version of target representation T_Id - elsif Is_Finalizer_Proc (Target_Id) then - null; + ---------------------------- + -- Activated_Task_Objects -- + ---------------------------- - -- Initial_Condition + function Activated_Task_Objects + (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List + is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Task_Activation_Scenario); - elsif Is_Initial_Condition_Proc (Target_Id) then - Info_Verification_Call - (Pred => "Initial_Condition", - Id => Find_Enclosing_Scope (Call), - Id_Kind => "package"); + begin + return Scenario_Reps.Table (S_Id).List_1; + end Activated_Task_Objects; - -- Initialization + ------------------------- + -- Activated_Task_Type -- + ------------------------- - elsif Is_Init_Proc (Target_Id) - or else Is_TSS (Target_Id, TSS_Deep_Initialize) - then - Info_Type_Actions ("initialization"); + function Activated_Task_Type + (S_Id : Scenario_Rep_Id) return Entity_Id + is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Task_Activation_Scenario); - -- Invariant + begin + return Scenario_Reps.Table (S_Id).Field_1; + end Activated_Task_Type; - elsif Is_Invariant_Proc (Target_Id) then - Info_Verification_Call - (Pred => "invariants", - Id => First_Formal_Type (Target_Id), - Id_Kind => "type"); + ------------------------------ + -- Barrier_Body_Declaration -- + ------------------------------ - -- Partial invariant calls must not appear in the output because this - -- creates confusing noise. + function Barrier_Body_Declaration + (T_Id : Target_Rep_Id) return Node_Id + is + pragma Assert (Present (T_Id)); + pragma Assert (Kind (T_Id) = Subprogram_Target); - elsif Is_Partial_Invariant_Proc (Target_Id) then - null; + begin + return Target_Reps.Table (T_Id).Field_1; + end Barrier_Body_Declaration; - -- _Postconditions + ---------------------- + -- Body_Declaration -- + ---------------------- - elsif Is_Postconditions_Proc (Target_Id) then - Info_Verification_Call - (Pred => "postconditions", - Id => Find_Enclosing_Scope (Call), - Id_Kind => "subprogram"); + function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Body_Decl; + end Body_Declaration; - -- Subprograms must come last because some of the previous cases fall - -- under this category. + ----------------------------- + -- Create_Access_Taken_Rep -- + ----------------------------- - elsif Ekind (Target_Id) = E_Function then - Info_Simple_Call; + function Create_Access_Taken_Rep + (Attr : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; + + begin + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Attr); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Attr); + Rec.GM := Is_Checked_Or_Not_Specified; + Rec.SM := SPARK_Mode_Of_Node (Attr); + Rec.Kind := Access_Taken_Scenario; + Rec.Target := Canonical_Subprogram (Entity (Prefix (Attr))); + + return Rec; + end Create_Access_Taken_Rep; + + ---------------------------------------- + -- Create_Call_Or_Task_Activation_Rep -- + ---------------------------------------- - elsif Ekind (Target_Id) = E_Procedure then - Info_Simple_Call; + function Create_Call_Or_Task_Activation_Rep + (Call : Node_Id) return Scenario_Rep_Record + is + Subp_Id : constant Entity_Id := Canonical_Subprogram (Target (Call)); + Kind : Scenario_Kind; + Rec : Scenario_Rep_Record; + begin + if Is_Activation_Proc (Subp_Id) then + Kind := Task_Activation_Scenario; else - pragma Assert (False); - null; + Kind := Call_Scenario; end if; - end if; - end Info_Call; - ------------------------ - -- Info_Instantiation -- - ------------------------ + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); + Rec.GM := Ghost_Mode_Of_Node (Call); + Rec.SM := SPARK_Mode_Of_Node (Call); + Rec.Kind := Kind; + Rec.Target := Subp_Id; - procedure Info_Instantiation - (Inst : Node_Id; - Gen_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean) - is - begin - Elab_Msg_NE - (Msg => "instantiation of & during elaboration", - N => Inst, - Id => Gen_Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Instantiation; + -- Scenario-specific attributes - ----------------------------- - -- Info_Variable_Reference -- - ----------------------------- + Rec.Flag_1 := Is_Dispatching_Call (Call); -- Dispatching_Call - procedure Info_Variable_Reference - (Ref : Node_Id; - Var_Id : Entity_Id; - Info_Msg : Boolean; - In_SPARK : Boolean) - is - begin - if Is_Read (Ref) then - Elab_Msg_NE - (Msg => "read of variable & during elaboration", - N => Ref, - Id => Var_Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end if; - end Info_Variable_Reference; + return Rec; + end Create_Call_Or_Task_Activation_Rep; - -------------------- - -- Insertion_Node -- - -------------------- + ----------------------------- + -- Create_Derived_Type_Rep -- + ----------------------------- - function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id is - begin - -- When the scenario denotes an instantiation, the proper insertion node - -- is the instance spec. This ensures that the generic actuals will not - -- be evaluated prior to a potential ABE. + function Create_Derived_Type_Rep + (Typ_Decl : Node_Id) return Scenario_Rep_Record + is + Typ : constant Entity_Id := Defining_Entity (Typ_Decl); + Rec : Scenario_Rep_Record; - if Nkind (N) in N_Generic_Instantiation - and then Present (Instance_Spec (N)) - then - return Instance_Spec (N); + begin + Rec.Elab_Checks_OK := False; -- not relevant + Rec.Elab_Warnings_OK := False; -- not relevant + Rec.GM := Ghost_Mode_Of_Entity (Typ); + Rec.SM := SPARK_Mode_Of_Entity (Typ); + Rec.Kind := Derived_Type_Scenario; + Rec.Target := Typ; + + return Rec; + end Create_Derived_Type_Rep; + + ------------------------ + -- Create_Generic_Rep -- + ------------------------ + + function Create_Generic_Rep + (Gen_Id : Entity_Id) return Target_Rep_Record + is + Rec : Target_Rep_Record; - -- Otherwise the proper insertion node is the candidate insertion node + begin + Rec.Kind := Generic_Target; - else - return Ins_Nod; - end if; - end Insertion_Node; + Spec_And_Body_From_Entity + (Id => Gen_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - ----------------------- - -- Install_ABE_Check -- - ----------------------- + return Rec; + end Create_Generic_Rep; - procedure Install_ABE_Check - (N : Node_Id; - Id : Entity_Id; - Ins_Nod : Node_Id) - is - Check_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); - -- Insert the check prior to this node + ------------------------------ + -- Create_Instantiation_Rep -- + ------------------------------ - Loc : constant Source_Ptr := Sloc (N); - Spec_Id : constant Entity_Id := Unique_Entity (Id); - Unit_Id : constant Entity_Id := Find_Top_Unit (Id); - Scop_Id : Entity_Id; + function Create_Instantiation_Rep + (Inst : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; - begin - -- Nothing to do when compiling for GNATprove because raise statements - -- are not supported. + begin + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); + Rec.GM := Ghost_Mode_Of_Node (Inst); + Rec.SM := SPARK_Mode_Of_Node (Inst); + Rec.Kind := Instantiation_Scenario; + Rec.Target := Instantiated_Generic (Inst); - if GNATprove_Mode then - return; + return Rec; + end Create_Instantiation_Rep; - -- Nothing to do when the compilation will not produce an executable + -------------------------------- + -- Create_Protected_Entry_Rep -- + -------------------------------- - elsif Serious_Errors_Detected > 0 then - return; + function Create_Protected_Entry_Rep + (PE_Id : Entity_Id) return Target_Rep_Record + is + Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PE_Id); - -- Nothing to do for a compilation unit because there is no executable - -- environment at that level. + Barf_Id : Entity_Id; + Dummy : Node_Id; + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; - elsif Nkind (Parent (Check_Ins_Nod)) = N_Compilation_Unit then - return; + begin + -- When the entry [family] has already been expanded, it carries both + -- the procedure which emulates the behavior of the entry [family] as + -- well as the barrier function. - -- Nothing to do when the unit is elaborated prior to the main unit. - -- This check must also consider the following cases: + if Present (Prot_Id) then + Barf_Id := Barrier_Function (PE_Id); + Spec_Id := Prot_Id; - -- * Id's unit appears in the context of the main unit + -- Otherwise no expansion took place - -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST - -- NOT be generated because Id's unit is always elaborated prior to - -- the main unit. + else + Barf_Id := Empty; + Spec_Id := PE_Id; + end if; - -- * Id's unit is the main unit. An ABE check MUST be generated in this - -- case because a conditional ABE may be raised depending on the flow - -- of execution within the main unit (flag Same_Unit_OK is False). + Rec.Kind := Subprogram_Target; - elsif Has_Prior_Elaboration - (Unit_Id => Unit_Id, - Context_OK => True, - Elab_Body_OK => True) - then - return; - end if; + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - -- Prevent multiple scenarios from installing the same ABE check + -- Target-specific attributes - Set_Is_Elaboration_Checks_OK_Node (N, False); + if Present (Barf_Id) then + Spec_And_Body_From_Entity + (Id => Barf_Id, + Body_Decl => Rec.Field_1, -- Barrier_Body_Declaration + Spec_Decl => Dummy); + end if; - -- Install the nearest enclosing scope of the scenario as there must be - -- something on the scope stack. + return Rec; + end Create_Protected_Entry_Rep; - -- Performance note: parent traversal + ------------------------------------- + -- Create_Protected_Subprogram_Rep -- + ------------------------------------- - Scop_Id := Find_Enclosing_Scope (Check_Ins_Nod); - pragma Assert (Present (Scop_Id)); + function Create_Protected_Subprogram_Rep + (PS_Id : Entity_Id) return Target_Rep_Record + is + Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PS_Id); + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; - Push_Scope (Scop_Id); + begin + -- When the protected subprogram has already been expanded, it + -- carries the subprogram which seizes the lock and invokes the + -- original statements. - -- Generate: - -- if not Spec_Id'Elaborated then - -- raise Program_Error with "access before elaboration"; - -- end if; + if Present (Prot_Id) then + Spec_Id := Prot_Id; - Insert_Action (Check_Ins_Nod, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Not (Loc, - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Spec_Id, Loc), - Attribute_Name => Name_Elaborated)), - Reason => PE_Access_Before_Elaboration)); + -- Otherwise no expansion took place - Pop_Scope; - end Install_ABE_Check; + else + Spec_Id := PS_Id; + end if; - ----------------------- - -- Install_ABE_Check -- - ----------------------- + Rec.Kind := Subprogram_Target; - procedure Install_ABE_Check - (N : Node_Id; - Target_Id : Entity_Id; - Target_Decl : Node_Id; - Target_Body : Node_Id; - Ins_Nod : Node_Id) - is - procedure Build_Elaboration_Entity; - pragma Inline (Build_Elaboration_Entity); - -- Create a new elaboration flag for Target_Id, insert it prior to - -- Target_Decl, and set it after Body_Decl. + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - ------------------------------ - -- Build_Elaboration_Entity -- - ------------------------------ + return Rec; + end Create_Protected_Subprogram_Rep; + + ------------------------------------- + -- Create_Refined_State_Pragma_Rep -- + ------------------------------------- - procedure Build_Elaboration_Entity is - Loc : constant Source_Ptr := Sloc (Target_Id); - Flag_Id : Entity_Id; + function Create_Refined_State_Pragma_Rep + (Prag : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; begin - -- Create the declaration of the elaboration flag. The name carries a - -- unique counter in case of name overloading. + Rec.Elab_Checks_OK := False; -- not relevant + Rec.Elab_Warnings_OK := False; -- not relevant + Rec.GM := + To_Ghost_Mode (Is_Ignored_Ghost_Pragma (Prag)); + Rec.SM := Is_Off_Or_Not_Specified; + Rec.Kind := Refined_State_Pragma_Scenario; + Rec.Target := Empty; - Flag_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Target_Id), 'E', -1)); + return Rec; + end Create_Refined_State_Pragma_Rep; - Set_Elaboration_Entity (Target_Id, Flag_Id); - Set_Elaboration_Entity_Required (Target_Id); + ------------------------- + -- Create_Scenario_Rep -- + ------------------------- - Push_Scope (Scope (Target_Id)); + function Create_Scenario_Rep + (N : Node_Id; + In_State : Processing_In_State) return Scenario_Rep_Record + is + pragma Unreferenced (In_State); - -- Generate: - -- Enn : Short_Integer := 0; + Rec : Scenario_Rep_Record; - Insert_Action (Target_Decl, - Make_Object_Declaration (Loc, - Defining_Identifier => Flag_Id, - Object_Definition => - New_Occurrence_Of (Standard_Short_Integer, Loc), - Expression => Make_Integer_Literal (Loc, Uint_0))); + begin + if Is_Suitable_Access_Taken (N) then + Rec := Create_Access_Taken_Rep (N); - -- Generate: - -- Enn := 1; + elsif Is_Suitable_Call (N) then + Rec := Create_Call_Or_Task_Activation_Rep (N); - Set_Elaboration_Flag (Target_Body, Target_Id); + elsif Is_Suitable_Instantiation (N) then + Rec := Create_Instantiation_Rep (N); - Pop_Scope; - end Build_Elaboration_Entity; + elsif Is_Suitable_SPARK_Derived_Type (N) then + Rec := Create_Derived_Type_Rep (N); - -- Local variables + elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then + Rec := Create_Refined_State_Pragma_Rep (N); - Target_Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); + elsif Is_Suitable_Variable_Assignment (N) then + Rec := Create_Variable_Assignment_Rep (N); - -- Start for processing for Install_ABE_Check + elsif Is_Suitable_Variable_Reference (N) then + Rec := Create_Variable_Reference_Rep (N); - begin - -- Nothing to do when compiling for GNATprove because raise statements - -- are not supported. + else + pragma Assert (False); + return Rec; + end if; - if GNATprove_Mode then - return; + -- Common scenario attributes - -- Nothing to do when the compilation will not produce an executable + Rec.Level := Find_Enclosing_Level (N); - elsif Serious_Errors_Detected > 0 then - return; + return Rec; + end Create_Scenario_Rep; - -- Nothing to do when the target is a protected subprogram because the - -- check is associated with the protected body subprogram. + --------------------------- + -- Create_Subprogram_Rep -- + --------------------------- - elsif Is_Protected_Subp (Target_Id) then - return; + function Create_Subprogram_Rep + (Subp_Id : Entity_Id) return Target_Rep_Record + is + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; - -- Nothing to do when the target is elaborated prior to the main unit. - -- This check must also consider the following cases: + begin + Spec_Id := Subp_Id; - -- * The unit of the target appears in the context of the main unit + -- The elaboration target denotes an internal function that returns a + -- constrained array type in a SPARK-to-C compilation. In this case + -- the function receives a corresponding procedure which has an out + -- parameter. The proper body for ABE checks and diagnostics is that + -- of the procedure. - -- * The unit of the target is subject to pragma Elaborate_Body. An ABE - -- check MUST NOT be generated because the unit is always elaborated - -- prior to the main unit. + if Ekind (Spec_Id) = E_Function + and then Rewritten_For_C (Spec_Id) + then + Spec_Id := Corresponding_Procedure (Spec_Id); + end if; - -- * The unit of the target is the main unit. An ABE check MUST be added - -- in this case because a conditional ABE may be raised depending on - -- the flow of execution within the main unit (flag Same_Unit_OK is - -- False). + Rec.Kind := Subprogram_Target; - elsif Has_Prior_Elaboration - (Unit_Id => Target_Unit_Id, - Context_OK => True, - Elab_Body_OK => True) - then - return; + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - -- Create an elaboration flag for the target when it does not have one + return Rec; + end Create_Subprogram_Rep; - elsif No (Elaboration_Entity (Target_Id)) then - Build_Elaboration_Entity; - end if; + ----------------------- + -- Create_Target_Rep -- + ----------------------- - Install_ABE_Check - (N => N, - Ins_Nod => Ins_Nod, - Id => Target_Id); - end Install_ABE_Check; + function Create_Target_Rep + (Id : Entity_Id; + In_State : Processing_In_State) return Target_Rep_Record + is + Rec : Target_Rep_Record; - ------------------------- - -- Install_ABE_Failure -- - ------------------------- + begin + if Is_Generic_Unit (Id) then + Rec := Create_Generic_Rep (Id); - procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id) is - Fail_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); - -- Insert the failure prior to this node + elsif Is_Protected_Entry (Id) then + Rec := Create_Protected_Entry_Rep (Id); - Loc : constant Source_Ptr := Sloc (N); - Scop_Id : Entity_Id; + elsif Is_Protected_Subp (Id) then + Rec := Create_Protected_Subprogram_Rep (Id); - begin - -- Nothing to do when compiling for GNATprove because raise statements - -- are not supported. + elsif Is_Task_Entry (Id) then + Rec := Create_Task_Entry_Rep (Id); - if GNATprove_Mode then - return; + elsif Is_Task_Type (Id) then + Rec := Create_Task_Rep (Id); - -- Nothing to do when the compilation will not produce an executable + elsif Ekind_In (Id, E_Constant, E_Variable) then + Rec := Create_Variable_Rep (Id); - elsif Serious_Errors_Detected > 0 then - return; + elsif Ekind_In (Id, E_Entry, + E_Function, + E_Operator, + E_Procedure) + then + Rec := Create_Subprogram_Rep (Id); - -- Do not install an ABE check for a compilation unit because there is - -- no executable environment at that level. + else + pragma Assert (False); + return Rec; + end if; - elsif Nkind (Parent (Fail_Ins_Nod)) = N_Compilation_Unit then - return; - end if; + -- Common target attributes + + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Id); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Id); + Rec.GM := Ghost_Mode_Of_Entity (Id); + Rec.SM := SPARK_Mode_Of_Entity (Id); + Rec.Unit := Find_Top_Unit (Id); + Rec.Version := In_State.Representation; + + return Rec; + end Create_Target_Rep; + + --------------------------- + -- Create_Task_Entry_Rep -- + --------------------------- - -- Prevent multiple scenarios from installing the same ABE failure + function Create_Task_Entry_Rep + (TE_Id : Entity_Id) return Target_Rep_Record + is + Task_Typ : constant Entity_Id := Non_Private_View (Scope (TE_Id)); + Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); - Set_Is_Elaboration_Checks_OK_Node (N, False); + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; + + begin + -- The the task type has already been expanded, it carries the + -- procedure which emulates the behavior of the task body. - -- Install the nearest enclosing scope of the scenario as there must be - -- something on the scope stack. + if Present (Task_Body_Id) then + Spec_Id := Task_Body_Id; - -- Performance note: parent traversal + -- Otherwise no expansion took place - Scop_Id := Find_Enclosing_Scope (Fail_Ins_Nod); - pragma Assert (Present (Scop_Id)); + else + Spec_Id := TE_Id; + end if; - Push_Scope (Scop_Id); + Rec.Kind := Subprogram_Target; - -- Generate: - -- raise Program_Error with "access before elaboration"; + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - Insert_Action (Fail_Ins_Nod, - Make_Raise_Program_Error (Loc, - Reason => PE_Access_Before_Elaboration)); + return Rec; + end Create_Task_Entry_Rep; - Pop_Scope; - end Install_ABE_Failure; + --------------------- + -- Create_Task_Rep -- + --------------------- - -------------------------------- - -- Is_Accept_Alternative_Proc -- - -------------------------------- + function Create_Task_Rep + (Task_Typ : Entity_Id) return Target_Rep_Record + is + Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); - function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a procedure with a receiving entry + Rec : Target_Rep_Record; + Spec_Id : Entity_Id; - return Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); - end Is_Accept_Alternative_Proc; + begin + -- The the task type has already been expanded, it carries the + -- procedure which emulates the behavior of the task body. - ------------------------ - -- Is_Activation_Proc -- - ------------------------ + if Present (Task_Body_Id) then + Spec_Id := Task_Body_Id; - function Is_Activation_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote one of the runtime procedures in - -- charge of task activation. + -- Otherwise no expansion took place - if Ekind (Id) = E_Procedure then - if Restricted_Profile then - return Is_RTE (Id, RE_Activate_Restricted_Tasks); else - return Is_RTE (Id, RE_Activate_Tasks); + Spec_Id := Task_Typ; end if; - end if; - return False; - end Is_Activation_Proc; + Rec.Kind := Task_Target; - ---------------------------- - -- Is_Ada_Semantic_Target -- - ---------------------------- + Spec_And_Body_From_Entity + (Id => Spec_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); - function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is - begin - return - Is_Activation_Proc (Id) - or else Is_Controlled_Proc (Id, Name_Adjust) - or else Is_Controlled_Proc (Id, Name_Finalize) - or else Is_Controlled_Proc (Id, Name_Initialize) - or else Is_Init_Proc (Id) - or else Is_Invariant_Proc (Id) - or else Is_Protected_Entry (Id) - or else Is_Protected_Subp (Id) - or else Is_Protected_Body_Subp (Id) - or else Is_Task_Entry (Id); - end Is_Ada_Semantic_Target; + return Rec; + end Create_Task_Rep; - -------------------------------- - -- Is_Assertion_Pragma_Target -- - -------------------------------- + ------------------------------------ + -- Create_Variable_Assignment_Rep -- + ------------------------------------ - function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is - begin - return - Is_Default_Initial_Condition_Proc (Id) - or else Is_Initial_Condition_Proc (Id) - or else Is_Invariant_Proc (Id) - or else Is_Partial_Invariant_Proc (Id) - or else Is_Postconditions_Proc (Id); - end Is_Assertion_Pragma_Target; + function Create_Variable_Assignment_Rep + (Asmt : Node_Id) return Scenario_Rep_Record + is + Var_Id : constant Entity_Id := Entity (Assignment_Target (Asmt)); + Rec : Scenario_Rep_Record; - ---------------------------- - -- Is_Bodiless_Subprogram -- - ---------------------------- + begin + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Asmt); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Var_Id); + Rec.GM := Ghost_Mode_Of_Node (Asmt); + Rec.SM := SPARK_Mode_Of_Node (Asmt); + Rec.Kind := Variable_Assignment_Scenario; + Rec.Target := Var_Id; - function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is - begin - -- An abstract subprogram does not have a body + return Rec; + end Create_Variable_Assignment_Rep; - if Ekind_In (Subp_Id, E_Function, - E_Operator, - E_Procedure) - and then Is_Abstract_Subprogram (Subp_Id) - then - return True; + ----------------------------------- + -- Create_Variable_Reference_Rep -- + ----------------------------------- - -- A formal subprogram does not have a body + function Create_Variable_Reference_Rep + (Ref : Node_Id) return Scenario_Rep_Record + is + Rec : Scenario_Rep_Record; - elsif Is_Formal_Subprogram (Subp_Id) then - return True; + begin + Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Ref); + Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Ref); + Rec.GM := Ghost_Mode_Of_Node (Ref); + Rec.SM := SPARK_Mode_Of_Node (Ref); + Rec.Kind := Variable_Reference_Scenario; + Rec.Target := Target (Ref); - -- An imported subprogram may have a body, however it is not known at - -- compile or bind time where the body resides and whether it will be - -- elaborated on time. + -- Scenario-specific attributes - elsif Is_Imported (Subp_Id) then - return True; - end if; + Rec.Flag_1 := Is_Read (Ref); -- Is_Read_Reference - return False; - end Is_Bodiless_Subprogram; + return Rec; + end Create_Variable_Reference_Rep; - ------------------------ - -- Is_Controlled_Proc -- - ------------------------ + ------------------------- + -- Create_Variable_Rep -- + ------------------------- - function Is_Controlled_Proc - (Subp_Id : Entity_Id; - Subp_Nam : Name_Id) return Boolean - is - Formal_Id : Entity_Id; + function Create_Variable_Rep + (Var_Id : Entity_Id) return Target_Rep_Record + is + Rec : Target_Rep_Record; - begin - pragma Assert (Nam_In (Subp_Nam, Name_Adjust, - Name_Finalize, - Name_Initialize)); + begin + Rec.Kind := Variable_Target; - -- To qualify, the subprogram must denote a source procedure with name - -- Adjust, Finalize, or Initialize where the sole formal is controlled. + -- Target-specific attributes - if Comes_From_Source (Subp_Id) - and then Ekind (Subp_Id) = E_Procedure - and then Chars (Subp_Id) = Subp_Nam - then - Formal_Id := First_Formal (Subp_Id); + Rec.Field_1 := Declaration_Node (Var_Id); -- Variable_Declaration - return - Present (Formal_Id) - and then Is_Controlled (Etype (Formal_Id)) - and then No (Next_Formal (Formal_Id)); - end if; + return Rec; + end Create_Variable_Rep; - return False; - end Is_Controlled_Proc; + ------------- + -- Destroy -- + ------------- - --------------------------------------- - -- Is_Default_Initial_Condition_Proc -- - --------------------------------------- + procedure Destroy (S_Id : in out Scenario_Rep_Id) is + pragma Unreferenced (S_Id); + begin + null; + end Destroy; - function Is_Default_Initial_Condition_Proc - (Id : Entity_Id) return Boolean - is - begin - -- To qualify, the entity must denote a Default_Initial_Condition - -- procedure. + ------------- + -- Destroy -- + ------------- - return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); - end Is_Default_Initial_Condition_Proc; + procedure Destroy (T_Id : in out Target_Rep_Id) is + pragma Unreferenced (T_Id); + begin + null; + end Destroy; - ----------------------- - -- Is_Finalizer_Proc -- - ----------------------- + -------------------------------- + -- Disable_Elaboration_Checks -- + -------------------------------- - function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a _Finalizer procedure + procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id) is + pragma Assert (Present (S_Id)); + begin + Scenario_Reps.Table (S_Id).Elab_Checks_OK := False; + end Disable_Elaboration_Checks; - return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; - end Is_Finalizer_Proc; + -------------------------------- + -- Disable_Elaboration_Checks -- + -------------------------------- - ----------------------- - -- Is_Guaranteed_ABE -- - ----------------------- + procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id) is + pragma Assert (Present (T_Id)); + begin + Target_Reps.Table (T_Id).Elab_Checks_OK := False; + end Disable_Elaboration_Checks; - function Is_Guaranteed_ABE - (N : Node_Id; - Target_Decl : Node_Id; - Target_Body : Node_Id) return Boolean - is - begin - -- Avoid cascaded errors if there were previous serious infractions. - -- As a result the scenario will not be treated as a guaranteed ABE. - -- This behaviour parallels that of the old ABE mechanism. + --------------------------- + -- Elaboration_Checks_OK -- + --------------------------- - if Serious_Errors_Detected > 0 then - return False; + function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).Elab_Checks_OK; + end Elaboration_Checks_OK; - -- The scenario and the target appear within the same context ignoring - -- enclosing library levels. + --------------------------- + -- Elaboration_Checks_OK -- + --------------------------- - -- Performance note: parent traversal + function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Elab_Checks_OK; + end Elaboration_Checks_OK; - elsif In_Same_Context (N, Target_Decl) then + ----------------------------- + -- Elaboration_Warnings_OK -- + ----------------------------- - -- The target body has already been encountered. The scenario results - -- in a guaranteed ABE if it appears prior to the body. + function Elaboration_Warnings_OK + (S_Id : Scenario_Rep_Id) return Boolean + is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).Elab_Warnings_OK; + end Elaboration_Warnings_OK; - if Present (Target_Body) then - return Earlier_In_Extended_Unit (N, Target_Body); + ----------------------------- + -- Elaboration_Warnings_OK -- + ----------------------------- - -- Otherwise the body has not been encountered yet. The scenario is - -- a guaranteed ABE since the body will appear later. It is assumed - -- that the caller has already checked whether the scenario is ABE- - -- safe as optional bodies are not considered here. + function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Elab_Warnings_OK; + end Elaboration_Warnings_OK; - else - return True; - end if; - end if; + -------------------------------------- + -- Finalize_Internal_Representation -- + -------------------------------------- - return False; - end Is_Guaranteed_ABE; + procedure Finalize_Internal_Representation is + begin + ETT_Map.Destroy (Entity_To_Target_Map); + NTS_Map.Destroy (Node_To_Scenario_Map); + end Finalize_Internal_Representation; - ------------------------------- - -- Is_Initial_Condition_Proc -- - ------------------------------- + ------------------- + -- Ghost_Mode_Of -- + ------------------- - function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote an Initial_Condition procedure + function Ghost_Mode_Of + (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode + is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).GM; + end Ghost_Mode_Of; - return - Ekind (Id) = E_Procedure and then Is_Initial_Condition_Procedure (Id); - end Is_Initial_Condition_Proc; + ------------------- + -- Ghost_Mode_Of -- + ------------------- - -------------------- - -- Is_Initialized -- - -------------------- + function Ghost_Mode_Of + (T_Id : Target_Rep_Id) return Extended_Ghost_Mode + is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).GM; + end Ghost_Mode_Of; - function Is_Initialized (Obj_Decl : Node_Id) return Boolean is - begin - -- To qualify, the object declaration must have an expression + -------------------------- + -- Ghost_Mode_Of_Entity -- + -------------------------- - return - Present (Expression (Obj_Decl)) or else Has_Init_Expression (Obj_Decl); - end Is_Initialized; + function Ghost_Mode_Of_Entity + (Id : Entity_Id) return Extended_Ghost_Mode + is + begin + return To_Ghost_Mode (Is_Ignored_Ghost_Entity (Id)); + end Ghost_Mode_Of_Entity; - ----------------------- - -- Is_Invariant_Proc -- - ----------------------- + ------------------------ + -- Ghost_Mode_Of_Node -- + ------------------------ - function Is_Invariant_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote the "full" invariant procedure + function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode is + begin + return To_Ghost_Mode (Is_Ignored_Ghost_Node (N)); + end Ghost_Mode_Of_Node; - return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); - end Is_Invariant_Proc; + ---------------------------------------- + -- Initialize_Internal_Representation -- + ---------------------------------------- - --------------------------------------- - -- Is_Non_Library_Level_Encapsulator -- - --------------------------------------- + procedure Initialize_Internal_Representation is + begin + null; + end Initialize_Internal_Representation; - function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean is - begin - case Nkind (N) is - when N_Abstract_Subprogram_Declaration - | N_Aspect_Specification - | N_Component_Declaration - | N_Entry_Body - | N_Entry_Declaration - | N_Expression_Function - | N_Formal_Abstract_Subprogram_Declaration - | N_Formal_Concrete_Subprogram_Declaration - | N_Formal_Object_Declaration - | N_Formal_Package_Declaration - | N_Formal_Type_Declaration - | N_Generic_Association - | N_Implicit_Label_Declaration - | N_Incomplete_Type_Declaration - | N_Private_Extension_Declaration - | N_Private_Type_Declaration - | N_Protected_Body - | N_Protected_Type_Declaration - | N_Single_Protected_Declaration - | N_Single_Task_Declaration - | N_Subprogram_Body - | N_Subprogram_Declaration - | N_Task_Body - | N_Task_Type_Declaration - => - return True; + ------------------------- + -- Is_Dispatching_Call -- + ------------------------- - when others => - return Is_Generic_Declaration_Or_Body (N); - end case; - end Is_Non_Library_Level_Encapsulator; + function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Call_Scenario); - ------------------------------- - -- Is_Partial_Invariant_Proc -- - ------------------------------- + begin + return Scenario_Reps.Table (S_Id).Flag_1; + end Is_Dispatching_Call; - function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote the "partial" invariant procedure + ----------------------- + -- Is_Read_Reference -- + ----------------------- - return - Ekind (Id) = E_Procedure and then Is_Partial_Invariant_Procedure (Id); - end Is_Partial_Invariant_Proc; + function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Variable_Reference_Scenario); - ---------------------------- - -- Is_Postconditions_Proc -- - ---------------------------- + begin + return Scenario_Reps.Table (S_Id).Flag_1; + end Is_Read_Reference; - function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a _Postconditions procedure + ---------- + -- Kind -- + ---------- - return - Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; - end Is_Postconditions_Proc; + function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).Kind; + end Kind; - --------------------------- - -- Is_Preelaborated_Unit -- - --------------------------- + ---------- + -- Kind -- + ---------- - function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is - begin - return - Is_Preelaborated (Id) - or else Is_Pure (Id) - or else Is_Remote_Call_Interface (Id) - or else Is_Remote_Types (Id) - or else Is_Shared_Passive (Id); - end Is_Preelaborated_Unit; + function Kind (T_Id : Target_Rep_Id) return Target_Kind is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Kind; + end Kind; - ------------------------ - -- Is_Protected_Entry -- - ------------------------ + ----------- + -- Level -- + ----------- - function Is_Protected_Entry (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote an entry defined in a protected - -- type. + function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).Level; + end Level; - return - Is_Entry (Id) - and then Is_Protected_Type (Non_Private_View (Scope (Id))); - end Is_Protected_Entry; + ------------- + -- Present -- + ------------- - ----------------------- - -- Is_Protected_Subp -- - ----------------------- + function Present (S_Id : Scenario_Rep_Id) return Boolean is + begin + return S_Id /= No_Scenario_Rep; + end Present; - function Is_Protected_Subp (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a subprogram defined within a - -- protected type. + ------------- + -- Present -- + ------------- - return - Ekind_In (Id, E_Function, E_Procedure) - and then Is_Protected_Type (Non_Private_View (Scope (Id))); - end Is_Protected_Subp; + function Present (T_Id : Target_Rep_Id) return Boolean is + begin + return T_Id /= No_Target_Rep; + end Present; - ---------------------------- - -- Is_Protected_Body_Subp -- - ---------------------------- + -------------------------------- + -- Scenario_Representation_Of -- + -------------------------------- - function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a subprogram with attribute - -- Protected_Subprogram set. + function Scenario_Representation_Of + (N : Node_Id; + In_State : Processing_In_State) return Scenario_Rep_Id + is + S_Id : Scenario_Rep_Id; - return - Ekind_In (Id, E_Function, E_Procedure) - and then Present (Protected_Subprogram (Id)); - end Is_Protected_Body_Subp; + begin + S_Id := NTS_Map.Get (Node_To_Scenario_Map, N); - -------------------------------- - -- Is_Recorded_SPARK_Scenario -- - -------------------------------- + -- The elaboration scenario lacks a representation. This indicates + -- that the scenario is encountered for the first time. Create the + -- representation of it. - function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean is - begin - if Recorded_SPARK_Scenarios_In_Use then - return Recorded_SPARK_Scenarios.Get (N); - end if; + if not Present (S_Id) then + Scenario_Reps.Append (Create_Scenario_Rep (N, In_State)); + S_Id := Scenario_Reps.Last; - return Recorded_SPARK_Scenarios_No_Element; - end Is_Recorded_SPARK_Scenario; + -- Associate the internal representation with the elaboration + -- scenario. - ------------------------------------ - -- Is_Recorded_Top_Level_Scenario -- - ------------------------------------ + NTS_Map.Put (Node_To_Scenario_Map, N, S_Id); + end if; - function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean is - begin - if Recorded_Top_Level_Scenarios_In_Use then - return Recorded_Top_Level_Scenarios.Get (N); - end if; + pragma Assert (Present (S_Id)); - return Recorded_Top_Level_Scenarios_No_Element; - end Is_Recorded_Top_Level_Scenario; + return S_Id; + end Scenario_Representation_Of; - ------------------------ - -- Is_Safe_Activation -- - ------------------------ + -------------------------------- + -- Set_Activated_Task_Objects -- + -------------------------------- - function Is_Safe_Activation - (Call : Node_Id; - Task_Decl : Node_Id) return Boolean - is - begin - -- The activation of a task coming from an external instance cannot - -- cause an ABE because the generic was already instantiated. Note - -- that the instantiation itself may lead to an ABE. + procedure Set_Activated_Task_Objects + (S_Id : Scenario_Rep_Id; + Task_Objs : NE_List.Doubly_Linked_List) + is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Task_Activation_Scenario); - return - In_External_Instance - (N => Call, - Target_Decl => Task_Decl); - end Is_Safe_Activation; + begin + Scenario_Reps.Table (S_Id).List_1 := Task_Objs; + end Set_Activated_Task_Objects; - ------------------ - -- Is_Safe_Call -- - ------------------ + ----------------------------- + -- Set_Activated_Task_Type -- + ----------------------------- - function Is_Safe_Call - (Call : Node_Id; - Target_Attrs : Target_Attributes) return Boolean - is - begin - -- The target is either an abstract subprogram, formal subprogram, or - -- imported, in which case it does not have a body at compile or bind - -- time. Assume that the call is ABE-safe. + procedure Set_Activated_Task_Type + (S_Id : Scenario_Rep_Id; + Task_Typ : Entity_Id) + is + pragma Assert (Present (S_Id)); + pragma Assert (Kind (S_Id) = Task_Activation_Scenario); - if Is_Bodiless_Subprogram (Target_Attrs.Spec_Id) then - return True; + begin + Scenario_Reps.Table (S_Id).Field_1 := Task_Typ; + end Set_Activated_Task_Type; - -- The target is an instantiation of a generic subprogram. The call - -- cannot cause an ABE because the generic was already instantiated. - -- Note that the instantiation itself may lead to an ABE. + ------------------- + -- SPARK_Mode_Of -- + ------------------- - elsif Is_Generic_Instance (Target_Attrs.Spec_Id) then - return True; + function SPARK_Mode_Of + (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode + is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).SM; + end SPARK_Mode_Of; - -- The invocation of a target coming from an external instance cannot - -- cause an ABE because the generic was already instantiated. Note that - -- the instantiation itself may lead to an ABE. + ------------------- + -- SPARK_Mode_Of -- + ------------------- - elsif In_External_Instance - (N => Call, - Target_Decl => Target_Attrs.Spec_Decl) - then - return True; + function SPARK_Mode_Of + (T_Id : Target_Rep_Id) return Extended_SPARK_Mode + is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).SM; + end SPARK_Mode_Of; - -- The target is a subprogram body without a previous declaration. The - -- call cannot cause an ABE because the body has already been seen. + -------------------------- + -- SPARK_Mode_Of_Entity -- + -------------------------- - elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body - and then No (Corresponding_Spec (Target_Attrs.Spec_Decl)) - then - return True; + function SPARK_Mode_Of_Entity + (Id : Entity_Id) return Extended_SPARK_Mode + is + Prag : constant Node_Id := SPARK_Pragma (Id); - -- The target is a subprogram body stub without a prior declaration. - -- The call cannot cause an ABE because the proper body substitutes - -- the stub. + begin + return + To_SPARK_Mode + (Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On); + end SPARK_Mode_Of_Entity; - elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body_Stub - and then No (Corresponding_Spec_Of_Stub (Target_Attrs.Spec_Decl)) - then - return True; + ------------------------ + -- SPARK_Mode_Of_Node -- + ------------------------ - -- Subprogram bodies which wrap attribute references used as actuals - -- in instantiations are always ABE-safe. These bodies are artifacts - -- of expansion. + function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode is + begin + return To_SPARK_Mode (Is_SPARK_Mode_On_Node (N)); + end SPARK_Mode_Of_Node; - elsif Present (Target_Attrs.Body_Decl) - and then Nkind (Target_Attrs.Body_Decl) = N_Subprogram_Body - and then Was_Attribute_Reference (Target_Attrs.Body_Decl) - then - return True; - end if; + ---------------------- + -- Spec_Declaration -- + ---------------------- - return False; - end Is_Safe_Call; + function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Spec_Decl; + end Spec_Declaration; - --------------------------- - -- Is_Safe_Instantiation -- - --------------------------- + ------------ + -- Target -- + ------------ - function Is_Safe_Instantiation - (Inst : Node_Id; - Gen_Attrs : Target_Attributes) return Boolean - is - begin - -- The generic is an intrinsic subprogram in which case it does not - -- have a body at compile or bind time. Assume that the instantiation - -- is ABE-safe. + function Target (S_Id : Scenario_Rep_Id) return Entity_Id is + pragma Assert (Present (S_Id)); + begin + return Scenario_Reps.Table (S_Id).Target; + end Target; - if Is_Bodiless_Subprogram (Gen_Attrs.Spec_Id) then - return True; + ------------------------------ + -- Target_Representation_Of -- + ------------------------------ - -- The instantiation of an external nested generic cannot cause an ABE - -- if the outer generic was already instantiated. Note that the instance - -- of the outer generic may lead to an ABE. + function Target_Representation_Of + (Id : Entity_Id; + In_State : Processing_In_State) return Target_Rep_Id + is + T_Id : Target_Rep_Id; - elsif In_External_Instance - (N => Inst, - Target_Decl => Gen_Attrs.Spec_Decl) - then - return True; + begin + T_Id := ETT_Map.Get (Entity_To_Target_Map, Id); - -- The generic is a package. The instantiation cannot cause an ABE when - -- the package has no body. + -- The elaboration target lacks an internal representation. This + -- indicates that the target is encountered for the first time. + -- Create the internal representation of it. - elsif Ekind (Gen_Attrs.Spec_Id) = E_Generic_Package - and then not Has_Body (Gen_Attrs.Spec_Decl) - then - return True; - end if; + if not Present (T_Id) then + Target_Reps.Append (Create_Target_Rep (Id, In_State)); + T_Id := Target_Reps.Last; - return False; - end Is_Safe_Instantiation; + -- Associate the internal representation with the elaboration + -- target. - ------------------ - -- Is_Same_Unit -- - ------------------ + ETT_Map.Put (Entity_To_Target_Map, Id, T_Id); - function Is_Same_Unit - (Unit_1 : Entity_Id; - Unit_2 : Entity_Id) return Boolean - is - begin - return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); - end Is_Same_Unit; + -- The Processing phase is working with a partially analyzed tree, + -- where various attributes become available as analysis continues. + -- This case arrises in the context of guaranteed ABE processing. + -- Update the existing representation by including new attributes. - ----------------- - -- Is_Scenario -- - ----------------- + elsif In_State.Representation = Inconsistent_Representation then + Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); - function Is_Scenario (N : Node_Id) return Boolean is - begin - case Nkind (N) is - when N_Assignment_Statement - | N_Attribute_Reference - | N_Call_Marker - | N_Entry_Call_Statement - | N_Expanded_Name - | N_Function_Call - | N_Function_Instantiation - | N_Identifier - | N_Package_Instantiation - | N_Procedure_Call_Statement - | N_Procedure_Instantiation - | N_Requeue_Statement - => - return True; + -- Otherwise the Processing phase imposes a particular representation + -- version which is not satisfied by the target. This case arrises + -- when the Processing phase switches from guaranteed ABE checks and + -- diagnostics to some other mode of operation. Update the existing + -- representation to include all attributes. - when others => - return False; - end case; - end Is_Scenario; + elsif In_State.Representation /= Version (T_Id) then + Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); + end if; - ------------------------------ - -- Is_SPARK_Semantic_Target -- - ------------------------------ + pragma Assert (Present (T_Id)); - function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is - begin - return - Is_Default_Initial_Condition_Proc (Id) - or else Is_Initial_Condition_Proc (Id); - end Is_SPARK_Semantic_Target; + return T_Id; + end Target_Representation_Of; - ------------------------ - -- Is_Suitable_Access -- - ------------------------ + ------------------- + -- To_Ghost_Mode -- + ------------------- - function Is_Suitable_Access (N : Node_Id) return Boolean is - Nam : Name_Id; - Pref : Node_Id; - Subp_Id : Entity_Id; + function To_Ghost_Mode + (Ignored_Status : Boolean) return Extended_Ghost_Mode + is + begin + if Ignored_Status then + return Is_Ignored; + else + return Is_Checked_Or_Not_Specified; + end if; + end To_Ghost_Mode; - begin - -- This scenario is relevant only when the static model is in effect - -- because it is graph-dependent and does not involve any run-time - -- checks. Allowing it in the dynamic model would create confusing - -- noise. + ------------------- + -- To_SPARK_Mode -- + ------------------- - if not Static_Elaboration_Checks then - return False; + function To_SPARK_Mode + (On_Status : Boolean) return Extended_SPARK_Mode + is + begin + if On_Status then + return Is_On; + else + return Is_Off_Or_Not_Specified; + end if; + end To_SPARK_Mode; - -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect + ---------- + -- Unit -- + ---------- - elsif Debug_Flag_Dot_UU then - return False; + function Unit (T_Id : Target_Rep_Id) return Entity_Id is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Unit; + end Unit; - -- Nothing to do when the scenario is not an attribute reference + -------------------------- + -- Variable_Declaration -- + -------------------------- - elsif Nkind (N) /= N_Attribute_Reference then - return False; + function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id is + pragma Assert (Present (T_Id)); + pragma Assert (Kind (T_Id) = Variable_Target); - -- Nothing to do for internally-generated attributes because they are - -- assumed to be ABE safe. + begin + return Target_Reps.Table (T_Id).Field_1; + end Variable_Declaration; - elsif not Comes_From_Source (N) then - return False; - end if; + ------------- + -- Version -- + ------------- - Nam := Attribute_Name (N); - Pref := Prefix (N); + function Version (T_Id : Target_Rep_Id) return Representation_Kind is + pragma Assert (Present (T_Id)); + begin + return Target_Reps.Table (T_Id).Version; + end Version; + end Internal_Representation; - -- Sanitize the prefix of the attribute + ---------------------- + -- Invocation_Graph -- + ---------------------- - if not Is_Entity_Name (Pref) then - return False; + package body Invocation_Graph is - elsif No (Entity (Pref)) then - return False; - end if; + ----------- + -- Types -- + ----------- - Subp_Id := Entity (Pref); + -- The following type represents simplified version of an invocation + -- relation. - if not Is_Subprogram_Or_Entry (Subp_Id) then - return False; - end if; + type Invoker_Target_Relation is record + Invoker : Entity_Id := Empty; + Target : Entity_Id := Empty; + end record; - -- Traverse a possible chain of renamings to obtain the original entry - -- or subprogram which the prefix may rename. + -- The following variables define the entities of the dummy elaboration + -- procedures used as origins of library level paths. - Subp_Id := Get_Renamed_Entity (Subp_Id); + Elab_Body_Id : Entity_Id := Empty; + Elab_Spec_Id : Entity_Id := Empty; - -- To qualify, the attribute must meet the following prerequisites: + --------------------- + -- Data structures -- + --------------------- - return + -- The following set contains all declared invocation constructs. It + -- ensures that the same construct is not declared multiple times in + -- the ALI file of the main unit. - -- The prefix must denote a source entry, operator, or subprogram - -- which is not imported. + Saved_Constructs_Set : NE_Set.Membership_Set := NE_Set.Nil; - Comes_From_Source (Subp_Id) - and then Is_Subprogram_Or_Entry (Subp_Id) - and then not Is_Bodiless_Subprogram (Subp_Id) + function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type; + -- Obtain the hash value of pair Key - -- The attribute name must be one of the 'Access forms. Note that - -- 'Unchecked_Access cannot apply to a subprogram. + package IR_Set is new Membership_Sets + (Element_Type => Invoker_Target_Relation, + "=" => "=", + Hash => Hash); - and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); - end Is_Suitable_Access; + -- The following set contains all recorded simple invocation relations. + -- It ensures that multiple relations involving the same invoker and + -- target do not appear in the ALI file of the main unit. - ---------------------- - -- Is_Suitable_Call -- - ---------------------- + Saved_Relations_Set : IR_Set.Membership_Set := IR_Set.Nil; - function Is_Suitable_Call (N : Node_Id) return Boolean is - begin - -- Entry and subprogram calls are intentionally ignored because they - -- may undergo expansion depending on the compilation mode, previous - -- errors, generic context, etc. Call markers play the role of calls - -- and provide a uniform foundation for ABE processing. + -------------- + -- Builders -- + -------------- - return Nkind (N) = N_Call_Marker; - end Is_Suitable_Call; + function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id; + pragma Inline (Signature_Of); + -- Obtain the invication signature id of arbitrary entity Id - ------------------------------- - -- Is_Suitable_Instantiation -- - ------------------------------- + ----------------------- + -- Local subprograms -- + ----------------------- - function Is_Suitable_Instantiation (N : Node_Id) return Boolean is - Orig_N : constant Node_Id := Original_Node (N); - -- Use the original node in case an instantiation library unit is - -- rewritten as a package or subprogram. + procedure Build_Elaborate_Body_Procedure; + pragma Inline (Build_Elaborate_Body_Procedure); + -- Create a dummy elaborate body procedure and store its entity in + -- Elab_Body_Id. + + procedure Build_Elaborate_Procedure + (Proc_Id : out Entity_Id; + Proc_Nam : Name_Id; + Loc : Source_Ptr); + pragma Inline (Build_Elaborate_Procedure); + -- Create a dummy elaborate procedure with name Proc_Nam and source + -- location Loc. The entity is returned in Proc_Id. + + procedure Build_Elaborate_Spec_Procedure; + pragma Inline (Build_Elaborate_Spec_Procedure); + -- Create a dummy elaborate spec procedure and store its entity in + -- Elab_Spec_Id. + + function Build_Subprogram_Invocation + (Subp_Id : Entity_Id) return Node_Id; + pragma Inline (Build_Subprogram_Invocation); + -- Create a dummy call marker that invokes subprogram Subp_Id + + function Build_Task_Activation + (Task_Typ : Entity_Id; + In_State : Processing_In_State) return Node_Id; + pragma Inline (Build_Task_Activation); + -- Create a dummy call marker that activates an anonymous task object of + -- type Task_Typ. + + procedure Declare_Invocation_Construct + (Constr_Id : Entity_Id; + In_State : Processing_In_State); + pragma Inline (Declare_Invocation_Construct); + -- Declare invocation construct Constr_Id by creating a declaration for + -- it in the ALI file of the main unit. In_State is the current state of + -- the Processing phase. + + function Invocation_Graph_Recording_OK return Boolean; + pragma Inline (Invocation_Graph_Recording_OK); + -- Determine whether the invocation graph can be recorded + + function Is_Invocation_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Invocation_Scenario); + -- Determine whether node N is a suitable scenario for invocation graph + -- recording purposes. + + function Is_Invocation_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Invocation_Target); + -- Determine whether arbitrary entity Id denotes an invocation target + + function Is_Saved_Construct (Constr : Entity_Id) return Boolean; + pragma Inline (Is_Saved_Construct); + -- Determine whether invocation construct Constr has already been + -- declared in the ALI file of the main unit. + + function Is_Saved_Relation + (Rel : Invoker_Target_Relation) return Boolean; + pragma Inline (Is_Saved_Relation); + -- Determine whether simple invocation relation Rel has already been + -- recorded in the ALI file of the main unit. + + procedure Process_Declarations + (Decls : List_Id; + In_State : Processing_In_State); + pragma Inline (Process_Declarations); + -- Process declaration list Decls by processing all invocation scenarios + -- within it. + + procedure Process_Freeze_Node + (Fnode : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Freeze_Node); + -- Process freeze node Fnode by processing all invocation scenarios in + -- its Actions list. + + procedure Process_Invocation_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Invocation_Activation); + -- Process activation call Call which activates object Obj_Id of task + -- type Task_Typ by processing all invocation scenarios within the task + -- body. Call_Rep is the representation of the call. Obj_Rep denotes the + -- representation of the object. Task_Rep is the representation of the + -- task type. In_State is the current state of the Processing phase. + + procedure Process_Invocation_Body_Scenarios; + pragma Inline (Process_Invocation_Body_Scenarios); + -- Process all library level body scenarios + + procedure Process_Invocation_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Invocation_Call); + -- Process invocation call scenario Call with representation Call_Rep. + -- In_State is the current state of the Processing phase. + + procedure Process_Invocation_Scenario + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Invocation_Scenario); + -- Process single invocation scenario N. In_State is the current state + -- of the Processing phase. + + procedure Process_Invocation_Scenarios + (Iter : in out NE_Set.Iterator; + In_State : Processing_In_State); + pragma Inline (Process_Invocation_Scenarios); + -- Process all invocation scenarios obtained via iterator Iter. In_State + -- is the current state of the Processing phase. + + procedure Process_Invocation_Spec_Scenarios; + pragma Inline (Process_Invocation_Spec_Scenarios); + -- Process all library level spec scenarios + + procedure Process_Main_Unit; + pragma Inline (Process_Main_Unit); + -- Process all invocation scenarios within the main unit + + procedure Process_Package_Declaration + (Pack_Decl : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Package_Declaration); + -- Process package declaration Pack_Decl by processing all invocation + -- scenarios in its visible and private declarations. If the main unit + -- contains a generic, the declarations of the body are also examined. + -- In_State is the current state of the Processing phase. + + procedure Process_Protected_Type_Declaration + (Prot_Decl : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Protected_Type_Declaration); + -- Process the declarations of protected type Prot_Decl. In_State is the + -- current state of the Processing phase. + + procedure Process_Subprogram_Declaration + (Subp_Decl : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Subprogram_Declaration); + -- Process subprogram declaration Subp_Decl by processing all invocation + -- scenarios within its body. In_State denotes the current state of the + -- Processing phase. + + procedure Process_Subprogram_Instantiation + (Inst : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Subprogram_Instantiation); + -- Process subprogram instantiation Inst. In_State is the current state + -- of the Processing phase. + + procedure Process_Task_Type_Declaration + (Task_Decl : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_Task_Type_Declaration); + -- Process task declaration Task_Decl by processing all invocation + -- scenarios within its body. In_State is the current state of the + -- Processing phase. + + procedure Record_Full_Invocation_Path (In_State : Processing_In_State); + pragma Inline (Record_Full_Invocation_Path); + -- Record all relations between scenario pairs found in the stack of + -- active scenarios. In_State is the current state of the Processing + -- phase. + + procedure Record_Invocation_Path (In_State : Processing_In_State); + pragma Inline (Record_Invocation_Path); + -- Record the invocation relations found within the path represented in + -- the active scenario stack. In_State denotes the current state of the + -- Processing phase. + + procedure Record_Simple_Invocation_Path (In_State : Processing_In_State); + pragma Inline (Record_Simple_Invocation_Path); + -- Record a single relation from the start to the end of the stack of + -- active scenarios. In_State is the current state of the Processing + -- phase. + + procedure Record_Invocation_Relation + (Invk_Id : Entity_Id; + Targ_Id : Entity_Id; + In_State : Processing_In_State); + pragma Inline (Record_Invocation_Relation); + -- Record an invocation relation with invoker Invk_Id and target Targ_Id + -- by creating an entry for it in the ALI file of the main unit. Formal + -- In_State denotes the current state of the Processing phase. + + procedure Set_Is_Saved_Construct + (Constr : Entity_Id; + Val : Boolean := True); + pragma Inline (Set_Is_Saved_Construct); + -- Mark invocation construct Constr as declared in the ALI file of the + -- main unit depending on value Val. + + procedure Set_Is_Saved_Relation + (Rel : Invoker_Target_Relation; + Val : Boolean := True); + pragma Inline (Set_Is_Saved_Relation); + -- Mark simple invocation relation Rel as recorded in the ALI file of + -- the main unit depending on value Val. + + function Target_Of + (Pos : Active_Scenario_Pos; + In_State : Processing_In_State) return Entity_Id; + pragma Inline (Target_Of); + -- Given position within the active scenario stack Pos, obtain the + -- target of the indicated scenario. In_State is the current state + -- of the Processing phase. + + procedure Traverse_Invocation_Body + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Traverse_Invocation_Body); + -- Traverse subprogram body N looking for suitable invocation scenarios + -- that need to be processed for invocation graph recording purposes. + -- In_State is the current state of the Processing phase. + + procedure Write_Invocation_Path (In_State : Processing_In_State); + pragma Inline (Write_Invocation_Path); + -- Write out a path represented by the active scenario on the stack to + -- standard output. In_State denotes the current state of the Processing + -- phase. - begin - -- To qualify, the instantiation must come from source + ------------------------------------ + -- Build_Elaborate_Body_Procedure -- + ------------------------------------ - return - Comes_From_Source (Orig_N) - and then Nkind (Orig_N) in N_Generic_Instantiation; - end Is_Suitable_Instantiation; + procedure Build_Elaborate_Body_Procedure is + Body_Decl : Node_Id; + Spec_Decl : Node_Id; - -------------------------- - -- Is_Suitable_Scenario -- - -------------------------- + begin + -- Nothing to do when a previous call already created the procedure - function Is_Suitable_Scenario (N : Node_Id) return Boolean is - begin - -- NOTE: Derived types and pragma Refined_State are intentionally left - -- out because they are not executable during elaboration. + if Present (Elab_Body_Id) then + return; + end if; - return - Is_Suitable_Access (N) - or else Is_Suitable_Call (N) - or else Is_Suitable_Instantiation (N) - or else Is_Suitable_Variable_Assignment (N) - or else Is_Suitable_Variable_Reference (N); - end Is_Suitable_Scenario; + Spec_And_Body_From_Entity + (Id => Cunit_Entity (Main_Unit), + Body_Decl => Body_Decl, + Spec_Decl => Spec_Decl); - ------------------------------------ - -- Is_Suitable_SPARK_Derived_Type -- - ------------------------------------ + pragma Assert (Present (Body_Decl)); - function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is - Prag : Node_Id; - Typ : Entity_Id; + Build_Elaborate_Procedure + (Proc_Id => Elab_Body_Id, + Proc_Nam => Name_B, + Loc => Sloc (Body_Decl)); + end Build_Elaborate_Body_Procedure; - begin - -- To qualify, the type declaration must denote a derived tagged type - -- with primitive operations, subject to pragma SPARK_Mode On. + ------------------------------- + -- Build_Elaborate_Procedure -- + ------------------------------- - if Nkind (N) = N_Full_Type_Declaration - and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition - then - Typ := Defining_Entity (N); - Prag := SPARK_Pragma (Typ); + procedure Build_Elaborate_Procedure + (Proc_Id : out Entity_Id; + Proc_Nam : Name_Id; + Loc : Source_Ptr) + is + Proc_Decl : Node_Id; + pragma Unreferenced (Proc_Decl); - return - Is_Tagged_Type (Typ) - and then Has_Primitive_Operations (Typ) - and then Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On; - end if; + begin + Proc_Id := Make_Defining_Identifier (Loc, Proc_Nam); - return False; - end Is_Suitable_SPARK_Derived_Type; + -- Partially decorate the elaboration procedure because it will not + -- be insertred into the tree and analyzed. - ------------------------------------- - -- Is_Suitable_SPARK_Instantiation -- - ------------------------------------- + Set_Ekind (Proc_Id, E_Procedure); + Set_Etype (Proc_Id, Standard_Void_Type); + Set_Scope (Proc_Id, Unique_Entity (Cunit_Entity (Main_Unit))); - function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is - Gen_Attrs : Target_Attributes; - Gen_Id : Entity_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; + -- Create a dummy declaration for the elaboration procedure. The + -- declaration does not need to be syntactically legal, but must + -- carry an accurate source location. - begin - -- To qualify, both the instantiation and the generic must be subject to - -- SPARK_Mode On. + Proc_Decl := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id), + Declarations => No_List, + Handled_Statement_Sequence => Empty); + end Build_Elaborate_Procedure; - if Is_Suitable_Instantiation (N) then - Extract_Instantiation_Attributes - (Exp_Inst => N, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + ------------------------------------ + -- Build_Elaborate_Spec_Procedure -- + ------------------------------------ - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + procedure Build_Elaborate_Spec_Procedure is + Body_Decl : Node_Id; + Spec_Decl : Node_Id; - return Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; - end if; + begin + -- Nothing to do when a previous call already created the procedure - return False; - end Is_Suitable_SPARK_Instantiation; + if Present (Elab_Spec_Id) then + return; + end if; - -------------------------------------------- - -- Is_Suitable_SPARK_Refined_State_Pragma -- - -------------------------------------------- + Spec_And_Body_From_Entity + (Id => Cunit_Entity (Main_Unit), + Body_Decl => Body_Decl, + Spec_Decl => Spec_Decl); - function Is_Suitable_SPARK_Refined_State_Pragma - (N : Node_Id) return Boolean - is - begin - -- To qualfy, the pragma must denote Refined_State + pragma Assert (Present (Spec_Decl)); - return - Nkind (N) = N_Pragma - and then Pragma_Name (N) = Name_Refined_State; - end Is_Suitable_SPARK_Refined_State_Pragma; + Build_Elaborate_Procedure + (Proc_Id => Elab_Spec_Id, + Proc_Nam => Name_S, + Loc => Sloc (Spec_Decl)); + end Build_Elaborate_Spec_Procedure; - ------------------------------------- - -- Is_Suitable_Variable_Assignment -- - ------------------------------------- + --------------------------------- + -- Build_Subprogram_Invocation -- + --------------------------------- - function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is - N_Unit : Node_Id; - N_Unit_Id : Entity_Id; - Nam : Node_Id; - Var_Decl : Node_Id; - Var_Id : Entity_Id; - Var_Unit : Node_Id; - Var_Unit_Id : Entity_Id; + function Build_Subprogram_Invocation + (Subp_Id : Entity_Id) return Node_Id + is + Marker : constant Node_Id := Make_Call_Marker (Sloc (Subp_Id)); + Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); - begin - -- This scenario is relevant only when the static model is in effect - -- because it is graph-dependent and does not involve any run-time - -- checks. Allowing it in the dynamic model would create confusing - -- noise. + begin + -- Create a dummy call marker which invokes the subprogram - if not Static_Elaboration_Checks then - return False; + Set_Is_Declaration_Level_Node (Marker, False); + Set_Is_Dispatching_Call (Marker, False); + Set_Is_Elaboration_Checks_OK_Node (Marker, False); + Set_Is_Elaboration_Warnings_OK_Node (Marker, False); + Set_Is_Ignored_Ghost_Node (Marker, False); + Set_Is_Source_Call (Marker, False); + Set_Is_SPARK_Mode_On_Node (Marker, False); - -- Nothing to do when the scenario is not an assignment + -- Invoke the uniform canonical entity of the subprogram - elsif Nkind (N) /= N_Assignment_Statement then - return False; + Set_Target (Marker, Canonical_Subprogram (Subp_Id)); - -- Nothing to do for internally-generated assignments because they are - -- assumed to be ABE safe. + -- Partially insert the marker into the tree - elsif not Comes_From_Source (N) then - return False; + Set_Parent (Marker, Parent (Subp_Decl)); - -- Assignments are ignored in GNAT mode on the assumption that they are - -- ABE-safe. This behaviour parallels that of the old ABE mechanism. + return Marker; + end Build_Subprogram_Invocation; - elsif GNAT_Mode then - return False; - end if; + --------------------------- + -- Build_Task_Activation -- + --------------------------- - Nam := Extract_Assignment_Name (N); + function Build_Task_Activation + (Task_Typ : Entity_Id; + In_State : Processing_In_State) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Task_Typ); + Marker : constant Node_Id := Make_Call_Marker (Loc); + Task_Decl : constant Node_Id := Unit_Declaration_Node (Task_Typ); - -- Sanitize the left hand side of the assignment + Activ_Id : Entity_Id; + Marker_Rep_Id : Scenario_Rep_Id; + Task_Obj : Entity_Id; + Task_Objs : NE_List.Doubly_Linked_List; - if not Is_Entity_Name (Nam) then - return False; + begin + -- Create a dummy call marker which activates some tasks - elsif No (Entity (Nam)) then - return False; - end if; + Set_Is_Declaration_Level_Node (Marker, False); + Set_Is_Dispatching_Call (Marker, False); + Set_Is_Elaboration_Checks_OK_Node (Marker, False); + Set_Is_Elaboration_Warnings_OK_Node (Marker, False); + Set_Is_Ignored_Ghost_Node (Marker, False); + Set_Is_Source_Call (Marker, False); + Set_Is_SPARK_Mode_On_Node (Marker, False); - Var_Id := Entity (Nam); + -- Invoke the appropriate version of Activate_Tasks - -- Sanitize the variable + if Restricted_Profile then + Activ_Id := RTE (RE_Activate_Restricted_Tasks); + else + Activ_Id := RTE (RE_Activate_Tasks); + end if; - if Var_Id = Any_Id then - return False; + Set_Target (Marker, Activ_Id); - elsif Ekind (Var_Id) /= E_Variable then - return False; - end if; + -- Partially insert the marker into the tree - Var_Decl := Declaration_Node (Var_Id); + Set_Parent (Marker, Parent (Task_Decl)); - if Nkind (Var_Decl) /= N_Object_Declaration then - return False; - end if; + -- Create a dummy task object. Partially decorate the object because + -- it will not be inserted into the tree and analyzed. - N_Unit_Id := Find_Top_Unit (N); - N_Unit := Unit_Declaration_Node (N_Unit_Id); + Task_Obj := Make_Temporary (Loc, 'T'); + Set_Ekind (Task_Obj, E_Variable); + Set_Etype (Task_Obj, Task_Typ); - Var_Unit_Id := Find_Top_Unit (Var_Decl); - Var_Unit := Unit_Declaration_Node (Var_Unit_Id); + -- Associate the dummy task object with the activation call - -- To qualify, the assignment must meet the following prerequisites: + Task_Objs := NE_List.Create; + NE_List.Append (Task_Objs, Task_Obj); - return - Comes_From_Source (Var_Id) + Marker_Rep_Id := Scenario_Representation_Of (Marker, In_State); + Set_Activated_Task_Objects (Marker_Rep_Id, Task_Objs); + Set_Activated_Task_Type (Marker_Rep_Id, Task_Typ); - -- The variable must be declared in the spec of compilation unit U + return Marker; + end Build_Task_Activation; - and then Nkind (Var_Unit) = N_Package_Declaration + ---------------------------------- + -- Declare_Invocation_Construct -- + ---------------------------------- - -- Performance note: parent traversal + procedure Declare_Invocation_Construct + (Constr_Id : Entity_Id; + In_State : Processing_In_State) + is + function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind; + pragma Inline (Kind_Of); + -- Obtain the invocation construct kind of arbitrary entity Id - and then Find_Enclosing_Level (Var_Decl) = Package_Spec + function Placement_Of (Id : Entity_Id) return Body_Placement_Kind; + pragma Inline (Placement_Of); + -- Obtain the body placement of arbitrary entity Id - -- The assignment must occur in the body of compilation unit U + function Placement_Of_Node (N : Node_Id) return Body_Placement_Kind; + pragma Inline (Placement_Of_Node); + -- Obtain the body placement of arbitrary node N - and then Nkind (N_Unit) = N_Package_Body - and then Present (Corresponding_Body (Var_Unit)) - and then Corresponding_Body (Var_Unit) = N_Unit_Id; - end Is_Suitable_Variable_Assignment; + ------------- + -- Kind_Of -- + ------------- - ------------------------------------ - -- Is_Suitable_Variable_Reference -- - ------------------------------------ + function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is + begin + if Id = Elab_Body_Id then + return Elaborate_Body_Procedure; - function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is - begin - -- Expanded names and identifiers are intentionally ignored because they - -- be folded, optimized away, etc. Variable references markers play the - -- role of variable references and provide a uniform foundation for ABE - -- processing. + elsif Id = Elab_Spec_Id then + return Elaborate_Spec_Procedure; - return Nkind (N) = N_Variable_Reference_Marker; - end Is_Suitable_Variable_Reference; + else + return Regular_Construct; + end if; + end Kind_Of; - ------------------------------------ - -- Is_Synchronous_Suspension_Call -- - ------------------------------------ + ------------------ + -- Placement_Of -- + ------------------ - function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean is - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; + function Placement_Of (Id : Entity_Id) return Body_Placement_Kind is + Id_Rep : constant Target_Rep_Id := + Target_Representation_Of (Id, In_State); + Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); + Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); - begin - -- To qualify, the call must invoke one of the runtime routines which - -- perform synchronous suspension. + begin + -- The entity has a body - if Is_Suitable_Call (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); + if Present (Body_Decl) then + return Placement_Of_Node (Body_Decl); - return - Is_RTE (Target_Id, RE_Suspend_Until_True) - or else - Is_RTE (Target_Id, RE_Wait_For_Release); - end if; + -- Otherwise the entity must have a spec - return False; - end Is_Synchronous_Suspension_Call; + else + pragma Assert (Present (Spec_Decl)); + return Placement_Of_Node (Spec_Decl); + end if; + end Placement_Of; - ------------------- - -- Is_Task_Entry -- - ------------------- + ----------------------- + -- Placement_Of_Node -- + ----------------------- - function Is_Task_Entry (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote an entry defined in a task type + function Placement_Of_Node (N : Node_Id) return Body_Placement_Kind is + Main_Unit_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + N_Unit_Id : constant Entity_Id := Find_Top_Unit (N); - return - Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); - end Is_Task_Entry; + begin + -- The node is in the main unit, its placement depends on the main + -- unit kind. - ------------------------ - -- Is_Up_Level_Target -- - ------------------------ + if N_Unit_Id = Main_Unit_Id then - function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean is - Root : constant Node_Id := Root_Scenario; + -- The main unit is a body - begin - -- The root appears within the declaratons of a block statement, entry - -- body, subprogram body, or task body ignoring enclosing packages. The - -- root is always within the main unit. An up-level target is a notion - -- applicable only to the static model because scenarios are reached by - -- means of graph traversal started from a fixed declarative or library - -- level. + if Ekind_In (Main_Unit_Id, E_Package_Body, + E_Subprogram_Body) + then + return In_Body; - -- Performance note: parent traversal + -- The main unit is a stand-alone subprogram body - if Static_Elaboration_Checks - and then Find_Enclosing_Level (Root) = Declaration_Level - then - -- The target is within the main unit. It acts as an up-level target - -- when it appears within a context which encloses the root. + elsif Ekind_In (Main_Unit_Id, E_Function, E_Procedure) + and then Nkind (Unit_Declaration_Node (Main_Unit_Id)) = + N_Subprogram_Body + then + return In_Body; - -- package body Main_Unit is - -- function Func ...; -- target + -- Otherwise the main unit is a spec - -- procedure Proc is - -- X : ... := Func; -- root scenario + else + return In_Spec; + end if; - if In_Extended_Main_Code_Unit (Target_Decl) then + -- Otherwise the node is in the complementary unit of the main + -- unit. The main unit is a body, the node is in the spec. - -- Performance note: parent traversal + elsif Ekind_In (Main_Unit_Id, E_Package_Body, + E_Subprogram_Body) + then + return In_Spec; - return not In_Same_Context (Root, Target_Decl, Nested_OK => True); + -- The main unit is a spec, the node is in the body - -- Otherwise the target is external to the main unit which makes it - -- an up-level target. + else + return In_Body; + end if; + end Placement_Of_Node; - else - return True; - end if; - end if; + -- Local variables - return False; - end Is_Up_Level_Target; + IC_Rec : Invocation_Construct_Record; - --------------------- - -- Is_Visited_Body -- - --------------------- + -- Start of processing for Declare_Invocation_Construct - function Is_Visited_Body (Body_Decl : Node_Id) return Boolean is - begin - if Visited_Bodies_In_Use then - return Visited_Bodies.Get (Body_Decl); - end if; + begin + -- Nothing to do when the construct has already been declared in the + -- ALI file. - return Visited_Bodies_No_Element; - end Is_Visited_Body; + if Is_Saved_Construct (Constr_Id) then + return; + end if; - ------------------------------- - -- Kill_Elaboration_Scenario -- - ------------------------------- + -- Mark the construct as declared in the ALI file - procedure Kill_Elaboration_Scenario (N : Node_Id) is - procedure Kill_SPARK_Scenario; - pragma Inline (Kill_SPARK_Scenario); - -- Eliminate scenario N from table SPARK_Scenarios if it is recorded - -- there. + Set_Is_Saved_Construct (Constr_Id); - procedure Kill_Top_Level_Scenario; - pragma Inline (Kill_Top_Level_Scenario); - -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded - -- there. + IC_Rec.Kind := Kind_Of (Constr_Id); + IC_Rec.Placement := Placement_Of (Constr_Id); + IC_Rec.Signature := Signature_Of (Constr_Id); - ------------------------- - -- Kill_SPARK_Scenario -- - ------------------------- + -- Add the construct in the ALI file - procedure Kill_SPARK_Scenario is - package Scenarios renames SPARK_Scenarios; + Add_Invocation_Construct + (IC_Rec => IC_Rec, + Update_Units => False); + end Declare_Invocation_Construct; - begin - if Is_Recorded_SPARK_Scenario (N) then + ------------------------------- + -- Finalize_Invocation_Graph -- + ------------------------------- - -- Performance note: list traversal + procedure Finalize_Invocation_Graph is + begin + NE_Set.Destroy (Saved_Constructs_Set); + IR_Set.Destroy (Saved_Relations_Set); + end Finalize_Invocation_Graph; - for Index in Scenarios.First .. Scenarios.Last loop - if Scenarios.Table (Index) = N then - Scenarios.Table (Index) := Empty; + ---------- + -- Hash -- + ---------- - -- The SPARK scenario is no longer recorded + function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type is + pragma Assert (Present (Key.Invoker)); + pragma Assert (Present (Key.Target)); - Set_Is_Recorded_SPARK_Scenario (N, False); - return; - end if; - end loop; + begin + return + Hash_Two_Keys + (Bucket_Range_Type (Key.Invoker), + Bucket_Range_Type (Key.Target)); + end Hash; - -- A recorded SPARK scenario must be in the table of recorded - -- SPARK scenarios. + --------------------------------- + -- Initialize_Invocation_Graph -- + --------------------------------- - pragma Assert (False); - end if; - end Kill_SPARK_Scenario; + procedure Initialize_Invocation_Graph is + begin + Saved_Constructs_Set := NE_Set.Create (100); + Saved_Relations_Set := IR_Set.Create (200); + end Initialize_Invocation_Graph; - ----------------------------- - -- Kill_Top_Level_Scenario -- - ----------------------------- + ----------------------------------- + -- Invocation_Graph_Recording_OK -- + ----------------------------------- - procedure Kill_Top_Level_Scenario is - package Scenarios renames Top_Level_Scenarios; + function Invocation_Graph_Recording_OK return Boolean is + Main_Cunit : constant Node_Id := Cunit (Main_Unit); begin - if Is_Recorded_Top_Level_Scenario (N) then + -- Nothing to do when switch -gnatd_G (encode invocation graph in ALI + -- files) is not in effect. - -- Performance node: list traversal + if not Debug_Flag_Underscore_GG then + return False; - for Index in Scenarios.First .. Scenarios.Last loop - if Scenarios.Table (Index) = N then - Scenarios.Table (Index) := Empty; + -- Nothing to do when compiling for GNATprove because the invocation + -- graph is not needed. - -- The top-level scenario is no longer recorded + elsif GNATprove_Mode then + return False; - Set_Is_Recorded_Top_Level_Scenario (N, False); - return; - end if; - end loop; + -- Nothing to do when the compilation will not produce an ALI file - -- A recorded top-level scenario must be in the table of recorded - -- top-level scenarios. + elsif Serious_Errors_Detected > 0 then + return False; - pragma Assert (False); - end if; - end Kill_Top_Level_Scenario; + -- Nothing to do when the main unit requires a body. Processing the + -- completing body will create the ALI file for the unit and record + -- the invocation graph. - -- Start of processing for Kill_Elaboration_Scenario + elsif Body_Required (Main_Cunit) then + return False; + end if; - begin - -- Nothing to do when switch -gnatH (legacy elaboration checking mode - -- enabled) is in effect because the legacy ABE lechanism does not need - -- to carry out this action. + return True; + end Invocation_Graph_Recording_OK; - if Legacy_Elaboration_Checks then - return; - end if; + ---------------------------- + -- Is_Invocation_Scenario -- + ---------------------------- - -- Eliminate a recorded scenario when it appears within dead code - -- because it will not be executed at elaboration time. + function Is_Invocation_Scenario (N : Node_Id) return Boolean is + begin + return + Is_Suitable_Access_Taken (N) + or else Is_Suitable_Call (N) + or else Is_Suitable_Instantiation (N); + end Is_Invocation_Scenario; - if Is_Scenario (N) then - Kill_SPARK_Scenario; - Kill_Top_Level_Scenario; - end if; - end Kill_Elaboration_Scenario; + -------------------------- + -- Is_Invocation_Target -- + -------------------------- - ---------------------------------- - -- Meet_Elaboration_Requirement -- - ---------------------------------- + function Is_Invocation_Target (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must either come from source, or denote an + -- Ada, bridge, or SPARK target. - procedure Meet_Elaboration_Requirement - (N : Node_Id; - Target_Id : Entity_Id; - Req_Nam : Name_Id) - is - Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); - Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); + return + Comes_From_Source (Id) + or else Is_Ada_Semantic_Target (Id) + or else Is_Bridge_Target (Id) + or else Is_SPARK_Semantic_Target (Id); + end Is_Invocation_Target; + + ------------------------ + -- Is_Saved_Construct -- + ------------------------ + + function Is_Saved_Construct (Constr : Entity_Id) return Boolean is + pragma Assert (Present (Constr)); + begin + return NE_Set.Contains (Saved_Constructs_Set, Constr); + end Is_Saved_Construct; - function Find_Preelaboration_Pragma - (Prag_Nam : Name_Id) return Node_Id; - pragma Inline (Find_Preelaboration_Pragma); - -- Traverse the visible declarations of unit Unit_Id and locate a source - -- preelaboration-related pragma with name Prag_Nam. + ----------------------- + -- Is_Saved_Relation -- + ----------------------- - procedure Info_Requirement_Met (Prag : Node_Id); - pragma Inline (Info_Requirement_Met); - -- Output information concerning pragma Prag which meets requirement - -- Req_Nam. + function Is_Saved_Relation + (Rel : Invoker_Target_Relation) return Boolean + is + pragma Assert (Present (Rel.Invoker)); + pragma Assert (Present (Rel.Target)); - procedure Info_Scenario; - pragma Inline (Info_Scenario); - -- Output information concerning scenario N + begin + return IR_Set.Contains (Saved_Relations_Set, Rel); + end Is_Saved_Relation; - -------------------------------- - -- Find_Preelaboration_Pragma -- - -------------------------------- + -------------------------- + -- Process_Declarations -- + -------------------------- - function Find_Preelaboration_Pragma - (Prag_Nam : Name_Id) return Node_Id + procedure Process_Declarations + (Decls : List_Id; + In_State : Processing_In_State) is - Spec : constant Node_Id := Parent (Unit_Id); Decl : Node_Id; begin - -- A preelaboration-related pragma comes from source and appears at - -- the top of the visible declarations of a package. + Decl := First (Decls); + while Present (Decl) loop - if Nkind (Spec) = N_Package_Specification then - Decl := First (Visible_Declarations (Spec)); - while Present (Decl) loop - if Comes_From_Source (Decl) then - if Nkind (Decl) = N_Pragma - and then Pragma_Name (Decl) = Prag_Nam - then - return Decl; + -- Freeze node - -- Otherwise the construct terminates the region where the - -- preelaboration-related pragma may appear. + if Nkind (Decl) = N_Freeze_Entity then + Process_Freeze_Node + (Fnode => Decl, + In_State => In_State); - else - exit; - end if; - end if; + -- Package (nested) - Next (Decl); - end loop; - end if; + elsif Nkind (Decl) = N_Package_Declaration then + Process_Package_Declaration + (Pack_Decl => Decl, + In_State => In_State); - return Empty; - end Find_Preelaboration_Pragma; + -- Protected type - -------------------------- - -- Info_Requirement_Met -- - -------------------------- + elsif Nkind_In (Decl, N_Protected_Type_Declaration, + N_Single_Protected_Declaration) + then + Process_Protected_Type_Declaration + (Prot_Decl => Decl, + In_State => In_State); + + -- Subprogram or entry + + elsif Nkind_In (Decl, N_Entry_Declaration, + N_Subprogram_Declaration) + then + Process_Subprogram_Declaration + (Subp_Decl => Decl, + In_State => In_State); + + -- Subprogram body (stand alone) + + elsif Nkind (Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Decl)) + then + Process_Subprogram_Declaration + (Subp_Decl => Decl, + In_State => In_State); + + -- Subprogram instantiation + + elsif Nkind (Decl) in N_Subprogram_Instantiation then + Process_Subprogram_Instantiation + (Inst => Decl, + In_State => In_State); + + -- Task type - procedure Info_Requirement_Met (Prag : Node_Id) is + elsif Nkind_In (Decl, N_Single_Task_Declaration, + N_Task_Type_Declaration) + then + Process_Task_Type_Declaration + (Task_Decl => Decl, + In_State => In_State); + + -- Task type (derived) + + elsif Nkind (Decl) = N_Full_Type_Declaration + and then Is_Task_Type (Defining_Entity (Decl)) + then + Process_Task_Type_Declaration + (Task_Decl => Decl, + In_State => In_State); + end if; + + Next (Decl); + end loop; + end Process_Declarations; + + ------------------------- + -- Process_Freeze_Node -- + ------------------------- + + procedure Process_Freeze_Node + (Fnode : Node_Id; + In_State : Processing_In_State) + is begin - pragma Assert (Present (Prag)); + Process_Declarations + (Decls => Actions (Fnode), + In_State => In_State); + end Process_Freeze_Node; - Error_Msg_Name_1 := Req_Nam; - Error_Msg_Sloc := Sloc (Prag); - Error_Msg_NE - ("\\% requirement for unit & met by pragma #", N, Unit_Id); - end Info_Requirement_Met; + ----------------------------------- + -- Process_Invocation_Activation -- + ----------------------------------- - ------------------- - -- Info_Scenario -- - ------------------- + procedure Process_Invocation_Activation + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + Obj_Id : Entity_Id; + Obj_Rep : Target_Rep_Id; + Task_Typ : Entity_Id; + Task_Rep : Target_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Call); + pragma Unreferenced (Call_Rep); + pragma Unreferenced (Obj_Id); + pragma Unreferenced (Obj_Rep); - procedure Info_Scenario is begin - if Is_Suitable_Call (N) then - Info_Call - (Call => N, - Target_Id => Target_Id, - Info_Msg => False, - In_SPARK => True); + -- Nothing to do when the task type appears within an internal unit - elsif Is_Suitable_Instantiation (N) then - Info_Instantiation - (Inst => N, - Gen_Id => Target_Id, - Info_Msg => False, - In_SPARK => True); + if In_Internal_Unit (Task_Typ) then + return; + end if; - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Error_Msg_N - ("read of refinement constituents during elaboration in SPARK", - N); + -- The task type being activated is within the main unit. Extend the + -- DFS traversal into its body. - elsif Is_Suitable_Variable_Reference (N) then - Info_Variable_Reference - (Ref => N, - Var_Id => Target_Id, - Info_Msg => False, - In_SPARK => True); + if In_Extended_Main_Code_Unit (Task_Typ) then + Traverse_Invocation_Body + (N => Body_Declaration (Task_Rep), + In_State => In_State); - -- No other scenario may impose a requirement on the context of the - -- main unit. + -- The task type being activated resides within an external unit + -- + -- Main unit External unit + -- +-----------+ +-------------+ + -- | | | | + -- | Start ------------> Task_Typ | + -- | | | | + -- +-----------+ +-------------+ + -- + -- Record the invocation path which originates from Start and reaches + -- the task type. else - pragma Assert (False); - null; + Record_Invocation_Path (In_State); end if; - end Info_Scenario; - - -- Local variables + end Process_Invocation_Activation; - Elab_Attrs : Elaboration_Attributes; - Elab_Nam : Name_Id; - Req_Met : Boolean; + --------------------------------------- + -- Process_Invocation_Body_Scenarios -- + --------------------------------------- - -- Start of processing for Meet_Elaboration_Requirement + procedure Process_Invocation_Body_Scenarios is + Iter : NE_Set.Iterator := Iterate_Library_Body_Scenarios; + begin + Process_Invocation_Scenarios + (Iter => Iter, + In_State => Invocation_Body_State); + end Process_Invocation_Body_Scenarios; - begin - pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); + ----------------------------- + -- Process_Invocation_Call -- + ----------------------------- - -- Assume that the requirement has not been met + procedure Process_Invocation_Call + (Call : Node_Id; + Call_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Call); - Req_Met := False; + Subp_Id : constant Entity_Id := Target (Call_Rep); + Subp_Rep : constant Target_Rep_Id := + Target_Representation_Of (Subp_Id, In_State); - -- Elaboration requirements are verified only when the static model is - -- in effect because this diagnostic is graph-dependent. + begin + -- Nothing to do when the subprogram appears within an internal unit - if not Static_Elaboration_Checks then - return; + if In_Internal_Unit (Subp_Id) then + return; - -- If the target is within the main unit, either at the source level or - -- through an instantiation, then there is no real requirement to meet - -- because the main unit cannot force its own elaboration by means of an - -- Elaborate[_All] pragma. Treat this case as valid coverage. + -- Nothing to do for an abstract subprogram because it has no body to + -- examine. - elsif In_Extended_Main_Code_Unit (Target_Id) then - Req_Met := True; + elsif Ekind_In (Subp_Id, E_Function, E_Procedure) + and then Is_Abstract_Subprogram (Subp_Id) + then + return; - -- Otherwise the target resides in an external unit + -- Nothin to do for a formal subprogram because it has no body to + -- examine. - -- The requirement is met when the target comes from an internal unit - -- because such a unit is elaborated prior to a non-internal unit. + elsif Is_Formal_Subprogram (Subp_Id) then + return; + end if; - elsif In_Internal_Unit (Unit_Id) - and then not In_Internal_Unit (Main_Id) - then - Req_Met := True; + -- The subprogram being called is within the main unit. Extend the + -- DFS traversal into its barrier function and body. - -- The requirement is met when the target comes from a preelaborated - -- unit. This portion must parallel predicate Is_Preelaborated_Unit. + if In_Extended_Main_Code_Unit (Subp_Id) then + if Ekind_In (Subp_Id, E_Entry, E_Entry_Family, E_Procedure) then + Traverse_Invocation_Body + (N => Barrier_Body_Declaration (Subp_Rep), + In_State => In_State); + end if; - elsif Is_Preelaborated_Unit (Unit_Id) then - Req_Met := True; + Traverse_Invocation_Body + (N => Body_Declaration (Subp_Rep), + In_State => In_State); - -- Output extra information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas. + -- The subprogram being called resides within an external unit + -- + -- Main unit External unit + -- +-----------+ +-------------+ + -- | | | | + -- | Start ------------> Subp_Id | + -- | | | | + -- +-----------+ +-------------+ + -- + -- Record the invocation path which originates from Start and reaches + -- the subprogram. - if Elab_Info_Messages then - if Is_Preelaborated (Unit_Id) then - Elab_Nam := Name_Preelaborate; + else + Record_Invocation_Path (In_State); + end if; + end Process_Invocation_Call; - elsif Is_Pure (Unit_Id) then - Elab_Nam := Name_Pure; + --------------------------------- + -- Process_Invocation_Scenario -- + --------------------------------- - elsif Is_Remote_Call_Interface (Unit_Id) then - Elab_Nam := Name_Remote_Call_Interface; + procedure Process_Invocation_Scenario + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); + Scen_Rep : Scenario_Rep_Id; - elsif Is_Remote_Types (Unit_Id) then - Elab_Nam := Name_Remote_Types; + begin + -- Add the current scenario to the stack of active scenarios - else - pragma Assert (Is_Shared_Passive (Unit_Id)); - Elab_Nam := Name_Shared_Passive; - end if; + Push_Active_Scenario (Scen); - Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); - end if; + -- Call or task activation - -- Determine whether the context of the main unit has a pragma strong - -- enough to meet the requirement. + if Is_Suitable_Call (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - else - Elab_Attrs := Elaboration_Status (Unit_Id); + -- Routine Build_Call_Marker creates call markers regardless of + -- whether the call occurs within the main unit or not. This way + -- the serialization of internal names is kept consistent. Only + -- call markers found within the main unit must be processed. - -- The pragma must be either Elaborate_All or be as strong as the - -- requirement. + if In_Main_Context (Scen) then + Scen_Rep := Scenario_Representation_Of (Scen, In_State); - if Present (Elab_Attrs.Source_Pragma) - and then Nam_In (Pragma_Name (Elab_Attrs.Source_Pragma), - Name_Elaborate_All, - Req_Nam) - then - Req_Met := True; + if Kind (Scen_Rep) = Call_Scenario then + Process_Invocation_Call + (Call => Scen, + Call_Rep => Scen_Rep, + In_State => In_State); - -- Output extra information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas. + else + pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); - if Elab_Info_Messages then - Info_Requirement_Met (Elab_Attrs.Source_Pragma); + Process_Activation + (Call => Scen, + Call_Rep => Scen_Rep, + Processor => Process_Invocation_Activation'Access, + In_State => In_State); + end if; end if; end if; - end if; - - -- The requirement was not met by the context of the main unit, issue an - -- error. - if not Req_Met then - Info_Scenario; + -- Remove the current scenario from the stack of active scenarios + -- once all invocation constructs and paths have been saved. - Error_Msg_Name_1 := Req_Nam; - Error_Msg_Node_2 := Unit_Id; - Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); + Pop_Active_Scenario (Scen); + end Process_Invocation_Scenario; - Output_Active_Scenarios (N); - end if; - end Meet_Elaboration_Requirement; + ---------------------------------- + -- Process_Invocation_Scenarios -- + ---------------------------------- - ---------------------- - -- Non_Private_View -- - ---------------------- + procedure Process_Invocation_Scenarios + (Iter : in out NE_Set.Iterator; + In_State : Processing_In_State) + is + N : Node_Id; - function Non_Private_View (Typ : Entity_Id) return Entity_Id is - begin - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - return Full_View (Typ); - else - return Typ; - end if; - end Non_Private_View; + begin + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - ----------------------------- - -- Output_Active_Scenarios -- - ----------------------------- + -- Reset the traversed status of all subprogram bodies because the + -- current invocation scenario acts as a new DFS traversal root. - procedure Output_Active_Scenarios (Error_Nod : Node_Id) is - procedure Output_Access (N : Node_Id); - -- Emit a specific diagnostic message for 'Access denote by N + Reset_Traversed_Bodies; - procedure Output_Activation_Call (N : Node_Id); - -- Emit a specific diagnostic message for task activation N + Process_Invocation_Scenario (N, In_State); + end loop; + end Process_Invocation_Scenarios; - procedure Output_Call (N : Node_Id; Target_Id : Entity_Id); - -- Emit a specific diagnostic message for call N which invokes target - -- Target_Id. + --------------------------------------- + -- Process_Invocation_Spec_Scenarios -- + --------------------------------------- - procedure Output_Header; - -- Emit a specific diagnostic message for the unit of the root scenario + procedure Process_Invocation_Spec_Scenarios is + Iter : NE_Set.Iterator := Iterate_Library_Spec_Scenarios; + begin + Process_Invocation_Scenarios + (Iter => Iter, + In_State => Invocation_Spec_State); + end Process_Invocation_Spec_Scenarios; - procedure Output_Instantiation (N : Node_Id); - -- Emit a specific diagnostic message for instantiation N + ----------------------- + -- Process_Main_Unit -- + ----------------------- - procedure Output_SPARK_Refined_State_Pragma (N : Node_Id); - -- Emit a specific diagnostic message for Refined_State pragma N + procedure Process_Main_Unit is + Unit_Decl : constant Node_Id := Unit (Cunit (Main_Unit)); + Spec_Id : Entity_Id; - procedure Output_Variable_Assignment (N : Node_Id); - -- Emit a specific diagnostic message for assignment statement N + begin + -- The main unit is a [generic] package body - procedure Output_Variable_Reference (N : Node_Id); - -- Emit a specific diagnostic message for reference N which mentions a - -- variable. + if Nkind (Unit_Decl) = N_Package_Body then + Spec_Id := Corresponding_Spec (Unit_Decl); + pragma Assert (Present (Spec_Id)); - ------------------- - -- Output_Access -- - ------------------- + Process_Package_Declaration + (Pack_Decl => Unit_Declaration_Node (Spec_Id), + In_State => Invocation_Construct_State); - procedure Output_Access (N : Node_Id) is - Subp_Id : constant Entity_Id := Entity (Prefix (N)); + -- The main unit is a [generic] package declaration - begin - Error_Msg_Name_1 := Attribute_Name (N); - Error_Msg_Sloc := Sloc (N); - Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); - end Output_Access; + elsif Nkind (Unit_Decl) = N_Package_Declaration then + Process_Package_Declaration + (Pack_Decl => Unit_Decl, + In_State => Invocation_Construct_State); - ---------------------------- - -- Output_Activation_Call -- - ---------------------------- + -- The main unit is a [generic] subprogram body - procedure Output_Activation_Call (N : Node_Id) is - function Find_Activator (Call : Node_Id) return Entity_Id; - -- Find the nearest enclosing construct which houses call Call + elsif Nkind (Unit_Decl) = N_Subprogram_Body then + Spec_Id := Corresponding_Spec (Unit_Decl); - -------------------- - -- Find_Activator -- - -------------------- + -- The body completes a previous declaration - function Find_Activator (Call : Node_Id) return Entity_Id is - Par : Node_Id; + if Present (Spec_Id) then + Process_Subprogram_Declaration + (Subp_Decl => Unit_Declaration_Node (Spec_Id), + In_State => Invocation_Construct_State); - begin - -- Climb the parent chain looking for a package [body] or a - -- construct with a statement sequence. + -- Otherwise the body is stand-alone - Par := Parent (Call); - while Present (Par) loop - if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then - return Defining_Entity (Par); + else + Process_Subprogram_Declaration + (Subp_Decl => Unit_Decl, + In_State => Invocation_Construct_State); + end if; - elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then - return Defining_Entity (Parent (Par)); - end if; + -- The main unit is a subprogram instantiation - Par := Parent (Par); - end loop; + elsif Nkind (Unit_Decl) in N_Subprogram_Instantiation then + Process_Subprogram_Instantiation + (Inst => Unit_Decl, + In_State => Invocation_Construct_State); - return Empty; - end Find_Activator; + -- The main unit is an imported subprogram declaration - -- Local variables + elsif Nkind (Unit_Decl) = N_Subprogram_Declaration then + Process_Subprogram_Declaration + (Subp_Decl => Unit_Decl, + In_State => Invocation_Construct_State); + end if; + end Process_Main_Unit; - Activator : constant Entity_Id := Find_Activator (N); + --------------------------------- + -- Process_Package_Declaration -- + --------------------------------- - -- Start of processing for Output_Activation_Call + procedure Process_Package_Declaration + (Pack_Decl : Node_Id; + In_State : Processing_In_State) + is + Body_Id : constant Entity_Id := Corresponding_Body (Pack_Decl); + Spec : constant Node_Id := Specification (Pack_Decl); + Spec_Id : constant Entity_Id := Defining_Entity (Pack_Decl); begin - pragma Assert (Present (Activator)); + -- Add a declaration for the generic package in the ALI of the main + -- unit in case a client unit instantiates it. - Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); - end Output_Activation_Call; + if Ekind (Spec_Id) = E_Generic_Package then + Declare_Invocation_Construct + (Constr_Id => Spec_Id, + In_State => In_State); - ----------------- - -- Output_Call -- - ----------------- + -- Otherwise inspect the visible and private declarations of the + -- package for invocation constructs. - procedure Output_Call (N : Node_Id; Target_Id : Entity_Id) is - procedure Output_Accept_Alternative; - pragma Inline (Output_Accept_Alternative); - -- Emit a specific diagnostic message concerning an accept - -- alternative. + else + Process_Declarations + (Decls => Visible_Declarations (Spec), + In_State => In_State); + + Process_Declarations + (Decls => Private_Declarations (Spec), + In_State => In_State); + + -- The package body containst at least one generic unit or an + -- inlinable subprogram. Such constructs may grant clients of + -- the main unit access to the private enclosing contexts of + -- the constructs. Process the main unit body to discover and + -- encode relevant invocation constructs and relations that + -- may ultimately reach an external unit. + + if Present (Body_Id) + and then Save_Invocation_Graph_Of_Body (Cunit (Main_Unit)) + then + Process_Declarations + (Decls => Declarations (Unit_Declaration_Node (Body_Id)), + In_State => In_State); + end if; + end if; + end Process_Package_Declaration; - procedure Output_Call (Kind : String); - pragma Inline (Output_Call); - -- Emit a specific diagnostic message concerning a call of kind Kind + ---------------------------------------- + -- Process_Protected_Type_Declaration -- + ---------------------------------------- - procedure Output_Type_Actions (Action : String); - pragma Inline (Output_Type_Actions); - -- Emit a specific diagnostic message concerning action Action of a - -- type. + procedure Process_Protected_Type_Declaration + (Prot_Decl : Node_Id; + In_State : Processing_In_State) + is + Prot_Def : constant Node_Id := Protected_Definition (Prot_Decl); - procedure Output_Verification_Call - (Pred : String; - Id : Entity_Id; - Id_Kind : String); - pragma Inline (Output_Verification_Call); - -- Emit a specific diagnostic message concerning the verification of - -- predicate Pred applied to related entity Id with kind Id_Kind. + begin + if Present (Prot_Def) then + Process_Declarations + (Decls => Visible_Declarations (Prot_Def), + In_State => In_State); + end if; + end Process_Protected_Type_Declaration; - ------------------------------- - -- Output_Accept_Alternative -- - ------------------------------- + ------------------------------------ + -- Process_Subprogram_Declaration -- + ------------------------------------ + + procedure Process_Subprogram_Declaration + (Subp_Decl : Node_Id; + In_State : Processing_In_State) + is + Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); - procedure Output_Accept_Alternative is - Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); + begin + -- Nothing to do when the subprogram is not an invocation target - begin - pragma Assert (Present (Entry_Id)); + if not Is_Invocation_Target (Subp_Id) then + return; + end if; - Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); - end Output_Accept_Alternative; + -- Add a declaration for the subprogram in the ALI file of the main + -- unit in case a client unit calls or instantiates it. - ----------------- - -- Output_Call -- - ----------------- + Declare_Invocation_Construct + (Constr_Id => Subp_Id, + In_State => In_State); - procedure Output_Call (Kind : String) is - begin - Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Target_Id); - end Output_Call; + -- Do not process subprograms without a body because they do not + -- contain any invocation scenarios. - ------------------------- - -- Output_Type_Actions -- - ------------------------- + if Is_Bodiless_Subprogram (Subp_Id) then + null; - procedure Output_Type_Actions (Action : String) is - Typ : constant Entity_Id := First_Formal_Type (Target_Id); + -- Do not process generic subprograms because generics must not be + -- examined. - begin - pragma Assert (Present (Typ)); + elsif Is_Generic_Subprogram (Subp_Id) then + null; - Error_Msg_NE - ("\\ " & Action & " actions for type & #", Error_Nod, Typ); - end Output_Type_Actions; + -- Otherwise create a dummy scenario which calls the subprogram to + -- act as a root for a DFS traversal. - ------------------------------ - -- Output_Verification_Call -- - ------------------------------ + else + -- Reset the traversed status of all subprogram bodies because the + -- subprogram acts as a new DFS traversal root. - procedure Output_Verification_Call - (Pred : String; - Id : Entity_Id; - Id_Kind : String) - is - begin - pragma Assert (Present (Id)); + Reset_Traversed_Bodies; - Error_Msg_NE - ("\\ " & Pred & " of " & Id_Kind & " & verified #", - Error_Nod, Id); - end Output_Verification_Call; + Process_Invocation_Scenario + (N => Build_Subprogram_Invocation (Subp_Id), + In_State => In_State); + end if; + end Process_Subprogram_Declaration; - -- Start of processing for Output_Call + -------------------------------------- + -- Process_Subprogram_Instantiation -- + -------------------------------------- + procedure Process_Subprogram_Instantiation + (Inst : Node_Id; + In_State : Processing_In_State) + is begin - Error_Msg_Sloc := Sloc (N); + -- Add a declaration for the instantiation in the ALI file of the + -- main unit in case a client unit calls it. - -- Accept alternative + Declare_Invocation_Construct + (Constr_Id => Defining_Entity (Inst), + In_State => In_State); + end Process_Subprogram_Instantiation; - if Is_Accept_Alternative_Proc (Target_Id) then - Output_Accept_Alternative; + ----------------------------------- + -- Process_Task_Type_Declaration -- + ----------------------------------- - -- Adjustment + procedure Process_Task_Type_Declaration + (Task_Decl : Node_Id; + In_State : Processing_In_State) + is + Task_Typ : constant Entity_Id := Defining_Entity (Task_Decl); + Task_Def : Node_Id; - elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then - Output_Type_Actions ("adjustment"); + begin + -- Add a declaration for the task type the ALI file of the main unit + -- in case a client unit creates a task object and activates it. - -- Default_Initial_Condition + Declare_Invocation_Construct + (Constr_Id => Task_Typ, + In_State => In_State); - elsif Is_Default_Initial_Condition_Proc (Target_Id) then - Output_Verification_Call - (Pred => "Default_Initial_Condition", - Id => First_Formal_Type (Target_Id), - Id_Kind => "type"); + -- Process the entries of the task type because they represent valid + -- entry points into the task body. - -- Entries + if Nkind_In (Task_Decl, N_Single_Task_Declaration, + N_Task_Type_Declaration) + then + Task_Def := Task_Definition (Task_Decl); - elsif Is_Protected_Entry (Target_Id) then - Output_Call ("entry"); + if Present (Task_Def) then + Process_Declarations + (Decls => Visible_Declarations (Task_Def), + In_State => In_State); + end if; + end if; - -- Task entry calls are never processed because the entry being - -- invoked does not have a corresponding "body", it has a select. A - -- task entry call appears in the stack of active scenarios for the - -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and - -- nothing more. + -- Reset the traversed status of all subprogram bodies because the + -- task type acts as a new DFS traversal root. - elsif Is_Task_Entry (Target_Id) then - null; + Reset_Traversed_Bodies; - -- Finalization + -- Create a dummy scenario which activates an anonymous object of the + -- task type to acts as a root of a DFS traversal. - elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then - Output_Type_Actions ("finalization"); + Process_Invocation_Scenario + (N => Build_Task_Activation (Task_Typ, In_State), + In_State => In_State); + end Process_Task_Type_Declaration; - -- Calls to _Finalizer procedures must not appear in the output - -- because this creates confusing noise. + --------------------------------- + -- Record_Full_Invocation_Path -- + --------------------------------- - elsif Is_Finalizer_Proc (Target_Id) then - null; + procedure Record_Full_Invocation_Path (In_State : Processing_In_State) is + package Scenarios renames Active_Scenario_Stack; - -- Initial_Condition + begin + -- The path originates from the elaboration of the body. Add an extra + -- relation from the elaboration body procedure to the first active + -- scenario. - elsif Is_Initial_Condition_Proc (Target_Id) then - Output_Verification_Call - (Pred => "Initial_Condition", - Id => Find_Enclosing_Scope (N), - Id_Kind => "package"); + if In_State.Processing = Invocation_Body_Processing then + Build_Elaborate_Body_Procedure; - -- Initialization + Record_Invocation_Relation + (Invk_Id => Elab_Body_Id, + Targ_Id => Target_Of (Scenarios.First, In_State), + In_State => In_State); - elsif Is_Init_Proc (Target_Id) - or else Is_TSS (Target_Id, TSS_Deep_Initialize) - then - Output_Type_Actions ("initialization"); + -- The path originates from the elaboration of the spec. Add an extra + -- relation from the elaboration spec procedure to the first active + -- scenario. - -- Invariant + elsif In_State.Processing = Invocation_Spec_Processing then + Build_Elaborate_Spec_Procedure; - elsif Is_Invariant_Proc (Target_Id) then - Output_Verification_Call - (Pred => "invariants", - Id => First_Formal_Type (Target_Id), - Id_Kind => "type"); + Record_Invocation_Relation + (Invk_Id => Elab_Spec_Id, + Targ_Id => Target_Of (Scenarios.First, In_State), + In_State => In_State); + end if; - -- Partial invariant calls must not appear in the output because this - -- creates confusing noise. Note that a partial invariant is always - -- invoked by the "full" invariant which is already placed on the - -- stack. + -- Record individual relations formed by pairs of scenarios - elsif Is_Partial_Invariant_Proc (Target_Id) then - null; + for Index in Scenarios.First .. Scenarios.Last - 1 loop + Record_Invocation_Relation + (Invk_Id => Target_Of (Index, In_State), + Targ_Id => Target_Of (Index + 1, In_State), + In_State => In_State); + end loop; + end Record_Full_Invocation_Path; - -- _Postconditions + ----------------------------- + -- Record_Invocation_Graph -- + ----------------------------- - elsif Is_Postconditions_Proc (Target_Id) then - Output_Verification_Call - (Pred => "postconditions", - Id => Find_Enclosing_Scope (N), - Id_Kind => "subprogram"); + procedure Record_Invocation_Graph is + begin + -- Nothing to do when the invocation graph is not recorded - -- Subprograms must come last because some of the previous cases fall - -- under this category. + if not Invocation_Graph_Recording_OK then + return; + end if; - elsif Ekind (Target_Id) = E_Function then - Output_Call ("function"); + -- Examine all library level invocation scenarios and perform DFS + -- traversals from each one. Encode a path in the ALI file of the + -- main unit if it reaches into an external unit. - elsif Ekind (Target_Id) = E_Procedure then - Output_Call ("procedure"); + Process_Invocation_Body_Scenarios; + Process_Invocation_Spec_Scenarios; - else - pragma Assert (False); - null; - end if; - end Output_Call; + -- Examine all invocation constructs within the spec and body of the + -- main unit and perform DFS traversals from each one. Encode a path + -- in the ALI file of the main unit if it reaches into an external + -- unit. - ------------------- - -- Output_Header -- - ------------------- + Process_Main_Unit; + end Record_Invocation_Graph; - procedure Output_Header is - Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); + ---------------------------- + -- Record_Invocation_Path -- + ---------------------------- + + procedure Record_Invocation_Path (In_State : Processing_In_State) is + package Scenarios renames Active_Scenario_Stack; begin - if Ekind (Unit_Id) = E_Package then - Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); + -- Save a path when the active scenario stack contains at least one + -- invocation scenario. - elsif Ekind (Unit_Id) = E_Package_Body then - Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); + if Scenarios.Last - Scenarios.First < 0 then + return; + end if; + + -- Register all relations in the path when switch -gnatd_F (encode + -- full invocation paths in ALI files) is in effect. + + if Debug_Flag_Underscore_FF then + Record_Full_Invocation_Path (In_State); + + -- Otherwise register a single relation else - Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); + Record_Simple_Invocation_Path (In_State); end if; - end Output_Header; - -------------------------- - -- Output_Instantiation -- - -------------------------- + Write_Invocation_Path (In_State); + end Record_Invocation_Path; - procedure Output_Instantiation (N : Node_Id) is - procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); - pragma Inline (Output_Instantiation); - -- Emit a specific diagnostic message concerning an instantiation of - -- generic unit Gen_Id. Kind denotes the kind of the instantiation. + -------------------------------- + -- Record_Invocation_Relation -- + -------------------------------- - -------------------------- - -- Output_Instantiation -- - -------------------------- + procedure Record_Invocation_Relation + (Invk_Id : Entity_Id; + Targ_Id : Entity_Id; + In_State : Processing_In_State) + is + pragma Assert (Present (Invk_Id)); + pragma Assert (Present (Targ_Id)); - procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is + procedure Get_Invocation_Attributes + (Extra : out Entity_Id; + Kind : out Invocation_Kind); + pragma Inline (Get_Invocation_Attributes); + -- Return the additional entity used in error diagnostics in Extra + -- and the invocation kind in Kind which pertain to the invocation + -- relation with invoker Invk_Id and target Targ_Id. + + ------------------------------- + -- Get_Invocation_Attributes -- + ------------------------------- + + procedure Get_Invocation_Attributes + (Extra : out Entity_Id; + Kind : out Invocation_Kind) + is begin - Error_Msg_NE - ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); - end Output_Instantiation; + -- Accept within a task body - -- Local variables + if Is_Accept_Alternative_Proc (Targ_Id) then + Extra := Receiving_Entry (Targ_Id); + Kind := Accept_Alternative; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; - Gen_Id : Entity_Id; + -- Activation of a task object - -- Start of processing for Output_Instantiation + elsif Is_Activation_Proc (Targ_Id) + or else Is_Task_Type (Targ_Id) + then + Extra := Empty; + Kind := Task_Activation; - begin - Extract_Instantiation_Attributes - (Exp_Inst => N, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + -- Controlled adjustment actions - Error_Msg_Node_2 := Inst_Id; - Error_Msg_Sloc := Sloc (Inst); + elsif Is_Controlled_Proc (Targ_Id, Name_Adjust) then + Extra := First_Formal_Type (Targ_Id); + Kind := Controlled_Adjustment; - if Nkind (Inst) = N_Function_Instantiation then - Output_Instantiation (Gen_Id, "function"); + -- Controlled finalization actions - elsif Nkind (Inst) = N_Package_Instantiation then - Output_Instantiation (Gen_Id, "package"); + elsif Is_Controlled_Proc (Targ_Id, Name_Finalize) + or else Is_Finalizer_Proc (Targ_Id) + then + Extra := First_Formal_Type (Targ_Id); + Kind := Controlled_Finalization; - elsif Nkind (Inst) = N_Procedure_Instantiation then - Output_Instantiation (Gen_Id, "procedure"); + -- Controlled initialization actions - else - pragma Assert (False); - null; - end if; - end Output_Instantiation; + elsif Is_Controlled_Proc (Targ_Id, Name_Initialize) then + Extra := First_Formal_Type (Targ_Id); + Kind := Controlled_Initialization; - --------------------------------------- - -- Output_SPARK_Refined_State_Pragma -- - --------------------------------------- + -- Default_Initial_Condition verification - procedure Output_SPARK_Refined_State_Pragma (N : Node_Id) is - begin - Error_Msg_Sloc := Sloc (N); - Error_Msg_N ("\\ refinement constituents read #", Error_Nod); - end Output_SPARK_Refined_State_Pragma; + elsif Is_Default_Initial_Condition_Proc (Targ_Id) then + Extra := First_Formal_Type (Targ_Id); + Kind := Default_Initial_Condition_Verification; - -------------------------------- - -- Output_Variable_Assignment -- - -------------------------------- + -- Initialization of object - procedure Output_Variable_Assignment (N : Node_Id) is - Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (N)); + elsif Is_Init_Proc (Targ_Id) then + Extra := First_Formal_Type (Targ_Id); + Kind := Type_Initialization; - begin - Error_Msg_Sloc := Sloc (N); - Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); - end Output_Variable_Assignment; + -- Initial_Condition verification - ------------------------------- - -- Output_Variable_Reference -- - ------------------------------- + elsif Is_Initial_Condition_Proc (Targ_Id) then + Extra := First_Formal_Type (Targ_Id); + Kind := Initial_Condition_Verification; - procedure Output_Variable_Reference (N : Node_Id) is - Dummy : Variable_Attributes; - Var_Id : Entity_Id; + -- Instantiation - begin - Extract_Variable_Reference_Attributes - (Ref => N, - Var_Id => Var_Id, - Attrs => Dummy); + elsif Is_Generic_Unit (Targ_Id) then + Extra := Empty; + Kind := Instantiation; - Error_Msg_Sloc := Sloc (N); + -- Internal controlled adjustment actions - if Is_Read (N) then - Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); + elsif Is_TSS (Targ_Id, TSS_Deep_Adjust) then + Extra := First_Formal_Type (Targ_Id); + Kind := Internal_Controlled_Adjustment; - else - pragma Assert (False); - null; - end if; - end Output_Variable_Reference; + -- Internal controlled finalization actions - -- Local variables + elsif Is_TSS (Targ_Id, TSS_Deep_Finalize) then + Extra := First_Formal_Type (Targ_Id); + Kind := Internal_Controlled_Finalization; - package Stack renames Scenario_Stack; + -- Internal controlled initialization actions - Dummy : Call_Attributes; - N : Node_Id; - Posted : Boolean; - Target_Id : Entity_Id; + elsif Is_TSS (Targ_Id, TSS_Deep_Initialize) then + Extra := First_Formal_Type (Targ_Id); + Kind := Internal_Controlled_Initialization; - -- Start of processing for Output_Active_Scenarios + -- Invariant verification - begin - -- Active scenarios are emitted only when the static model is in effect - -- because there is an inherent order by which all these scenarios were - -- reached from the declaration or library level. + elsif Is_Invariant_Proc (Targ_Id) + or else Is_Partial_Invariant_Proc (Targ_Id) + then + Extra := First_Formal_Type (Targ_Id); + Kind := Invariant_Verification; - if not Static_Elaboration_Checks then - return; - end if; + -- Postcondition verification - Posted := False; + elsif Is_Postconditions_Proc (Targ_Id) then + Extra := Find_Enclosing_Scope (Targ_Id); + Kind := Postcondition_Verification; - for Index in Stack.First .. Stack.Last loop - N := Stack.Table (Index); + -- Protected entry call - if not Posted then - Posted := True; - Output_Header; - end if; + elsif Is_Protected_Entry (Targ_Id) then + Extra := Empty; + Kind := Protected_Entry_Call; - -- 'Access + -- Protected subprogram call - if Nkind (N) = N_Attribute_Reference then - Output_Access (N); + elsif Is_Protected_Subp (Targ_Id) then + Extra := Empty; + Kind := Protected_Subprogram_Call; - -- Calls + -- Task entry call - elsif Is_Suitable_Call (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Dummy); + elsif Is_Task_Entry (Targ_Id) then + Extra := Empty; + Kind := Task_Entry_Call; + + -- Entry, operator, or subprogram call. This case must come last + -- because most invocations above are variations of this case. + + elsif Ekind_In (Targ_Id, E_Entry, + E_Function, + E_Operator, + E_Procedure) + then + Extra := Empty; + Kind := Call; - if Is_Activation_Proc (Target_Id) then - Output_Activation_Call (N); else - Output_Call (N, Target_Id); + pragma Assert (False); + Extra := Empty; + Kind := No_Invocation; end if; + end Get_Invocation_Attributes; - -- Instantiations + -- Local variables - elsif Is_Suitable_Instantiation (N) then - Output_Instantiation (N); + Extra : Entity_Id; + Extra_Nam : Name_Id; + IR_Rec : Invocation_Relation_Record; + Kind : Invocation_Kind; + Rel : Invoker_Target_Relation; - -- Pragma Refined_State + -- Start of processing for Record_Invocation_Relation - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Output_SPARK_Refined_State_Pragma (N); + begin + Rel.Invoker := Invk_Id; + Rel.Target := Targ_Id; - -- Variable assignments + -- Nothing to do when the invocation relation has already been + -- recorded in ALI file of the main unit. + + if Is_Saved_Relation (Rel) then + return; + end if; - elsif Nkind (N) = N_Assignment_Statement then - Output_Variable_Assignment (N); + -- Mark the relation as recorded in the ALI file - -- Variable references + Set_Is_Saved_Relation (Rel); - elsif Is_Suitable_Variable_Reference (N) then - Output_Variable_Reference (N); + -- Declare the invoker in the ALI file + + Declare_Invocation_Construct + (Constr_Id => Invk_Id, + In_State => In_State); + + -- Obtain the invocation-specific attributes of the relation + Get_Invocation_Attributes (Extra, Kind); + + -- Certain invocations lack an extra entity used in error diagnostics + + if Present (Extra) then + Extra_Nam := Chars (Extra); else - pragma Assert (False); - null; + Extra_Nam := No_Name; end if; - end loop; - end Output_Active_Scenarios; - ------------------------- - -- Pop_Active_Scenario -- - ------------------------- + IR_Rec.Extra := Extra_Nam; + IR_Rec.Invoker := Signature_Of (Invk_Id); + IR_Rec.Kind := Kind; + IR_Rec.Target := Signature_Of (Targ_Id); - procedure Pop_Active_Scenario (N : Node_Id) is - Top : Node_Id renames Scenario_Stack.Table (Scenario_Stack.Last); + -- Add the relation in the ALI file - begin - pragma Assert (Top = N); - Scenario_Stack.Decrement_Last; - end Pop_Active_Scenario; + Add_Invocation_Relation + (IR_Rec => IR_Rec, + Update_Units => False); + end Record_Invocation_Relation; - -------------------------------- - -- Process_Activation_Generic -- - -------------------------------- + ----------------------------------- + -- Record_Simple_Invocation_Path -- + ----------------------------------- - procedure Process_Activation_Generic - (Call : Node_Id; - Call_Attrs : Call_Attributes; - State : Processing_Attributes) - is - procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); - -- Perform ABE checks and diagnostics for object Obj_Id with type Typ. - -- Typ may be a task type or a composite type with at least one task - -- component. + procedure Record_Simple_Invocation_Path + (In_State : Processing_In_State) + is + package Scenarios renames Active_Scenario_Stack; - procedure Process_Task_Objects (List : List_Id); - -- Perform ABE checks and diagnostics for all task objects found in the - -- list List. + Last_Targ : constant Entity_Id := + Target_Of (Scenarios.Last, In_State); + First_Targ : Entity_Id; - ------------------------- - -- Process_Task_Object -- - ------------------------- + begin + -- The path originates from the elaboration of the body. Add an extra + -- relation from the elaboration body procedure to the first active + -- scenario. - procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is - Base_Typ : constant Entity_Id := Base_Type (Typ); + if In_State.Processing = Invocation_Body_Processing then + Build_Elaborate_Body_Procedure; + First_Targ := Elab_Body_Id; - Comp_Id : Entity_Id; - Task_Attrs : Task_Attributes; + -- The path originates from the elaboration of the spec. Add an extra + -- relation from the elaboration spec procedure to the first active + -- scenario. - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + elsif In_State.Processing = Invocation_Spec_Processing then + Build_Elaborate_Spec_Procedure; + First_Targ := Elab_Spec_Id; + + else + First_Targ := Target_Of (Scenarios.First, In_State); + end if; + + -- Record a single relation from the first to the last scenario + + if First_Targ /= Last_Targ then + Record_Invocation_Relation + (Invk_Id => First_Targ, + Targ_Id => Last_Targ, + In_State => In_State); + end if; + end Record_Simple_Invocation_Path; + + ---------------------------- + -- Set_Is_Saved_Construct -- + ---------------------------- + + procedure Set_Is_Saved_Construct + (Constr : Entity_Id; + Val : Boolean := True) + is + pragma Assert (Present (Constr)); begin - if Is_Task_Type (Typ) then - Extract_Task_Attributes - (Typ => Base_Typ, - Attrs => Task_Attrs); + if Val then + NE_Set.Insert (Saved_Constructs_Set, Constr); + else + NE_Set.Delete (Saved_Constructs_Set, Constr); + end if; + end Set_Is_Saved_Construct; - -- Warnings are suppressed when a prior scenario is already in - -- that mode, or when the object, activation call, or task type - -- have warnings suppressed. Update the state of the Processing - -- phase to reflect this. + --------------------------- + -- Set_Is_Saved_Relation -- + --------------------------- - New_State.Suppress_Warnings := - New_State.Suppress_Warnings - or else not Is_Elaboration_Warnings_OK_Id (Obj_Id) - or else not Call_Attrs.Elab_Warnings_OK - or else not Task_Attrs.Elab_Warnings_OK; + procedure Set_Is_Saved_Relation + (Rel : Invoker_Target_Relation; + Val : Boolean := True) + is + begin + if Val then + IR_Set.Insert (Saved_Relations_Set, Rel); + else + IR_Set.Delete (Saved_Relations_Set, Rel); + end if; + end Set_Is_Saved_Relation; - -- Update the state of the Processing phase to indicate that any - -- further traversal is now within a task body. + ------------------ + -- Signature_Of -- + ------------------ - New_State.Within_Task_Body := True; + function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id is + Loc : constant Source_Ptr := Sloc (Id); - Process_Single_Activation - (Call => Call, - Call_Attrs => Call_Attrs, - Obj_Id => Obj_Id, - Task_Attrs => Task_Attrs, - State => New_State); + function Instantiation_Locations return Name_Id; + pragma Inline (Instantiation_Locations); + -- Create a concatenation of all lines and colums of each instance + -- where source location Loc appears. Return No_Name if no instances + -- exist. - -- Examine the component type when the object is an array + function Qualified_Scope return Name_Id; + pragma Inline (Qualified_Scope); + -- Obtain the qualified name of Id's scope - elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then - Process_Task_Object - (Obj_Id => Obj_Id, - Typ => Component_Type (Typ)); + ----------------------------- + -- Instantiation_Locations -- + ----------------------------- - -- Examine individual component types when the object is a record + function Instantiation_Locations return Name_Id is + Buffer : Bounded_String (2052); + Inst : Source_Ptr; + Loc_Nam : Name_Id; + SFI : Source_File_Index; - elsif Is_Record_Type (Typ) and then Has_Task (Base_Typ) then - Comp_Id := First_Component (Typ); - while Present (Comp_Id) loop - Process_Task_Object - (Obj_Id => Obj_Id, - Typ => Etype (Comp_Id)); + begin + SFI := Get_Source_File_Index (Loc); + Inst := Instantiation (SFI); - Next_Component (Comp_Id); - end loop; - end if; - end Process_Task_Object; + -- The location is within an instance. Construct a concatenation + -- of all lines and colums of each individual instance using the + -- following format: + -- + -- line1_column1_line2_column2_ ... _lineN_columnN - -------------------------- - -- Process_Task_Objects -- - -------------------------- + if Inst /= No_Location then + loop + Append (Buffer, Nat (Get_Logical_Line_Number (Inst))); + Append (Buffer, '_'); + Append (Buffer, Nat (Get_Column_Number (Inst))); - procedure Process_Task_Objects (List : List_Id) is - Item : Node_Id; - Item_Id : Entity_Id; - Item_Typ : Entity_Id; + SFI := Get_Source_File_Index (Inst); + Inst := Instantiation (SFI); - begin - -- Examine the contents of the list looking for an object declaration - -- of a task type or one that contains a task within. + exit when Inst = No_Location; - Item := First (List); - while Present (Item) loop - if Nkind (Item) = N_Object_Declaration then - Item_Id := Defining_Entity (Item); - Item_Typ := Etype (Item_Id); + Append (Buffer, '_'); + end loop; - if Has_Task (Item_Typ) then - Process_Task_Object - (Obj_Id => Item_Id, - Typ => Item_Typ); - end if; + Loc_Nam := Name_Find (Buffer); + return Loc_Nam; + + -- Otherwise there no instances are involved + + else + return No_Name; end if; + end Instantiation_Locations; - Next (Item); - end loop; - end Process_Task_Objects; + --------------------- + -- Qualified_Scope -- + --------------------- - -- Local variables + function Qualified_Scope return Name_Id is + Scop : Entity_Id; - Context : Node_Id; - Spec : Node_Id; + begin + Scop := Scope (Id); - -- Start of processing for Process_Activation_Generic + -- The entity appears within an anonymous concurrent type created + -- for a single protected or task type declaration. Use the entity + -- of the anonymous object as it represents the original scope. - begin - -- Nothing to do when the activation is a guaranteed ABE + if Is_Concurrent_Type (Scop) + and then Present (Anonymous_Object (Scop)) + then + Scop := Anonymous_Object (Scop); + end if; - if Is_Known_Guaranteed_ABE (Call) then - return; - end if; + return Get_Qualified_Name (Scop); + end Qualified_Scope; - -- Find the proper context of the activation call where all task objects - -- being activated are declared. This is usually the immediate parent of - -- the call. + -- Start of processing for Signature_Of - Context := Parent (Call); + begin + return + Invocation_Signature_Of + (Column => Nat (Get_Column_Number (Loc)), + Line => Nat (Get_Logical_Line_Number (Loc)), + Locations => Instantiation_Locations, + Name => Chars (Id), + Scope => Qualified_Scope); + end Signature_Of; - -- In the case of package bodies, the activation call is in the handled - -- sequence of statements, but the task objects are in the declaration - -- list of the body. + --------------- + -- Target_Of -- + --------------- - if Nkind (Context) = N_Handled_Sequence_Of_Statements - and then Nkind (Parent (Context)) = N_Package_Body - then - Context := Parent (Context); - end if; + function Target_Of + (Pos : Active_Scenario_Pos; + In_State : Processing_In_State) return Entity_Id + is + package Scenarios renames Active_Scenario_Stack; - -- Process all task objects defined in both the spec and body when the - -- activation call precedes the "begin" of a package body. + -- Ensure that the position is within the bounds of the active + -- scenario stack. - if Nkind (Context) = N_Package_Body then - Spec := - Specification - (Unit_Declaration_Node (Corresponding_Spec (Context))); + pragma Assert (Scenarios.First <= Pos); + pragma Assert (Pos <= Scenarios.Last); - Process_Task_Objects (Visible_Declarations (Spec)); - Process_Task_Objects (Private_Declarations (Spec)); - Process_Task_Objects (Declarations (Context)); + Scen_Rep : constant Scenario_Rep_Id := + Scenario_Representation_Of + (Scenarios.Table (Pos), In_State); - -- Process all task objects defined in the spec when the activation call - -- appears at the end of a package spec. + begin + -- The true target of an activation call is the current task type + -- rather than routine Activate_Tasks. - elsif Nkind (Context) = N_Package_Specification then - Process_Task_Objects (Visible_Declarations (Context)); - Process_Task_Objects (Private_Declarations (Context)); + if Kind (Scen_Rep) = Task_Activation_Scenario then + return Activated_Task_Type (Scen_Rep); + else + return Target (Scen_Rep); + end if; + end Target_Of; - -- Otherwise the context of the activation is some construct with a - -- declarative part. Note that the corresponding record type of a task - -- type is controlled. Because of this, the finalization machinery must - -- relocate the task object to the handled statements of the construct - -- to perform proper finalization in case of an exception. Examine the - -- statements of the construct rather than the declarations. + ------------------------------ + -- Traverse_Invocation_Body -- + ------------------------------ - else - pragma Assert (Nkind (Context) = N_Handled_Sequence_Of_Statements); + procedure Traverse_Invocation_Body + (N : Node_Id; + In_State : Processing_In_State) + is + begin + Traverse_Body + (N => N, + Requires_Processing => Is_Invocation_Scenario'Access, + Processor => Process_Invocation_Scenario'Access, + In_State => In_State); + end Traverse_Invocation_Body; - Process_Task_Objects (Statements (Context)); - end if; - end Process_Activation_Generic; + --------------------------- + -- Write_Invocation_Path -- + --------------------------- - ------------------------------------ - -- Process_Conditional_ABE_Access -- - ------------------------------------ + procedure Write_Invocation_Path (In_State : Processing_In_State) is + procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean); + pragma Inline (Write_Target); + -- Write out invocation target Targ_Id to standard output. Flag + -- Is_First should be set when the target is first in a path. - procedure Process_Conditional_ABE_Access - (Attr : Node_Id; - State : Processing_Attributes) - is - function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id; - pragma Inline (Build_Access_Marker); - -- Create a suitable call marker which invokes target Target_Id + ------------- + -- Targ_Id -- + ------------- - ------------------------- - -- Build_Access_Marker -- - ------------------------- + procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean) is + begin + if not Is_First then + Write_Str (" --> "); + end if; - function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id is - Marker : Node_Id; + Write_Name (Get_Qualified_Name (Targ_Id)); + Write_Eol; + end Write_Target; + + -- Local variables + + package Scenarios renames Active_Scenario_Stack; + + First_Seen : Boolean := False; + + -- Start of processing for Write_Invocation_Path begin - Marker := Make_Call_Marker (Sloc (Attr)); + -- Nothing to do when flag -gnatd_T (output trace information on + -- invocation path recording) is not in effect. - -- Inherit relevant attributes from the attribute + if not Debug_Flag_Underscore_TT then + return; + end if; - -- Performance note: parent traversal + -- The path originates from the elaboration of the body. Write the + -- elaboration body procedure. - Set_Target (Marker, Target_Id); - Set_Is_Declaration_Level_Node - (Marker, Find_Enclosing_Level (Attr) = Declaration_Level); - Set_Is_Dispatching_Call - (Marker, False); - Set_Is_Elaboration_Checks_OK_Node - (Marker, Is_Elaboration_Checks_OK_Node (Attr)); - Set_Is_Elaboration_Warnings_OK_Node - (Marker, Is_Elaboration_Warnings_OK_Node (Attr)); - Set_Is_Source_Call - (Marker, Comes_From_Source (Attr)); - Set_Is_SPARK_Mode_On_Node - (Marker, Is_SPARK_Mode_On_Node (Attr)); + if In_State.Processing = Invocation_Body_Processing then + Write_Target (Elab_Body_Id, True); + First_Seen := True; - -- Partially insert the call marker into the tree by setting its - -- parent pointer. + -- The path originates from the elaboration of the spec. Write the + -- elaboration spec procedure. - Set_Parent (Marker, Attr); + elsif In_State.Processing = Invocation_Spec_Processing then + Write_Target (Elab_Spec_Id, True); + First_Seen := True; + end if; - return Marker; - end Build_Access_Marker; + -- Write each individual target invoked by its corresponding scenario + -- on the active scenario stack. - -- Local variables + for Index in Scenarios.First .. Scenarios.Last loop + Write_Target + (Targ_Id => Target_Of (Index, In_State), + Is_First => Index = Scenarios.First and then not First_Seen); + end loop; - Root : constant Node_Id := Root_Scenario; - Target_Id : constant Entity_Id := Entity (Prefix (Attr)); + Write_Eol; + end Write_Invocation_Path; + end Invocation_Graph; - Target_Attrs : Target_Attributes; + ------------------------ + -- Is_Safe_Activation -- + ------------------------ + + function Is_Safe_Activation + (Call : Node_Id; + Task_Rep : Target_Rep_Id) return Boolean + is + begin + -- The activation of a task coming from an external instance cannot + -- cause an ABE because the generic was already instantiated. Note + -- that the instantiation itself may lead to an ABE. - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + return + In_External_Instance + (N => Call, + Target_Decl => Spec_Declaration (Task_Rep)); + end Is_Safe_Activation; - -- Start of processing for Process_Conditional_ABE_Access + ------------------ + -- Is_Safe_Call -- + ------------------ + + function Is_Safe_Call + (Call : Node_Id; + Subp_Id : Entity_Id; + Subp_Rep : Target_Rep_Id) return Boolean + is + Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); + Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); begin - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + -- The target is either an abstract subprogram, formal subprogram, or + -- imported, in which case it does not have a body at compile or bind + -- time. Assume that the call is ABE-safe. - if Elab_Info_Messages then - Error_Msg_NE - ("info: access to & during elaboration", Attr, Target_Id); - end if; + if Is_Bodiless_Subprogram (Subp_Id) then + return True; - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); + -- The target is an instantiation of a generic subprogram. The call + -- cannot cause an ABE because the generic was already instantiated. + -- Note that the instantiation itself may lead to an ABE. - -- Warnings are suppressed when a prior scenario is already in that - -- mode, or when the attribute or the target have warnings suppressed. - -- Update the state of the Processing phase to reflect this. + elsif Is_Generic_Instance (Subp_Id) then + return True; - New_State.Suppress_Warnings := - New_State.Suppress_Warnings - or else not Is_Elaboration_Warnings_OK_Node (Attr) - or else not Target_Attrs.Elab_Warnings_OK; + -- The invocation of a target coming from an external instance cannot + -- cause an ABE because the generic was already instantiated. Note that + -- the instantiation itself may lead to an ABE. - -- Do not emit any ABE diagnostics when the current or previous scenario - -- in this traversal has suppressed elaboration warnings. + elsif In_External_Instance + (N => Call, + Target_Decl => Spec_Decl) + then + return True; - if New_State.Suppress_Warnings then - null; + -- The target is a subprogram body without a previous declaration. The + -- call cannot cause an ABE because the body has already been seen. - -- Both the attribute and the corresponding body are in the same unit. - -- The corresponding body must appear prior to the root scenario which - -- started the recursive search. If this is not the case, then there is - -- a potential ABE if the access value is used to call the subprogram. - -- Emit a warning only when switch -gnatw.f (warnings on suspucious - -- 'Access) is in effect. - - elsif Warn_On_Elab_Access - and then Present (Target_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) - and then Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) + elsif Nkind (Spec_Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Spec_Decl)) then - Error_Msg_Name_1 := Attribute_Name (Attr); - Error_Msg_NE ("??% attribute of & before body seen", Attr, Target_Id); - Error_Msg_N ("\possible Program_Error on later references", Attr); + return True; + + -- The target is a subprogram body stub without a prior declaration. + -- The call cannot cause an ABE because the proper body substitutes + -- the stub. + + elsif Nkind (Spec_Decl) = N_Subprogram_Body_Stub + and then No (Corresponding_Spec_Of_Stub (Spec_Decl)) + then + return True; + + -- Subprogram bodies which wrap attribute references used as actuals + -- in instantiations are always ABE-safe. These bodies are artifacts + -- of expansion. - Output_Active_Scenarios (Attr); + elsif Present (Body_Decl) + and then Nkind (Body_Decl) = N_Subprogram_Body + and then Was_Attribute_Reference (Body_Decl) + then + return True; end if; - -- Treat the attribute as an immediate invocation of the target when - -- switch -gnatd.o (conservative elaboration order for indirect calls) - -- is in effect. Note that the prior elaboration of the unit containing - -- the target is ensured processing the corresponding call marker. + return False; + end Is_Safe_Call; - if Debug_Flag_Dot_O then - Process_Conditional_ABE - (N => Build_Access_Marker (Target_Id), - State => New_State); + --------------------------- + -- Is_Safe_Instantiation -- + --------------------------- - -- Otherwise ensure that the unit with the corresponding body is - -- elaborated prior to the main unit. + function Is_Safe_Instantiation + (Inst : Node_Id; + Gen_Id : Entity_Id; + Gen_Rep : Target_Rep_Id) return Boolean + is + Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); - else - Ensure_Prior_Elaboration - (N => Attr, - Unit_Id => Target_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - State => New_State); + begin + -- The generic is an intrinsic subprogram in which case it does not + -- have a body at compile or bind time. Assume that the instantiation + -- is ABE-safe. + + if Is_Bodiless_Subprogram (Gen_Id) then + return True; + + -- The instantiation of an external nested generic cannot cause an ABE + -- if the outer generic was already instantiated. Note that the instance + -- of the outer generic may lead to an ABE. + + elsif In_External_Instance + (N => Inst, + Target_Decl => Spec_Decl) + then + return True; + + -- The generic is a package. The instantiation cannot cause an ABE when + -- the package has no body. + + elsif Ekind (Gen_Id) = E_Generic_Package + and then not Has_Body (Spec_Decl) + then + return True; end if; - end Process_Conditional_ABE_Access; - - --------------------------------------------- - -- Process_Conditional_ABE_Activation_Impl -- - --------------------------------------------- - - procedure Process_Conditional_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - State : Processing_Attributes) - is - Check_OK : constant Boolean := - not Is_Ignored_Ghost_Entity (Obj_Id) - and then not Task_Attrs.Ghost_Mode_Ignore - and then Is_Elaboration_Checks_OK_Id (Obj_Id) - and then Task_Attrs.Elab_Checks_OK; - -- A run-time ABE check may be installed only when the object and the - -- task type have active elaboration checks, and both are not ignored - -- Ghost constructs. - Root : constant Node_Id := Root_Scenario; + return False; + end Is_Safe_Instantiation; - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + ------------------ + -- Is_Same_Unit -- + ------------------ + function Is_Same_Unit + (Unit_1 : Entity_Id; + Unit_2 : Entity_Id) return Boolean + is begin - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); + end Is_Same_Unit; - if Elab_Info_Messages then - Error_Msg_NE - ("info: activation of & during elaboration", Call, Obj_Id); - end if; + ------------------------------- + -- Kill_Elaboration_Scenario -- + ------------------------------- - -- Nothing to do when the call activates a task whose type is defined - -- within an instance and switch -gnatd_i (ignore activations and calls - -- to instances for elaboration) is in effect. + procedure Kill_Elaboration_Scenario (N : Node_Id) is + begin + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE lechanism does not need + -- to carry out this action. - if Debug_Flag_Underscore_I - and then In_External_Instance - (N => Call, - Target_Decl => Task_Attrs.Task_Decl) - then + if Legacy_Elaboration_Checks then return; + end if; - -- Nothing to do when the activation is a guaranteed ABE + -- Eliminate a recorded scenario when it appears within dead code + -- because it will not be executed at elaboration time. - elsif Is_Known_Guaranteed_ABE (Call) then - return; + if Is_Scenario (N) then + Delete_Scenario (N); + end if; + end Kill_Elaboration_Scenario; - -- Nothing to do when the root scenario appears at the declaration - -- level and the task is in the same unit, but outside this context. - -- - -- task type Task_Typ; -- task declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- T : Task_Typ; - -- begin - -- <activation call> -- activation site - -- end; - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- task body Task_Typ is - -- ... - -- end Task_Typ; - -- - -- In the example above, the context of X is the declarative list of - -- Proc. The "elaboration" of X may reach the activation of T whose body - -- is defined outside of X's context. The task body is relevant only - -- when Proc is invoked, but this happens only in "normal" elaboration, - -- therefore the task body must not be considered if this is not the - -- case. + ---------------------- + -- Non_Private_View -- + ---------------------- + + function Non_Private_View (Typ : Entity_Id) return Entity_Id is + begin + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + return Full_View (Typ); + else + return Typ; + end if; + end Non_Private_View; - -- Performance note: parent traversal + --------------------------------- + -- Record_Elaboration_Scenario -- + --------------------------------- - elsif Is_Up_Level_Target (Task_Attrs.Task_Decl) then - return; + procedure Record_Elaboration_Scenario (N : Node_Id) is + procedure Check_Preelaborated_Call + (Call : Node_Id; + Call_Lvl : Enclosing_Level_Kind); + pragma Inline (Check_Preelaborated_Call); + -- Verify that entry, operator, or subprogram call Call with enclosing + -- level Call_Lvl does not appear at the library level of preelaborated + -- unit. - -- Nothing to do when the activation is ABE-safe - -- - -- generic - -- package Gen is - -- task type Task_Typ; - -- end Gen; - -- - -- package body Gen is - -- task body Task_Typ is - -- begin - -- ... - -- end Task_Typ; - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- package Nested is - -- package Inst is new Gen; - -- T : Inst.Task_Typ; - -- <activation call> -- safe activation - -- end Nested; - -- ... + function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id; + pragma Inline (Find_Code_Unit); + -- Return the code unit which contains arbitrary node or entity Nod. + -- This is the unit of the file which physically contains the related + -- construct denoted by Nod except when Nod is within an instantiation. + -- In that case the unit is that of the top-level instantiation. + + function In_Preelaborated_Context (Nod : Node_Id) return Boolean; + pragma Inline (In_Preelaborated_Context); + -- Determine whether arbitrary node Nod appears within a preelaborated + -- context. + + procedure Record_Access_Taken + (Attr : Node_Id; + Attr_Lvl : Enclosing_Level_Kind); + pragma Inline (Record_Access_Taken); + -- Record 'Access scenario Attr with enclosing level Attr_Lvl + + procedure Record_Call_Or_Task_Activation + (Call : Node_Id; + Call_Lvl : Enclosing_Level_Kind); + pragma Inline (Record_Call_Or_Task_Activation); + -- Record call scenario Call with enclosing level Call_Lvl + + procedure Record_Instantiation + (Inst : Node_Id; + Inst_Lvl : Enclosing_Level_Kind); + pragma Inline (Record_Instantiation); + -- Record instantiation scenario Inst with enclosing level Inst_Lvl + + procedure Record_Variable_Assignment + (Asmt : Node_Id; + Asmt_Lvl : Enclosing_Level_Kind); + pragma Inline (Record_Variable_Assignment); + -- Record variable assignment scenario Asmt with enclosing level + -- Asmt_Lvl. + + procedure Record_Variable_Reference + (Ref : Node_Id; + Ref_Lvl : Enclosing_Level_Kind); + pragma Inline (Record_Variable_Reference); + -- Record variable reference scenario Ref with enclosing level Ref_Lvl - elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then + ------------------------------ + -- Check_Preelaborated_Call -- + ------------------------------ - -- Note that the task body must still be examined for any nested - -- scenarios. + procedure Check_Preelaborated_Call + (Call : Node_Id; + Call_Lvl : Enclosing_Level_Kind) + is + begin + -- Nothing to do when the call is internally generated because it is + -- assumed that it will never violate preelaboration. - null; + if not Is_Source_Call (Call) then + return; - -- The activation call and the task body are both in the main unit + -- Library-level calls are always considered because they are part of + -- the associated unit's elaboration actions. - elsif Present (Task_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Task_Attrs.Body_Decl) - then - -- If the root scenario appears prior to the task body, then this is - -- a possible ABE with respect to the root scenario. - -- - -- task type Task_Typ; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- package Pack is - -- T : Task_Typ; - -- end Pack; -- activation of T - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- - -- task body Task_Typ is -- task body - -- ... - -- end Task_Typ; - -- - -- Y : ... := A; -- root scenario - -- - -- IMPORTANT: The activation of T is a possible ABE for X, but - -- not for Y. Intalling an unconditional ABE raise prior to the - -- activation call would be wrong as it will fail for Y as well - -- but in Y's case the activation of T is never an ABE. + elsif Call_Lvl in Library_Level then + null; - if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then + -- Calls at the library level of a generic package body have to be + -- checked because they would render an instantiation illegal if the + -- template is marked as preelaborated. Note that this does not apply + -- to calls at the library level of a generic package spec. - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + elsif Call_Lvl = Generic_Body_Level then + null; - if State.Suppress_Warnings then - null; + -- Otherwise the call does not appear at the proper level and must + -- not be considered for this check. - -- Do not emit any ABE diagnostics when the activation occurs in - -- a partial finalization context because this leads to confusing - -- noise. + else + return; + end if; - elsif State.Within_Partial_Finalization then - null; + -- The call appears within a preelaborated unit. Emit a warning only + -- for internal uses, otherwise this is an error. - -- ABE diagnostics are emitted only in the static model because - -- there is a well-defined order to visiting scenarios. Without - -- this order diagnostics appear jumbled and result in unwanted - -- noise. + if In_Preelaborated_Context (Call) then + Error_Msg_Warn := GNAT_Mode; + Error_Msg_N + ("<<non-static call not allowed in preelaborated unit", Call); + end if; + end Check_Preelaborated_Call; - elsif Static_Elaboration_Checks then - Error_Msg_Sloc := Sloc (Call); - Error_Msg_N - ("??task & will be activated # before elaboration of its " - & "body", Obj_Id); - Error_Msg_N - ("\Program_Error may be raised at run time", Obj_Id); + -------------------- + -- Find_Code_Unit -- + -------------------- - Output_Active_Scenarios (Obj_Id); - end if; + function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id is + begin + return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (Nod)))); + end Find_Code_Unit; - -- Install a conditional run-time ABE check to verify that the - -- task body has been elaborated prior to the activation call. + ------------------------------ + -- In_Preelaborated_Context -- + ------------------------------ - if Check_OK then - Install_ABE_Check - (N => Call, - Ins_Nod => Call, - Target_Id => Task_Attrs.Spec_Id, - Target_Decl => Task_Attrs.Task_Decl, - Target_Body => Task_Attrs.Body_Decl); + function In_Preelaborated_Context (Nod : Node_Id) return Boolean is + Body_Id : constant Entity_Id := Find_Code_Unit (Nod); + Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); - -- Update the state of the Processing phase to indicate that - -- no implicit Elaborate[_All] pragmas must be generated from - -- this point on. - -- - -- task type Task_Typ; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- package Pack is - -- <ABE check> - -- T : Task_Typ; - -- end Pack; -- activation of T - -- ... - -- end A; - -- - -- X : ... := A; - -- - -- task body Task_Typ is - -- begin - -- External.Subp; -- imparts Elaborate_All - -- end Task_Typ; - -- - -- If Some_Condition is True, then the ABE check will fail at - -- runtime and the call to External.Subp will never take place, - -- rendering the implicit Elaborate_All useless. - -- - -- If Some_Condition is False, then the call to External.Subp - -- will never take place, rendering the implicit Elaborate_All - -- useless. + begin + -- The node appears within a package body whose corresponding spec is + -- subject to pragma Remote_Call_Interface or Remote_Types. This does + -- not result in a preelaborated context because the package body may + -- be on another machine. - New_State.Suppress_Implicit_Pragmas := True; - end if; + if Ekind (Body_Id) = E_Package_Body + and then Ekind_In (Spec_Id, E_Generic_Package, E_Package) + and then (Is_Remote_Call_Interface (Spec_Id) + or else Is_Remote_Types (Spec_Id)) + then + return False; + + -- Otherwise the node appears within a preelaborated context when the + -- associated unit is preelaborated. + + else + return Is_Preelaborated_Unit (Spec_Id); end if; + end In_Preelaborated_Context; - -- Otherwise the task body is not available in this compilation or it - -- resides in an external unit. Install a run-time ABE check to verify - -- that the task body has been elaborated prior to the activation call - -- when the dynamic model is in effect. + ------------------------- + -- Record_Access_Taken -- + ------------------------- - elsif Dynamic_Elaboration_Checks and then Check_OK then - Install_ABE_Check - (N => Call, - Ins_Nod => Call, - Id => Task_Attrs.Unit_Id); - end if; + procedure Record_Access_Taken + (Attr : Node_Id; + Attr_Lvl : Enclosing_Level_Kind) + is + begin + -- Signal any enclosing local exception handlers that the 'Access may + -- raise Program_Error due to a failed ABE check when switch -gnatd.o + -- (conservative elaboration order for indirect calls) is in effect. + -- Marking the exception handlers ensures proper expansion by both + -- the front and back end restriction when No_Exception_Propagation + -- is in effect. - -- Both the activation call and task type are subject to SPARK_Mode - -- On, this triggers the SPARK rules for task activation. Compared to - -- calls and instantiations, task activation in SPARK does not require - -- the presence of Elaborate[_All] pragmas in case the task type is - -- defined outside the main unit. This is because SPARK utilizes a - -- special policy which activates all tasks after the main unit has - -- finished its elaboration. + if Debug_Flag_Dot_O then + Possible_Local_Raise (Attr, Standard_Program_Error); + end if; - if Call_Attrs.SPARK_Mode_On and Task_Attrs.SPARK_Mode_On then - null; + -- Add 'Access to the appropriate set - -- Otherwise the Ada rules are in effect. Ensure that the unit with the - -- task body is elaborated prior to the main unit. + if Attr_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Attr); - else - Ensure_Prior_Elaboration + elsif Attr_Lvl = Library_Spec_Level + or else Attr_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Attr); + end if; + + -- 'Access requires a conditional ABE check when the dynamic model is + -- in effect. + + Add_Dynamic_ABE_Check_Scenario (Attr); + end Record_Access_Taken; + + ------------------------------------ + -- Record_Call_Or_Task_Activation -- + ------------------------------------ + + procedure Record_Call_Or_Task_Activation + (Call : Node_Id; + Call_Lvl : Enclosing_Level_Kind) + is + begin + -- Signal any enclosing local exception handlers that the call may + -- raise Program_Error due to failed ABE check. Marking the exception + -- handlers ensures proper expansion by both the front and back end + -- restriction when No_Exception_Propagation is in effect. + + Possible_Local_Raise (Call, Standard_Program_Error); + + -- Perform early detection of guaranteed ABEs in order to suppress + -- the instantiation of generic bodies because gigi cannot handle + -- certain types of premature instantiations. + + Process_Guaranteed_ABE (N => Call, - Unit_Id => Task_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - State => New_State); - end if; + In_State => Guaranteed_ABE_State); - Traverse_Body - (N => Task_Attrs.Body_Decl, - State => New_State); - end Process_Conditional_ABE_Activation_Impl; + -- Add the call or task activation to the appropriate set - procedure Process_Conditional_ABE_Activation is - new Process_Activation_Generic (Process_Conditional_ABE_Activation_Impl); + if Call_Lvl = Declaration_Level then + Add_Declaration_Scenario (Call); - ---------------------------------- - -- Process_Conditional_ABE_Call -- - ---------------------------------- + elsif Call_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Call); - procedure Process_Conditional_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - State : Processing_Attributes) - is - function In_Initialization_Context (N : Node_Id) return Boolean; - -- Determine whether arbitrary node N appears within a type init proc, - -- primitive [Deep_]Initialize, or a block created for initialization - -- purposes. + elsif Call_Lvl = Library_Spec_Level + or else Call_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Call); + end if; - function Is_Partial_Finalization_Proc return Boolean; - pragma Inline (Is_Partial_Finalization_Proc); - -- Determine whether call Call with target Target_Id invokes a partial - -- finalization procedure. + -- A call or a task activation requires a conditional ABE check when + -- the dynamic model is in effect. - ------------------------------- - -- In_Initialization_Context -- - ------------------------------- + Add_Dynamic_ABE_Check_Scenario (Call); + end Record_Call_Or_Task_Activation; - function In_Initialization_Context (N : Node_Id) return Boolean is - Par : Node_Id; - Spec_Id : Entity_Id; + -------------------------- + -- Record_Instantiation -- + -------------------------- + procedure Record_Instantiation + (Inst : Node_Id; + Inst_Lvl : Enclosing_Level_Kind) + is begin - -- Climb the parent chain looking for initialization actions + -- Signal enclosing local exception handlers that instantiation may + -- raise Program_Error due to failed ABE check. Marking the exception + -- handlers ensures proper expansion by both the front and back end + -- restriction when No_Exception_Propagation is in effect. - Par := Parent (N); - while Present (Par) loop + Possible_Local_Raise (Inst, Standard_Program_Error); - -- A block may be part of the initialization actions of a default - -- initialized object. + -- Perform early detection of guaranteed ABEs in order to suppress + -- the instantiation of generic bodies because gigi cannot handle + -- certain types of premature instantiations. - if Nkind (Par) = N_Block_Statement - and then Is_Initialization_Block (Par) - then - return True; + Process_Guaranteed_ABE + (N => Inst, + In_State => Guaranteed_ABE_State); - -- A subprogram body may denote an initialization routine + -- Add the instantiation to the appropriate set - elsif Nkind (Par) = N_Subprogram_Body then - Spec_Id := Unique_Defining_Entity (Par); + if Inst_Lvl = Declaration_Level then + Add_Declaration_Scenario (Inst); - -- The current subprogram body denotes a type init proc or - -- primitive [Deep_]Initialize. + elsif Inst_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Inst); - if Is_Init_Proc (Spec_Id) - or else Is_Controlled_Proc (Spec_Id, Name_Initialize) - or else Is_TSS (Spec_Id, TSS_Deep_Initialize) - then - return True; - end if; + elsif Inst_Lvl = Library_Spec_Level + or else Inst_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Inst); + end if; - -- Prevent the search from going too far + -- Instantiations of generics subject to SPARK_Mode On require + -- elaboration-related checks even though the instantiations may + -- not appear within elaboration code. - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; + if Is_Suitable_SPARK_Instantiation (Inst) then + Add_SPARK_Scenario (Inst); + end if; - Par := Parent (Par); - end loop; + -- An instantiation requires a conditional ABE check when the dynamic + -- model is in effect. - return False; - end In_Initialization_Context; + Add_Dynamic_ABE_Check_Scenario (Inst); + end Record_Instantiation; - ---------------------------------- - -- Is_Partial_Finalization_Proc -- - ---------------------------------- + -------------------------------- + -- Record_Variable_Assignment -- + -------------------------------- - function Is_Partial_Finalization_Proc return Boolean is + procedure Record_Variable_Assignment + (Asmt : Node_Id; + Asmt_Lvl : Enclosing_Level_Kind) + is begin - -- To qualify, the target must denote primitive [Deep_]Finalize or a - -- finalizer procedure, and the call must appear in an initialization - -- context. + -- Add the variable assignment to the appropriate set - return - (Is_Controlled_Proc (Target_Id, Name_Finalize) - or else Is_Finalizer_Proc (Target_Id) - or else Is_TSS (Target_Id, TSS_Deep_Finalize)) - and then In_Initialization_Context (Call); - end Is_Partial_Finalization_Proc; + if Asmt_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Asmt); - -- Local variables + elsif Asmt_Lvl = Library_Spec_Level + or else Asmt_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Asmt); + end if; + end Record_Variable_Assignment; - SPARK_Rules_On : Boolean; - Target_Attrs : Target_Attributes; + ------------------------------- + -- Record_Variable_Reference -- + ------------------------------- - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + procedure Record_Variable_Reference + (Ref : Node_Id; + Ref_Lvl : Enclosing_Level_Kind) + is + begin + -- Add the variable reference to the appropriate set - -- Start of processing for Process_Conditional_ABE_Call + if Ref_Lvl = Library_Body_Level then + Add_Library_Body_Scenario (Ref); - begin - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); + elsif Ref_Lvl = Library_Spec_Level + or else Ref_Lvl = Instantiation_Level + then + Add_Library_Spec_Scenario (Ref); + end if; + end Record_Variable_Reference; - -- The SPARK rules are in effect when both the call and target are - -- subject to SPARK_Mode On. + -- Local variables - SPARK_Rules_On := - Call_Attrs.SPARK_Mode_On and Target_Attrs.SPARK_Mode_On; + Scen : constant Node_Id := Scenario (N); + Scen_Lvl : Enclosing_Level_Kind; - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + -- Start of processing for Record_Elaboration_Scenario - if Elab_Info_Messages then - Info_Call - (Call => Call, - Target_Id => Target_Id, - Info_Msg => True, - In_SPARK => SPARK_Rules_On); - end if; + begin + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE mechanism does not need + -- to carry out this action. - -- Check whether the invocation of an entry clashes with an existing - -- restriction. + if Legacy_Elaboration_Checks then + return; - if Is_Protected_Entry (Target_Id) then - Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); + -- Nothing to do for ASIS because ABE checks and diagnostics are not + -- performed in this mode. - elsif Is_Task_Entry (Target_Id) then - Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); + elsif ASIS_Mode then + return; - -- Task entry calls are never processed because the entry being - -- invoked does not have a corresponding "body", it has a select. + -- Nothing to do when the scenario is being preanalyzed + elsif Preanalysis_Active then return; end if; - -- Nothing to do when the call invokes a target defined within an - -- instance and switch -gnatd_i (ignore activations and calls to - -- instances for elaboration) is in effect. + Scen_Lvl := Find_Enclosing_Level (Scen); - if Debug_Flag_Underscore_I - and then In_External_Instance - (N => Call, - Target_Decl => Target_Attrs.Spec_Decl) - then - return; + -- Ensure that a library-level call does not appear in a preelaborated + -- unit. The check must come before ignoring scenarios within external + -- units or inside generics because calls in those context must also be + -- verified. - -- Nothing to do when the call is a guaranteed ABE + if Is_Suitable_Call (Scen) then + Check_Preelaborated_Call (Scen, Scen_Lvl); + end if; - elsif Is_Known_Guaranteed_ABE (Call) then - return; + -- Nothing to do when the scenario does not appear within the main unit - -- Nothing to do when the root scenario appears at the declaration level - -- and the target is in the same unit, but outside this context. - -- - -- function B ...; -- target declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- function B ... is - -- ... - -- end B; - -- - -- In the example above, the context of X is the declarative region of - -- Proc. The "elaboration" of X may eventually reach B which is defined - -- outside of X's context. B is relevant only when Proc is invoked, but - -- this happens only by means of "normal" elaboration, therefore B must - -- not be considered if this is not the case. + if not In_Main_Context (Scen) then + return; - -- Performance note: parent traversal + -- Nothing to do when the scenario appears within a generic - elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then + elsif Inside_A_Generic then return; - end if; - - -- Warnings are suppressed when a prior scenario is already in that - -- mode, or the call or target have warnings suppressed. Update the - -- state of the Processing phase to reflect this. - New_State.Suppress_Warnings := - New_State.Suppress_Warnings - or else not Call_Attrs.Elab_Warnings_OK - or else not Target_Attrs.Elab_Warnings_OK; + -- 'Access - -- The call occurs in an initial condition context when a prior scenario - -- is already in that mode, or when the target is an Initial_Condition - -- procedure. Update the state of the Processing phase to reflect this. + elsif Is_Suitable_Access_Taken (Scen) then + Record_Access_Taken + (Attr => Scen, + Attr_Lvl => Scen_Lvl); - New_State.Within_Initial_Condition := - New_State.Within_Initial_Condition - or else Is_Initial_Condition_Proc (Target_Id); + -- Call or task activation - -- The call occurs in a partial finalization context when a prior - -- scenario is already in that mode, or when the target denotes a - -- [Deep_]Finalize primitive or a finalizer within an initialization - -- context. Update the state of the Processing phase to reflect this. + elsif Is_Suitable_Call (Scen) then + Record_Call_Or_Task_Activation + (Call => Scen, + Call_Lvl => Scen_Lvl); - New_State.Within_Partial_Finalization := - New_State.Within_Partial_Finalization - or else Is_Partial_Finalization_Proc; + -- Derived type declaration - -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK - -- elaboration rules in SPARK code) is intentionally not taken into - -- account here because Process_Conditional_ABE_Call_SPARK has two - -- separate modes of operation. + elsif Is_Suitable_SPARK_Derived_Type (Scen) then + Add_SPARK_Scenario (Scen); - if SPARK_Rules_On then - Process_Conditional_ABE_Call_SPARK - (Call => Call, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs, - State => New_State); + -- Instantiation - -- Otherwise the Ada rules are in effect + elsif Is_Suitable_Instantiation (Scen) then + Record_Instantiation + (Inst => Scen, + Inst_Lvl => Scen_Lvl); - else - Process_Conditional_ABE_Call_Ada - (Call => Call, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs, - State => New_State); - end if; + -- Refined_State pragma - -- Inspect the target body (and barried function) for other suitable - -- elaboration scenarios. + elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then + Add_SPARK_Scenario (Scen); - Traverse_Body - (N => Target_Attrs.Body_Barf, - State => New_State); + -- Variable assignment - Traverse_Body - (N => Target_Attrs.Body_Decl, - State => New_State); - end Process_Conditional_ABE_Call; + elsif Is_Suitable_Variable_Assignment (Scen) then + Record_Variable_Assignment + (Asmt => Scen, + Asmt_Lvl => Scen_Lvl); - -------------------------------------- - -- Process_Conditional_ABE_Call_Ada -- - -------------------------------------- + -- Variable reference - procedure Process_Conditional_ABE_Call_Ada - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - State : Processing_Attributes) - is - Check_OK : constant Boolean := - not Call_Attrs.Ghost_Mode_Ignore - and then not Target_Attrs.Ghost_Mode_Ignore - and then Call_Attrs.Elab_Checks_OK - and then Target_Attrs.Elab_Checks_OK; - -- A run-time ABE check may be installed only when both the call and the - -- target have active elaboration checks, and both are not ignored Ghost - -- constructs. + elsif Is_Suitable_Variable_Reference (Scen) then + Record_Variable_Reference + (Ref => Scen, + Ref_Lvl => Scen_Lvl); + end if; + end Record_Elaboration_Scenario; - Root : constant Node_Id := Root_Scenario; + -------------- + -- Scenario -- + -------------- - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + function Scenario (N : Node_Id) return Node_Id is + Orig_N : constant Node_Id := Original_Node (N); begin - -- Nothing to do for an Ada dispatching call because there are no ABE - -- diagnostics for either models. ABE checks for the dynamic model are - -- handled by Install_Primitive_Elaboration_Check. + -- An expanded instantiation is rewritten into a spec-body pair where + -- N denotes the spec. In this case the original instantiation is the + -- proper elaboration scenario. - if Call_Attrs.Is_Dispatching then - return; + if Nkind (Orig_N) in N_Generic_Instantiation then + return Orig_N; - -- Nothing to do when the call is ABE-safe - -- - -- generic - -- function Gen ...; - -- - -- function Gen ... is - -- begin - -- ... - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- function Inst is new Gen; - -- X : ... := Inst; -- safe call - -- ... + -- Otherwise the scenario is already in its proper form - elsif Is_Safe_Call (Call, Target_Attrs) then - return; + else + return N; + end if; + end Scenario; - -- The call and the target body are both in the main unit + ---------------------- + -- Scenario_Storage -- + ---------------------- - elsif Present (Target_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) - then - -- If the root scenario appears prior to the target body, then this - -- is a possible ABE with respect to the root scenario. - -- - -- function B ...; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- - -- function B ... is -- target body - -- ... - -- end B; - -- - -- Y : ... := A; -- root scenario - -- - -- IMPORTANT: The call to B from A is a possible ABE for X, but not - -- for Y. Installing an unconditional ABE raise prior to the call to - -- B would be wrong as it will fail for Y as well, but in Y's case - -- the call to B is never an ABE. + package body Scenario_Storage is - if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then + --------------------- + -- Data structures -- + --------------------- - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + -- The following sets store all scenarios - if State.Suppress_Warnings then - null; + Declaration_Scenarios : NE_Set.Membership_Set := + NE_Set.Create (1000); + Dynamic_ABE_Check_Scenarios : NE_Set.Membership_Set := + NE_Set.Create (500); + Library_Body_Scenarios : NE_Set.Membership_Set := + NE_Set.Create (1000); + Library_Spec_Scenarios : NE_Set.Membership_Set := + NE_Set.Create (1000); + SPARK_Scenarios : NE_Set.Membership_Set := + NE_Set.Create (100); - -- Do not emit any ABE diagnostics when the call occurs in a - -- partial finalization context because this leads to confusing - -- noise. + ------------------------------- + -- Finalize_Scenario_Storage -- + ------------------------------- - elsif State.Within_Partial_Finalization then - null; + procedure Finalize_Scenario_Storage is + begin + NE_Set.Destroy (Declaration_Scenarios); + NE_Set.Destroy (Dynamic_ABE_Check_Scenarios); + NE_Set.Destroy (Library_Body_Scenarios); + NE_Set.Destroy (Library_Spec_Scenarios); + NE_Set.Destroy (SPARK_Scenarios); + end Finalize_Scenario_Storage; + + --------------------------------- + -- Initialize_Scenario_Storage -- + --------------------------------- + + procedure Initialize_Scenario_Storage is + begin + null; + end Initialize_Scenario_Storage; - -- ABE diagnostics are emitted only in the static model because - -- there is a well-defined order to visiting scenarios. Without - -- this order diagnostics appear jumbled and result in unwanted - -- noise. + ------------------------------ + -- Add_Declaration_Scenario -- + ------------------------------ - elsif Static_Elaboration_Checks then - Error_Msg_NE - ("??cannot call & before body seen", Call, Target_Id); - Error_Msg_N ("\Program_Error may be raised at run time", Call); + procedure Add_Declaration_Scenario (N : Node_Id) is + pragma Assert (Present (N)); + begin + NE_Set.Insert (Declaration_Scenarios, N); + end Add_Declaration_Scenario; - Output_Active_Scenarios (Call); - end if; + ------------------------------------ + -- Add_Dynamic_ABE_Check_Scenario -- + ------------------------------------ - -- Install a conditional run-time ABE check to verify that the - -- target body has been elaborated prior to the call. + procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id) is + pragma Assert (Present (N)); - if Check_OK then - Install_ABE_Check - (N => Call, - Ins_Nod => Call, - Target_Id => Target_Attrs.Spec_Id, - Target_Decl => Target_Attrs.Spec_Decl, - Target_Body => Target_Attrs.Body_Decl); + begin + if not Check_Or_Failure_Generation_OK then + return; - -- Update the state of the Processing phase to indicate that - -- no implicit Elaborate[_All] pragmas must be generated from - -- this point on. - -- - -- function B ...; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- <ABE check> - -- return B; - -- ... - -- end A; - -- - -- X : ... := A; - -- - -- function B ... is - -- External.Subp; -- imparts Elaborate_All - -- end B; - -- - -- If Some_Condition is True, then the ABE check will fail at - -- runtime and the call to External.Subp will never take place, - -- rendering the implicit Elaborate_All useless. - -- - -- If Some_Condition is False, then the call to External.Subp - -- will never take place, rendering the implicit Elaborate_All - -- useless. + -- Nothing to do if the dynamic model is not in effect - New_State.Suppress_Implicit_Pragmas := True; - end if; + elsif not Dynamic_Elaboration_Checks then + return; end if; - -- Otherwise the target body is not available in this compilation or it - -- resides in an external unit. Install a run-time ABE check to verify - -- that the target body has been elaborated prior to the call site when - -- the dynamic model is in effect. + NE_Set.Insert (Dynamic_ABE_Check_Scenarios, N); + end Add_Dynamic_ABE_Check_Scenario; - elsif Dynamic_Elaboration_Checks and then Check_OK then - Install_ABE_Check - (N => Call, - Ins_Nod => Call, - Id => Target_Attrs.Unit_Id); - end if; + ------------------------------- + -- Add_Library_Body_Scenario -- + ------------------------------- - -- Ensure that the unit with the target body is elaborated prior to the - -- main unit. The implicit Elaborate[_All] is generated only when the - -- call has elaboration checks enabled. This behaviour parallels that of - -- the old ABE mechanism. + procedure Add_Library_Body_Scenario (N : Node_Id) is + pragma Assert (Present (N)); + begin + NE_Set.Insert (Library_Body_Scenarios, N); + end Add_Library_Body_Scenario; - if Call_Attrs.Elab_Checks_OK then - Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Target_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - State => New_State); - end if; - end Process_Conditional_ABE_Call_Ada; + ------------------------------- + -- Add_Library_Spec_Scenario -- + ------------------------------- - ---------------------------------------- - -- Process_Conditional_ABE_Call_SPARK -- - ---------------------------------------- + procedure Add_Library_Spec_Scenario (N : Node_Id) is + pragma Assert (Present (N)); + begin + NE_Set.Insert (Library_Spec_Scenarios, N); + end Add_Library_Spec_Scenario; - procedure Process_Conditional_ABE_Call_SPARK - (Call : Node_Id; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - State : Processing_Attributes) - is - Region : Node_Id; + ------------------------ + -- Add_SPARK_Scenario -- + ------------------------ - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + procedure Add_SPARK_Scenario (N : Node_Id) is + pragma Assert (Present (N)); + begin + NE_Set.Insert (SPARK_Scenarios, N); + end Add_SPARK_Scenario; - Check_SPARK_Model_In_Effect (Call); + --------------------- + -- Delete_Scenario -- + --------------------- - -- The call and the target body are both in the main unit + procedure Delete_Scenario (N : Node_Id) is + pragma Assert (Present (N)); - if Present (Target_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) - then - -- If the call appears prior to the target body, then the call must - -- appear within the early call region of the target body. - -- - -- function B ...; - -- - -- X : ... := B; -- call site - -- - -- <preelaborable construct 1> --+ - -- ... | early call region - -- <preelaborable construct N> --+ - -- - -- function B ... is -- target body - -- ... - -- end B; - -- - -- When the call to B is not nested within some other scenario, the - -- call is automatically illegal because it can never appear in the - -- early call region of B's body. This is equivalent to a guaranteed - -- ABE. - -- - -- <preelaborable construct 1> --+ - -- | - -- function B ...; | - -- | - -- function A ... is | - -- begin | early call region - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; | - -- | - -- <preelaborable construct N> --+ - -- - -- function B ... is -- target body - -- ... - -- end B; - -- - -- When the call to B is nested within some other scenario, the call - -- is always ABE-safe. It is not immediately obvious why this is the - -- case. The elaboration safety follows from the early call region - -- rule being applied to ALL calls preceding their associated bodies. - -- - -- In the example above, the call to B is safe as long as the call to - -- A is safe. There are several cases to consider: - -- - -- <call 1 to A> - -- function B ...; - -- - -- <call 2 to A> - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; - -- ... - -- end A; - -- - -- <call 3 to A> - -- function B ... is - -- ... - -- end B; - -- - -- * Call 1 - This call is either nested within some scenario or not, - -- which falls under the two general cases outlined above. - -- - -- * Call 2 - This is the same case as Call 1. - -- - -- * Call 3 - The placement of this call limits the range of B's - -- early call region unto call 3, therefore the call to B is no - -- longer within the early call region of B's body, making it ABE- - -- unsafe and therefore illegal. + begin + -- Delete the scenario from whichever set it belongs to - if Earlier_In_Extended_Unit (Call, Target_Attrs.Body_Decl) then + NE_Set.Delete (Declaration_Scenarios, N); + NE_Set.Delete (Dynamic_ABE_Check_Scenarios, N); + NE_Set.Delete (Library_Body_Scenarios, N); + NE_Set.Delete (Library_Spec_Scenarios, N); + NE_Set.Delete (SPARK_Scenarios, N); + end Delete_Scenario; - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + ----------------------------------- + -- Iterate_Declaration_Scenarios -- + ----------------------------------- - if State.Suppress_Warnings then - null; + function Iterate_Declaration_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Declaration_Scenarios); + end Iterate_Declaration_Scenarios; - -- Do not emit any ABE diagnostics when the call occurs in an - -- initial condition context because this leads to incorrect - -- diagnostics. + ----------------------------------------- + -- Iterate_Dynamic_ABE_Check_Scenarios -- + ----------------------------------------- - elsif State.Within_Initial_Condition then - null; + function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Dynamic_ABE_Check_Scenarios); + end Iterate_Dynamic_ABE_Check_Scenarios; - -- Do not emit any ABE diagnostics when the call occurs in a - -- partial finalization context because this leads to confusing - -- noise. + ------------------------------------ + -- Iterate_Library_Body_Scenarios -- + ------------------------------------ - elsif State.Within_Partial_Finalization then - null; + function Iterate_Library_Body_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Library_Body_Scenarios); + end Iterate_Library_Body_Scenarios; - -- ABE diagnostics are emitted only in the static model because - -- there is a well-defined order to visiting scenarios. Without - -- this order diagnostics appear jumbled and result in unwanted - -- noise. + ------------------------------------ + -- Iterate_Library_Spec_Scenarios -- + ------------------------------------ - elsif Static_Elaboration_Checks then + function Iterate_Library_Spec_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (Library_Spec_Scenarios); + end Iterate_Library_Spec_Scenarios; - -- Ensure that a call which textually precedes the subprogram - -- body it invokes appears within the early call region of the - -- subprogram body. + ----------------------------- + -- Iterate_SPARK_Scenarios -- + ----------------------------- - -- IMPORTANT: This check must always be performed even when - -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is - -- not specified because the static model cannot guarantee the - -- absence of elaboration issues in the presence of dispatching - -- calls. + function Iterate_SPARK_Scenarios return NE_Set.Iterator is + begin + return NE_Set.Iterate (SPARK_Scenarios); + end Iterate_SPARK_Scenarios; - Region := Find_Early_Call_Region (Target_Attrs.Body_Decl); + ---------------------- + -- Replace_Scenario -- + ---------------------- - if Earlier_In_Extended_Unit (Call, Region) then - Error_Msg_NE - ("call must appear within early call region of subprogram " - & "body & (SPARK RM 7.7(3))", Call, Target_Id); + procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id) is + procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set); + -- Determine whether scenario Old_N is present in set Scenarios, and + -- if this is the case it, replace it with New_N. - Error_Msg_Sloc := Sloc (Region); - Error_Msg_N ("\region starts #", Call); + ------------------------- + -- Replace_Scenario_In -- + ------------------------- - Error_Msg_Sloc := Sloc (Target_Attrs.Body_Decl); - Error_Msg_N ("\region ends #", Call); + procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set) is + begin + -- The set is intentionally checked for existance because node + -- rewriting may occur after Sem_Elab has verified all scenarios + -- and data structures have been destroyed. - Output_Active_Scenarios (Call); - end if; + if NE_Set.Present (Scenarios) + and then NE_Set.Contains (Scenarios, Old_N) + then + NE_Set.Delete (Scenarios, Old_N); + NE_Set.Insert (Scenarios, New_N); end if; + end Replace_Scenario_In; - -- Otherwise the call appears after the target body. The call is - -- ABE-safe as a consequence of applying the early call region rule - -- to ALL calls preceding their associated bodies. + -- Start of processing for Replace_Scenario - else - null; - end if; - end if; + begin + Replace_Scenario_In (Declaration_Scenarios); + Replace_Scenario_In (Dynamic_ABE_Check_Scenarios); + Replace_Scenario_In (Library_Body_Scenarios); + Replace_Scenario_In (Library_Spec_Scenarios); + Replace_Scenario_In (SPARK_Scenarios); + end Replace_Scenario; + end Scenario_Storage; - -- A call to a source target or to a target which emulates Ada or SPARK - -- semantics imposes an Elaborate_All requirement on the context of the - -- main unit. Determine whether the context has a pragma strong enough - -- to meet the requirement. + --------------- + -- Semantics -- + --------------- - -- IMPORTANT: This check must be performed only when -gnatd.v (enforce - -- SPARK elaboration rules in SPARK code) is active because the static - -- model can ensure the prior elaboration of the unit which contains a - -- body by installing an implicit Elaborate[_All] pragma. + package body Semantics is - if Debug_Flag_Dot_V then - if Target_Attrs.From_Source - or else Is_Ada_Semantic_Target (Target_Id) - or else Is_SPARK_Semantic_Target (Target_Id) - then - Meet_Elaboration_Requirement - (N => Call, - Target_Id => Target_Id, - Req_Nam => Name_Elaborate_All); - end if; + -------------------------------- + -- Is_Accept_Alternative_Proc -- + -------------------------------- - -- Otherwise ensure that the unit with the target body is elaborated - -- prior to the main unit. + function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a procedure with a receiving + -- entry. - else - Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Target_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - State => State); - end if; - end Process_Conditional_ABE_Call_SPARK; + return + Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); + end Is_Accept_Alternative_Proc; - ------------------------------------------- - -- Process_Conditional_ABE_Instantiation -- - ------------------------------------------- + ------------------------ + -- Is_Activation_Proc -- + ------------------------ - procedure Process_Conditional_ABE_Instantiation - (Exp_Inst : Node_Id; - State : Processing_Attributes) - is - Gen_Attrs : Target_Attributes; - Gen_Id : Entity_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; + function Is_Activation_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote one of the runtime procedures + -- in charge of task activation. - SPARK_Rules_On : Boolean; - -- This flag is set when the SPARK rules are in effect + if Ekind (Id) = E_Procedure then + if Restricted_Profile then + return Is_RTE (Id, RE_Activate_Restricted_Tasks); + else + return Is_RTE (Id, RE_Activate_Tasks); + end if; + end if; - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + return False; + end Is_Activation_Proc; - begin - Extract_Instantiation_Attributes - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + ---------------------------- + -- Is_Ada_Semantic_Target -- + ---------------------------- - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Activation_Proc (Id) + or else Is_Controlled_Proc (Id, Name_Adjust) + or else Is_Controlled_Proc (Id, Name_Finalize) + or else Is_Controlled_Proc (Id, Name_Initialize) + or else Is_Init_Proc (Id) + or else Is_Invariant_Proc (Id) + or else Is_Protected_Entry (Id) + or else Is_Protected_Subp (Id) + or else Is_Protected_Body_Subp (Id) + or else Is_Subprogram_Inst (Id) + or else Is_Task_Entry (Id); + end Is_Ada_Semantic_Target; - -- The SPARK rules are in effect when both the instantiation and generic - -- are subject to SPARK_Mode On. + -------------------------------- + -- Is_Assertion_Pragma_Target -- + -------------------------------- - SPARK_Rules_On := Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; + function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Default_Initial_Condition_Proc (Id) + or else Is_Initial_Condition_Proc (Id) + or else Is_Invariant_Proc (Id) + or else Is_Partial_Invariant_Proc (Id) + or else Is_Postconditions_Proc (Id); + end Is_Assertion_Pragma_Target; - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + ---------------------------- + -- Is_Bodiless_Subprogram -- + ---------------------------- - if Elab_Info_Messages then - Info_Instantiation - (Inst => Inst, - Gen_Id => Gen_Id, - Info_Msg => True, - In_SPARK => SPARK_Rules_On); - end if; + function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is + begin + -- An abstract subprogram does not have a body - -- Nothing to do when the instantiation is a guaranteed ABE + if Ekind_In (Subp_Id, E_Function, + E_Operator, + E_Procedure) + and then Is_Abstract_Subprogram (Subp_Id) + then + return True; - if Is_Known_Guaranteed_ABE (Inst) then - return; + -- A formal subprogram does not have a body - -- Nothing to do when the root scenario appears at the declaration level - -- and the generic is in the same unit, but outside this context. - -- - -- generic - -- procedure Gen is ...; -- generic declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- procedure I is new Gen; -- instantiation site - -- ... - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- procedure Gen is - -- ... - -- end Gen; - -- - -- In the example above, the context of X is the declarative region of - -- Proc. The "elaboration" of X may eventually reach Gen which appears - -- outside of X's context. Gen is relevant only when Proc is invoked, - -- but this happens only by means of "normal" elaboration, therefore - -- Gen must not be considered if this is not the case. + elsif Is_Formal_Subprogram (Subp_Id) then + return True; - -- Performance note: parent traversal + -- An imported subprogram may have a body, however it is not known at + -- compile or bind time where the body resides and whether it will be + -- elaborated on time. - elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then - return; - end if; + elsif Is_Imported (Subp_Id) then + return True; + end if; - -- Warnings are suppressed when a prior scenario is already in that - -- mode, or when the instantiation has warnings suppressed. Update - -- the state of the processing phase to reflect this. + return False; + end Is_Bodiless_Subprogram; - New_State.Suppress_Warnings := - New_State.Suppress_Warnings or else not Inst_Attrs.Elab_Warnings_OK; + ---------------------- + -- Is_Bridge_Target -- + ---------------------- - -- The SPARK rules are in effect + function Is_Bridge_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Accept_Alternative_Proc (Id) + or else Is_Finalizer_Proc (Id) + or else Is_Partial_Invariant_Proc (Id) + or else Is_Postconditions_Proc (Id) + or else Is_TSS (Id, TSS_Deep_Adjust) + or else Is_TSS (Id, TSS_Deep_Finalize) + or else Is_TSS (Id, TSS_Deep_Initialize); + end Is_Bridge_Target; - if SPARK_Rules_On then - Process_Conditional_ABE_Instantiation_SPARK - (Inst => Inst, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs, - State => New_State); + ------------------------ + -- Is_Controlled_Proc -- + ------------------------ - -- Otherwise the Ada rules are in effect, or SPARK code is allowed to - -- violate the SPARK rules. + function Is_Controlled_Proc + (Subp_Id : Entity_Id; + Subp_Nam : Name_Id) return Boolean + is + Formal_Id : Entity_Id; - else - Process_Conditional_ABE_Instantiation_Ada - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Attrs => Inst_Attrs, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs, - State => New_State); - end if; - end Process_Conditional_ABE_Instantiation; - - ----------------------------------------------- - -- Process_Conditional_ABE_Instantiation_Ada -- - ----------------------------------------------- - - procedure Process_Conditional_ABE_Instantiation_Ada - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - State : Processing_Attributes) - is - Check_OK : constant Boolean := - not Inst_Attrs.Ghost_Mode_Ignore - and then not Gen_Attrs.Ghost_Mode_Ignore - and then Inst_Attrs.Elab_Checks_OK - and then Gen_Attrs.Elab_Checks_OK; - -- A run-time ABE check may be installed only when both the instance and - -- the generic have active elaboration checks and both are not ignored - -- Ghost constructs. + begin + pragma Assert (Nam_In (Subp_Nam, Name_Adjust, + Name_Finalize, + Name_Initialize)); - Root : constant Node_Id := Root_Scenario; + -- To qualify, the subprogram must denote a source procedure with + -- name Adjust, Finalize, or Initialize where the sole formal is + -- controlled. - New_State : Processing_Attributes := State; - -- Each step of the Processing phase constitutes a new state + if Comes_From_Source (Subp_Id) + and then Ekind (Subp_Id) = E_Procedure + and then Chars (Subp_Id) = Subp_Nam + then + Formal_Id := First_Formal (Subp_Id); - begin - -- Nothing to do when the instantiation is ABE-safe - -- - -- generic - -- package Gen is - -- ... - -- end Gen; - -- - -- package body Gen is - -- ... - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- package Inst is new Gen (ABE); -- safe instantiation - -- ... + return + Present (Formal_Id) + and then Is_Controlled (Etype (Formal_Id)) + and then No (Next_Formal (Formal_Id)); + end if; - if Is_Safe_Instantiation (Inst, Gen_Attrs) then - return; + return False; + end Is_Controlled_Proc; - -- The instantiation and the generic body are both in the main unit + --------------------------------------- + -- Is_Default_Initial_Condition_Proc -- + --------------------------------------- - elsif Present (Gen_Attrs.Body_Decl) - and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) - then - -- If the root scenario appears prior to the generic body, then this - -- is a possible ABE with respect to the root scenario. - -- - -- generic - -- package Gen is - -- ... - -- end Gen; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- package Inst is new Gen; -- instantiation site - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- - -- package body Gen is -- generic body - -- ... - -- end Gen; - -- - -- Y : ... := A; -- root scenario - -- - -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but - -- not for Y. Installing an unconditional ABE raise prior to the - -- instance site would be wrong as it will fail for Y as well, but in - -- Y's case the instantiation of Gen is never an ABE. + function Is_Default_Initial_Condition_Proc + (Id : Entity_Id) return Boolean + is + begin + -- To qualify, the entity must denote a Default_Initial_Condition + -- procedure. - if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then + return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); + end Is_Default_Initial_Condition_Proc; - -- Do not emit any ABE diagnostics when a previous scenario in - -- this traversal has suppressed elaboration warnings. + ----------------------- + -- Is_Finalizer_Proc -- + ----------------------- - if State.Suppress_Warnings then - null; + function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a _Finalizer procedure - -- Do not emit any ABE diagnostics when the instantiation occurs - -- in partial finalization context because this leads to unwanted - -- noise. + return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; + end Is_Finalizer_Proc; - elsif State.Within_Partial_Finalization then - null; + ------------------------------- + -- Is_Initial_Condition_Proc -- + ------------------------------- - -- ABE diagnostics are emitted only in the static model because - -- there is a well-defined order to visiting scenarios. Without - -- this order diagnostics appear jumbled and result in unwanted - -- noise. + function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an Initial_Condition procedure - elsif Static_Elaboration_Checks then - Error_Msg_NE - ("??cannot instantiate & before body seen", Inst, Gen_Id); - Error_Msg_N ("\Program_Error may be raised at run time", Inst); + return + Ekind (Id) = E_Procedure + and then Is_Initial_Condition_Procedure (Id); + end Is_Initial_Condition_Proc; - Output_Active_Scenarios (Inst); - end if; + -------------------- + -- Is_Initialized -- + -------------------- - -- Install a conditional run-time ABE check to verify that the - -- generic body has been elaborated prior to the instantiation. + function Is_Initialized (Obj_Decl : Node_Id) return Boolean is + begin + -- To qualify, the object declaration must have an expression - if Check_OK then - Install_ABE_Check - (N => Inst, - Ins_Nod => Exp_Inst, - Target_Id => Gen_Attrs.Spec_Id, - Target_Decl => Gen_Attrs.Spec_Decl, - Target_Body => Gen_Attrs.Body_Decl); + return + Present (Expression (Obj_Decl)) + or else Has_Init_Expression (Obj_Decl); + end Is_Initialized; - -- Update the state of the Processing phase to indicate that - -- no implicit Elaborate[_All] pragmas must be generated from - -- this point on. - -- - -- generic - -- package Gen is - -- ... - -- end Gen; - -- - -- function A ... is - -- begin - -- if Some_Condition then - -- <ABE check> - -- declare Inst is new Gen; - -- ... - -- end A; - -- - -- X : ... := A; - -- - -- package body Gen is - -- begin - -- External.Subp; -- imparts Elaborate_All - -- end Gen; - -- - -- If Some_Condition is True, then the ABE check will fail at - -- runtime and the call to External.Subp will never take place, - -- rendering the implicit Elaborate_All useless. - -- - -- If Some_Condition is False, then the call to External.Subp - -- will never take place, rendering the implicit Elaborate_All - -- useless. + ----------------------- + -- Is_Invariant_Proc -- + ----------------------- - New_State.Suppress_Implicit_Pragmas := True; - end if; - end if; + function Is_Invariant_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote the "full" invariant procedure - -- Otherwise the generic body is not available in this compilation or it - -- resides in an external unit. Install a run-time ABE check to verify - -- that the generic body has been elaborated prior to the instantiation - -- when the dynamic model is in effect. + return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); + end Is_Invariant_Proc; - elsif Dynamic_Elaboration_Checks and then Check_OK then - Install_ABE_Check - (N => Inst, - Ins_Nod => Exp_Inst, - Id => Gen_Attrs.Unit_Id); - end if; + --------------------------------------- + -- Is_Non_Library_Level_Encapsulator -- + --------------------------------------- - -- Ensure that the unit with the generic body is elaborated prior to - -- the main unit. No implicit pragma is generated if the instantiation - -- has elaboration checks suppressed. This behaviour parallels that of - -- the old ABE mechanism. + function Is_Non_Library_Level_Encapsulator + (N : Node_Id) return Boolean + is + begin + case Nkind (N) is + when N_Abstract_Subprogram_Declaration + | N_Aspect_Specification + | N_Component_Declaration + | N_Entry_Body + | N_Entry_Declaration + | N_Expression_Function + | N_Formal_Abstract_Subprogram_Declaration + | N_Formal_Concrete_Subprogram_Declaration + | N_Formal_Object_Declaration + | N_Formal_Package_Declaration + | N_Formal_Type_Declaration + | N_Generic_Association + | N_Implicit_Label_Declaration + | N_Incomplete_Type_Declaration + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Protected_Body + | N_Protected_Type_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Subprogram_Body + | N_Subprogram_Declaration + | N_Task_Body + | N_Task_Type_Declaration + => + return True; - if Inst_Attrs.Elab_Checks_OK then - Ensure_Prior_Elaboration - (N => Inst, - Unit_Id => Gen_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate, - State => New_State); - end if; - end Process_Conditional_ABE_Instantiation_Ada; + when others => + return Is_Generic_Declaration_Or_Body (N); + end case; + end Is_Non_Library_Level_Encapsulator; - ------------------------------------------------- - -- Process_Conditional_ABE_Instantiation_SPARK -- - ------------------------------------------------- + ------------------------------- + -- Is_Partial_Invariant_Proc -- + ------------------------------- - procedure Process_Conditional_ABE_Instantiation_SPARK - (Inst : Node_Id; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - State : Processing_Attributes) - is - Req_Nam : Name_Id; + function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote the "partial" invariant + -- procedure. - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + return + Ekind (Id) = E_Procedure + and then Is_Partial_Invariant_Procedure (Id); + end Is_Partial_Invariant_Proc; - Check_SPARK_Model_In_Effect (Inst); + ---------------------------- + -- Is_Postconditions_Proc -- + ---------------------------- - -- A source instantiation imposes an Elaborate[_All] requirement on the - -- context of the main unit. Determine whether the context has a pragma - -- strong enough to meet the requirement. The check is orthogonal to the - -- ABE ramifications of the instantiation. + function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a _Postconditions procedure - -- IMPORTANT: This check must be performed only when -gnatd.v (enforce - -- SPARK elaboration rules in SPARK code) is active because the static - -- model can ensure the prior elaboration of the unit which contains a - -- body by installing an implicit Elaborate[_All] pragma. + return + Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; + end Is_Postconditions_Proc; - if Debug_Flag_Dot_V then - if Nkind (Inst) = N_Package_Instantiation then - Req_Nam := Name_Elaborate_All; - else - Req_Nam := Name_Elaborate; - end if; + --------------------------- + -- Is_Preelaborated_Unit -- + --------------------------- - Meet_Elaboration_Requirement - (N => Inst, - Target_Id => Gen_Id, - Req_Nam => Req_Nam); + function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is + begin + return + Is_Preelaborated (Id) + or else Is_Pure (Id) + or else Is_Remote_Call_Interface (Id) + or else Is_Remote_Types (Id) + or else Is_Shared_Passive (Id); + end Is_Preelaborated_Unit; + + ------------------------ + -- Is_Protected_Entry -- + ------------------------ + + function Is_Protected_Entry (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an entry defined in a protected + -- type. - -- Otherwise ensure that the unit with the target body is elaborated - -- prior to the main unit. + return + Is_Entry (Id) + and then Is_Protected_Type (Non_Private_View (Scope (Id))); + end Is_Protected_Entry; - else - Ensure_Prior_Elaboration - (N => Inst, - Unit_Id => Gen_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate, - State => State); - end if; - end Process_Conditional_ABE_Instantiation_SPARK; + ----------------------- + -- Is_Protected_Subp -- + ----------------------- - ------------------------------------------------- - -- Process_Conditional_ABE_Variable_Assignment -- - ------------------------------------------------- + function Is_Protected_Subp (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a subprogram defined within a + -- protected type. - procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id) is - Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (Asmt)); - Prag : constant Node_Id := SPARK_Pragma (Var_Id); + return + Ekind_In (Id, E_Function, E_Procedure) + and then Is_Protected_Type (Non_Private_View (Scope (Id))); + end Is_Protected_Subp; - SPARK_Rules_On : Boolean; - -- This flag is set when the SPARK rules are in effect + ---------------------------- + -- Is_Protected_Body_Subp -- + ---------------------------- - begin - -- The SPARK rules are in effect when both the assignment and the - -- variable are subject to SPARK_Mode On. + function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a subprogram with attribute + -- Protected_Subprogram set. - SPARK_Rules_On := - Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On - and then Is_SPARK_Mode_On_Node (Asmt); + return + Ekind_In (Id, E_Function, E_Procedure) + and then Present (Protected_Subprogram (Id)); + end Is_Protected_Body_Subp; - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + ----------------- + -- Is_Scenario -- + ----------------- - if Elab_Info_Messages then - Elab_Msg_NE - (Msg => "assignment to & during elaboration", - N => Asmt, - Id => Var_Id, - Info_Msg => True, - In_SPARK => SPARK_Rules_On); - end if; + function Is_Scenario (N : Node_Id) return Boolean is + begin + case Nkind (N) is + when N_Assignment_Statement + | N_Attribute_Reference + | N_Call_Marker + | N_Entry_Call_Statement + | N_Expanded_Name + | N_Function_Call + | N_Function_Instantiation + | N_Identifier + | N_Package_Instantiation + | N_Procedure_Call_Statement + | N_Procedure_Instantiation + | N_Requeue_Statement + => + return True; - -- The SPARK rules are in effect. These rules are applied regardless of - -- whether -gnatd.v (enforce SPARK elaboration rules in SPARK code) is - -- in effect because the static model cannot ensure safe assignment of - -- variables. + when others => + return False; + end case; + end Is_Scenario; - if SPARK_Rules_On then - Process_Conditional_ABE_Variable_Assignment_SPARK - (Asmt => Asmt, - Var_Id => Var_Id); + ------------------------------ + -- Is_SPARK_Semantic_Target -- + ------------------------------ - -- Otherwise the Ada rules are in effect + function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Default_Initial_Condition_Proc (Id) + or else Is_Initial_Condition_Proc (Id); + end Is_SPARK_Semantic_Target; - else - Process_Conditional_ABE_Variable_Assignment_Ada - (Asmt => Asmt, - Var_Id => Var_Id); - end if; - end Process_Conditional_ABE_Variable_Assignment; + ------------------------ + -- Is_Subprogram_Inst -- + ------------------------ - ----------------------------------------------------- - -- Process_Conditional_ABE_Variable_Assignment_Ada -- - ----------------------------------------------------- + function Is_Subprogram_Inst (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a function or a procedure which + -- is hidden within an anonymous package, and is a generic instance. - procedure Process_Conditional_ABE_Variable_Assignment_Ada - (Asmt : Node_Id; - Var_Id : Entity_Id) - is - Var_Decl : constant Node_Id := Declaration_Node (Var_Id); - Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); + return + Ekind_In (Id, E_Function, E_Procedure) + and then Is_Hidden (Id) + and then Is_Generic_Instance (Id); + end Is_Subprogram_Inst; - begin - -- Emit a warning when an uninitialized variable declared in a package - -- spec without a pragma Elaborate_Body is initialized by elaboration - -- code within the corresponding body. + ------------------------------ + -- Is_Suitable_Access_Taken -- + ------------------------------ - if Is_Elaboration_Warnings_OK_Id (Var_Id) - and then not Is_Initialized (Var_Decl) - and then not Has_Pragma_Elaborate_Body (Spec_Id) - then - Error_Msg_NE - ("??variable & can be accessed by clients before this " - & "initialization", Asmt, Var_Id); + function Is_Suitable_Access_Taken (N : Node_Id) return Boolean is + Nam : Name_Id; + Pref : Node_Id; + Subp_Id : Entity_Id; - Error_Msg_NE - ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " - & "initialization", Asmt, Spec_Id); + begin + -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect - Output_Active_Scenarios (Asmt); + if Debug_Flag_Dot_UU then + return False; - -- Generate an implicit Elaborate_Body in the spec + -- Nothing to do when the scenario is not an attribute reference - Set_Elaborate_Body_Desirable (Spec_Id); - end if; - end Process_Conditional_ABE_Variable_Assignment_Ada; + elsif Nkind (N) /= N_Attribute_Reference then + return False; - ------------------------------------------------------- - -- Process_Conditional_ABE_Variable_Assignment_SPARK -- - ------------------------------------------------------- + -- Nothing to do for internally-generated attributes because they are + -- assumed to be ABE safe. - procedure Process_Conditional_ABE_Variable_Assignment_SPARK - (Asmt : Node_Id; - Var_Id : Entity_Id) - is - Var_Decl : constant Node_Id := Declaration_Node (Var_Id); - Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); + elsif not Comes_From_Source (N) then + return False; + end if; - begin - -- Ensure that a suitable elaboration model is in effect for SPARK rule - -- verification. + Nam := Attribute_Name (N); + Pref := Prefix (N); - Check_SPARK_Model_In_Effect (Asmt); + -- Sanitize the prefix of the attribute - -- Emit an error when an initialized variable declared in a package spec - -- without pragma Elaborate_Body is further modified by elaboration code - -- within the corresponding body. + if not Is_Entity_Name (Pref) then + return False; - if Is_Elaboration_Warnings_OK_Id (Var_Id) - and then Is_Initialized (Var_Decl) - and then not Has_Pragma_Elaborate_Body (Spec_Id) - then - Error_Msg_NE - ("variable & modified by elaboration code in package body", - Asmt, Var_Id); + elsif No (Entity (Pref)) then + return False; + end if; - Error_Msg_NE - ("\add pragma ""Elaborate_Body"" to spec & to ensure full " - & "initialization", Asmt, Spec_Id); + Subp_Id := Entity (Pref); - Output_Active_Scenarios (Asmt); - end if; - end Process_Conditional_ABE_Variable_Assignment_SPARK; + if not Is_Subprogram_Or_Entry (Subp_Id) then + return False; + end if; - ------------------------------------------------ - -- Process_Conditional_ABE_Variable_Reference -- - ------------------------------------------------ + -- Traverse a possible chain of renamings to obtain the original + -- entry or subprogram which the prefix may rename. - procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id) is - Var_Attrs : Variable_Attributes; - Var_Id : Entity_Id; + Subp_Id := Get_Renamed_Entity (Subp_Id); - begin - Extract_Variable_Reference_Attributes - (Ref => Ref, - Var_Id => Var_Id, - Attrs => Var_Attrs); - - if Is_Read (Ref) then - Process_Conditional_ABE_Variable_Reference_Read - (Ref => Ref, - Var_Id => Var_Id, - Attrs => Var_Attrs); - end if; - end Process_Conditional_ABE_Variable_Reference; + -- To qualify, the attribute must meet the following prerequisites: - ----------------------------------------------------- - -- Process_Conditional_ABE_Variable_Reference_Read -- - ----------------------------------------------------- + return - procedure Process_Conditional_ABE_Variable_Reference_Read - (Ref : Node_Id; - Var_Id : Entity_Id; - Attrs : Variable_Attributes) - is - begin - -- Output relevant information when switch -gnatel (info messages on - -- implicit Elaborate[_All] pragmas) is in effect. + -- The prefix must denote a source entry, operator, or subprogram + -- which is not imported. - if Elab_Info_Messages then - Elab_Msg_NE - (Msg => "read of variable & during elaboration", - N => Ref, - Id => Var_Id, - Info_Msg => True, - In_SPARK => True); - end if; + Comes_From_Source (Subp_Id) + and then Is_Subprogram_Or_Entry (Subp_Id) + and then not Is_Bodiless_Subprogram (Subp_Id) - -- Nothing to do when the variable appears within the main unit because - -- diagnostics on reads are relevant only for external variables. + -- The attribute name must be one of the 'Access forms. Note that + -- 'Unchecked_Access cannot apply to a subprogram. - if Is_Same_Unit (Attrs.Unit_Id, Cunit_Entity (Main_Unit)) then - null; + and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); + end Is_Suitable_Access_Taken; - -- Nothing to do when the variable is already initialized. Note that the - -- variable may be further modified by the external unit. + ---------------------- + -- Is_Suitable_Call -- + ---------------------- - elsif Is_Initialized (Declaration_Node (Var_Id)) then - null; + function Is_Suitable_Call (N : Node_Id) return Boolean is + begin + -- Entry and subprogram calls are intentionally ignored because they + -- may undergo expansion depending on the compilation mode, previous + -- errors, generic context, etc. Call markers play the role of calls + -- and provide a uniform foundation for ABE processing. - -- Nothing to do when the external unit guarantees the initialization of - -- the variable by means of pragma Elaborate_Body. + return Nkind (N) = N_Call_Marker; + end Is_Suitable_Call; - elsif Has_Pragma_Elaborate_Body (Attrs.Unit_Id) then - null; + ------------------------------- + -- Is_Suitable_Instantiation -- + ------------------------------- - -- A variable read imposes an Elaborate requirement on the context of - -- the main unit. Determine whether the context has a pragma strong - -- enough to meet the requirement. + function Is_Suitable_Instantiation (N : Node_Id) return Boolean is + Inst : constant Node_Id := Scenario (N); - else - Meet_Elaboration_Requirement - (N => Ref, - Target_Id => Var_Id, - Req_Nam => Name_Elaborate); - end if; - end Process_Conditional_ABE_Variable_Reference_Read; + begin + -- To qualify, the instantiation must come from source - ----------------------------- - -- Process_Conditional_ABE -- - ----------------------------- + return + Comes_From_Source (Inst) + and then Nkind (Inst) in N_Generic_Instantiation; + end Is_Suitable_Instantiation; - -- NOTE: The body of this routine is intentionally out of order because it - -- invokes an instantiated subprogram (Process_Conditional_ABE_Activation). - -- Placing the body in alphabetical order will result in a guaranteed ABE. + ------------------------------------ + -- Is_Suitable_SPARK_Derived_Type -- + ------------------------------------ - procedure Process_Conditional_ABE - (N : Node_Id; - State : Processing_Attributes := Initial_State) - is - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; + function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is + Prag : Node_Id; + Typ : Entity_Id; - begin - -- Add the current scenario to the stack of active scenarios + begin + -- To qualify, the type declaration must denote a derived tagged type + -- with primitive operations, subject to pragma SPARK_Mode On. - Push_Active_Scenario (N); + if Nkind (N) = N_Full_Type_Declaration + and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition + then + Typ := Defining_Entity (N); + Prag := SPARK_Pragma (Typ); - -- 'Access + return + Is_Tagged_Type (Typ) + and then Has_Primitive_Operations (Typ) + and then Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On; + end if; - if Is_Suitable_Access (N) then - Process_Conditional_ABE_Access - (Attr => N, - State => State); + return False; + end Is_Suitable_SPARK_Derived_Type; - -- Activations and calls + ------------------------------------- + -- Is_Suitable_SPARK_Instantiation -- + ------------------------------------- - elsif Is_Suitable_Call (N) then + function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is + Inst : constant Node_Id := Scenario (N); - -- In general, only calls found within the main unit are processed - -- because the ALI information supplied to binde is for the main - -- unit only. However, to preserve the consistency of the tree and - -- ensure proper serialization of internal names, external calls - -- also receive corresponding call markers (see Build_Call_Marker). - -- Regardless of the reason, external calls must not be processed. + Gen_Id : Entity_Id; + Prag : Node_Id; - if In_Main_Context (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); + begin + -- To qualify, both the instantiation and the generic must be subject + -- to SPARK_Mode On. - if Is_Activation_Proc (Target_Id) then - Process_Conditional_ABE_Activation - (Call => N, - Call_Attrs => Call_Attrs, - State => State); + if Is_Suitable_Instantiation (N) then + Gen_Id := Instantiated_Generic (Inst); + Prag := SPARK_Pragma (Gen_Id); - else - Process_Conditional_ABE_Call - (Call => N, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - State => State); - end if; + return + Is_SPARK_Mode_On_Node (Inst) + and then Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On; end if; - -- Instantiations + return False; + end Is_Suitable_SPARK_Instantiation; - elsif Is_Suitable_Instantiation (N) then - Process_Conditional_ABE_Instantiation - (Exp_Inst => N, - State => State); + -------------------------------------------- + -- Is_Suitable_SPARK_Refined_State_Pragma -- + -------------------------------------------- - -- Variable assignments + function Is_Suitable_SPARK_Refined_State_Pragma + (N : Node_Id) return Boolean + is + begin + -- To qualfy, the pragma must denote Refined_State - elsif Is_Suitable_Variable_Assignment (N) then - Process_Conditional_ABE_Variable_Assignment (N); + return + Nkind (N) = N_Pragma + and then Pragma_Name (N) = Name_Refined_State; + end Is_Suitable_SPARK_Refined_State_Pragma; + + ------------------------------------- + -- Is_Suitable_Variable_Assignment -- + ------------------------------------- + + function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is + N_Unit : Node_Id; + N_Unit_Id : Entity_Id; + Nam : Node_Id; + Var_Decl : Node_Id; + Var_Id : Entity_Id; + Var_Unit : Node_Id; + Var_Unit_Id : Entity_Id; - -- Variable references + begin + -- Nothing to do when the scenario is not an assignment - elsif Is_Suitable_Variable_Reference (N) then + if Nkind (N) /= N_Assignment_Statement then + return False; - -- In general, only variable references found within the main unit - -- are processed because the ALI information supplied to binde is for - -- the main unit only. However, to preserve the consistency of the - -- tree and ensure proper serialization of internal names, external - -- variable references also receive corresponding variable reference - -- markers (see Build_Varaible_Reference_Marker). Regardless of the - -- reason, external variable references must not be processed. + -- Nothing to do for internally-generated assignments because they + -- are assumed to be ABE safe. - if In_Main_Context (N) then - Process_Conditional_ABE_Variable_Reference (N); - end if; - end if; + elsif not Comes_From_Source (N) then + return False; - -- Remove the current scenario from the stack of active scenarios once - -- all ABE diagnostics and checks have been performed. + -- Assignments are ignored in GNAT mode on the assumption that + -- they are ABE-safe. This behaviour parallels that of the old + -- ABE mechanism. - Pop_Active_Scenario (N); - end Process_Conditional_ABE; + elsif GNAT_Mode then + return False; + end if; - -------------------------------------------- - -- Process_Guaranteed_ABE_Activation_Impl -- - -------------------------------------------- + Nam := Assignment_Target (N); - procedure Process_Guaranteed_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - State : Processing_Attributes) - is - pragma Unreferenced (State); + -- Sanitize the left hand side of the assignment - Check_OK : constant Boolean := - not Is_Ignored_Ghost_Entity (Obj_Id) - and then not Task_Attrs.Ghost_Mode_Ignore - and then Is_Elaboration_Checks_OK_Id (Obj_Id) - and then Task_Attrs.Elab_Checks_OK; - -- A run-time ABE check may be installed only when the object and the - -- task type have active elaboration checks, and both are not ignored - -- Ghost constructs. + if not Is_Entity_Name (Nam) then + return False; - begin - -- Nothing to do when the root scenario appears at the declaration - -- level and the task is in the same unit, but outside this context. - -- - -- task type Task_Typ; -- task declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- T : Task_Typ; - -- begin - -- <activation call> -- activation site - -- end; - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- task body Task_Typ is - -- ... - -- end Task_Typ; - -- - -- In the example above, the context of X is the declarative list of - -- Proc. The "elaboration" of X may reach the activation of T whose body - -- is defined outside of X's context. The task body is relevant only - -- when Proc is invoked, but this happens only in "normal" elaboration, - -- therefore the task body must not be considered if this is not the - -- case. + elsif No (Entity (Nam)) then + return False; + end if; - -- Performance note: parent traversal + Var_Id := Entity (Nam); - if Is_Up_Level_Target (Task_Attrs.Task_Decl) then - return; + -- Sanitize the variable - -- Nothing to do when the activation is ABE-safe - -- - -- generic - -- package Gen is - -- task type Task_Typ; - -- end Gen; - -- - -- package body Gen is - -- task body Task_Typ is - -- begin - -- ... - -- end Task_Typ; - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- package Nested is - -- package Inst is new Gen; - -- T : Inst.Task_Typ; - -- end Nested; -- safe activation - -- ... - - elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then - return; + if Var_Id = Any_Id then + return False; - -- An activation call leads to a guaranteed ABE when the activation - -- call and the task appear within the same context ignoring library - -- levels, and the body of the task has not been seen yet or appears - -- after the activation call. - -- - -- procedure Guaranteed_ABE is - -- task type Task_Typ; - -- - -- package Nested is - -- T : Task_Typ; - -- <activation call> -- guaranteed ABE - -- end Nested; - -- - -- task body Task_Typ is - -- ... - -- end Task_Typ; - -- ... + elsif Ekind (Var_Id) /= E_Variable then + return False; + end if; - -- Performance note: parent traversal + Var_Decl := Declaration_Node (Var_Id); - elsif Is_Guaranteed_ABE - (N => Call, - Target_Decl => Task_Attrs.Task_Decl, - Target_Body => Task_Attrs.Body_Decl) - then - if Call_Attrs.Elab_Warnings_OK then - Error_Msg_Sloc := Sloc (Call); - Error_Msg_N - ("??task & will be activated # before elaboration of its body", - Obj_Id); - Error_Msg_N ("\Program_Error will be raised at run time", Obj_Id); + if Nkind (Var_Decl) /= N_Object_Declaration then + return False; end if; - -- Mark the activation call as a guaranteed ABE + N_Unit_Id := Find_Top_Unit (N); + N_Unit := Unit_Declaration_Node (N_Unit_Id); - Set_Is_Known_Guaranteed_ABE (Call); + Var_Unit_Id := Find_Top_Unit (Var_Decl); + Var_Unit := Unit_Declaration_Node (Var_Unit_Id); - -- Install a run-time ABE failue because this activation call will - -- always result in an ABE. + -- To qualify, the assignment must meet the following prerequisites: - if Check_OK then - Install_ABE_Failure - (N => Call, - Ins_Nod => Call); - end if; - end if; - end Process_Guaranteed_ABE_Activation_Impl; + return + Comes_From_Source (Var_Id) - procedure Process_Guaranteed_ABE_Activation is - new Process_Activation_Generic (Process_Guaranteed_ABE_Activation_Impl); + -- The variable must be declared in the spec of compilation unit + -- U. - --------------------------------- - -- Process_Guaranteed_ABE_Call -- - --------------------------------- + and then Nkind (Var_Unit) = N_Package_Declaration + and then Find_Enclosing_Level (Var_Decl) = Library_Spec_Level - procedure Process_Guaranteed_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id) - is - Target_Attrs : Target_Attributes; + -- The assignment must occur in the body of compilation unit U - begin - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); + and then Nkind (N_Unit) = N_Package_Body + and then Present (Corresponding_Body (Var_Unit)) + and then Corresponding_Body (Var_Unit) = N_Unit_Id; + end Is_Suitable_Variable_Assignment; - -- Nothing to do when the root scenario appears at the declaration level - -- and the target is in the same unit, but outside this context. - -- - -- function B ...; -- target declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- function B ... is - -- ... - -- end B; - -- - -- In the example above, the context of X is the declarative region of - -- Proc. The "elaboration" of X may eventually reach B which is defined - -- outside of X's context. B is relevant only when Proc is invoked, but - -- this happens only by means of "normal" elaboration, therefore B must - -- not be considered if this is not the case. + ------------------------------------ + -- Is_Suitable_Variable_Reference -- + ------------------------------------ - -- Performance note: parent traversal + function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is + begin + -- Expanded names and identifiers are intentionally ignored because + -- they be folded, optimized away, etc. Variable references markers + -- play the role of variable references and provide a uniform + -- foundation for ABE processing. - if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then - return; + return Nkind (N) = N_Variable_Reference_Marker; + end Is_Suitable_Variable_Reference; - -- Nothing to do when the call is ABE-safe - -- - -- generic - -- function Gen ...; - -- - -- function Gen ... is - -- begin - -- ... - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- function Inst is new Gen; - -- X : ... := Inst; -- safe call - -- ... + ------------------- + -- Is_Task_Entry -- + ------------------- - elsif Is_Safe_Call (Call, Target_Attrs) then - return; + function Is_Task_Entry (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an entry defined in a task type - -- A call leads to a guaranteed ABE when the call and the target appear - -- within the same context ignoring library levels, and the body of the - -- target has not been seen yet or appears after the call. - -- - -- procedure Guaranteed_ABE is - -- function Func ...; - -- - -- package Nested is - -- Obj : ... := Func; -- guaranteed ABE - -- end Nested; - -- - -- function Func ... is - -- ... - -- end Func; - -- ... + return + Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); + end Is_Task_Entry; - -- Performance note: parent traversal + ------------------------ + -- Is_Up_Level_Target -- + ------------------------ - elsif Is_Guaranteed_ABE - (N => Call, - Target_Decl => Target_Attrs.Spec_Decl, - Target_Body => Target_Attrs.Body_Decl) - then - if Call_Attrs.Elab_Warnings_OK then - Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id); - Error_Msg_N ("\Program_Error will be raised at run time", Call); - end if; + function Is_Up_Level_Target + (Targ_Decl : Node_Id; + In_State : Processing_In_State) return Boolean + is + Root : constant Node_Id := Root_Scenario; + Root_Rep : constant Scenario_Rep_Id := + Scenario_Representation_Of (Root, In_State); - -- Mark the call as a guarnateed ABE + begin + -- The root appears within the declaratons of a block statement, + -- entry body, subprogram body, or task body ignoring enclosing + -- packages. The root is always within the main unit. - Set_Is_Known_Guaranteed_ABE (Call); + if not In_State.Suppress_Up_Level_Targets + and then Level (Root_Rep) = Declaration_Level + then + -- The target is within the main unit. It acts as an up-level + -- target when it appears within a context which encloses the + -- root. + -- + -- package body Main_Unit is + -- function Func ...; -- target + -- + -- procedure Proc is + -- X : ... := Func; -- root scenario - -- Install a run-time ABE failure because the call will always result - -- in an ABE. The failure is installed when both the call and target - -- have enabled elaboration checks, and both are not ignored Ghost - -- constructs. + if In_Extended_Main_Code_Unit (Targ_Decl) then + return not In_Same_Context (Root, Targ_Decl, Nested_OK => True); - if Call_Attrs.Elab_Checks_OK - and then Target_Attrs.Elab_Checks_OK - and then not Call_Attrs.Ghost_Mode_Ignore - and then not Target_Attrs.Ghost_Mode_Ignore - then - Install_ABE_Failure - (N => Call, - Ins_Nod => Call); + -- Otherwise the target is external to the main unit which makes + -- it an up-level target. + + else + return True; + end if; end if; - end if; - end Process_Guaranteed_ABE_Call; - ------------------------------------------ - -- Process_Guaranteed_ABE_Instantiation -- - ------------------------------------------ + return False; + end Is_Up_Level_Target; + end Semantics; - procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id) is - Gen_Attrs : Target_Attributes; - Gen_Id : Entity_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Inst_Id : Entity_Id; + --------------------- + -- SPARK_Processor -- + --------------------- - begin - Extract_Instantiation_Attributes - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Id => Inst_Id, - Gen_Id => Gen_Id, - Attrs => Inst_Attrs); + package body SPARK_Processor is - Extract_Target_Attributes (Gen_Id, Gen_Attrs); + ----------------------- + -- Local subprograms -- + ----------------------- - -- Nothing to do when the root scenario appears at the declaration level - -- and the generic is in the same unit, but outside this context. - -- - -- generic - -- procedure Gen is ...; -- generic declaration - -- - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- procedure I is new Gen; -- instantiation site - -- ... - -- ... - -- end A; - -- - -- X : ... := A; -- root scenario - -- ... - -- - -- procedure Gen is - -- ... - -- end Gen; - -- - -- In the example above, the context of X is the declarative region of - -- Proc. The "elaboration" of X may eventually reach Gen which appears - -- outside of X's context. Gen is relevant only when Proc is invoked, - -- but this happens only by means of "normal" elaboration, therefore - -- Gen must not be considered if this is not the case. + procedure Process_SPARK_Derived_Type + (Typ_Decl : Node_Id; + Typ_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_SPARK_Derived_Type); + -- Verify that the freeze node of a derived type denoted by declaration + -- Typ_Decl is within the early call region of each overriding primitive + -- body that belongs to the derived type (SPARK RM 7.7(8)). Typ_Rep is + -- the representation of the type. In_State denotes the current state of + -- the Processing phase. + + procedure Process_SPARK_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_SPARK_Instantiation); + -- Verify that instanciation Inst does not precede the generic body it + -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the + -- instantiation. In_State is the current state of the Processing phase. + + procedure Process_SPARK_Refined_State_Pragma + (Prag : Node_Id; + Prag_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_SPARK_Refined_State_Pragma); + -- Verify that each constituent of Refined_State pragma Prag which + -- belongs to abstract state mentioned in pragma Initializes has prior + -- elaboration with respect to the main unit (SPARK RM 7.7.1(7)). + -- Prag_Rep is the representation of the pragma. In_State denotes the + -- current state of the Processing phase. + + procedure Process_SPARK_Scenario + (N : Node_Id; + In_State : Processing_In_State); + pragma Inline (Process_SPARK_Scenario); + -- Top-level dispatcher for verifying SPARK scenarios which are not + -- always executable during elaboration but still need elaboration- + -- related checks. In_State is the current state of the Processing + -- phase. + + --------------------------------- + -- Check_SPARK_Model_In_Effect -- + --------------------------------- + + SPARK_Model_Warning_Posted : Boolean := False; + -- This flag prevents the same SPARK model-related warning from being + -- emitted multiple times. + + procedure Check_SPARK_Model_In_Effect is + Spec_Id : constant Entity_Id := + Unique_Entity (Cunit_Entity (Main_Unit)); - -- Performance note: parent traversal + begin + -- Do not emit the warning multiple times as this creates useless + -- noise. - if Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then - return; + if SPARK_Model_Warning_Posted then + null; - -- Nothing to do when the instantiation is ABE-safe - -- - -- generic - -- package Gen is - -- ... - -- end Gen; - -- - -- package body Gen is - -- ... - -- end Gen; - -- - -- with Gen; - -- procedure Main is - -- package Inst is new Gen (ABE); -- safe instantiation - -- ... + -- SPARK rule verification requires the "strict" static model - elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then - return; + elsif Static_Elaboration_Checks + and not Relaxed_Elaboration_Checks + then + null; - -- An instantiation leads to a guaranteed ABE when the instantiation and - -- the generic appear within the same context ignoring library levels, - -- and the body of the generic has not been seen yet or appears after - -- the instantiation. - -- - -- procedure Guaranteed_ABE is - -- generic - -- procedure Gen; - -- - -- package Nested is - -- procedure Inst is new Gen; -- guaranteed ABE - -- end Nested; - -- - -- procedure Gen is - -- ... - -- end Gen; - -- ... + -- Any other combination of models does not guarantee the absence of + -- ABE problems for SPARK rule verification purposes. Note that there + -- is no need to check for the presence of the legacy ABE mechanism + -- because the legacy code has its own dedicated processing for SPARK + -- rules. - -- Performance note: parent traversal + else + SPARK_Model_Warning_Posted := True; - elsif Is_Guaranteed_ABE - (N => Inst, - Target_Decl => Gen_Attrs.Spec_Decl, - Target_Body => Gen_Attrs.Body_Decl) - then - if Inst_Attrs.Elab_Warnings_OK then - Error_Msg_NE - ("??cannot instantiate & before body seen", Inst, Gen_Id); - Error_Msg_N ("\Program_Error will be raised at run time", Inst); + Error_Msg_N + ("??SPARK elaboration checks require static elaboration model", + Spec_Id); + + if Dynamic_Elaboration_Checks then + Error_Msg_N + ("\dynamic elaboration model is in effect", Spec_Id); + + else + pragma Assert (Relaxed_Elaboration_Checks); + Error_Msg_N + ("\relaxed elaboration model is in effect", Spec_Id); + end if; end if; + end Check_SPARK_Model_In_Effect; - -- Mark the instantiation as a guarantee ABE. This automatically - -- suppresses the instantiation of the generic body. + --------------------------- + -- Check_SPARK_Scenarios -- + --------------------------- - Set_Is_Known_Guaranteed_ABE (Inst); + procedure Check_SPARK_Scenarios is + Iter : NE_Set.Iterator; + N : Node_Id; - -- Install a run-time ABE failure because the instantiation will - -- always result in an ABE. The failure is installed when both the - -- instance and the generic have enabled elaboration checks, and both - -- are not ignored Ghost constructs. + begin + Iter := Iterate_SPARK_Scenarios; + while NE_Set.Has_Next (Iter) loop + NE_Set.Next (Iter, N); - if Inst_Attrs.Elab_Checks_OK - and then Gen_Attrs.Elab_Checks_OK - and then not Inst_Attrs.Ghost_Mode_Ignore - and then not Gen_Attrs.Ghost_Mode_Ignore - then - Install_ABE_Failure - (N => Inst, - Ins_Nod => Exp_Inst); - end if; - end if; - end Process_Guaranteed_ABE_Instantiation; + Process_SPARK_Scenario + (N => N, + In_State => SPARK_State); + end loop; + end Check_SPARK_Scenarios; - ---------------------------- - -- Process_Guaranteed_ABE -- - ---------------------------- + -------------------------------- + -- Process_SPARK_Derived_Type -- + -------------------------------- - -- NOTE: The body of this routine is intentionally out of order because it - -- invokes an instantiated subprogram (Process_Guaranteed_ABE_Activation). - -- Placing the body in alphabetical order will result in a guaranteed ABE. + procedure Process_SPARK_Derived_Type + (Typ_Decl : Node_Id; + Typ_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (In_State); + + Typ : constant Entity_Id := Target (Typ_Rep); + + Stop_Check : exception; + -- This exception is raised when the freeze node violates the + -- placement rules. + + procedure Check_Overriding_Primitive + (Prim : Entity_Id; + FNode : Node_Id); + pragma Inline (Check_Overriding_Primitive); + -- Verify that freeze node FNode is within the early call region of + -- overriding primitive Prim's body. + + function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; + pragma Inline (Freeze_Node_Location); + -- Return a more accurate source location associated with freeze node + -- FNode. + + function Precedes_Source_Construct (N : Node_Id) return Boolean; + pragma Inline (Precedes_Source_Construct); + -- Determine whether arbitrary node N appears prior to some source + -- construct. + + procedure Suggest_Elaborate_Body + (N : Node_Id; + Body_Decl : Node_Id; + Error_Nod : Node_Id); + pragma Inline (Suggest_Elaborate_Body); + -- Suggest the use of pragma Elaborate_Body when the pragma will + -- allow for node N to appear within the early call region of + -- subprogram body Body_Decl. The suggestion is attached to + -- Error_Nod as a continuation error. + + -------------------------------- + -- Check_Overriding_Primitive -- + -------------------------------- + + procedure Check_Overriding_Primitive + (Prim : Entity_Id; + FNode : Node_Id) + is + Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); + Body_Decl : Node_Id; + Body_Id : Entity_Id; + Region : Node_Id; - procedure Process_Guaranteed_ABE (N : Node_Id) is - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; + begin + -- Nothing to do for predefined primitives because they are + -- artifacts of tagged type expansion and cannot override source + -- primitives. - begin - -- Add the current scenario to the stack of active scenarios + if Is_Predefined_Dispatching_Operation (Prim) then + return; + end if; - Push_Active_Scenario (N); + Body_Id := Corresponding_Body (Prim_Decl); - -- Only calls, instantiations, and task activations may result in a - -- guaranteed ABE. + -- Nothing to do when the primitive does not have a corresponding + -- body. This can happen when the unit with the bodies is not the + -- main unit subjected to ABE checks. - if Is_Suitable_Call (N) then - Extract_Call_Attributes - (Call => N, - Target_Id => Target_Id, - Attrs => Call_Attrs); + if No (Body_Id) then + return; - if Is_Activation_Proc (Target_Id) then - Process_Guaranteed_ABE_Activation - (Call => N, - Call_Attrs => Call_Attrs, - State => Initial_State); + -- The primitive overrides a parent or progenitor primitive - else - Process_Guaranteed_ABE_Call - (Call => N, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id); - end if; + elsif Present (Overridden_Operation (Prim)) then - elsif Is_Suitable_Instantiation (N) then - Process_Guaranteed_ABE_Instantiation (N); - end if; + -- Nothing to do when overriding an interface primitive happens + -- by inheriting a non-interface primitive as the check would + -- be done on the parent primitive. - -- Remove the current scenario from the stack of active scenarios once - -- all ABE diagnostics and checks have been performed. + if Present (Alias (Prim)) then + return; + end if; - Pop_Active_Scenario (N); - end Process_Guaranteed_ABE; + -- Nothing to do when the primitive is not overriding. The body of + -- such a primitive cannot be targeted by a dispatching call which + -- is executable during elaboration, and cannot cause an ABE. - -------------------------- - -- Push_Active_Scenario -- - -------------------------- + else + return; + end if; - procedure Push_Active_Scenario (N : Node_Id) is - begin - Scenario_Stack.Append (N); - end Push_Active_Scenario; + Body_Decl := Unit_Declaration_Node (Body_Id); + Region := Find_Early_Call_Region (Body_Decl); - --------------------------------- - -- Record_Elaboration_Scenario -- - --------------------------------- + -- The freeze node appears prior to the early call region of the + -- primitive body. - procedure Record_Elaboration_Scenario (N : Node_Id) is - Level : Enclosing_Level_Kind; + -- IMPORTANT: This check must always be performed even when + -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not + -- specified because the static model cannot guarantee the absence + -- of ABEs in the presence of dispatching calls. - Any_Level_OK : Boolean; - -- This flag is set when a particular scenario is allowed to appear at - -- any level. + if Earlier_In_Extended_Unit (FNode, Region) then + Error_Msg_Node_2 := Prim; + Error_Msg_NE + ("first freezing point of type & must appear within early " + & "call region of primitive body & (SPARK RM 7.7(8))", + Typ_Decl, Typ); - Declaration_Level_OK : Boolean; - -- This flag is set when a particular scenario is allowed to appear at - -- the declaration level. + Error_Msg_Sloc := Sloc (Region); + Error_Msg_N ("\region starts #", Typ_Decl); - Library_Level_OK : Boolean; - -- This flag is set when a particular scenario is allowed to appear at - -- the library level. + Error_Msg_Sloc := Sloc (Body_Decl); + Error_Msg_N ("\region ends #", Typ_Decl); - begin - -- Assume that the scenario cannot appear on any level + Error_Msg_Sloc := Freeze_Node_Location (FNode); + Error_Msg_N ("\first freezing point #", Typ_Decl); - Any_Level_OK := False; - Declaration_Level_OK := False; - Library_Level_OK := False; + -- If applicable, suggest the use of pragma Elaborate_Body in + -- the associated package spec. - -- Nothing to do when switch -gnatH (legacy elaboration checking mode - -- enabled) is in effect because the legacy ABE mechanism does not need - -- to carry out this action. + Suggest_Elaborate_Body + (N => FNode, + Body_Decl => Body_Decl, + Error_Nod => Typ_Decl); - if Legacy_Elaboration_Checks then - return; + raise Stop_Check; + end if; + end Check_Overriding_Primitive; - -- Nothing to do for ASIS because ABE checks and diagnostics are not - -- performed in this mode. + -------------------------- + -- Freeze_Node_Location -- + -------------------------- - elsif ASIS_Mode then - return; + function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is + Context : constant Node_Id := Parent (FNode); + Loc : constant Source_Ptr := Sloc (FNode); - -- Nothing to do when the scenario is being preanalyzed + Prv_Decls : List_Id; + Vis_Decls : List_Id; - elsif Preanalysis_Active then - return; - end if; + begin + -- In general, the source location of the freeze node is as close + -- as possible to the real freeze point, except when the freeze + -- node is at the "bottom" of a package spec. - -- Ensure that a library-level call does not appear in a preelaborated - -- unit. The check must come before ignoring scenarios within external - -- units or inside generics because calls in those context must also be - -- verified. + if Nkind (Context) = N_Package_Specification then + Prv_Decls := Private_Declarations (Context); + Vis_Decls := Visible_Declarations (Context); - if Is_Suitable_Call (N) then - Check_Preelaborated_Call (N); - end if; + -- The freeze node appears in the private declarations of the + -- package. - -- Nothing to do when the scenario does not appear within the main unit + if Present (Prv_Decls) + and then List_Containing (FNode) = Prv_Decls + then + null; - if not In_Main_Context (N) then - return; + -- The freeze node appears in the visible declarations of the + -- package and there are no private declarations. - -- Scenarios within a generic unit are never considered because generics - -- cannot be elaborated. + elsif Present (Vis_Decls) + and then List_Containing (FNode) = Vis_Decls + and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) + then + null; - elsif Inside_A_Generic then - return; + -- Otherwise the freeze node is not in the "last" declarative + -- list of the package. Use the existing source location of the + -- freeze node. - -- Scenarios which do not fall in one of the elaboration categories - -- listed below are not considered. The categories are: + else + return Loc; + end if; - -- 'Access for entries, operators, and subprograms - -- Assignments to variables - -- Calls (includes task activation) - -- Derived types - -- Instantiations - -- Pragma Refined_State - -- Reads of variables + -- The freeze node appears at the "bottom" of the package when + -- it is in the "last" declarative list and is either the last + -- in the list or is followed by internal constructs only. In + -- that case the more appropriate source location is that of + -- the package end label. - elsif Is_Suitable_Access (N) then - Library_Level_OK := True; + if not Precedes_Source_Construct (FNode) then + return Sloc (End_Label (Context)); + end if; + end if; - -- Signal any enclosing local exception handlers that the 'Access may - -- raise Program_Error due to a failed ABE check when switch -gnatd.o - -- (conservative elaboration order for indirect calls) is in effect. - -- Marking the exception handlers ensures proper expansion by both - -- the front and back end restriction when No_Exception_Propagation - -- is in effect. + return Loc; + end Freeze_Node_Location; - if Debug_Flag_Dot_O then - Possible_Local_Raise (N, Standard_Program_Error); - end if; + ------------------------------- + -- Precedes_Source_Construct -- + ------------------------------- - elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then - Declaration_Level_OK := True; - Library_Level_OK := True; + function Precedes_Source_Construct (N : Node_Id) return Boolean is + Decl : Node_Id; - -- Signal any enclosing local exception handlers that the call or - -- instantiation may raise Program_Error due to a failed ABE check. - -- Marking the exception handlers ensures proper expansion by both - -- the front and back end restriction when No_Exception_Propagation - -- is in effect. + begin + Decl := Next (N); + while Present (Decl) loop + if Comes_From_Source (Decl) then + return True; - Possible_Local_Raise (N, Standard_Program_Error); + -- A generated body for a source expression function is treated + -- as a source construct. - elsif Is_Suitable_SPARK_Derived_Type (N) then - Any_Level_OK := True; + elsif Nkind (Decl) = N_Subprogram_Body + and then Was_Expression_Function (Decl) + and then Comes_From_Source (Original_Node (Decl)) + then + return True; + end if; - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Library_Level_OK := True; + Next (Decl); + end loop; - elsif Is_Suitable_Variable_Assignment (N) - or else Is_Suitable_Variable_Reference (N) - then - Library_Level_OK := True; + return False; + end Precedes_Source_Construct; - -- Otherwise the input does not denote a suitable scenario + ---------------------------- + -- Suggest_Elaborate_Body -- + ---------------------------- - else - return; - end if; + procedure Suggest_Elaborate_Body + (N : Node_Id; + Body_Decl : Node_Id; + Error_Nod : Node_Id) + is + Unit_Id : constant Node_Id := Unit (Cunit (Main_Unit)); + Region : Node_Id; - -- The static model imposes additional restrictions on the placement of - -- scenarios. In contrast, the dynamic model assumes that every scenario - -- will be elaborated or invoked at some point. + begin + -- The suggestion applies only when the subprogram body resides in + -- a compilation package body, and a pragma Elaborate_Body would + -- allow for the node to appear in the early call region of the + -- subprogram body. This implies that all code from the subprogram + -- body up to the node is preelaborable. - if Static_Elaboration_Checks then + if Nkind (Unit_Id) = N_Package_Body then - -- Certain scenarios are allowed to appear at any level. This check - -- is performed here in order to save on a parent traversal. + -- Find the start of the early call region again assuming that + -- the package spec has pragma Elaborate_Body. Note that the + -- internal data structures are intentionally not updated + -- because this is a speculative search. - if Any_Level_OK then - null; + Region := + Find_Early_Call_Region + (Body_Decl => Body_Decl, + Assume_Elab_Body => True, + Skip_Memoization => True); - -- Otherwise the scenario must appear at a specific level + -- If the node appears within the early call region, assuming + -- that the package spec carries pragma Elaborate_Body, then it + -- is safe to suggest the pragma. - else - -- Performance note: parent traversal + if Earlier_In_Extended_Unit (Region, N) then + Error_Msg_Name_1 := Name_Elaborate_Body; + Error_Msg_NE + ("\consider adding pragma % in spec of unit &", + Error_Nod, Defining_Entity (Unit_Id)); + end if; + end if; + end Suggest_Elaborate_Body; - Level := Find_Enclosing_Level (N); + -- Local variables - -- Declaration-level scenario + FNode : constant Node_Id := Freeze_Node (Typ); + Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); - if Declaration_Level_OK and then Level = Declaration_Level then - null; + Prim_Elmt : Elmt_Id; - -- Library-level or instantiation scenario + -- Start of processing for Process_SPARK_Derived_Type - elsif Library_Level_OK - and then Level in Library_Or_Instantiation_Level - then - null; + begin + -- A type should have its freeze node set by the time SPARK scenarios + -- are being verified. - -- Otherwise the scenario does not appear at the proper level and - -- cannot possibly act as a top-level scenario. + pragma Assert (Present (FNode)); - else - return; - end if; + -- Verify that the freeze node of the derived type is within the + -- early call region of each overriding primitive body + -- (SPARK RM 7.7(8)). + + if Present (Prims) then + Prim_Elmt := First_Elmt (Prims); + while Present (Prim_Elmt) loop + Check_Overriding_Primitive + (Prim => Node (Prim_Elmt), + FNode => FNode); + + Next_Elmt (Prim_Elmt); + end loop; end if; - end if; - -- Derived types subject to SPARK_Mode On require elaboration-related - -- checks even though the type may not be declared within elaboration - -- code. The types are recorded in a separate table which is examined - -- during the Processing phase. Note that the checks must be delayed - -- because the bodies of overriding primitives are not available yet. + exception + when Stop_Check => + null; + end Process_SPARK_Derived_Type; - if Is_Suitable_SPARK_Derived_Type (N) then - Record_SPARK_Elaboration_Scenario (N); + --------------------------------- + -- Process_SPARK_Instantiation -- + --------------------------------- - -- Nothing left to do for derived types + procedure Process_SPARK_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + Gen_Id : constant Entity_Id := Target (Inst_Rep); + Gen_Rep : constant Target_Rep_Id := + Target_Representation_Of (Gen_Id, In_State); + Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); - return; + begin + -- The instantiation and the generic body are both in the main unit - -- Instantiations of generics both subject to SPARK_Mode On require - -- elaboration-related checks even though the instantiations may not - -- appear within elaboration code. The instantiations are recored in - -- a separate table which is examined during the Procesing phase. Note - -- that the checks must be delayed because it is not known yet whether - -- the generic unit has a body or not. + if Present (Body_Decl) + and then In_Extended_Main_Code_Unit (Body_Decl) - -- IMPORTANT: A SPARK instantiation is also a normal instantiation which - -- is subject to common conditional and guaranteed ABE checks. + -- If the instantiation appears prior to the generic body, then the + -- instantiation is illegal (SPARK RM 7.7(6)). - elsif Is_Suitable_SPARK_Instantiation (N) then - Record_SPARK_Elaboration_Scenario (N); + -- IMPORTANT: This check must always be performed even when + -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not + -- specified because the rule prevents use-before-declaration of + -- objects that may precede the generic body. - -- External constituents that refine abstract states which appear in - -- pragma Initializes require elaboration-related checks even though - -- a Refined_State pragma lacks any elaboration semantic. + and then Earlier_In_Extended_Unit (Inst, Body_Decl) + then + Error_Msg_NE + ("cannot instantiate & before body seen", Inst, Gen_Id); + end if; + end Process_SPARK_Instantiation; - elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then - Record_SPARK_Elaboration_Scenario (N); + ---------------------------- + -- Process_SPARK_Scenario -- + ---------------------------- - -- Nothing left to do for pragma Refined_State + procedure Process_SPARK_Scenario + (N : Node_Id; + In_State : Processing_In_State) + is + Scen : constant Node_Id := Scenario (N); - return; - end if; + begin + -- Ensure that a suitable elaboration model is in effect for SPARK + -- rule verification. - -- Perform early detection of guaranteed ABEs in order to suppress the - -- instantiation of generic bodies as gigi cannot handle certain types - -- of premature instantiations. + Check_SPARK_Model_In_Effect; - Process_Guaranteed_ABE (N); + -- Add the current scenario to the stack of active scenarios - -- At this point all checks have been performed. Record the scenario for - -- later processing by the ABE phase. + Push_Active_Scenario (Scen); - Top_Level_Scenarios.Append (N); - Set_Is_Recorded_Top_Level_Scenario (N); - end Record_Elaboration_Scenario; + -- Derived type - --------------------------------------- - -- Record_SPARK_Elaboration_Scenario -- - --------------------------------------- + if Is_Suitable_SPARK_Derived_Type (Scen) then + Process_SPARK_Derived_Type + (Typ_Decl => Scen, + Typ_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - procedure Record_SPARK_Elaboration_Scenario (N : Node_Id) is - begin - SPARK_Scenarios.Append (N); - Set_Is_Recorded_SPARK_Scenario (N); - end Record_SPARK_Elaboration_Scenario; + -- Instantiation - ----------------------------------- - -- Recorded_SPARK_Scenarios_Hash -- - ----------------------------------- + elsif Is_Suitable_SPARK_Instantiation (Scen) then + Process_SPARK_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); - function Recorded_SPARK_Scenarios_Hash - (Key : Node_Id) return Recorded_SPARK_Scenarios_Index - is - begin - return - Recorded_SPARK_Scenarios_Index (Key mod Recorded_SPARK_Scenarios_Max); - end Recorded_SPARK_Scenarios_Hash; + -- Refined_State pragma - --------------------------------------- - -- Recorded_Top_Level_Scenarios_Hash -- - --------------------------------------- + elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then + Process_SPARK_Refined_State_Pragma + (Prag => Scen, + Prag_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); + end if; - function Recorded_Top_Level_Scenarios_Hash - (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index - is - begin - return - Recorded_Top_Level_Scenarios_Index - (Key mod Recorded_Top_Level_Scenarios_Max); - end Recorded_Top_Level_Scenarios_Hash; + -- Remove the current scenario from the stack of active scenarios + -- once all ABE diagnostics and checks have been performed. - -------------------------- - -- Reset_Visited_Bodies -- - -------------------------- + Pop_Active_Scenario (Scen); + end Process_SPARK_Scenario; - procedure Reset_Visited_Bodies is - begin - if Visited_Bodies_In_Use then - Visited_Bodies_In_Use := False; - Visited_Bodies.Reset; - end if; - end Reset_Visited_Bodies; + ---------------------------------------- + -- Process_SPARK_Refined_State_Pragma -- + ---------------------------------------- - ------------------- - -- Root_Scenario -- - ------------------- + procedure Process_SPARK_Refined_State_Pragma + (Prag : Node_Id; + Prag_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Prag_Rep); - function Root_Scenario return Node_Id is - package Stack renames Scenario_Stack; + procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); + pragma Inline (Check_SPARK_Constituent); + -- Ensure that a single constituent Constit_Id is elaborated prior to + -- the main unit. - begin - -- Ensure that the scenario stack has at least one active scenario in - -- it. The one at the bottom (index First) is the root scenario. + procedure Check_SPARK_Constituents (Constits : Elist_Id); + pragma Inline (Check_SPARK_Constituents); + -- Ensure that all constituents found in list Constits are elaborated + -- prior to the main unit. - pragma Assert (Stack.Last >= Stack.First); - return Stack.Table (Stack.First); - end Root_Scenario; + procedure Check_SPARK_Initialized_State (State : Node_Id); + pragma Inline (Check_SPARK_Initialized_State); + -- Ensure that the constituents of single abstract state State are + -- elaborated prior to the main unit. - --------------------------- - -- Set_Early_Call_Region -- - --------------------------- + procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); + pragma Inline (Check_SPARK_Initialized_States); + -- Ensure that the constituents of all abstract states which appear + -- in the Initializes pragma of package Pack_Id are elaborated prior + -- to the main unit. - procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is - begin - pragma Assert (Ekind_In (Body_Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure, - E_Subprogram_Body)); + ----------------------------- + -- Check_SPARK_Constituent -- + ----------------------------- - Early_Call_Regions_In_Use := True; - Early_Call_Regions.Set (Body_Id, Start); - end Set_Early_Call_Region; + procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is + SM_Prag : Node_Id; - ---------------------------- - -- Set_Elaboration_Status -- - ---------------------------- + begin + -- Nothing to do for "null" constituents - procedure Set_Elaboration_Status - (Unit_Id : Entity_Id; - Val : Elaboration_Attributes) - is - begin - Elaboration_Statuses_In_Use := True; - Elaboration_Statuses.Set (Unit_Id, Val); - end Set_Elaboration_Status; + if Nkind (Constit_Id) = N_Null then + return; - ------------------------------------ - -- Set_Is_Recorded_SPARK_Scenario -- - ------------------------------------ + -- Nothing to do for illegal constituents - procedure Set_Is_Recorded_SPARK_Scenario - (N : Node_Id; - Val : Boolean := True) - is - begin - Recorded_SPARK_Scenarios_In_Use := True; - Recorded_SPARK_Scenarios.Set (N, Val); - end Set_Is_Recorded_SPARK_Scenario; + elsif Error_Posted (Constit_Id) then + return; + end if; - ---------------------------------------- - -- Set_Is_Recorded_Top_Level_Scenario -- - ---------------------------------------- + SM_Prag := SPARK_Pragma (Constit_Id); - procedure Set_Is_Recorded_Top_Level_Scenario - (N : Node_Id; - Val : Boolean := True) - is - begin - Recorded_Top_Level_Scenarios_In_Use := True; - Recorded_Top_Level_Scenarios.Set (N, Val); - end Set_Is_Recorded_Top_Level_Scenario; + -- The check applies only when the constituent is subject to + -- pragma SPARK_Mode On. - ------------------------- - -- Set_Is_Visited_Body -- - ------------------------- + if Present (SM_Prag) + and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On + then + -- An external constituent of an abstract state which appears + -- in the Initializes pragma of a package spec imposes an + -- Elaborate requirement on the context of the main unit. + -- Determine whether the context has a pragma strong enough to + -- meet the requirement. + + -- IMPORTANT: This check is performed only when -gnatd.v + -- (enforce SPARK elaboration rules in SPARK code) is in effect + -- because the static model can ensure the prior elaboration of + -- the unit which contains a constituent by installing implicit + -- Elaborate pragma. + + if Debug_Flag_Dot_V then + Meet_Elaboration_Requirement + (N => Prag, + Targ_Id => Constit_Id, + Req_Nam => Name_Elaborate, + In_State => In_State); + + -- Otherwise ensure that the unit with the external constituent + -- is elaborated prior to the main unit. - procedure Set_Is_Visited_Body (Subp_Body : Node_Id) is - begin - Visited_Bodies_In_Use := True; - Visited_Bodies.Set (Subp_Body, True); - end Set_Is_Visited_Body; + else + Ensure_Prior_Elaboration + (N => Prag, + Unit_Id => Find_Top_Unit (Constit_Id), + Prag_Nam => Name_Elaborate, + In_State => In_State); + end if; + end if; + end Check_SPARK_Constituent; - ------------------------------- - -- Static_Elaboration_Checks -- - ------------------------------- + ------------------------------ + -- Check_SPARK_Constituents -- + ------------------------------ - function Static_Elaboration_Checks return Boolean is - begin - return not Dynamic_Elaboration_Checks; - end Static_Elaboration_Checks; + procedure Check_SPARK_Constituents (Constits : Elist_Id) is + Constit_Elmt : Elmt_Id; - ------------------- - -- Traverse_Body -- - ------------------- + begin + if Present (Constits) then + Constit_Elmt := First_Elmt (Constits); + while Present (Constit_Elmt) loop + Check_SPARK_Constituent (Node (Constit_Elmt)); + Next_Elmt (Constit_Elmt); + end loop; + end if; + end Check_SPARK_Constituents; - procedure Traverse_Body (N : Node_Id; State : Processing_Attributes) is - procedure Find_And_Process_Nested_Scenarios; - pragma Inline (Find_And_Process_Nested_Scenarios); - -- Examine the declarations and statements of subprogram body N for - -- suitable scenarios. + ----------------------------------- + -- Check_SPARK_Initialized_State -- + ----------------------------------- - --------------------------------------- - -- Find_And_Process_Nested_Scenarios -- - --------------------------------------- + procedure Check_SPARK_Initialized_State (State : Node_Id) is + SM_Prag : Node_Id; + State_Id : Entity_Id; - procedure Find_And_Process_Nested_Scenarios is - function Is_Potential_Scenario - (Nod : Node_Id) return Traverse_Result; - -- Determine whether arbitrary node Nod denotes a suitable scenario. - -- If it does, save it in the Nested_Scenarios list of the subprogram - -- body, and process it. + begin + -- Nothing to do for "null" initialization items - procedure Traverse_List (List : List_Id); - pragma Inline (Traverse_List); - -- Invoke Traverse_Potential_Scenarios on each node in list List + if Nkind (State) = N_Null then + return; - procedure Traverse_Potential_Scenarios is - new Traverse_Proc (Is_Potential_Scenario); + -- Nothing to do for illegal states - --------------------------- - -- Is_Potential_Scenario -- - --------------------------- + elsif Error_Posted (State) then + return; + end if; - function Is_Potential_Scenario - (Nod : Node_Id) return Traverse_Result - is - begin - -- Special cases + State_Id := Entity_Of (State); - -- Skip constructs which do not have elaboration of their own and - -- need to be elaborated by other means such as invocation, task - -- activation, etc. + -- Sanitize the state - if Is_Non_Library_Level_Encapsulator (Nod) then - return Skip; + if No (State_Id) then + return; - -- Terminate the traversal of a task body when encountering an - -- accept or select statement, and - -- - -- * Entry calls during elaboration are not allowed. In this - -- case the accept or select statement will cause the task - -- to block at elaboration time because there are no entry - -- calls to unblock it. - -- - -- or - -- - -- * Switch -gnatd_a (stop elaboration checks on accept or - -- select statement) is in effect. + elsif Error_Posted (State_Id) then + return; - elsif (Debug_Flag_Underscore_A - or else Restriction_Active - (No_Entry_Calls_In_Elaboration_Code)) - and then Nkind_In (Original_Node (Nod), N_Accept_Statement, - N_Selective_Accept) - then - return Abandon; + elsif Ekind (State_Id) /= E_Abstract_State then + return; + end if; - -- Terminate the traversal of a task body when encountering a - -- suspension call, and - -- - -- * Entry calls during elaboration are not allowed. In this - -- case the suspension call emulates an entry call and will - -- cause the task to block at elaboration time. - -- - -- or - -- - -- * Switch -gnatd_s (stop elaboration checks on synchronous - -- suspension) is in effect. - -- - -- Note that the guard should not be checking the state of flag - -- Within_Task_Body because only suspension calls which appear - -- immediately within the statements of the task are supported. - -- Flag Within_Task_Body carries over to deeper levels of the - -- traversal. + -- The check is performed only when the abstract state is subject + -- to SPARK_Mode On. - elsif (Debug_Flag_Underscore_S - or else Restriction_Active - (No_Entry_Calls_In_Elaboration_Code)) - and then Is_Synchronous_Suspension_Call (Nod) - and then In_Task_Body (Nod) + SM_Prag := SPARK_Pragma (State_Id); + + if Present (SM_Prag) + and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On then - return Abandon; + Check_SPARK_Constituents (Refinement_Constituents (State_Id)); + end if; + end Check_SPARK_Initialized_State; - -- Certain nodes carry semantic lists which act as repositories - -- until expansion transforms the node and relocates the contents. - -- Examine these lists in case expansion is disabled. + ------------------------------------ + -- Check_SPARK_Initialized_States -- + ------------------------------------ - elsif Nkind_In (Nod, N_And_Then, N_Or_Else) then - Traverse_List (Actions (Nod)); + procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is + Init_Prag : constant Node_Id := + Get_Pragma (Pack_Id, Pragma_Initializes); - elsif Nkind_In (Nod, N_Elsif_Part, N_Iteration_Scheme) then - Traverse_List (Condition_Actions (Nod)); + Init : Node_Id; + Inits : Node_Id; - elsif Nkind (Nod) = N_If_Expression then - Traverse_List (Then_Actions (Nod)); - Traverse_List (Else_Actions (Nod)); + begin + if Present (Init_Prag) then + Inits := Expression (Get_Argument (Init_Prag, Pack_Id)); - elsif Nkind_In (Nod, N_Component_Association, - N_Iterated_Component_Association) - then - Traverse_List (Loop_Actions (Nod)); + -- Avoid processing a "null" initialization list. The only + -- other alternative is an aggregate. - -- General case + if Nkind (Inits) = N_Aggregate then - elsif Is_Suitable_Scenario (Nod) then - Process_Conditional_ABE - (N => Nod, - State => State); - end if; + -- The initialization items appear in list form: + -- + -- (state1, state2) - return OK; - end Is_Potential_Scenario; + if Present (Expressions (Inits)) then + Init := First (Expressions (Inits)); + while Present (Init) loop + Check_SPARK_Initialized_State (Init); + Next (Init); + end loop; + end if; - ------------------- - -- Traverse_List -- - ------------------- + -- The initialization items appear in associated form: + -- + -- (state1 => item1, + -- state2 => (item2, item3)) + + if Present (Component_Associations (Inits)) then + Init := First (Component_Associations (Inits)); + while Present (Init) loop + Check_SPARK_Initialized_State (Init); + Next (Init); + end loop; + end if; + end if; + end if; + end Check_SPARK_Initialized_States; - procedure Traverse_List (List : List_Id) is - Item : Node_Id; + -- Local variables - begin - Item := First (List); - while Present (Item) loop - Traverse_Potential_Scenarios (Item); - Next (Item); - end loop; - end Traverse_List; + Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (Prag); - -- Start of processing for Find_And_Process_Nested_Scenarios + -- Start of processing for Process_SPARK_Refined_State_Pragma begin - -- Examine the declarations for suitable scenarios + -- Pragma Refined_State must be associated with a package body - Traverse_List (Declarations (N)); + pragma Assert + (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); - -- Examine the handled sequence of statements. This also includes any - -- exceptions handlers. + -- Verify that each external contitunent of an abstract state + -- mentioned in pragma Initializes is properly elaborated. - Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); - end Find_And_Process_Nested_Scenarios; + Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); + end Process_SPARK_Refined_State_Pragma; + end SPARK_Processor; - -- Start of processing for Traverse_Body + ------------------------------- + -- Spec_And_Body_From_Entity -- + ------------------------------- + procedure Spec_And_Body_From_Entity + (Id : Node_Id; + Spec_Decl : out Node_Id; + Body_Decl : out Node_Id) + is begin - -- Nothing to do when there is no body + Spec_And_Body_From_Node + (N => Unit_Declaration_Node (Id), + Spec_Decl => Spec_Decl, + Body_Decl => Body_Decl); + end Spec_And_Body_From_Entity; - if No (N) then - return; + ----------------------------- + -- Spec_And_Body_From_Node -- + ----------------------------- - elsif Nkind (N) /= N_Subprogram_Body then - return; - end if; + procedure Spec_And_Body_From_Node + (N : Node_Id; + Spec_Decl : out Node_Id; + Body_Decl : out Node_Id) + is + Body_Id : Entity_Id; + Spec_Id : Entity_Id; - -- Nothing to do if the body was already traversed during the processing - -- of the same top-level scenario. + begin + -- Assume that the construct lacks spec and body - if Is_Visited_Body (N) then - return; + Body_Decl := Empty; + Spec_Decl := Empty; - -- Otherwise mark the body as traversed + -- Bodies - else - Set_Is_Visited_Body (N); + if Nkind_In (N, N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) + then + Spec_Id := Corresponding_Spec (N); + + -- The body completes a previous declaration + + if Present (Spec_Id) then + Spec_Decl := Unit_Declaration_Node (Spec_Id); + + -- Otherwise the body acts as the initial declaration, and is both a + -- spec and body. There is no need to look for an optional body. + + else + Body_Decl := N; + Spec_Decl := N; + return; + end if; + + -- Declarations + + elsif Nkind_In (N, N_Entry_Declaration, + N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Protected_Type_Declaration, + N_Subprogram_Declaration, + N_Task_Type_Declaration) + then + Spec_Decl := N; + + -- Expression function + + elsif Nkind (N) = N_Expression_Function then + Spec_Id := Corresponding_Spec (N); + pragma Assert (Present (Spec_Id)); + + Spec_Decl := Unit_Declaration_Node (Spec_Id); + + -- Instantiations + + elsif Nkind (N) in N_Generic_Instantiation then + Spec_Decl := Instance_Spec (N); + pragma Assert (Present (Spec_Decl)); + + -- Stubs + + elsif Nkind (N) in N_Body_Stub then + Spec_Id := Corresponding_Spec_Of_Stub (N); + + -- The stub completes a previous declaration + + if Present (Spec_Id) then + Spec_Decl := Unit_Declaration_Node (Spec_Id); + + -- Otherwise the stub acts as a spec + + else + Spec_Decl := N; + end if; end if; - -- Examine the declarations and statements of the subprogram body for - -- suitable scenarios, save and process them accordingly. + -- Obtain an optional or mandatory body + + if Present (Spec_Decl) then + Body_Id := Corresponding_Body (Spec_Decl); - Find_And_Process_Nested_Scenarios; - end Traverse_Body; + if Present (Body_Id) then + Body_Decl := Unit_Declaration_Node (Body_Id); + end if; + end if; + end Spec_And_Body_From_Node; + + ------------------------------- + -- Static_Elaboration_Checks -- + ------------------------------- + + function Static_Elaboration_Checks return Boolean is + begin + return not Dynamic_Elaboration_Checks; + end Static_Elaboration_Checks; ----------------- -- Unit_Entity -- @@ -11256,82 +15699,6 @@ package body Sem_Elab is --------------------------------- procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is - procedure Update_SPARK_Scenario; - pragma Inline (Update_SPARK_Scenario); - -- Update the contents of table SPARK_Scenarios if Old_N is recorded - -- there. - - procedure Update_Top_Level_Scenario; - pragma Inline (Update_Top_Level_Scenario); - -- Update the contexts of table Top_Level_Scenarios if Old_N is recorded - -- there. - - --------------------------- - -- Update_SPARK_Scenario -- - --------------------------- - - procedure Update_SPARK_Scenario is - package Scenarios renames SPARK_Scenarios; - - begin - if Is_Recorded_SPARK_Scenario (Old_N) then - - -- Performance note: list traversal - - for Index in Scenarios.First .. Scenarios.Last loop - if Scenarios.Table (Index) = Old_N then - Scenarios.Table (Index) := New_N; - - -- The old SPARK scenario is no longer recorded, but the new - -- one is. - - Set_Is_Recorded_Top_Level_Scenario (Old_N, False); - Set_Is_Recorded_Top_Level_Scenario (New_N); - return; - end if; - end loop; - - -- A recorded SPARK scenario must be in the table of recorded - -- SPARK scenarios. - - pragma Assert (False); - end if; - end Update_SPARK_Scenario; - - ------------------------------- - -- Update_Top_Level_Scenario -- - ------------------------------- - - procedure Update_Top_Level_Scenario is - package Scenarios renames Top_Level_Scenarios; - - begin - if Is_Recorded_Top_Level_Scenario (Old_N) then - - -- Performance note: list traversal - - for Index in Scenarios.First .. Scenarios.Last loop - if Scenarios.Table (Index) = Old_N then - Scenarios.Table (Index) := New_N; - - -- The old top-level scenario is no longer recorded, but the - -- new one is. - - Set_Is_Recorded_Top_Level_Scenario (Old_N, False); - Set_Is_Recorded_Top_Level_Scenario (New_N); - return; - end if; - end loop; - - -- A recorded top-level scenario must be in the table of recorded - -- top-level scenarios. - - pragma Assert (False); - end if; - end Update_Top_Level_Scenario; - - -- Start of processing for Update_Elaboration_Requirement - begin -- Nothing to do when the old and new scenarios are one and the same @@ -11344,20 +15711,10 @@ package body Sem_Elab is -- is inserted at the proper place in the tree. elsif Is_Scenario (Old_N) then - Update_SPARK_Scenario; - Update_Top_Level_Scenario; + Replace_Scenario (Old_N, New_N); end if; end Update_Elaboration_Scenario; - ------------------------- - -- Visited_Bodies_Hash -- - ------------------------- - - function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index is - begin - return Visited_Bodies_Index (Key mod Visited_Bodies_Max); - end Visited_Bodies_Hash; - --------------------------------------------------------------------------- -- -- -- L E G A C Y A C C E S S B E F O R E E L A B O R A T I O N -- diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads index 5d47957..f47d525 100644 --- a/gcc/ada/sem_elab.ads +++ b/gcc/ada/sem_elab.ads @@ -30,25 +30,9 @@ with Types; use Types; package Sem_Elab is - procedure Build_Call_Marker (N : Node_Id); - -- Create a call marker for call or requeue statement N and record it for - -- later processing by the ABE mechanism. - - procedure Build_Variable_Reference_Marker - (N : Node_Id; - Read : Boolean; - Write : Boolean); - -- Create a variable reference marker for arbitrary node N if it mentions a - -- variable, and record it for later processing by the ABE mechanism. Flag - -- Read should be set when the reference denotes a read. Flag Write should - -- be set when the reference denotes a write. - - procedure Check_Elaboration_Scenarios; - -- Examine each scenario recorded during analysis/resolution and apply the - -- Ada or SPARK elaboration rules taking into account the model in effect. - -- This processing detects and diagnoses ABE issues, installs conditional - -- ABE checks or guaranteed ABE failures, and ensures the elaboration of - -- units. + ----------- + -- Types -- + ----------- -- The following type classifies the various enclosing levels used in ABE -- diagnostics. @@ -64,9 +48,9 @@ package Sem_Elab is -- package Nested is -- enclosing package ignored -- X ... -- at declaration level - Generic_Package_Spec, - Generic_Package_Body, - -- A construct is at the "generic library level" when it appears in a + Generic_Spec_Level, + Generic_Body_Level, + -- A construct is at the "generic level" when it appears in a -- generic package library unit, ignoring enclosing packages. Example: -- generic @@ -74,14 +58,14 @@ package Sem_Elab is -- package Nested is -- enclosing package ignored -- X ... -- at generic library level - Instantiation, + Instantiation_Level, -- A construct is at the "instantiation library level" when it appears -- in a library unit which is also an instantiation. Example: -- package Inst is new Gen; -- at instantiation level - Package_Spec, - Package_Body, + Library_Spec_Level, + Library_Body_Level, -- A construct is at the "library level" when it appears in a package -- library unit, ignoring enclosing packages. Example: @@ -93,26 +77,46 @@ package Sem_Elab is -- This value is used to indicate that none of the levels above are in -- effect. - subtype Any_Library_Level is Enclosing_Level_Kind range - Generic_Package_Spec .. - Package_Body; - - subtype Generic_Library_Level is Enclosing_Level_Kind range - Generic_Package_Spec .. - Generic_Package_Body; + subtype Generic_Level is Enclosing_Level_Kind range + Generic_Spec_Level .. + Generic_Body_Level; subtype Library_Level is Enclosing_Level_Kind range - Package_Spec .. - Package_Body; + Library_Spec_Level .. + Library_Body_Level; subtype Library_Or_Instantiation_Level is Enclosing_Level_Kind range - Instantiation .. - Package_Body; + Instantiation_Level .. + Library_Body_Level; + + procedure Build_Call_Marker (N : Node_Id); + pragma Inline (Build_Call_Marker); + -- Create a call marker for call or requeue statement N and record it for + -- later processing by the ABE mechanism. + + procedure Build_Variable_Reference_Marker + (N : Node_Id; + Read : Boolean; + Write : Boolean); + pragma Inline (Build_Variable_Reference_Marker); + -- Create a variable reference marker for arbitrary node N if it mentions a + -- variable, and record it for later processing by the ABE mechanism. Flag + -- Read should be set when the reference denotes a read. Flag Write should + -- be set when the reference denotes a write. + + procedure Check_Elaboration_Scenarios; + -- Examine each scenario recorded during analysis/resolution and apply the + -- Ada or SPARK elaboration rules taking into account the model in effect. + -- This processing detects and diagnoses ABE issues, installs conditional + -- ABE checks or guaranteed ABE failures, and ensures the elaboration of + -- units. function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind; + pragma Inline (Find_Enclosing_Level); -- Determine the enclosing level of arbitrary node N procedure Initialize; + pragma Inline (Initialize); -- Initialize the internal structures of this unit procedure Kill_Elaboration_Scenario (N : Node_Id); @@ -121,9 +125,10 @@ package Sem_Elab is -- dead code. procedure Record_Elaboration_Scenario (N : Node_Id); + pragma Inline (Record_Elaboration_Scenario); -- Determine whether atribtray node N denotes a scenario which requires - -- ABE diagnostics or runtime checks. If this is the case, store N into - -- a table for later processing. + -- ABE diagnostics or runtime checks. If this is the case, store N for + -- later processing. --------------------------------------------------------------------------- -- -- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 5e7f743..b499dbd 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9861,6 +9861,17 @@ package body Sem_Prag is -- Start of processing for Process_Inline begin + -- An inlined subprogram may grant access to its private enclosing + -- context depending on the placement of its body. From elaboration + -- point of view, the flow of execution may enter this private + -- context, and then reach an external unit, thus producing a + -- dependency on that external unit. For such a path to be properly + -- discovered and encoded in the ALI file of the main unit, let the + -- ABE mechanism process the body of the main unit, and encode all + -- relevant invocation constructs and the relations between them. + + Mark_Save_Invocation_Graph_Of_Body; + Check_No_Identifiers; Check_At_Least_N_Arguments (1); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 50ea52a..77eefdc 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6721,33 +6721,26 @@ package body Sem_Util is -- Enclosing_Generic_Body -- ---------------------------- - function Enclosing_Generic_Body - (N : Node_Id) return Node_Id - is - P : Node_Id; - Decl : Node_Id; - Spec : Node_Id; + function Enclosing_Generic_Body (N : Node_Id) return Node_Id is + Par : Node_Id; + Spec_Id : Entity_Id; begin - P := Parent (N); - while Present (P) loop - if Nkind (P) = N_Package_Body - or else Nkind (P) = N_Subprogram_Body - then - Spec := Corresponding_Spec (P); - - if Present (Spec) then - Decl := Unit_Declaration_Node (Spec); + Par := Parent (N); + while Present (Par) loop + if Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then + Spec_Id := Corresponding_Spec (Par); - if Nkind (Decl) = N_Generic_Package_Declaration - or else Nkind (Decl) = N_Generic_Subprogram_Declaration - then - return P; - end if; + if Present (Spec_Id) + and then Nkind_In (Unit_Declaration_Node (Spec_Id), + N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration) + then + return Par; end if; end if; - P := Parent (P); + Par := Parent (Par); end loop; return Empty; @@ -6757,38 +6750,34 @@ package body Sem_Util is -- Enclosing_Generic_Unit -- ---------------------------- - function Enclosing_Generic_Unit - (N : Node_Id) return Node_Id - is - P : Node_Id; - Decl : Node_Id; - Spec : Node_Id; + function Enclosing_Generic_Unit (N : Node_Id) return Node_Id is + Par : Node_Id; + Spec_Decl : Node_Id; + Spec_Id : Entity_Id; begin - P := Parent (N); - while Present (P) loop - if Nkind (P) = N_Generic_Package_Declaration - or else Nkind (P) = N_Generic_Subprogram_Declaration + Par := Parent (N); + while Present (Par) loop + if Nkind_In (Par, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration) then - return P; + return Par; - elsif Nkind (P) = N_Package_Body - or else Nkind (P) = N_Subprogram_Body - then - Spec := Corresponding_Spec (P); + elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then + Spec_Id := Corresponding_Spec (Par); - if Present (Spec) then - Decl := Unit_Declaration_Node (Spec); + if Present (Spec_Id) then + Spec_Decl := Unit_Declaration_Node (Spec_Id); - if Nkind (Decl) = N_Generic_Package_Declaration - or else Nkind (Decl) = N_Generic_Subprogram_Declaration + if Nkind_In (Spec_Decl, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration) then - return Decl; + return Spec_Decl; end if; end if; end if; - P := Parent (P); + Par := Parent (Par); end loop; return Empty; @@ -7579,6 +7568,18 @@ package body Sem_Util is end loop; end Examine_Array_Bounds; + ------------------- + -- Exceptions_OK -- + ------------------- + + function Exceptions_OK return Boolean is + begin + return + not (Restriction_Active (No_Exception_Handlers) or else + Restriction_Active (No_Exception_Propagation) or else + Restriction_Active (No_Exceptions)); + end Exceptions_OK; + -------------------------- -- Explain_Limited_Type -- -------------------------- @@ -18900,6 +18901,44 @@ package body Sem_Util is end if; end Mark_Elaboration_Attributes; + ---------------------------------------- + -- Mark_Save_Invocation_Graph_Of_Body -- + ---------------------------------------- + + procedure Mark_Save_Invocation_Graph_Of_Body is + Main : constant Node_Id := Cunit (Main_Unit); + Main_Unit : constant Node_Id := Unit (Main); + Aux_Id : Entity_Id; + + begin + Set_Save_Invocation_Graph_Of_Body (Main); + + -- Assume that the main unit does not have a complimentary unit + + Aux_Id := Empty; + + -- Obtain the complimentary unit of the main unit + + if Nkind_In (Main_Unit, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Subprogram_Declaration) + then + Aux_Id := Corresponding_Body (Main_Unit); + + elsif Nkind_In (Main_Unit, N_Package_Body, + N_Subprogram_Body, + N_Subprogram_Renaming_Declaration) + then + Aux_Id := Corresponding_Spec (Main_Unit); + end if; + + if Present (Aux_Id) then + Set_Save_Invocation_Graph_Of_Body + (Parent (Unit_Declaration_Node (Aux_Id))); + end if; + end Mark_Save_Invocation_Graph_Of_Body; + ---------------------------------- -- Matching_Static_Array_Bounds -- ---------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 4e4d4ba..3f8d2e7 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -708,6 +708,10 @@ package Sem_Util is -- If no suitable entity is available, return Empty. This routine carries -- out actions that are tied to SPARK semantics. + function Exceptions_OK return Boolean; + -- Determine whether exceptions are allowed to be caught, propagated, or + -- raised. + procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id); -- This procedure is called after issuing a message complaining about an -- inappropriate use of limited type T. If useful, it adds additional @@ -2182,6 +2186,10 @@ package Sem_Util is -- Modes - Save the Ghost and SPARK modes in effect (if applicable) -- Warnings - Save the status of Elab_Warnings + procedure Mark_Save_Invocation_Graph_Of_Body; + -- Notify the body of the main unit that the invocation constructs and + -- relations expressed within it must be recorded by the ABE mechanism. + function Matching_Static_Array_Bounds (L_Typ : Node_Id; R_Typ : Node_Id) return Boolean; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 2464b97..d24938c 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1913,7 +1913,8 @@ package body Sinfo is or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); return Flag1 (N); end Is_Elaboration_Checks_OK_Node; @@ -1932,12 +1933,15 @@ package body Sinfo is or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Call_Marker or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Identifier or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); return Flag3 (N); end Is_Elaboration_Warnings_OK_Node; @@ -2130,7 +2134,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Variable_Reference_Marker); - return Flag1 (N); + return Flag4 (N); end Is_Read; function Is_Source_Call @@ -2156,7 +2160,8 @@ package body Sinfo is or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); return Flag2 (N); end Is_SPARK_Mode_On_Node; @@ -2216,7 +2221,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Variable_Reference_Marker); - return Flag2 (N); + return Flag5 (N); end Is_Write; function Iteration_Scheme @@ -3091,6 +3096,14 @@ package body Sinfo is return Flag18 (N); end Rounded_Result; + function Save_Invocation_Graph_Of_Body + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + return Flag1 (N); + end Save_Invocation_Graph_Of_Body; + function SCIL_Controlling_Tag (N : Node_Id) return Node_Id is begin @@ -5387,7 +5400,8 @@ package body Sinfo is or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); Set_Flag1 (N, Val); end Set_Is_Elaboration_Checks_OK_Node; @@ -5406,12 +5420,15 @@ package body Sinfo is or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Call_Marker or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Identifier or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); Set_Flag3 (N, Val); end Set_Is_Elaboration_Warnings_OK_Node; @@ -5604,7 +5621,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Variable_Reference_Marker); - Set_Flag1 (N, Val); + Set_Flag4 (N, Val); end Set_Is_Read; procedure Set_Is_Source_Call @@ -5630,7 +5647,8 @@ package body Sinfo is or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation - or else NT (N).Nkind = N_Requeue_Statement); + or else NT (N).Nkind = N_Requeue_Statement + or else NT (N).Nkind = N_Variable_Reference_Marker); Set_Flag2 (N, Val); end Set_Is_SPARK_Mode_On_Node; @@ -5692,7 +5710,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Variable_Reference_Marker); - Set_Flag2 (N, Val); + Set_Flag5 (N, Val); end Set_Is_Write; procedure Set_Iteration_Scheme @@ -6567,6 +6585,14 @@ package body Sinfo is Set_Flag18 (N, Val); end Set_Rounded_Result; + procedure Set_Save_Invocation_Graph_Of_Body + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Compilation_Unit); + Set_Flag1 (N, Val); + end Set_Save_Invocation_Graph_Of_Body; + procedure Set_SCIL_Controlling_Tag (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index b3e1309..75883f0 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 fdba595..dc62ec2 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -51,6 +51,9 @@ package body Switch.B is -- Used for -d and -D to scan stack size including handling k/m. S is -- set to 'd' or 'D' to indicate the switch being scanned. + procedure Scan_Debug_Switches; + -- Scan out debug switches + --------------------------- -- Get_Optional_Filename -- --------------------------- @@ -114,6 +117,70 @@ package body Switch.B is return Result; end Get_Stack_Size; + ------------------------- + -- Scan_Debug_Switches -- + ------------------------- + + procedure Scan_Debug_Switches is + Dot : Boolean := False; + Underscore : Boolean := False; + + begin + while Ptr <= Max loop + C := Switch_Chars (Ptr); + + -- Binder debug flags come in the following forms: + -- + -- letter + -- . letter + -- _ letter + -- + -- digit + -- . digit + -- _ digit + -- + -- Note that the processing of switch -d aleady takes care of the + -- case where the first flag is a digit (default stack size). + + if C in '1' .. '9' or else + C in 'a' .. 'z' or else + C in 'A' .. 'Z' + then + -- . letter + -- . digit + + if Dot then + Set_Dotted_Debug_Flag (C); + Dot := False; + + -- _ letter + -- _ digit + + elsif Underscore then + Set_Underscored_Debug_Flag (C); + Underscore := False; + + -- letter + -- digit + + else + Set_Debug_Flag (C); + end if; + + elsif C = '.' then + Dot := True; + + elsif C = '_' then + Underscore := True; + + else + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + end loop; + end Scan_Debug_Switches; + -- Start of processing for Scan_Binder_Switches begin @@ -170,7 +237,6 @@ package body Switch.B is -- Processing for d switch when 'd' => - if Ptr = Max then Bad_Switch (Switch_Chars); end if; @@ -189,26 +255,7 @@ package body Switch.B is -- Case where character after -d is not digit (debug flags) else - -- Note: for the debug switch, the remaining characters in this - -- switch field must all be debug flags, since all valid switch - -- characters are also valid debug characters. This switch is - -- not documented on purpose because it is only used by the - -- implementors. - - -- Loop to scan out debug flags - - loop - C := Switch_Chars (Ptr); - - if C in 'a' .. 'z' or else C in 'A' .. 'Z' then - Set_Debug_Flag (C); - else - Bad_Switch (Switch_Chars); - end if; - - Ptr := Ptr + 1; - exit when Ptr > Max; - end loop; + Scan_Debug_Switches; end if; -- Processing for D switch |