diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 28 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 2 | ||||
| -rw-r--r-- | gcc/ada/impunit.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 96 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 175 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/ug_words | 1 | ||||
| -rw-r--r-- | gcc/ada/vms_data.ads | 8 |
9 files changed, 283 insertions, 60 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1dc9b05..6d8be82 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2013-10-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Validated_Access_Subprogram_Instance): According + to AI05-288, actuals for access_to_subprograms must be subtype + conformant with the generic formal. Previous to AI05-288 + only mode conformance was required, but the AI is a binding + interpretation that applies to previous versions of the language, + +2013-10-17 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Minor text correction. + * ug_words: Add entry for -gnateu /IGNORE_UNRECOGNIZED. + * vms_data.ads: Add /IGNORE_UNRECOGNIZED for -gnateu. + +2013-10-17 Tristan Gingold <gingold@adacore.com> + + * impunit.adb (Non_Imp_File_Names_95): Add g-cppexc. + +2013-10-17 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_prag.adb (Analyze_Constituent): Move the check + concerning option Part_Of to routine Check_Matching_Constituent. + (Check_Matching_Constituent): Verify that an abstract state + that acts as a constituent has the prope Part_Op option in + its aspect/pragma Abstract_State. Account for the case when a + constituent comes from a private child or private sibling. + * sem_util.ads, sem_util.adb (Is_Child_Or_Sibling): New routine. + 2013-10-17 Tristan Gingold <gingold@adacore.com> * g-cppexc.adb, g-cppexc.ads: New files. diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index d9c693c..a82f20b 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -3935,7 +3935,7 @@ TF 33 I 128 128 @item -gnateu @cindex @option{-gnateu} (@command{gcc}) Ignore unrecognized validity, warning, and style switches that -apppear after this switch is given. This may be useful when +appear after this switch is given. This may be useful when compiling sources developed on a later version of the compiler with an earlier version. Of course the earlier version must support this switch. diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index bb62264c..6b6b45f 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -253,6 +253,7 @@ package body Impunit is ("g-cgideb", F), -- GNAT.CGI.Debug ("g-comlin", F), -- GNAT.Command_Line ("g-comver", F), -- GNAT.Compiler_Version + ("g-cppexc", F), -- GNAT.CPP_Exceptions ("g-crc32 ", F), -- GNAT.CRC32 ("g-ctrl_c", F), -- GNAT.Ctrl_C ("g-curexc", F), -- GNAT.Current_Exception diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 4ce3fd6..1572e4f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -10529,23 +10529,13 @@ package body Sem_Ch12 is -- only mode conformance was required. -- This is a binding interpretation that applies to previous versions - -- of the language, but for now we retain the milder check in order - -- to preserve ACATS tests. These will be protested eventually ??? + -- of the language, no need to maintain previous weaker checks. - if Ada_Version < Ada_2012 then - Check_Mode_Conformant - (Designated_Type (Act_T), - Designated_Type (A_Gen_T), - Actual, - Get_Inst => True); - - else - Check_Subtype_Conformant - (Designated_Type (Act_T), - Designated_Type (A_Gen_T), - Actual, - Get_Inst => True); - end if; + Check_Subtype_Conformant + (Designated_Type (Act_T), + Designated_Type (A_Gen_T), + Actual, + Get_Inst => True); if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then if Ekind (A_Gen_T) = E_Access_Subprogram_Type then diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 15b13ff..0830f09 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -21439,51 +21439,74 @@ package body Sem_Prag is Error_Msg_NE ("duplicate use of constituent &", Constit, Constit_Id); return; - end if; - -- The related package has no hidden states, nothing to match. - -- This case arises when the constituents are states coming - -- from a private child. + -- A state can act as a constituent only when it is part of + -- another state. This relation is expressed by option Part_Of + -- of pragma Abstract_State. - if No (Hidden_States) then - return; + elsif Ekind (Constit_Id) = E_Abstract_State then + if not Is_Part_Of (Constit_Id, State_Id) then + Error_Msg_Name_1 := Chars (State_Id); + Error_Msg_NE + ("state & is not a valid constituent of ancestor " + & "state %", Constit, Constit_Id); + return; + + -- The constituent has the proper Part_Of option, but may + -- not appear in the immediate hidden state of the related + -- package. This case arises when the constituent comes from + -- a private child or a private sibling. Recognize these + -- scenarios to avoid generating a bogus error message. + + elsif Is_Child_Or_Sibling + (Pack_1 => Scope (State_Id), + Pack_2 => Scope (Constit_Id), + Private_Child => True) + then + return; + end if; end if; -- Inspect the hidden states of the related package looking for -- a match. - State_Elmt := First_Elmt (Hidden_States); - while Present (State_Elmt) loop + if Present (Hidden_States) then + State_Elmt := First_Elmt (Hidden_States); + while Present (State_Elmt) loop - -- A valid hidden state or variable participates in a - -- refinement. Add the constituent to the list of processed - -- items to aid with the detection of duplicate constituent - -- use. Remove the constituent from Hidden_States to signal - -- that it has already been used. + -- A valid hidden state or variable acts as a constituent - if Node (State_Elmt) = Constit_Id then - Add_Item (Constit_Id, Constituents_Seen); - Remove_Elmt (Hidden_States, State_Elmt); + if Node (State_Elmt) = Constit_Id then - -- Collect the constituent in the list of refinement - -- items. Establish a relation between the refined state - -- and its constituent. + -- Add the constituent to the lis of processed items + -- to aid with the detection of duplicates. Remove the + -- constituent from Hidden_States to signal that it + -- has already been matched. - Append_Elmt - (Constit_Id, Refinement_Constituents (State_Id)); - Set_Refined_State (Constit_Id, State_Id); + Add_Item (Constit_Id, Constituents_Seen); + Remove_Elmt (Hidden_States, State_Elmt); - -- The state has at least one legal constituent, mark the - -- start of the refinement region. The region ends when - -- the body declarations end (see Analyze_Declarations). + -- Collect the constituent in the list of refinement + -- items. Establish a relation between the refined + -- state and its constituent. - Set_Has_Visible_Refinement (State_Id); + Append_Elmt + (Constit_Id, Refinement_Constituents (State_Id)); + Set_Refined_State (Constit_Id, State_Id); - return; - end if; + -- The state has at least one legal constituent, mark + -- the start of the refinement region. The region ends + -- when the body declarations end (see routine + -- Analyze_Declarations). - Next_Elmt (State_Elmt); - end loop; + Set_Has_Visible_Refinement (State_Id); + + return; + end if; + + Next_Elmt (State_Elmt); + end loop; + end if; -- If we get here, we are refining a state that is not hidden -- with respect to the related package. @@ -21548,19 +21571,6 @@ package body Sem_Prag is if Ekind_In (Constit_Id, E_Abstract_State, E_Variable) then Check_Matching_Constituent (Constit_Id); - -- A state can act as a constituent only when it is part - -- of another state. This relation is expressed by option - -- "Part_Of" of pragma Abstract_State. - - if Ekind (Constit_Id) = E_Abstract_State - and then not Is_Part_Of (Constit_Id, State_Id) - then - Error_Msg_Name_1 := Chars (State_Id); - Error_Msg_NE - ("state & is not a valid constituent of ancestor " - & "state %", Constit, Constit_Id); - end if; - else Error_Msg_NE ("constituent & must denote a variable or state", diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 15e6a64..d2d8a41 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8324,6 +8324,181 @@ package body Sem_Util is Is_RTE (Root_Type (Under), RO_WW_Super_String)); end Is_Bounded_String; + ------------------------- + -- Is_Child_Or_Sibling -- + ------------------------- + + function Is_Child_Or_Sibling + (Pack_1 : Entity_Id; + Pack_2 : Entity_Id; + Private_Child : Boolean) return Boolean + is + function Distance_From_Standard (Pack : Entity_Id) return Nat; + -- Given an arbitrary package, return the number of "climbs" necessary + -- to reach scope Standard_Standard. + + procedure Equalize_Depths + (Pack : in out Entity_Id; + Depth : in out Nat; + Depth_To_Reach : Nat); + -- Given an arbitrary package, its depth and a target depth to reach, + -- climb the scope chain until the said depth is reached. The pointer + -- to the package and its depth a modified during the climb. + + function Is_Child (Pack : Entity_Id) return Boolean; + -- Given a package Pack, determine whether it is a child package that + -- satisfies the privacy requirement (if set). + + ---------------------------- + -- Distance_From_Standard -- + ---------------------------- + + function Distance_From_Standard (Pack : Entity_Id) return Nat is + Dist : Nat; + Scop : Entity_Id; + + begin + Dist := 0; + Scop := Pack; + while Present (Scop) and then Scop /= Standard_Standard loop + Dist := Dist + 1; + Scop := Scope (Scop); + end loop; + + return Dist; + end Distance_From_Standard; + + --------------------- + -- Equalize_Depths -- + --------------------- + + procedure Equalize_Depths + (Pack : in out Entity_Id; + Depth : in out Nat; + Depth_To_Reach : Nat) + is + begin + -- The package must be at a greater or equal depth + + if Depth < Depth_To_Reach then + raise Program_Error; + end if; + + -- Climb the scope chain until the desired depth is reached + + while Present (Pack) and then Depth /= Depth_To_Reach loop + Pack := Scope (Pack); + Depth := Depth - 1; + end loop; + end Equalize_Depths; + + -------------- + -- Is_Child -- + -------------- + + function Is_Child (Pack : Entity_Id) return Boolean is + begin + if Is_Child_Unit (Pack) then + if Private_Child then + return Is_Private_Descendant (Pack); + else + return True; + end if; + + -- The package is nested, it cannot act a child or a sibling + + else + return False; + end if; + end Is_Child; + + -- Local variables + + P_1 : Entity_Id := Pack_1; + P_1_Child : Boolean := False; + P_1_Depth : Nat := Distance_From_Standard (P_1); + P_2 : Entity_Id := Pack_2; + P_2_Child : Boolean := False; + P_2_Depth : Nat := Distance_From_Standard (P_2); + + -- Start of processing for Is_Child_Or_Sibling + + begin + pragma Assert + (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); + + -- Both packages denote the same entity, therefore they cannot be + -- children or siblings. + + if P_1 = P_2 then + return False; + + -- One of the packages is at a deeper level than the other. Note that + -- both may still come from differen hierarchies. + + -- (root) P_2 + -- / \ : + -- X P_2 or X + -- : : + -- P_1 P_1 + + elsif P_1_Depth > P_2_Depth then + Equalize_Depths (P_1, P_1_Depth, P_2_Depth); + P_1_Child := True; + + -- (root) P_1 + -- / \ : + -- P_1 X or X + -- : : + -- P_2 P_2 + + elsif P_2_Depth > P_1_Depth then + Equalize_Depths (P_2, P_2_Depth, P_1_Depth); + P_2_Child := True; + end if; + + -- At this stage the package pointers have been elevated to the same + -- depth. If the related entities are the same, then one package is a + -- potential child of the other: + + -- P_1 + -- : + -- X became P_1 P_2 or vica versa + -- : + -- P_2 + + if P_1 = P_2 then + if P_1_Child then + return Is_Child (Pack_1); + else pragma Assert (P_2_Child); + return Is_Child (Pack_2); + end if; + + -- The packages may come from the same package chain or from entirely + -- different hierarcies. To determine this, climb the scope stack until + -- a common root is found. + + -- (root) (root 1) (root 2) + -- / \ | | + -- P_1 P_2 P_1 P_2 + + else + while Present (P_1) and then Present (P_2) loop + + -- The two packages may be siblings + + if P_1 = P_2 then + return Is_Child (Pack_1) and then Is_Child (Pack_2); + end if; + + P_1 := Scope (P_1); + P_2 := Scope (P_2); + end loop; + end if; + + return False; + end Is_Child_Or_Sibling; + ----------------------------- -- Is_Concurrent_Interface -- ----------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index bf9987c..ffaf661 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -945,6 +945,16 @@ package Sem_Util is -- This is the RM definition, a type is a descendent of another type if it -- is the same type or is derived from a descendent of the other type. + function Is_Child_Or_Sibling + (Pack_1 : Entity_Id; + Pack_2 : Entity_Id; + Private_Child : Boolean) return Boolean; + -- Determine the following relations between two arbitrary packages: + -- 1) One package is the parent of a child package + -- 2) Both packages are siblings and share a common parent + -- If flag Private_Child is set, then the child in case 1) or both siblings + -- in case 2) must be private. + function Is_Concurrent_Interface (T : Entity_Id) return Boolean; -- First determine whether type T is an interface and then check whether -- it is of protected, synchronized or task kind. diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index bae43b9..1f73288 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -74,6 +74,7 @@ gcc -c ^ GNAT COMPILE -gnateS ^ /SCO_OUTPUT -gnatet ^ /WRITE_TARGET_DEPENDENT_INFO -gnateT ^ /READ_TARGET_DEPENDENT_INFO +-gnateu ^ /IGNORE_UNRECOGNIZED -gnateV ^ /PARAMETER_VALIDITY_CHECK -gnateY ^ /IGNORE_STYLE_CHECKS_PRAGMAS -gnatE ^ /CHECKS=ELABORATION diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 6fc9ed0..aa22577 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -1802,6 +1802,13 @@ package VMS_Data is -- otherwise ignored. Allows style checks to be fully controlled by -- command line qualifiers. + S_GCC_IgnoreU : aliased constant S := "/IGNORE_UNRECOGNIZED " & + "-gnateu"; + -- /IGNORE_UNRECOGNIZED + -- + -- Causes unrecognized style switches, validity switches, and warning + -- switches to be ignored rather than generating an error message. + S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " & "-gnatdO"; -- /NOIMMEDIATE_ERRORS (D) @@ -3706,6 +3713,7 @@ package VMS_Data is S_GCC_IdentX 'Access, S_GCC_IgnoreR 'Access, S_GCC_IgnoreS 'Access, + S_GCC_IgnoreU 'Access, S_GCC_Immed 'Access, S_GCC_Inline 'Access, S_GCC_InlineX 'Access, |