diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 17 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_strm.adb | 59 | ||||
| -rw-r--r-- | gcc/ada/lib-xref.adb | 6 |
4 files changed, 70 insertions, 18 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b2165b8..1af7b0d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2011-09-02 Bob Duff <duff@adacore.com> + + * lib-xref.adb: (Hash): Avoid use of 'Mod attribute, because old + compilers don't understand it. + +2011-09-02 Gary Dismukes <dismukes@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Pass the + underlying subtype rather than its base type on the call to + Build_Record_Or_Elementary_Input_Function, so that any + constraints on a discriminated subtype will be available for + doing the check required by AI05-0192. + * exp_strm.adb (Build_Record_Or_Elementary_Input_Function): + If the prefix subtype of the 'Input attribute is a constrained + discriminated subtype, then check each constrained discriminant value + against the corresponding value read from the stream. + 2011-09-02 Yannick Moy <moy@adacore.com> * usage.adb, warnsw.adb, sem_ch6.adb, opt.ads: Disable by default diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index c38a384..598520a 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2531,8 +2531,12 @@ package body Exp_Attr is return; end if; + -- Build the type's Input function, passing the subtype rather + -- than its base type, because checks are needed in the case of + -- constrained discriminants (see Ada 2012 AI05-0192). + Build_Record_Or_Elementary_Input_Function - (Loc, Base_Type (U_Type), Decl, Fname); + (Loc, U_Type, Decl, Fname); Insert_Action (N, Decl); if Nkind (Parent (N)) = N_Object_Declaration diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index d7aba24..c88c789 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Einfo; use Einfo; +with Elists; use Elists; with Exp_Util; use Exp_Util; with Namet; use Namet; with Nlists; use Nlists; @@ -1106,14 +1107,16 @@ package body Exp_Strm is Decl : out Node_Id; Fnam : out Entity_Id) is - Cn : Name_Id; - Constr : List_Id; - Decls : List_Id; - Discr : Entity_Id; - J : Pos; - Obj_Decl : Node_Id; - Odef : Node_Id; - Stms : List_Id; + B_Typ : constant Entity_Id := Base_Type (Typ); + Cn : Name_Id; + Constr : List_Id; + Decls : List_Id; + Discr : Entity_Id; + Discr_Elmt : Elmt_Id := No_Elmt; + J : Pos; + Obj_Decl : Node_Id; + Odef : Node_Id; + Stms : List_Id; begin Decls := New_List; @@ -1121,8 +1124,15 @@ package body Exp_Strm is J := 1; - if Has_Discriminants (Typ) then - Discr := First_Discriminant (Typ); + if Has_Discriminants (B_Typ) then + Discr := First_Discriminant (B_Typ); + + -- If the prefix subtype is constrained, then retrieve the first + -- element of its constraint. + + if Is_Constrained (Typ) then + Discr_Elmt := First_Elmt (Discriminant_Constraint (Typ)); + end if; while Present (Discr) loop Cn := New_External_Name ('C', J); @@ -1153,13 +1163,30 @@ package body Exp_Strm is Append_To (Constr, Make_Identifier (Loc, Cn)); + -- If the prefix subtype imposes a discriminant constraint, then + -- check that each discriminant value equals the value read. + + if Present (Discr_Elmt) then + Append_To (Decls, + Make_Raise_Constraint_Error (Loc, + Condition => Make_Op_Ne (Loc, + Left_Opnd => + New_Reference_To + (Defining_Identifier (Decl), Loc), + Right_Opnd => + New_Copy_Tree (Node (Discr_Elmt))), + Reason => CE_Discriminant_Check_Failed)); + + Next_Elmt (Discr_Elmt); + end if; + Next_Discriminant (Discr); J := J + 1; end loop; Odef := Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Subtype_Mark => New_Occurrence_Of (B_Typ, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constr)); @@ -1167,7 +1194,7 @@ package body Exp_Strm is -- If no discriminants, then just use the type with no constraint else - Odef := New_Occurrence_Of (Typ, Loc); + Odef := New_Occurrence_Of (B_Typ, Loc); end if; -- Create an extended return statement encapsulating the result object @@ -1184,7 +1211,7 @@ package body Exp_Strm is -- The object is about to get its value from Read, and if the type is -- null excluding we do not want spurious warnings on an initial null. - if Is_Access_Type (Typ) then + if Is_Access_Type (B_Typ) then Set_No_Initialization (Obj_Decl); end if; @@ -1195,15 +1222,15 @@ package body Exp_Strm is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), + Prefix => New_Occurrence_Of (B_Typ, Loc), Attribute_Name => Name_Read, Expressions => New_List ( Make_Identifier (Loc, Name_S), Make_Identifier (Loc, Name_V))))))); - Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input); + Fnam := Make_Stream_Subprogram_Name (Loc, B_Typ, TSS_Stream_Input); - Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); + Build_Stream_Function (Loc, B_Typ, Decl, Fnam, Decls, Stms); end Build_Record_Or_Elementary_Input_Function; ------------------------------------------------- diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 15edfb6..e8c47d7 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -1057,7 +1057,11 @@ package body Lib.Xref is XE : Xref_Entry renames Xrefs.Table (F); type M is mod 2**32; - H : constant M := M'Mod (XE.Key.Ent) + 2**7 * M'Mod (XE.Key.Loc); + + H : constant M := M (XE.Key.Ent) + 2**7 * M (abs XE.Key.Loc); + -- We can't use M'Mod above, because it prevents bootstrapping with + -- older compilers. Loc can be negative, so we do "abs" before + -- converting. begin return Header_Num (H mod Num_Buckets); end Hash; |