2011-09-02 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk rev 178437 using svnmerge.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@178439 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 200 insertions, 116 deletions

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 8073ff568fd..75746422125 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -156,36 +156,6 @@ package body Exp_Ch6 is
    --  the values are not changed for the call, we know immediately that
    --  we have an infinite recursion.
 
-   procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id);
-   --  For each actual of an in-out or out parameter which is a numeric
-   --  (view) conversion of the form T (A), where A denotes a variable,
-   --  we insert the declaration:
-   --
-   --    Temp : T[ := T (A)];
-   --
-   --  prior to the call. Then we replace the actual with a reference to Temp,
-   --  and append the assignment:
-   --
-   --    A := TypeA (Temp);
-   --
-   --  after the call. Here TypeA is the actual type of variable A. For out
-   --  parameters, the initial declaration has no expression. If A is not an
-   --  entity name, we generate instead:
-   --
-   --    Var  : TypeA renames A;
-   --    Temp : T := Var;       --  omitting expression for out parameter.
-   --    ...
-   --    Var := TypeA (Temp);
-   --
-   --  For other in-out parameters, we emit the required constraint checks
-   --  before and/or after the call.
-   --
-   --  For all parameter modes, actuals that denote components and slices of
-   --  packed arrays are expanded into suitable temporaries.
-   --
-   --  For non-scalar objects that are possibly unaligned, add call by copy
-   --  code (copy in for IN and IN OUT, copy out for OUT and IN OUT).
-
    procedure Expand_Ctrl_Function_Call (N : Node_Id);
    --  N is a function call which returns a controlled object. Transform the
    --  call into a temporary which retrieves the returned object from the
@@ -1201,10 +1171,49 @@ package body Exp_Ch6 is
 
                Set_Assignment_OK (Lhs);
 
-               Append_To (Post_Call,
-                 Make_Assignment_Statement (Loc,
-                   Name       => Lhs,
-                   Expression => Expr));
+               if Is_Access_Type (E_Formal)
+                 and then Is_Entity_Name (Lhs)
+                 and then
+                   Present (Effective_Extra_Accessibility (Entity (Lhs)))
+               then
+                  --  Copyback target is an Ada 2012 stand-alone object
+                  --  of an anonymous access type
+
+                  pragma Assert (Ada_Version >= Ada_2012);
+
+                  if Type_Access_Level (E_Formal) >
+                     Object_Access_Level (Lhs)
+                  then
+                     Append_To (Post_Call,
+                       Make_Raise_Program_Error (Loc,
+                         Reason => PE_Accessibility_Check_Failed));
+                  end if;
+
+                  Append_To (Post_Call,
+                    Make_Assignment_Statement (Loc,
+                      Name       => Lhs,
+                      Expression => Expr));
+
+                  --  We would like to somehow suppress generation of the
+                  --  extra_accessibility assignment generated by the expansion
+                  --  of the above assignment statement. It's not a correctness
+                  --  issue because the following assignment renders it dead,
+                  --  but generating back-to-back assignments to the same
+                  --  target is undesirable. ???
+
+                  Append_To (Post_Call,
+                    Make_Assignment_Statement (Loc,
+                      Name       => New_Occurrence_Of (
+                        Effective_Extra_Accessibility (Entity (Lhs)), Loc),
+                      Expression => Make_Integer_Literal (Loc,
+                        Type_Access_Level (E_Formal))));
+
+               else
+                  Append_To (Post_Call,
+                    Make_Assignment_Statement (Loc,
+                      Name       => Lhs,
+                      Expression => Expr));
+               end if;
             end;
          end if;
       end Add_Call_By_Copy_Code;
@@ -2199,8 +2208,8 @@ package body Exp_Ch6 is
       --  as we go through the loop, since this is a convenient place to do it.
       --  (Though it seems that this would be better done in Expand_Actuals???)
 
-      Formal      := First_Formal (Subp);
-      Actual      := First_Actual (Call_Node);
+      Formal := First_Formal (Subp);
+      Actual := First_Actual (Call_Node);
       Param_Count := 1;
       while Present (Formal) loop
 
@@ -2226,7 +2235,7 @@ package body Exp_Ch6 is
            CW_Interface_Formals_Present
              or else
                (Ekind (Etype (Formal)) = E_Class_Wide_Type
-                  and then Is_Interface (Etype (Etype (Formal))))
+                 and then Is_Interface (Etype (Etype (Formal))))
              or else
                (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
                  and then Is_Interface (Directly_Designated_Type
@@ -2406,8 +2415,7 @@ package body Exp_Ch6 is
 
                else
                   Add_Extra_Actual
-                    (Make_Integer_Literal (Loc,
-                       Intval => Type_Access_Level (Etype (Prev_Orig))),
+                    (Dynamic_Accessibility_Level (Prev_Orig),
                      Extra_Accessibility (Formal));
                end if;
 
@@ -2436,12 +2444,40 @@ package body Exp_Ch6 is
                         --  For X'Access, pass on the level of the prefix X
 
                         when Attribute_Access =>
-                           Add_Extra_Actual
-                             (Make_Integer_Literal (Loc,
-                               Intval =>
-                                 Object_Access_Level
-                                   (Prefix (Prev_Orig))),
-                                    Extra_Accessibility (Formal));
+
+                           --  If this is an Access attribute applied to the
+                           --  the current instance object passed to a type
+                           --  initialization procedure, then use the level
+                           --  of the type itself. This is not really correct,
+                           --  as there should be an extra level parameter
+                           --  passed in with _init formals (only in the case
+                           --  where the type is immutably limited), but we
+                           --  don't have an easy way currently to create such
+                           --  an extra formal (init procs aren't ever frozen).
+                           --  For now we just use the level of the type,
+                           --  which may be too shallow, but that works better
+                           --  than passing Object_Access_Level of the type,
+                           --  which can be one level too deep in some cases.
+                           --  ???
+
+                           if Is_Entity_Name (Prefix (Prev_Orig))
+                             and then Is_Type (Entity (Prefix (Prev_Orig)))
+                           then
+                              Add_Extra_Actual
+                                (Make_Integer_Literal (Loc,
+                                   Intval =>
+                                     Type_Access_Level
+                                       (Entity (Prefix (Prev_Orig)))),
+                                 Extra_Accessibility (Formal));
+
+                           else
+                              Add_Extra_Actual
+                                (Make_Integer_Literal (Loc,
+                                   Intval =>
+                                     Object_Access_Level
+                                       (Prefix (Prev_Orig))),
+                                 Extra_Accessibility (Formal));
+                           end if;
 
                         --  Treat the unchecked attributes as library-level
 
@@ -2470,15 +2506,15 @@ package body Exp_Ch6 is
                           Intval => Scope_Depth (Current_Scope) + 1),
                         Extra_Accessibility (Formal));
 
-                  --  For other cases we simply pass the level of the actual's
-                  --  access type. The type is retrieved from Prev rather than
-                  --  Prev_Orig, because in some cases Prev_Orig denotes an
-                  --  original expression that has not been analyzed.
+                  --  For most other cases we simply pass the level of the
+                  --  actual's access type. The type is retrieved from
+                  --  Prev rather than Prev_Orig, because in some cases
+                  --  Prev_Orig denotes an original expression that has
+                  --  not been analyzed.
 
                   when others =>
                      Add_Extra_Actual
-                       (Make_Integer_Literal (Loc,
-                          Intval => Type_Access_Level (Etype (Prev))),
+                       (Dynamic_Accessibility_Level (Prev),
                         Extra_Accessibility (Formal));
                end case;
             end if;
@@ -2503,7 +2539,7 @@ package body Exp_Ch6 is
               and then Ekind (Formal) /= E_Out_Parameter
               and then Nkind (Prev) /= N_Raise_Constraint_Error
               and then (Known_Null (Prev)
-                          or else not Can_Never_Be_Null (Etype (Prev)))
+                         or else not Can_Never_Be_Null (Etype (Prev)))
             then
                Install_Null_Excluding_Check (Prev);
             end if;
@@ -2549,10 +2585,10 @@ package body Exp_Ch6 is
 
          if Validity_Checks_On then
             if  (Ekind (Formal) = E_In_Parameter
-                   and then Validity_Check_In_Params)
+                  and then Validity_Check_In_Params)
               or else
                 (Ekind (Formal) = E_In_Out_Parameter
-                   and then Validity_Check_In_Out_Params)
+                  and then Validity_Check_In_Out_Params)
             then
                --  If the actual is an indexed component of a packed type (or
                --  is an indexed or selected component whose prefix recursively
@@ -2580,6 +2616,15 @@ package body Exp_Ch6 is
             end if;
          end if;
 
+         --  For Ada 2012, if a parameter is aliased, the actual must be an
+         --  aliased object.
+
+         if Is_Aliased (Formal) and then not Is_Aliased_View (Actual) then
+            Error_Msg_NE
+              ("actual for aliased formal& must be aliased object",
+               Actual, Formal);
+         end if;
+
          --  For IN OUT and OUT parameters, ensure that subscripts are valid
          --  since this is a left side reference. We only do this for calls
          --  from the source program since we assume that compiler generated
@@ -2631,9 +2676,7 @@ package body Exp_Ch6 is
                --  or IN OUT parameter! We do reset the Is_Known_Valid flag
                --  since the subprogram could have returned in invalid value.
 
-               if (Ekind (Formal) = E_Out_Parameter
-                     or else
-                   Ekind (Formal) = E_In_Out_Parameter)
+               if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter)
                  and then Is_Assignable (Ent)
                then
                   Sav := Last_Assignment (Ent);
@@ -4143,8 +4186,7 @@ package body Exp_Ch6 is
             --  code will have the same semantics.
 
             if Ekind (F) = E_In_Parameter
-              and then not Is_Limited_Type (Etype (A))
-              and then not Is_Tagged_Type  (Etype (A))
+              and then not Is_By_Reference_Type (Etype (A))
               and then
                (not Is_Array_Type (Etype (A))
                  or else not Is_Object_Reference (A)
@@ -4153,9 +4195,9 @@ package body Exp_Ch6 is
                Decl :=
                  Make_Object_Declaration (Loc,
                    Defining_Identifier => Temp,
-                   Constant_Present => True,
-                   Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
-                   Expression => New_A);
+                   Constant_Present    => True,
+                   Object_Definition   => New_Occurrence_Of (Temp_Typ, Loc),
+                   Expression          => New_A);
             else
                Decl :=
                  Make_Object_Renaming_Declaration (Loc,
@@ -4173,10 +4215,10 @@ package body Exp_Ch6 is
       end loop;
 
       --  Establish target of function call. If context is not assignment or
-      --  declaration, create a temporary as a target. The declaration for
-      --  the temporary may be subsequently optimized away if the body is a
-      --  single expression, or if the left-hand side of the assignment is
-      --  simple enough, i.e. an entity or an explicit dereference of one.
+      --  declaration, create a temporary as a target. The declaration for the
+      --  temporary may be subsequently optimized away if the body is a single
+      --  expression, or if the left-hand side of the assignment is simple
+      --  enough, i.e. an entity or an explicit dereference of one.
 
       if Ekind (Subp) = E_Function then
          if Nkind (Parent (N)) = N_Assignment_Statement
@@ -6042,7 +6084,7 @@ package body Exp_Ch6 is
 
          Build_Protected_Subprogram_Call (N,
            Name     => New_Occurrence_Of (Subp, Sloc (N)),
-           Rec      =>  Convert_Concurrent (Rec, Etype (Rec)),
+           Rec      => Convert_Concurrent (Rec, Etype (Rec)),
            External => True);
 
       else
@@ -6737,6 +6779,18 @@ package body Exp_Ch6 is
       Function_Id : Entity_Id;
 
    begin
+      --  Return False when the expander is inactive, since awareness of
+      --  build-in-place treatment is only relevant during expansion. Note that
+      --  Is_Build_In_Place_Function, which is called as part of this function,
+      --  is also conditioned this way, but we need to check here as well to
+      --  avoid blowing up on processing protected calls when expansion is
+      --  disabled (such as with -gnatc) since those would trip over the raise
+      --  of Program_Error below.
+
+      if not Expander_Active then
+         return False;
+      end if;
+
       --  Step past qualification or unchecked conversion (the latter can occur
       --  in cases of calls to 'Input).
 
@@ -6755,6 +6809,16 @@ package body Exp_Ch6 is
 
          elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
             Function_Id := Etype (Name (Exp_Node));
+
+         --  In Alfa mode, protected subprogram calls are not expanded, so that
+         --  we may end up with a call that is neither resolved to an entity,
+         --  nor an indirect call.
+
+         elsif Alfa_Mode then
+            return False;
+
+         else
+            raise Program_Error;
          end if;
 
          return Is_Build_In_Place_Function (Function_Id);
@@ -7536,54 +7600,26 @@ package body Exp_Ch6 is
 
       Result_Subt := Etype (Function_Id);
 
-      --  In the constrained case, add an implicit actual to the function call
-      --  that provides access to the declared object. An unchecked conversion
-      --  to the (specific) result type of the function is inserted to handle
-      --  the case where the object is declared with a class-wide type.
-
-      if Is_Constrained (Underlying_Type (Result_Subt)) then
-         Caller_Object :=
-            Make_Unchecked_Type_Conversion (Loc,
-              Subtype_Mark => New_Reference_To (Result_Subt, Loc),
-              Expression   => New_Reference_To (Obj_Def_Id, Loc));
-
-         --  When the function has a controlling result, an allocation-form
-         --  parameter must be passed indicating that the caller is allocating
-         --  the result object. This is needed because such a function can be
-         --  called as a dispatching operation and must be treated similarly
-         --  to functions with unconstrained result subtypes.
-
-         Add_Alloc_Form_Actual_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
-
-      --  If the function's result subtype is unconstrained and the object is
-      --  a return object of an enclosing build-in-place function, then the
-      --  implicit build-in-place parameters of the enclosing function must be
-      --  passed along to the called function. (Unfortunately, this won't cover
-      --  the case of extension aggregates where the ancestor part is a build-
-      --  in-place unconstrained function call that should be passed along the
-      --  caller's parameters. Currently those get mishandled by reassigning
-      --  the result of the call to the aggregate return object, when the call
-      --  result should really be directly built in place in the aggregate and
-      --  not built in a temporary. ???)
-
-      elsif Is_Return_Object (Defining_Identifier (Object_Decl)) then
+      --  If the the object is a return object of an enclosing build-in-place
+      --  function, then the implicit build-in-place parameters of the
+      --  enclosing function are simply passed along to the called function.
+      --  (Unfortunately, this won't cover the case of extension aggregates
+      --  where the ancestor part is a build-in-place unconstrained function
+      --  call that should be passed along the caller's parameters. Currently
+      --  those get mishandled by reassigning the result of the call to the
+      --  aggregate return object, when the call result should really be
+      --  directly built in place in the aggregate and not in a temporary. ???)
+
+      if Is_Return_Object (Defining_Identifier (Object_Decl)) then
          Pass_Caller_Acc := True;
 
          Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
 
-         --  If the enclosing function has a constrained result type, then
-         --  caller allocation will be used.
+         --  When the enclosing function has a BIP_Alloc_Form formal then we
+         --  pass it along to the callee (such as when the enclosing function
+         --  has an unconstrained or tagged result type).
 
-         if Is_Constrained (Etype (Enclosing_Func)) then
-            Add_Alloc_Form_Actual_To_Build_In_Place_Call
-              (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
-
-         --  Otherwise, when the enclosing function has an unconstrained result
-         --  type, the BIP_Alloc_Form formal of the enclosing function must be
-         --  passed along to the callee.
-
-         else
+         if Needs_BIP_Alloc_Form (Enclosing_Func) then
             Add_Alloc_Form_Actual_To_Build_In_Place_Call
               (Func_Call,
                Function_Id,
@@ -7591,6 +7627,13 @@ package body Exp_Ch6 is
                  New_Reference_To
                    (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form),
                     Loc));
+
+         --  Otherwise, if enclosing function has a constrained result subtype,
+         --  then caller allocation will be used.
+
+         else
+            Add_Alloc_Form_Actual_To_Build_In_Place_Call
+              (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
          end if;
 
          --  Retrieve the BIPacc formal from the enclosing function and convert
@@ -7608,6 +7651,26 @@ package body Exp_Ch6 is
                   (Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access),
                    Loc));
 
+      --  In the constrained case, add an implicit actual to the function call
+      --  that provides access to the declared object. An unchecked conversion
+      --  to the (specific) result type of the function is inserted to handle
+      --  the case where the object is declared with a class-wide type.
+
+      elsif Is_Constrained (Underlying_Type (Result_Subt)) then
+         Caller_Object :=
+            Make_Unchecked_Type_Conversion (Loc,
+              Subtype_Mark => New_Reference_To (Result_Subt, Loc),
+              Expression   => New_Reference_To (Obj_Def_Id, Loc));
+
+         --  When the function has a controlling result, an allocation-form
+         --  parameter must be passed indicating that the caller is allocating
+         --  the result object. This is needed because such a function can be
+         --  called as a dispatching operation and must be treated similarly
+         --  to functions with unconstrained result subtypes.
+
+         Add_Alloc_Form_Actual_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
+
       --  In other unconstrained cases, pass an indication to do the allocation
       --  on the secondary stack and set Caller_Object to Empty so that a null
       --  value will be passed for the caller's object address. A transient
@@ -7667,11 +7730,14 @@ package body Exp_Ch6 is
       --  The access type and its accompanying object must be inserted after
       --  the object declaration in the constrained case, so that the function
       --  call can be passed access to the object. In the unconstrained case,
-      --  the access type and object must be inserted before the object, since
-      --  the object declaration is rewritten to be a renaming of a dereference
-      --  of the access object.
+      --  or if the object declaration is for a return object, the access type
+      --  and object must be inserted before the object, since the object
+      --  declaration is rewritten to be a renaming of a dereference of the
+      --  access object.
 
-      if Is_Constrained (Underlying_Type (Result_Subt)) then
+      if Is_Constrained (Underlying_Type (Result_Subt))
+        and then not Is_Return_Object (Defining_Identifier (Object_Decl))
+      then
          Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
       else
          Insert_Action (Object_Decl, Ptr_Typ_Decl);
@@ -7691,11 +7757,18 @@ package body Exp_Ch6 is
           Object_Definition   => New_Reference_To (Ref_Type, Loc),
           Expression          => New_Expr));
 
-      if Is_Constrained (Underlying_Type (Result_Subt)) then
+      --  If the result subtype of the called function is constrained and
+      --  is not itself the return expression of an enclosing BIP function,
+      --  then mark the object as having no initialization.
+
+      if Is_Constrained (Underlying_Type (Result_Subt))
+        and then not Is_Return_Object (Defining_Identifier (Object_Decl))
+      then
          Set_Expression (Object_Decl, Empty);
          Set_No_Initialization (Object_Decl);
 
-      --  In case of an unconstrained result subtype, rewrite the object
+      --  In case of an unconstrained result subtype, or if the call is the
+      --  return expression of an enclosing BIP function, rewrite the object
       --  declaration as an object renaming where the renamed object is a
       --  dereference of <function_Call>'reference:
       --
@@ -7787,4 +7860,15 @@ package body Exp_Ch6 is
           and then Needs_Finalization (Func_Typ);
    end Needs_BIP_Finalization_Master;
 
+   --------------------------
+   -- Needs_BIP_Alloc_Form --
+   --------------------------
+
+   function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is
+      pragma Assert (Is_Build_In_Place_Function (Func_Id));
+      Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+   begin
+      return not Is_Constrained (Func_Typ) or else Is_Tagged_Type (Func_Typ);
+   end Needs_BIP_Alloc_Form;
+
 end Exp_Ch6;