2005-06-14 Ed Schonberg <schonberg@adacore.com>

	    Javier Miranda  <miranda@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* einfo.ads, einfo.adb (Is_Local_Anonymous_Access): New flag on
	anonymous access types, to indicate that the accessibility level of
	the type is determined by that of the enclosing declaration.
	(Has_Persistent_BSS): New flag
	(Set_Is_Primitive_Wrapper): Upgrade the barrier to allow the usage
	of this attribute with functions.
	(Is_Primitive_Wrapper): Remove the barrier.
	(Has_Specified_Stream_Input, Has_Specified_Stream_Output,
	Has_Specified_Stream_Read, Has_Specified_Stream_Write):
	New subprograms.
	(Set_Has_Specified_Stream_Input, Set_Has_Specified_Stream_Output,
	Set_Has_Specified_Stream_Read, Set_Has_Specified_Stream_Write):
	New subprograms.
	(Is_Pure_Unit_Access_Type): New flag
	(Abstract_Interfaces): Complete the assertion to cover all usages.
	(Set_Is_Interface): Complete the assertion to cover all usages.
	(Is_Primitive_Wrapper): New attribute.
	(Is_Obsolescent): Now applies to all entities (though it is only set
	for subprograms currently)
	New flag:  Has_Constrained_Partial_View, to implemente Ada 2005 AI-363,
	which solves various problems concerning access subtypes.
	(Has_Persistent_BSS): New flag
	(Is_Primitive_Wrapper, Set_Primitive_Wrapper): Code cleanup.
	Remove these subprograms because this attribute is currently
	not used.
	New entity flags:
	Has_Specified_Stream_Input (Flag190)
	Has_Specified_Stream_Output (Flag191)
	Has_Specified_Stream_Read (Flag192)
	Has_Specified_Stream_Write (Flag193)
	Present in all type and subtype entities. Set for a given view if the
	corresponding stream-oriented attribute has been defined by an
	attribute definition clause. When such a clause occurs, a TSS is set
	on the underlying full view; the flags are used to track visibility of
	the attribute definition clause for partial or incomplete views.
	(Is_Pure_Unit_Access_Type): New flag
	Clarify use of Is_Internal.
	(Is_Primitive_Wrapper): New attribute present in primitive subprograms
	internally generated to wrap the invocation of tasks and protected
	types that implement interfaces.
	(Implementation_Base_Type): Documentation correction
	(Is_Obsolescent): Now applies to all entities (though it is only set
	for subprograms currently)
	New flag:  Has_Constrained_Partial_View, to implement Ada 2005 AI-363,
	which solves various problems concerning access subtypes.

	* exp_ch9.adb (Type_Conformant_Parameters): Introduce mode conformance
	for examined parameters. Identify unequal parameter list lengths as
	non-conformant parameters.
	(Overriding_Possible): Do not check for "All" qualifier in declaration
	of controlling access parameter, following prescription of AI-404.
	(Build_Entry_Wrapper_Spec, Build_Entry_Wrapper_Body): New subprograms
	that build the procedure body that wraps an entry invocation
	(Build_Corresponding_Record, Build_Protected_Sub_Specification,
	Expand_N_Protected_Body, Expand_N_Protected_Type_Declaration,
	Expand_N_Task_Body, Expand_N_Task_Type_Declaration): Modified to
	give support to abstract interface types

	* freeze.adb (Freeze_Entity): Issue error message if
	Is_Pure_Unit_Access_Type set, unless we are in Ada 2005 mode and the
	type has no storage pool (Ada 2005) AI-366.
	Also modified to give support to abstract interface types
	(Freeze_Subprogram): Issue an error for a dispatching subprogram with an
	Inline_Always pragma.

	* par-ch9.adb (P_Task_Items): Reserved words "not" or "overriding" may
	now begin an entry declaration.
	(P_Entry_Or_Subprogram_With_Indicator): New procedure in
	P_Protected_Operation_Declaration_Opt. Parse an entry declaration or
	a subprogram declaration preceded by an overriding indicator.
	(P_Protected_Operation_Declaration_Opt): Add case for parsing entry
	declarations or subprogram declarations preceded by reserved words
	"not" or "overriding".
	(P_Entry_Declaration): Update comment. Parse and check overriding
	indicator, set semantic flags of entry declarations.
	(P_Task): New error message in case of private applied
	to a task type declaration.
	(P_Protected): New error message in case of private applied
	to a task type declaration.

	* sem_ch7.adb (Preserve_Full_Attributes): Modified to handle the case
	in which the full view of a type implementing an interface is a
	concurrent type.
	(Has_Overriding_Pragma): Remove obsolete implementation of AI-218.
	Declare_Inherited_Private_Subprograms): If an explicit operation
	overrides an operation that is inherited in the private part, mark the
	explicit one as overriding, to enable overriding indicator checks.
	(Preserve_Full_Attributes): Propagate Is_Unchecked_Union attribute from
	full view to partial view, to simplify handling in back-end.

	* sprint.adb: Print interface lists where needed: derived types,
	protected types, task types.
	output "is null" for null procedures. Part of implementation of

	* sem_cat.adb (Validate_Access_Type_Declaration): Implement AI-366
	relaxation of rules for access types in pure, shared passive partitions.

	* exp_strm.adb (Build_Mutable_Record_Read_Procedure): Reorganize to
	first read discriminants into temporary objects, performing checks on
	the read values, then possibly performing discriminant checks on the
	actual (if it is constrained), and only finally reading the components
	into a constrained temporary object.
	(Build_Elementary_Input_Call): Adjust the specific circuitry for the
	case of reading discriminants of a mutable record type to recognize
	the new form of the code generated by
	Build_Mutable_Record_Read_Procedure.

	* exp_tss.ads, exp_tss.adb (Make_Init_Proc_Name): Reimplement in terms
	of a simple call to Make_TSS_Name.
	(Make_TSS_Name_Local): Add the TSS name as the last thing in the name
	buffer, in order for Is_TSS to work correctly on local TSS names.

	* sem_attr.ads, sem_attr.adb (Resolve_Attribute, case 'Access): Use flag
	Is_Local_Anonymous_Access to check legaliy of attributes in the
	context of  access components and stand-alone access objects.
	(Stream_Attribute_Available): In Ada 95 mode, a stream attribute is
	treated as available for a limited private type if there is an
	attribute_definition_clause that applies to its full view, but not in
	other cases where the attribute is available for the full view
	(specifically, the sole fact that the full view is non-limited does not
	make the attribute available for the partial view).
	(Build_Access_Subprogram_Type): Diagnose attempt to apply 'access to a
	non-overloaded intrinsic subprogram.
	(Check_Stream_Attribute): Reject an attribute reference for an
	unavailable stream attribute even if the prefix is not a limited type
	(case of a 'Input attribute reference for an abstract, non-classwide
	type)
	(Stream_Attribute_Available): New function to determine whether a stream
	attribute is available at a place.
	(Check_Attribute): Use Stream_Attribute_Available instead of just
	testing for TSS presence on the implementation base type.
	(Analyze_Attribute): Modified to give support to task interfaces.
	(Analyze_Access_Attribute): Add error check for use of an Access (or
	Unrestricted_Access) attribute with a subprogram marked as
	Inline_Always.
	(Analyze_Attribute, case Attribute_Address): Add error check for use of
	an Address attribute with a subprogram marked as Inline_Always.
	Update Eval_Attribute to handle new value of Width from AI-395

	* sem_ch13.adb (Analyze_Stream_TSS_Definition): New subprogram.
	(Analyze_Attribute_Definition_Clause, cases Input, Output, Read, Write):
	Factor common code across the stream-oriented attribute circcuits into
	a new subprogram, Analyze_Stream_TSS_Definition. The new uniform
	processing is functionally identical to the previous duplicated one,
	except that an expression that denotes an abstract subprogram will now
	be rejected, as mandated by AI-195 item 5.

	* sem_util.ads, sem_util.adb (Type_Access_Level): Use flag
	Is_Local_Anonymous_Access to apply accessibility checks to access
	components and stand-alone access objects.
	(Has_Discriminant_Dependent_Constraint): Moved to spec for use
	elsewhere.
	(Is_Potentially_Persistent_Type): New function
	(Is_Dependent_Component_Of_Mutable_Object): If the enclosing object is
	a heap-object whose type has a constrained partial view, the object is
	unconstrained and the component may depend on a discriminant, making its
	renaming illegal.

	* sinfo.ads, sinfo.adb
	(Must_Not_Override): Flag applicable to N_Entry_Declaration.
	(Must_Override): Flag applicable to N_Entry_Declaration.
	Indicate that interface_list can appear in single task and single
	protected declarations.
	Replace Is_Overriding and Not_Overriding with Must_Override and
	Must_Not_Override, to better express intent of AI.
	Is_Overriding, Not_Overriding: Ada2005 flags that indicate the presence
	of an overriding indicator in a subprogram or instance.
	Ada 2005 (AI-248) Null_Present can appear in a procedure specification.
	Add the overriding indicator [[not] overriding] construct to the
	following grammar productions:
	 ENTRY_DECLARATION
	 GENERIC_INSTANTIATION
	 SUBPROGRAM_SPECIFICATION

	* par-ch10.adb (P_Compilation_Unit): Subprogram declaration or body
	can start with an overriding indicator.

	* par-ch6.adb (P_Subprogram): Recognize overriding indicator, and set
	flags accordingly on subrogram specifications or instances.

	* sem_ch8.adb:
	(Analyze_Subprogram_Renaming): For a renaming_as_body, verify that the
	overriding_indicator, if present, is consistent with status of spec.
	Improve error message for null-excluding checks on controlling access
	parameters.
	(Check_In_Previous_With_Clause): Protect the frontend against
	previously reported critical errors in the context clauses.
	Save and restore Ada_Version_Explicit, for implementation of AI-362
	(Analyze_Subprogram_Renaming): If the new entity is a dispatching
	operation verify that controlling formals of the renamed entity that
	are access parameters are explicitly non-null.
	(Find_Expanded_Name): Improve error message when prefix is an illegal
	reference to a private child unit.

	* exp_imgv.adb, s-imgwch.ads, s-imgwch.adb, s-valwch.adb,
	s-valwch.ads, s-widwch.adb, s-widwch.ads, s-wwdcha.adb, s-wwdwch.adb:
	Rewrite to correspond to new wide character names in AI-395

        * par-ch12.adb (P_Formal_Subprogram_Declaration): Recognize null
        default procedures.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@101029 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 90 insertions, 48 deletions

diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb
index c5875348494..905fe7e42a4 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.adb
@@ -592,12 +592,12 @@ package body Exp_Strm is
 
       --  Call the function, and do an unchecked conversion of the result
       --  to the actual type of the prefix. If the target is a discriminant,
-      --  set target type to force a constraint check (13.13.2 (35)).
+      --  and we are in the body of the default implementation of a 'Read
+      --  attribute, set target type to force a constraint check (13.13.2(35)).
 
-      if Nkind (Targ) = N_Selected_Component
-        and then Present (Entity (Selector_Name (Targ)))
-        and then Ekind (Entity (Selector_Name (Targ)))
-          = E_Discriminant
+      if Nkind (Targ) = N_Identifier
+        and then Is_Internal_Name (Chars (Targ))
+        and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read)
       then
          Res :=
            Unchecked_Convert_To (Base_Type (P_Type),
@@ -786,23 +786,41 @@ package body Exp_Strm is
       Decl : out Node_Id;
       Pnam : out Entity_Id)
    is
-      Stms : List_Id;
+      Out_Formal : Node_Id;
+      --  Expression denoting the out formal parameter
+
+      Dcls : constant List_Id := New_List;
+      --  Declarations for the 'Read body
+
+      Stms : List_Id := New_List;
       --  Statements for the 'Read body
 
+      Disc : Entity_Id;
+      --  Entity of the discriminant being processed
+
+      Tmp_For_Disc : Entity_Id;
+      --  Temporary object used to read the value of Disc
+
+      Tmps_For_Discs : constant List_Id := New_List;
+      --  List of object declarations for temporaries holding the read values
+      --  for the discriminants.
+
+      Cstr : constant List_Id := New_List;
+      --  List of constraints to be applied on temporary record
+
+      Discriminant_Checks : constant List_Id := New_List;
+      --  List of discriminant checks to be performed if the actual object
+      --  is constrained.
+
       Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V);
-      --  Temporary, must hide formal (assignments to components of the
+      --  Temporary record must hide formal (assignments to components of the
       --  record are always generated with V as the identifier for the record).
 
-      Cstr : List_Id;
-      --  List of constraints to be applied on temporary
-
-      Disc     : Entity_Id;
-      Disc_Ref : Node_Id;
-      Block    : Node_Id;
+      Constrained_Stms : List_Id := New_List;
+      --  Statements within the block where we have the constrained temporary
 
    begin
-      Stms := New_List;
-      Cstr := New_List;
+
       Disc := First_Discriminant (Typ);
 
       --  A mutable type cannot be a tagged type, so we generate a new name
@@ -812,33 +830,50 @@ package body Exp_Strm is
         Make_Defining_Identifier (Loc,
           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
 
+      Out_Formal :=
+        Make_Selected_Component (Loc,
+          Prefix => New_Occurrence_Of (Pnam, Loc),
+          Selector_Name => Make_Identifier (Loc, Name_V));
+
       --  Generate Reads for the discriminants of the type. The discriminants
       --  need to be read before the rest of the components, so that
-      --  variants are initialized correctly.
+      --  variants are initialized correctly. The discriminants must be read
+      --  into temporary variables so an incomplete Read (interrupted by an
+      --  exception, for example) does not alter the passed object.
 
       while Present (Disc) loop
-         Disc_Ref :=
-           Make_Selected_Component (Loc,
-             Prefix        => Make_Selected_Component (Loc,
-                                Prefix => New_Occurrence_Of (Pnam, Loc),
-                                Selector_Name =>
-                                  Make_Identifier (Loc, Name_V)),
-             Selector_Name => New_Occurrence_Of (Disc, Loc));
+         Tmp_For_Disc := Make_Defining_Identifier (Loc,
+                           New_External_Name (Chars (Disc), "D"));
 
-         Set_Assignment_OK (Disc_Ref);
+         Append_To (Tmps_For_Discs,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Tmp_For_Disc,
+             Object_Definition   => New_Occurrence_Of (Etype (Disc), Loc)));
+         Set_No_Initialization (Last (Tmps_For_Discs));
 
          Append_To (Stms,
            Make_Attribute_Reference (Loc,
              Prefix => New_Occurrence_Of (Etype (Disc), Loc),
-               Attribute_Name => Name_Read,
-               Expressions => New_List (
-                 Make_Identifier (Loc, Name_S),
-                 Disc_Ref)));
+             Attribute_Name => Name_Read,
+             Expressions => New_List (
+               Make_Identifier (Loc, Name_S),
+               New_Occurrence_Of (Tmp_For_Disc, Loc))));
 
          Append_To (Cstr,
            Make_Discriminant_Association (Loc,
              Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)),
-             Expression     => New_Copy_Tree (Disc_Ref)));
+             Expression     => New_Occurrence_Of (Tmp_For_Disc, Loc)));
+
+         Append_To (Discriminant_Checks,
+           Make_Raise_Constraint_Error (Loc,
+             Condition =>
+               Make_Op_Ne (Loc,
+                 Left_Opnd  => New_Occurrence_Of (Tmp_For_Disc, Loc),
+                 Right_Opnd =>
+                   Make_Selected_Component (Loc,
+                     Prefix => New_Copy_Tree (Out_Formal),
+                     Selector_Name => New_Occurrence_Of (Disc, Loc))),
+             Reason => CE_Discriminant_Check_Failed));
          Next_Discriminant (Disc);
       end loop;
 
@@ -854,27 +889,33 @@ package body Exp_Strm is
       --  prior to being initialized. To this effect, we wrap the component
       --  assignments in a block where V is a constrained temporary.
 
-      Block :=
+      Append_To (Dcls,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Tmp,
+          Object_Definition   =>
+            Make_Subtype_Indication (Loc,
+              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+              Constraint =>
+                Make_Index_Or_Discriminant_Constraint (Loc,
+                  Constraints => Cstr))));
+
+      Constrained_Stms := Statements (Handled_Statement_Sequence (Decl));
+      Append_To (Stms,
         Make_Block_Statement (Loc,
-          Declarations => New_List (
-           Make_Object_Declaration (Loc,
-             Defining_Identifier => Tmp,
-             Object_Definition   =>
-               Make_Subtype_Indication (Loc,
-                 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
-                 Constraint =>
-                   Make_Index_Or_Discriminant_Constraint (Loc,
-                     Constraints => Cstr)))),
-          Handled_Statement_Sequence =>
-            Handled_Statement_Sequence (Decl));
-
-      Append_To (Stms, Block);
-
-      Append_To (Statements (Handled_Statement_Sequence (Block)),
+          Declarations => Dcls,
+          Handled_Statement_Sequence => Parent (Constrained_Stms)));
+
+      Append_To (Constrained_Stms,
+        Make_Implicit_If_Statement (Pnam,
+          Condition =>
+            Make_Attribute_Reference (Loc,
+              Prefix => New_Copy_Tree (Out_Formal),
+              Attribute_Name => Name_Constrained),
+          Then_Statements => Discriminant_Checks));
+
+      Append_To (Constrained_Stms,
         Make_Assignment_Statement (Loc,
-          Name => Make_Selected_Component (Loc,
-                    Prefix => New_Occurrence_Of (Pnam, Loc),
-                    Selector_Name => Make_Identifier (Loc, Name_V)),
+          Name => Out_Formal,
           Expression => Make_Identifier (Loc, Name_V)));
 
       if Is_Unchecked_Union (Typ) then
@@ -890,6 +931,7 @@ package body Exp_Strm is
                Reason => PE_Unchecked_Union_Restriction));
       end if;
 
+      Set_Declarations (Decl, Tmps_For_Discs);
       Set_Handled_Statement_Sequence (Decl,
         Make_Handled_Sequence_Of_Statements (Loc,
           Statements => Stms));