From 44a10091cf20b5f4580c4e7bc33e8162acce97dc Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 5 Aug 2011 16:18:09 +0200 Subject: [PATCH] [multiple changes] 2011-08-05 Javier Miranda * exp_disp.adb (Set_All_DT_Position): Cleanup code and improve support for renamings of predefined primitives. (In_Predef_Prims_DT): New subprogram. 2011-08-05 Ed Schonberg * sem_util.adb, sem_util.ads (Check_Implicit_Dereference): If a possible interpretation of name is a reference type, add an interpretation that is the designated type of the reference discriminant of that type. * sem_res.adb (resolve): If the interpretation imposed by context is an implicit dereference, rewrite the node as the deference of the reference discriminant. * sem_ch3.adb (Analyze_Subtype_Declaration, Build_Derived_Record_Type, Build_Discriminated_Subtype): Inherit Has_Implicit_Dereference from parent type or base type. * sem_ch4.adb (Process_Indexed_Component, Process_Overloaded_Indexed_Component, Indicate_Name_And_Type, Analyze_Overloaded_Selected_Component, Analyze_Selected_Component): Check for implicit dereference. (List_Operand_Interps): Indicate when an implicit dereference is ambiguous. * sem_ch8.adb (Find_Direct_Name): Check for implicit dereference. 2011-08-05 Thomas Quinot * scos.ads: Update documentation of SCO table. Pragma statements can now be marked as disabled (using 'p' instead of 'P' as the statement kind). * par_sco.ads, par_sco.adb: Implement the above change. (Process_Decisions_Defer): Generate a P decision for the first parameter of a dyadic pragma Debug. * sem_prag.adb (Analyze_Pragma, case Debug): Mark pragma as enabled if necessary. * put_scos.adb: Code simplification based on above change. From-SVN: r177442 --- gcc/ada/ChangeLog | 37 ++++++++ gcc/ada/exp_disp.adb | 72 +++++++++++++--- gcc/ada/get_scos.adb | 12 +-- gcc/ada/par_sco.adb | 195 +++++++++++++++++++++++++------------------ gcc/ada/par_sco.ads | 6 +- gcc/ada/put_scos.adb | 12 +-- gcc/ada/scos.ads | 30 +++---- gcc/ada/sem_ch3.adb | 8 ++ gcc/ada/sem_ch4.adb | 35 +++++++- gcc/ada/sem_ch8.adb | 1 + gcc/ada/sem_prag.adb | 6 +- gcc/ada/sem_res.adb | 49 +++++++++++ gcc/ada/sem_util.adb | 37 ++++++++ gcc/ada/sem_util.ads | 5 ++ 14 files changed, 371 insertions(+), 134 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 69805dc4f28..13fdfccabd3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,40 @@ +2011-08-05 Javier Miranda + + * exp_disp.adb (Set_All_DT_Position): Cleanup code and improve support + for renamings of predefined primitives. + (In_Predef_Prims_DT): New subprogram. + +2011-08-05 Ed Schonberg + + * sem_util.adb, sem_util.ads (Check_Implicit_Dereference): If a + possible interpretation of name is a reference type, add an + interpretation that is the designated type of the reference + discriminant of that type. + * sem_res.adb (resolve): If the interpretation imposed by context is an + implicit dereference, rewrite the node as the deference of the + reference discriminant. + * sem_ch3.adb (Analyze_Subtype_Declaration, Build_Derived_Record_Type, + Build_Discriminated_Subtype): Inherit Has_Implicit_Dereference from + parent type or base type. + * sem_ch4.adb (Process_Indexed_Component, + Process_Overloaded_Indexed_Component, Indicate_Name_And_Type, + Analyze_Overloaded_Selected_Component, Analyze_Selected_Component): + Check for implicit dereference. + (List_Operand_Interps): Indicate when an implicit dereference is + ambiguous. + * sem_ch8.adb (Find_Direct_Name): Check for implicit dereference. + +2011-08-05 Thomas Quinot + + * scos.ads: Update documentation of SCO table. Pragma statements can now + be marked as disabled (using 'p' instead of 'P' as the statement kind). + * par_sco.ads, par_sco.adb: Implement the above change. + (Process_Decisions_Defer): Generate a P decision for the first parameter + of a dyadic pragma Debug. + * sem_prag.adb (Analyze_Pragma, case Debug): Mark pragma as enabled if + necessary. + * put_scos.adb: Code simplification based on above change. + 2011-08-05 Robert Dewar * sem_ch3.adb, gnatcmd.adb, switch-c.adb, exp_attr.adb, make.adb, diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index a577a2512ac..10c0d799e7e 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -7722,11 +7722,59 @@ package body Exp_Disp is procedure Set_All_DT_Position (Typ : Entity_Id) is + function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean; + -- Returns True if Prim is located in the dispatch table of + -- predefined primitives + procedure Validate_Position (Prim : Entity_Id); -- Check that the position assigned to Prim is completely safe -- (it has not been assigned to a previously defined primitive -- operation of Typ) + ------------------------ + -- In_Predef_Prims_DT -- + ------------------------ + + function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is + E : Entity_Id; + + begin + -- Predefined primitives + + if Is_Predefined_Dispatching_Operation (Prim) then + return True; + + -- Renamings of predefined primitives + + elsif Present (Alias (Prim)) + and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim)) + then + if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then + return True; + + -- User-defined renamings of predefined equality have their own + -- slot in the primary dispatch table + + else + E := Prim; + while Present (Alias (E)) loop + if Comes_From_Source (E) then + return False; + end if; + + E := Alias (E); + end loop; + + return not Comes_From_Source (E); + end if; + + -- User-defined primitives + + else + return False; + end if; + end In_Predef_Prims_DT; + ----------------------- -- Validate_Position -- ----------------------- @@ -7850,10 +7898,7 @@ package body Exp_Disp is -- Predefined primitives have a separate dispatch table - if not (Is_Predefined_Dispatching_Operation (Prim) - or else - Is_Predefined_Dispatching_Alias (Prim)) - then + if not In_Predef_Prims_DT (Prim) then Count_Prim := Count_Prim + 1; end if; @@ -7978,12 +8023,14 @@ package body Exp_Disp is -- Predefined primitives have a separate table and all its -- entries are at predefined fixed positions. - if Is_Predefined_Dispatching_Operation (Prim) then - Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); + if In_Predef_Prims_DT (Prim) then + if Is_Predefined_Dispatching_Operation (Prim) then + Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); - elsif Is_Predefined_Dispatching_Alias (Prim) then - Set_DT_Position (Prim, - Default_Prim_Op_Position (Ultimate_Alias (Prim))); + else pragma Assert (Present (Alias (Prim))); + Set_DT_Position (Prim, + Default_Prim_Op_Position (Ultimate_Alias (Prim))); + end if; -- Overriding primitives of ancestor abstract interfaces @@ -8124,8 +8171,7 @@ package body Exp_Disp is -- Calculate real size of the dispatch table - if not (Is_Predefined_Dispatching_Operation (Prim) - or else Is_Predefined_Dispatching_Alias (Prim)) + if not In_Predef_Prims_DT (Prim) and then UI_To_Int (DT_Position (Prim)) > DT_Length then DT_Length := UI_To_Int (DT_Position (Prim)); @@ -8134,8 +8180,8 @@ package body Exp_Disp is -- Ensure that the assigned position to non-predefined -- dispatching operations in the dispatch table is correct. - if not (Is_Predefined_Dispatching_Operation (Prim) - or else Is_Predefined_Dispatching_Alias (Prim)) + if not Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Predefined_Dispatching_Alias (Prim) then Validate_Position (Prim); end if; diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index 7ee46b300b0..e9c17bd07aa 100644 --- a/gcc/ada/get_scos.adb +++ b/gcc/ada/get_scos.adb @@ -315,7 +315,6 @@ begin declare Loc : Source_Location; - C2v : Character; begin -- Acquire location information @@ -326,18 +325,9 @@ begin Get_Source_Location (Loc); end if; - -- C2 is a space except for pragmas where it is 'e' since - -- clearly the pragma is enabled if it was written out. - - if C = 'P' then - C2v := 'e'; - else - C2v := ' '; - end if; - Add_SCO (C1 => Dtyp, - C2 => C2v, + C2 => ' ', From => Loc, To => No_Source_Location, Last => False); diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 2feec9c4471..8f76dd25039 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -69,9 +69,9 @@ package body Par_SCO is -- We need to be able to get to conditions quickly for handling the calls -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to - -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the - -- conditions and pragmas in the table by their starting sloc, and use this - -- hash table to map from these starting sloc values to SCO_Table indexes. + -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify + -- the conditions and pragmas in the table by their starting sloc, and use + -- this hash table to map from these sloc values to SCO_Table indexes. type Header_Num is new Integer range 0 .. 996; -- Type for hash table headers @@ -101,7 +101,10 @@ package body Par_SCO is -- excluding OR and AND) and returns True if so, False otherwise, it does -- no other processing. - procedure Process_Decisions (N : Node_Id; T : Character); + procedure Process_Decisions + (N : Node_Id; + T : Character; + Pragma_Sloc : Source_Ptr); -- If N is Empty, has no effect. Otherwise scans the tree for the node N, -- to output any decisions it contains. T is one of IEGPWX (for context of -- expression: if/exit when/entry guard/pragma/while/expression). If T is @@ -109,7 +112,10 @@ package body Par_SCO is -- decision is always present (at the very least a simple decision is -- present at the top level). - procedure Process_Decisions (L : List_Id; T : Character); + procedure Process_Decisions + (L : List_Id; + T : Character; + Pragma_Sloc : Source_Ptr); -- Calls above procedure for each element of the list L procedure Set_Table_Entry @@ -316,13 +322,17 @@ package body Par_SCO is -- Version taking a list - procedure Process_Decisions (L : List_Id; T : Character) is + procedure Process_Decisions + (L : List_Id; + T : Character; + Pragma_Sloc : Source_Ptr) + is N : Node_Id; begin if L /= No_List then N := First (L); while Present (N) loop - Process_Decisions (N, T); + Process_Decisions (N, T, Pragma_Sloc); Next (N); end loop; end if; @@ -330,11 +340,14 @@ package body Par_SCO is -- Version taking a node - Pragma_Sloc : Source_Ptr := No_Location; - -- While processing decisions within a pragma Assert/Debug/PPC, this is set - -- to the sloc of the pragma. + Current_Pragma_Sloc : Source_Ptr := No_Location; + -- While processing a pragma, this is set to the sloc of the N_Pragma node - procedure Process_Decisions (N : Node_Id; T : Character) is + procedure Process_Decisions + (N : Node_Id; + T : Character; + Pragma_Sloc : Source_Ptr) + is Mark : Nat; -- This is used to mark the location of a decision sequence in the SCO -- table. We use it for backing out a simple decision in an expression @@ -466,14 +479,6 @@ package body Par_SCO is Loc := Sloc (Parent (Parent (N))); - if T = 'P' then - - -- Record sloc of pragma (pragmas don't nest) - - pragma Assert (Pragma_Sloc = No_Location); - Pragma_Sloc := Loc; - end if; - when 'X' => -- For an expression, no Sloc @@ -493,17 +498,6 @@ package body Par_SCO is To => No_Location, Last => False, Pragma_Sloc => Pragma_Sloc); - - if T = 'P' then - - -- For pragmas we also must make an entry in the hash table for - -- later access by Set_SCO_Pragma_Enabled. We set the pragma as - -- disabled now, the call will change C2 to 'e' to enable the - -- pragma header entry. - - SCO_Table.Table (SCO_Table.Last).C2 := 'd'; - Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last); - end if; end Output_Header; ------------------------------ @@ -521,7 +515,7 @@ package body Par_SCO is Process_Decision_Operand (Right_Opnd (N)); else - Process_Decisions (N, 'X'); + Process_Decisions (N, 'X', Pragma_Sloc); end if; end Process_Decision_Operand; @@ -595,9 +589,9 @@ package body Par_SCO is Thnx : constant Node_Id := Next (Cond); Elsx : constant Node_Id := Next (Thnx); begin - Process_Decisions (Cond, 'I'); - Process_Decisions (Thnx, 'X'); - Process_Decisions (Elsx, 'X'); + Process_Decisions (Cond, 'I', Pragma_Sloc); + Process_Decisions (Thnx, 'X', Pragma_Sloc); + Process_Decisions (Elsx, 'X', Pragma_Sloc); return Skip; end; @@ -635,12 +629,6 @@ package body Par_SCO is end if; Traverse (N); - - -- Reset Pragma_Sloc after full subtree traversal - - if T = 'P' then - Pragma_Sloc := No_Location; - end if; end Process_Decisions; ----------- @@ -771,8 +759,12 @@ package body Par_SCO is -- disabled. if Index /= 0 then - pragma Assert (SCO_Table.Table (Index).C1 = 'P'); - return SCO_Table.Table (Index).C2 = 'd'; + declare + T : SCO_Table_Entry renames SCO_Table.Table (Index); + begin + pragma Assert (T.C1 = 'S' or else T.C1 = 's'); + return T.C2 = 'p'; + end; else return False; @@ -899,8 +891,17 @@ package body Par_SCO is -- The test here for zero is to deal with possible previous errors if Index /= 0 then - pragma Assert (SCO_Table.Table (Index).C1 = 'P'); - SCO_Table.Table (Index).C2 := 'e'; + declare + T : SCO_Table_Entry renames SCO_Table.Table (Index); + begin + -- Called multiple times for the same sloc (need to allow for + -- C2 = 'P') ??? + + pragma Assert ((T.C1 = 'S' or else T.C1 = 's') + and then + (T.C2 = 'p' or else T.C2 = 'P')); + T.C2 := 'P'; + end; end if; end Set_SCO_Pragma_Enabled; @@ -987,12 +988,14 @@ package body Par_SCO is Nod : Node_Id; Lst : List_Id; Typ : Character; + Plo : Source_Ptr; end record; -- Used to store a single entry in the following table. Nod is the node to -- be searched for decisions for the case of Process_Decisions_Defer with a -- node argument (with Lst set to No_List. Lst is the list to be searched -- for decisions for the case of Process_Decisions_Defer with a List - -- argument (in which case Nod is set to Empty). + -- argument (in which case Nod is set to Empty). Plo is the sloc of the + -- enclosing pragma, if any. package SD is new Table.Table ( Table_Component_Type => SD_Entry, @@ -1077,11 +1080,15 @@ package body Par_SCO is SCE : SC_Entry renames SC.Table (J); Pragma_Sloc : Source_Ptr := No_Location; begin - -- For the statement SCO for a pragma, set Pragma_Sloc so that - -- the SCO can be omitted if the pragma is disabled. + -- For the statement SCO for a pragma controlled by + -- Set_SCO_Pragma_Enable, set Pragma_Sloc so that the SCO (and + -- those of any nested decision) is emitted only if the pragma + -- is enabled. - if SCE.Typ = 'P' then + if SCE.Typ = 'p' then Pragma_Sloc := SCE.From; + Condition_Pragma_Hash_Table.Set + (Pragma_Sloc, SCO_Table.Last + 1); end if; Set_Table_Entry @@ -1105,9 +1112,9 @@ package body Par_SCO is SDE : SD_Entry renames SD.Table (J); begin if Present (SDE.Nod) then - Process_Decisions (SDE.Nod, SDE.Typ); + Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo); else - Process_Decisions (SDE.Lst, SDE.Typ); + Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo); end if; end; end loop; @@ -1148,12 +1155,12 @@ package body Par_SCO is procedure Process_Decisions_Defer (N : Node_Id; T : Character) is begin - SD.Append ((N, No_List, T)); + SD.Append ((N, No_List, T, Current_Pragma_Sloc)); end Process_Decisions_Defer; procedure Process_Decisions_Defer (L : List_Id; T : Character) is begin - SD.Append ((Empty, L, T)); + SD.Append ((Empty, L, T, Current_Pragma_Sloc)); end Process_Decisions_Defer; -- Start of processing for Traverse_Declarations_Or_Statements @@ -1391,42 +1398,70 @@ package body Par_SCO is -- Pragma when N_Pragma => - Extend_Statement_Sequence (N, 'P'); + + -- Record sloc of pragma (pragmas don't nest) + + pragma Assert (Current_Pragma_Sloc = No_Location); + Current_Pragma_Sloc := Sloc (N); -- Processing depends on the kind of pragma - case Pragma_Name (N) is - when Name_Assert | - Name_Check | - Name_Precondition | - Name_Postcondition => - - -- For Assert/Check/Precondition/Postcondition, we - -- must generate a P entry for the decision. Note that - -- this is done unconditionally at this stage. Output - -- for disabled pragmas is suppressed later on, when - -- we output the decision line in Put_SCOs. - - declare - Nam : constant Name_Id := - Chars (Pragma_Identifier (N)); - Arg : Node_Id := - First (Pragma_Argument_Associations (N)); - - begin + declare + Nam : constant Name_Id := Pragma_Name (N); + Arg : Node_Id := First (Pragma_Argument_Associations (N)); + Typ : Character; + + begin + case Nam is + when Name_Assert | + Name_Check | + Name_Precondition | + Name_Postcondition => + + -- For Assert/Check/Precondition/Postcondition, we + -- must generate a P entry for the decision. Note + -- that this is done unconditionally at this stage. + -- Output for disabled pragmas is suppressed later + -- on, when we output the decision line in + -- Put_SCOs, depending on marker sets by + -- Set_SCO_Pragma_Disabled. + if Nam = Name_Check then Next (Arg); end if; Process_Decisions_Defer (Expression (Arg), 'P'); - end; + Typ := 'p'; - -- For all other pragmas, we generate decision entries - -- for any embedded expressions. + when Name_Debug => + if Present (Arg) and then Present (Next (Arg)) then - when others => - Process_Decisions_Defer (N, 'X'); - end case; + -- Case of a dyadic pragma Debug: first argument + -- is a P decision, any nested decision in the + -- second argument is an X decision. + + Process_Decisions_Defer (Expression (Arg), 'P'); + Next (Arg); + end if; + + Process_Decisions_Defer (Expression (Arg), 'X'); + Typ := 'p'; + + -- For all other pragmas, we generate decision entries + -- for any embedded expressions, and the pragma is + -- never disabled. + + when others => + Process_Decisions_Defer (N, 'X'); + Typ := 'P'; + end case; + + -- Add statement SCO + + Extend_Statement_Sequence (N, Typ); + + Current_Pragma_Sloc := No_Location; + end; -- Object declaration. Ignored if Prev_Ids is set, since the -- parser generates multiple instances of the whole declaration @@ -1512,7 +1547,7 @@ package body Par_SCO is -- Now output any embedded decisions - Process_Decisions (N, 'X'); + Process_Decisions (N, 'X', No_Location); end Traverse_Generic_Instantiation; ------------------------------------------ @@ -1521,7 +1556,7 @@ package body Par_SCO is procedure Traverse_Generic_Package_Declaration (N : Node_Id) is begin - Process_Decisions (Generic_Formal_Declarations (N), 'X'); + Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location); Traverse_Package_Declaration (N); end Traverse_Generic_Package_Declaration; diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads index 170406dd2c7..5bcad0c30b5 100644 --- a/gcc/ada/par_sco.ads +++ b/gcc/ada/par_sco.ads @@ -50,9 +50,9 @@ package Par_SCO is -- original tree associated with Cond. procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr); - -- This procedure is called from Sem_Prag when a pragma is enabled (i.e. - -- when the Pragma_Enabled flag is set). Loc is the Sloc of the N_Pragma - -- node. This is used to enable the corresponding SCO table entry. Note + -- This procedure is called from Sem_Prag when a pragma is disabled (i.e. + -- when the Pragma_Enabled flag is unset). Loc is the Sloc of the N_Pragma + -- node. This is used to disable the corresponding SCO table entry. Note -- that we use the Sloc as the key here, since in the generic case, the -- analysis is on a copy of the node, which is different from the node -- seen by Par_SCO in the parse tree (but the Sloc values are the same). diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index a1ee86ebf4f..65dfbc80046 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -107,9 +107,8 @@ begin Ctr := 0; Continuation := False; loop - if SCO_Table.Table (Start).C2 = 'P' - and then SCO_Pragma_Disabled - (SCO_Table.Table (Start).Pragma_Sloc) + if SCO_Pragma_Disabled + (SCO_Table.Table (Start).Pragma_Sloc) then goto Next_Statement; end if; @@ -160,13 +159,10 @@ begin when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' => Start := Start + 1; - -- For disabled pragma, or nested decision nested, skip + -- For disabled pragma, or nested decision therein, skip -- decision output. - if (T.C1 = 'P' and then T.C2 = 'd') - or else - SCO_Pragma_Disabled (T.Pragma_Sloc) - then + if SCO_Pragma_Disabled (T.Pragma_Sloc) then while not SCO_Table.Table (Start).Last loop Start := Start + 1; end loop; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 8799fbcc2db..bdf5610c59e 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -152,6 +152,7 @@ package SCOs is -- E EXIT statement -- F FOR loop statement (from FOR through end of iteration scheme) -- I IF statement (from IF through end of condition) + -- p disabled PRAGMA -- P PRAGMA -- R extended RETURN statement -- W WHILE loop statement (from WHILE through end of condition) @@ -194,12 +195,12 @@ package SCOs is -- Decisions are either simple or complex. A simple decision is a top -- level boolean expression that has only one condition and that occurs -- in the context of a control structure in the source program, including - -- WHILE, IF, EXIT WHEN, or in an Assert, Check, Pre_Condition or - -- Post_Condition pragma. For pragmas, decision SCOs are generated only - -- if the corresponding pragma is enabled. Note that a top level boolean - -- expression with only one condition that occurs in any other context, - -- for example as right hand side of an assignment, is not considered to - -- be a (simple) decision. + -- WHILE, IF, EXIT WHEN, or immediately within an Assert, Check, + -- Pre_Condition or Post_Condition pragma, or as the first argument of a + -- dyadic pragma Debug. Note that a top level boolean expression with + -- only one condition that occurs in any other context, for example as + -- right hand side of an assignment, is not considered to be a (simple) + -- decision. -- A complex decision is a top level boolean expression that has more -- than one condition. A complex decision may occur in any boolean @@ -336,6 +337,10 @@ package SCOs is -- entries appear in one logical statement sequence, continuation lines -- are marked by Cc and appear immediately after the CC line. + -- Disabled pragmas + + -- No SCO is generated for disabled pragmas. + --------------------------------------------------------------------- -- Internal table used to store Source Coverage Obligations (SCOs) -- --------------------------------------------------------------------- @@ -392,7 +397,7 @@ package SCOs is -- Decision (PRAGMA) -- C1 = 'P' - -- C2 = 'e'/'d' for enabled/disabled + -- C2 = ' ' -- From = PRAGMA token -- To = No_Source_Location -- Last = unused @@ -400,14 +405,11 @@ package SCOs is -- Note: when the parse tree is first scanned, we unconditionally build -- a pragma decision entry for any decision in a pragma (here as always -- in SCO contexts, the only pragmas with decisions are Assert, Check, - -- Precondition and Postcondition), and we mark the pragma as disabled. - -- - -- During analysis, if the pragma is enabled, Set_SCO_Pragma_Enabled to - -- mark the SCO decision table entry as enabled (C2 set to 'e'). Then - -- in Put_SCOs, we only output the decision for a pragma if C2 is 'e'. + -- dyadic Debug, Precondition and Postcondition). -- - -- When we read SCOs from an ALI file (in Get_SCOs), we always set C2 - -- to 'e', since clearly the pragma is enabled if it was written out. + -- During analysis, if the pragma is enabled, Set_SCO_Pragma_Enabled + -- marks the statement SCO table entry as enaabled (C1 changed from 'p' + -- to 'P') to cause the entry to be emitted in Put_SCOs. -- Decision (Expression) -- C1 = 'X' diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 89583ddf147..c0187d7a2dc 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4215,6 +4215,8 @@ package body Sem_Ch3 is Set_Has_Discriminants (Id, Has_Discriminants (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Limited_Record (Id, Is_Limited_Record (T)); + Set_Has_Implicit_Dereference + (Id, Has_Implicit_Dereference (T)); Set_Has_Unknown_Discriminants (Id, Has_Unknown_Discriminants (T)); @@ -4248,6 +4250,8 @@ package body Sem_Ch3 is Set_Last_Entity (Id, Last_Entity (T)); Set_Private_Dependents (Id, New_Elmt_List); Set_Is_Limited_Record (Id, Is_Limited_Record (T)); + Set_Has_Implicit_Dereference + (Id, Has_Implicit_Dereference (T)); Set_Has_Unknown_Discriminants (Id, Has_Unknown_Discriminants (T)); Set_Known_To_Have_Preelab_Init @@ -7875,6 +7879,8 @@ package body Sem_Ch3 is Set_Stored_Constraint (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs)); Replace_Components (Derived_Type, New_Decl); + Set_Has_Implicit_Dereference + (Derived_Type, Has_Implicit_Dereference (Parent_Type)); end if; -- Insert the new derived type declaration @@ -8586,6 +8592,8 @@ package body Sem_Ch3 is Set_First_Entity (Def_Id, First_Entity (T)); Set_Last_Entity (Def_Id, Last_Entity (T)); + Set_Has_Implicit_Dereference + (Def_Id, Has_Implicit_Dereference (T)); -- If the subtype is the completion of a private declaration, there may -- have been representation clauses for the partial view, and they must diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d62f2628058..e2521687627 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -301,7 +301,24 @@ package body Sem_Ch4 is Nam := Opnd; elsif Nkind (Opnd) = N_Function_Call then Nam := Name (Opnd); - else + elsif Ada_Version >= Ada_2012 then + declare + It : Interp; + I : Interp_Index; + + begin + Get_First_Interp (Opnd, I, It); + while Present (It.Nam) loop + if Has_Implicit_Dereference (It.Typ) then + Error_Msg_N + ("can be interpreted as implicit dereference", Opnd); + return; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + return; end if; @@ -2068,6 +2085,7 @@ package body Sem_Ch4 is end loop; Set_Etype (N, Component_Type (Array_Type)); + Check_Implicit_Dereference (N, Etype (N)); if Present (Index) then Error_Msg_N @@ -2164,9 +2182,13 @@ package body Sem_Ch4 is end loop; if Found and then No (Index) and then No (Exp) then - Add_One_Interp (N, - Etype (Component_Type (Typ)), - Etype (Component_Type (Typ))); + declare + CT : constant Entity_Id := + Base_Type (Component_Type (Typ)); + begin + Add_One_Interp (N, CT, CT); + Check_Implicit_Dereference (N, CT); + end; end if; end if; @@ -2644,6 +2666,7 @@ package body Sem_Ch4 is procedure Indicate_Name_And_Type is begin Add_One_Interp (N, Nam, Etype (Nam)); + Check_Implicit_Dereference (N, Etype (Nam)); Success := True; -- If the prefix of the call is a name, indicate the entity @@ -3133,6 +3156,7 @@ package body Sem_Ch4 is Set_Entity (Sel, Comp); Set_Etype (Sel, Etype (Comp)); Add_One_Interp (N, Etype (Comp), Etype (Comp)); + Check_Implicit_Dereference (N, Etype (Comp)); -- This also specifies a candidate to resolve the name. -- Further overloading will be resolved from context. @@ -3740,6 +3764,7 @@ package body Sem_Ch4 is New_Occurrence_Of (Comp, Sloc (N))); Set_Original_Discriminant (Selector_Name (N), Comp); Set_Etype (N, Etype (Comp)); + Check_Implicit_Dereference (N, Etype (Comp)); if Is_Access_Type (Etype (Name)) then Insert_Explicit_Dereference (Name); @@ -3876,6 +3901,7 @@ package body Sem_Ch4 is Set_Etype (N, Etype (Comp)); end if; + Check_Implicit_Dereference (N, Etype (N)); return; end if; @@ -3941,6 +3967,7 @@ package body Sem_Ch4 is Set_Etype (Sel, Etype (Comp)); Set_Etype (N, Etype (Comp)); + Check_Implicit_Dereference (N, Etype (N)); if Is_Generic_Type (Prefix_Type) or else Is_Generic_Type (Root_Type (Prefix_Type)) diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 9c770019470..75813a4d729 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -4818,6 +4818,7 @@ package body Sem_Ch8 is end if; Set_Entity_Or_Discriminal (N, E); + Check_Implicit_Dereference (N, Etype (E)); end if; end; end Find_Direct_Name; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 32d38d8f8d2..d699fd4eb9a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1794,7 +1794,7 @@ package body Sem_Prag is (Get_Pragma_Arg (Arg2), Standard_String); end if; - -- Record if pragma is enabled + -- Record if pragma is disabled if Check_Enabled (Pname) then Set_SCO_Pragma_Enabled (Loc); @@ -7604,6 +7604,10 @@ package body Sem_Prag is (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active), Loc); + if Debug_Pragmas_Enabled then + Set_SCO_Pragma_Enabled (Loc); + end if; + if Arg_Count = 2 then Cond := Make_And_Then (Loc, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f383809bf3d..362e739b8ca 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1753,6 +1753,15 @@ package body Sem_Res is It1 : Interp; Seen : Entity_Id := Empty; -- prevent junk warning + procedure Build_Explicit_Dereference + (Expr : Node_Id; + Disc : Entity_Id); + -- AI05-139 : names with implicit dereference. If the expression N is a + -- reference type and the context imposes the corresponding designated + -- type, convert N into N.Disc.all. Such expressions are always over- + -- loaded with both interpretations, and the dereference interpretation + -- carries the name of the reference discriminant. + function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean; -- Determine whether a node comes from a predefined library unit or -- Standard. @@ -1768,6 +1777,30 @@ package body Sem_Res is procedure Resolution_Failed; -- Called when attempt at resolving current expression fails + -------------------------------- + -- Build_Explicit_Dereference -- + -------------------------------- + + procedure Build_Explicit_Dereference + (Expr : Node_Id; + Disc : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Expr); + + begin + Set_Is_Overloaded (Expr, False); + Rewrite (Expr, + Make_Explicit_Dereference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Relocate_Node (Expr), + Selector_Name => + New_Occurrence_Of (Disc, Loc)))); + + Set_Etype (Prefix (Expr), Etype (Disc)); + Set_Etype (Expr, Typ); + end Build_Explicit_Dereference; + ------------------------------------ -- Comes_From_Predefined_Lib_Unit -- ------------------------------------- @@ -2279,6 +2312,22 @@ package body Sem_Res is elsif Nkind (N) = N_Conditional_Expression then Set_Etype (N, Expr_Type); + -- AI05-0139-2 : expression is overloaded because + -- type has implicit dereference. If type matches + -- context, no implicit dereference is involved. + + elsif Has_Implicit_Dereference (Expr_Type) then + Set_Etype (N, Expr_Type); + Set_Is_Overloaded (N, False); + exit Interp_Loop; + + elsif Is_Overloaded (N) + and then Present (It.Nam) + and then Ekind (It.Nam) = E_Discriminant + and then Has_Implicit_Dereference (It.Nam) + then + Build_Explicit_Dereference (N, It.Nam); + -- For an explicit dereference, attribute reference, range, -- short-circuit form (which is not an operator node), or call -- with a name that is an explicit dereference, there is diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e910dd33983..1ee06ba0b83 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1104,6 +1104,43 @@ package body Sem_Util is end if; end Cannot_Raise_Constraint_Error; + -------------------------------- + -- Check_Implicit_Dereference -- + -------------------------------- + + procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) + is + Disc : Entity_Id; + Desig : Entity_Id; + + begin + if Ada_Version < Ada_2012 + or else not Has_Implicit_Dereference (Base_Type (Typ)) + then + return; + + elsif not Comes_From_Source (Nam) then + return; + + elsif Is_Entity_Name (Nam) + and then Is_Type (Entity (Nam)) + then + null; + + else + Disc := First_Discriminant (Typ); + while Present (Disc) loop + if Has_Implicit_Dereference (Disc) then + Desig := Designated_Type (Etype (Disc)); + Add_One_Interp (Nam, Disc, Desig); + exit; + end if; + + Next_Discriminant (Disc); + end loop; + end if; + end Check_Implicit_Dereference; + --------------------------------------- -- Check_Later_Vs_Basic_Declarations -- --------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 1b9babda944..f66caf391b1 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -147,6 +147,11 @@ package Sem_Util is -- not necessarily mean that CE could be raised, but a response of True -- means that for sure CE cannot be raised. + procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id); + -- AI05-139-2 : accessors and iterators for containers. This procedure + -- checks whether T is a reference type, and if so it adds an interprettion + -- to Expr whose type is the designated type of the reference_discriminant. + procedure Check_Later_Vs_Basic_Declarations (Decls : List_Id; During_Parsing : Boolean); -- 2.30.2