+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
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;
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;
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);
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));
-- 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
-- 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;
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;
-------------------------------------------------
projects / gcc.git / commitdiff