inline.adb (Back_End_Cannot_Inline): Use new flag Has_Pragma_Inline_Always…

inline.adb (Back_End_Cannot_Inline): Use new flag Has_Pragma_Inline_Always instead of obsolete function Is_Always_Inlined

2007-12-06  Robert Dewar  <dewar@adacore.com>

	* inline.adb (Back_End_Cannot_Inline): Use new flag
	Has_Pragma_Inline_Always instead of obsolete function Is_Always_Inlined

	* sem_ch6.ads, sem_ch6.adb (Analyze_Subprogram_Body): Use new flag
	Has_Pragma_Inline_Always instead.
	of obsolete function Is_Always_Inlined
	(Build_Body_To_Inline): Same change
	(Cannot_Inline): Same change
	Do not give warning on exception raise in No_Return function

	* sem_ch13.adb (Analyze_Record_Representation_Clause): If an inherited
	component has two inconsistent component clauses in the same record
	representation clause, favor the message that complains about
	duplication rather than inconsistency.
	Update comments.
	(Record_Representation_Clause): Do not warn on missing component
	clauses for inherited components of a type extension.
	(Rep_Item_Too_Late): Do not attempt to link pragma into rep chain for
	an overloadable item if it is a pragma that can apply to multiple
	overloadable entities (e.g. Inline) because a pragma cannot be on
	more than one chain at a time.
	(Validate_Unchecked_Conversion): Add code to warn on unchecked
	conversion where one of the operands is Ada.Calendar.Time.
	(Analyze_Attribute_Definition_Clause): Fix typo in error message.
	For now, ignore Component_Size clause on VM targets, as done for
	pragma Pack.

From-SVN: r130845

gcc/ada/inline.adb

@@ -393,7 +393,7 @@ package body Inline is
 
          --  If subprogram is marked Inline_Always, inlining is mandatory
 
-         if Is_Always_Inlined (Subp) then
+         if Has_Pragma_Inline_Always (Subp) then
             return False;
          end if;
 
@@ -726,7 +726,7 @@ package body Inline is
          E := First_Entity (P);
 
          while Present (E) loop
-            if Is_Always_Inlined (E)
+            if Has_Pragma_Inline_Always (E)
               or else (Front_End_Inlining and then Has_Pragma_Inline (E))
             then
                if not Is_Loaded (Bname) then

gcc/ada/sem_ch13.adb

@@ -1039,7 +1039,7 @@ package body Sem_Ch13 is
 
             if Has_Component_Size_Clause (Btype) then
                Error_Msg_N
-                 ("component size clase for& previously given", Nam);
+                 ("component size clause for& previously given", Nam);
 
             elsif Csize /= No_Uint then
                Check_Size (Expr, Component_Type (Btype), Csize, Biased);
@@ -1058,12 +1058,15 @@ package body Sem_Ch13 is
                --  that will be used to represent the biased subtype that
                --  reflects the biased representation of components. We need
                --  this subtype to get proper conversions on referencing
-               --  elements of the array.
+               --  elements of the array. Note that component size clauses
+               --  are ignored in VM mode.
 
+               if VM_Target = No_VM then
                   if Biased then
                      New_Ctyp :=
                        Make_Defining_Identifier (Loc,
-                      Chars => New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
+                         Chars =>
+                           New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
 
                      Decl :=
                        Make_Subtype_Declaration (Loc,
@@ -1086,6 +1089,19 @@ package body Sem_Ch13 is
                   end if;
 
                   Set_Component_Size (Btype, Csize);
+
+               --  For VM case, we ignore component size clauses
+
+               else
+                  --  Give a warning unless we are in GNAT mode, in which case
+                  --  the warning is suppressed since it is not useful.
+
+                  if not GNAT_Mode then
+                     Error_Msg_N
+                       ("?component size ignored in this configuration", N);
+                  end if;
+               end if;
+
                Set_Has_Component_Size_Clause (Btype, True);
                Set_Has_Non_Standard_Rep      (Btype, True);
             end if;
@@ -2190,14 +2206,19 @@ package body Sem_Ch13 is
          end;
       end if;
 
-      --  Clear any existing component clauses for the type (this happens with
-      --  derived types, where we are now overriding the original).
+      --  For untagged types, clear any existing component clauses for the
+      --  type. If the type is derived, this is what allows us to override
+      --  a rep clause for the parent. For type extensions, the representation
+      --  of the inherited components is inherited, so we want to keep previous
+      --  component clauses for completeness.
 
+      if not Is_Tagged_Type (Rectype) then
          Comp := First_Component_Or_Discriminant (Rectype);
          while Present (Comp) loop
             Set_Component_Clause (Comp, Empty);
             Next_Component_Or_Discriminant (Comp);
          end loop;
+      end if;
 
       --  All done if no component clauses
 
@@ -2323,9 +2344,40 @@ package body Sem_Ch13 is
                        ("component clause is for non-existent field", CC);
 
                   elsif Present (Component_Clause (Comp)) then
+
+                     --  Diagose duplicate rep clause, or check consistency
+                     --  if this is inherited component. In a double fault,
+                     --  there may be a duplicate inconsistent clause for an
+                     --  inherited component.
+
+                     if
+                       Scope (Original_Record_Component (Comp)) = Rectype
+                         or else Parent (Component_Clause (Comp)) = N
+                     then
                         Error_Msg_Sloc := Sloc (Component_Clause (Comp));
-                     Error_Msg_N
-                       ("component clause previously given#", CC);
+                        Error_Msg_N ("component clause previously given#", CC);
+
+                     else
+                        declare
+                           Rep1 : constant Node_Id := Component_Clause (Comp);
+
+                        begin
+                           if Intval (Position (Rep1)) /=
+                                                   Intval (Position (CC))
+                             or else Intval (First_Bit (Rep1)) /=
+                                                   Intval (First_Bit (CC))
+                             or else Intval (Last_Bit (Rep1)) /=
+                                                   Intval (Last_Bit (CC))
+                           then
+                              Error_Msg_N ("component clause inconsistent "
+                                & "with representation of ancestor", CC);
+
+                           elsif Warn_On_Redundant_Constructs then
+                              Error_Msg_N ("?redundant component clause "
+                                & "for inherited component!", CC);
+                           end if;
+                        end;
+                     end if;
 
                   else
                      --  Make reference for field in record rep clause and set
@@ -2684,6 +2736,7 @@ package body Sem_Ch13 is
             while Present (Comp) loop
                if Present (Component_Clause (Comp)) then
                   Num_Repped_Components := Num_Repped_Components + 1;
+
                else
                   Num_Unrepped_Components := Num_Unrepped_Components + 1;
                end if;
@@ -2702,6 +2755,7 @@ package body Sem_Ch13 is
                Comp := First_Component_Or_Discriminant (Rectype);
                while Present (Comp) loop
                   if No (Component_Clause (Comp))
+                    and then Comes_From_Source (Comp)
                     and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
                                 or else Size_Known_At_Compile_Time
                                              (Underlying_Type (Etype (Comp))))
@@ -3413,6 +3467,17 @@ package body Sem_Ch13 is
                return 0;
             end if;
 
+            --  Note: In the following two tests for LoSet and HiSet, it may
+            --  seem redundant to test for N_Real_Literal here since normally
+            --  one would assume that the test for the value being known at
+            --  compile time includes this case. However, there is a glitch.
+            --  If the real literal comes from folding a non-static expression,
+            --  then we don't consider any non- static expression to be known
+            --  at compile time if we are in configurable run time mode (needed
+            --  in some cases to give a clearer definition of what is and what
+            --  is not accepted). So the test is indeed needed. Without it, we
+            --  would set neither Lo_Set nor Hi_Set and get an infinite loop.
+
             if not LoSet then
                if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal
                  or else Compile_Time_Known_Value (Type_Low_Bound (Ancest))
@@ -3752,9 +3817,29 @@ package body Sem_Ch13 is
          end if;
       end if;
 
-      --  No error, link item into head of chain of rep items for the entity
+      --  No error, link item into head of chain of rep items for the entity,
+      --  but avoid chaining if we have an overloadable entity, and the pragma
+      --  is one that can apply to multiple overloaded entities.
 
+      if Is_Overloadable (T)
+        and then Nkind (N) = N_Pragma
+        and then (Chars (N) = Name_Convention
+                    or else
+                  Chars (N) = Name_Import
+                    or else
+                  Chars (N) = Name_Export
+                    or else
+                  Chars (N) = Name_External
+                    or else
+                  Chars (N) = Name_Interface)
+      then
+         null;
+      else
          Record_Rep_Item (T, N);
+      end if;
+
+      --  Rep item was OK, not too late
+
       return False;
    end Rep_Item_Too_Late;
 
@@ -4186,6 +4271,36 @@ package body Sem_Ch13 is
            ("?conversion between pointers with different conventions!", N);
       end if;
 
+      --  Warn if one of the operands is Ada.Calendar.Time. Do not emit a
+      --  warning when compiling GNAT-related sources.
+
+      if Warn_On_Unchecked_Conversion
+        and then not In_Predefined_Unit (N)
+        and then RTU_Loaded (Ada_Calendar)
+        and then
+          (Chars (Source) = Name_Time
+             or else
+           Chars (Target) = Name_Time)
+      then
+         --  If Ada.Calendar is loaded and the name of one of the operands is
+         --  Time, there is a good chance that this is Ada.Calendar.Time.
+
+         declare
+            Calendar_Time : constant Entity_Id :=
+                              Full_View (RTE (RO_CA_Time));
+         begin
+            pragma Assert (Present (Calendar_Time));
+
+            if Source = Calendar_Time
+              or else Target = Calendar_Time
+            then
+               Error_Msg_N
+                 ("?representation of 'Time values may change between " &
+                  "'G'N'A'T versions", N);
+            end if;
+         end;
+      end if;
+
       --  Make entry in unchecked conversion table for later processing
       --  by Validate_Unchecked_Conversions, which will check sizes and
       --  alignments (using values set by the back-end where possible).

gcc/ada/sem_ch6.adb

@@ -196,12 +196,6 @@ package body Sem_Ch6 is
    --  Flag functions that can be called without parameters, i.e. those that
    --  have no parameters, or those for which defaults exist for all parameters
 
-   procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id);
-   --  If there is a separate spec for a subprogram or generic subprogram, the
-   --  formals of the body are treated as references to the corresponding
-   --  formals of the spec. This reference does not count as an actual use of
-   --  the formal, in order to diagnose formals that are unused in the body.
-
    procedure Set_Formal_Validity (Formal_Id : Entity_Id);
    --  Formal_Id is an formal parameter entity. This procedure deals with
    --  setting the proper validity status for this entity, which depends
@@ -213,9 +207,8 @@ package body Sem_Ch6 is
 
    procedure Analyze_Return_Statement (N : Node_Id) is
 
-      pragma Assert (Nkind (N) = N_Simple_Return_Statement
-                       or else
-                     Nkind (N) = N_Extended_Return_Statement);
+      pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
+                                  N_Extended_Return_Statement));
 
       Returns_Object : constant Boolean :=
                          Nkind (N) = N_Extended_Return_Statement
@@ -914,9 +907,11 @@ package body Sem_Ch6 is
       Par : constant Node_Id := Parent (N);
 
    begin
-      if        (Nkind (Par) = N_Function_Call and then N = Name (Par))
+      if        (Nkind (Par) = N_Function_Call
+                   and then N = Name (Par))
         or else  Nkind (Par) = N_Function_Instantiation
-        or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
+        or else (Nkind (Par) = N_Indexed_Component
+                   and then N = Prefix (Par))
         or else (Nkind (Par) = N_Pragma_Argument_Association
                    and then not Is_Pragma_String_Literal (Par))
         or else  Nkind (Par) = N_Subprogram_Renaming_Declaration
@@ -1463,7 +1458,7 @@ package body Sem_Ch6 is
          Write_Eol;
       end if;
 
-      Trace_Scope (N, Body_Id, " Analyze subprogram");
+      Trace_Scope (N, Body_Id, " Analyze subprogram: ");
 
       --  Generic subprograms are handled separately. They always have a
       --  generic specification. Determine whether current scope has a
@@ -1945,7 +1940,7 @@ package body Sem_Ch6 is
       elsif Present (Spec_Id)
         and then Expander_Active
         and then
-          (Is_Always_Inlined (Spec_Id)
+          (Has_Pragma_Inline_Always (Spec_Id)
              or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
       then
          Build_Body_To_Inline (N, Spec_Id);
@@ -2092,13 +2087,14 @@ package body Sem_Ch6 is
       --  initialized!
 
       declare
-         Stm : Node_Id := First (Statements (HSS));
+         Stm : Node_Id;
 
       begin
          --  Skip initial labels (for one thing this occurs when we are in
          --  front end ZCX mode, but in any case it is irrelevant), and also
          --  initial Push_xxx_Error_Label nodes, which are also irrelevant.
 
+         Stm := First (Statements (HSS));
          while Nkind (Stm) = N_Label
            or else Nkind (Stm) in N_Push_xxx_Label
          loop
@@ -2212,7 +2208,7 @@ package body Sem_Ch6 is
       Trace_Scope
         (N,
          Defining_Entity (N),
-         " Analyze subprogram spec. ");
+         " Analyze subprogram spec: ");
 
       if Debug_Flag_C then
          Write_Str ("====  Compiling subprogram spec ");
@@ -2355,8 +2351,7 @@ package body Sem_Ch6 is
          Set_Etype (Designator, Standard_Void_Type);
       end if;
 
-      --  Introduce new scope for analysis of the formals and of the
-      --  return type.
+      --  Introduce new scope for analysis of the formals and the return type
 
       Set_Scope (Designator, Current_Scope);
 
@@ -2495,12 +2490,10 @@ package body Sem_Ch6 is
             then
                Conv := Current_Entity (Id);
 
-            elsif (Nkind (Id) = N_Selected_Component
-                    or else Nkind (Id) = N_Expanded_Name)
+            elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
               and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
             then
                Conv := Current_Entity (Selector_Name (Id));
-
             else
                return False;
             end if;
@@ -2515,16 +2508,15 @@ package body Sem_Ch6 is
 
       begin
          D := First (Decls);
-
          while Present (D) loop
             if (Nkind (D) = N_Function_Instantiation
                   and then not Is_Unchecked_Conversion (D))
-              or else Nkind (D) = N_Protected_Type_Declaration
-              or else Nkind (D) = N_Package_Declaration
-              or else Nkind (D) = N_Package_Instantiation
-              or else Nkind (D) = N_Subprogram_Body
-              or else Nkind (D) = N_Procedure_Instantiation
-              or else Nkind (D) = N_Task_Type_Declaration
+              or else Nkind_In (D, N_Protected_Type_Declaration,
+                                   N_Package_Declaration,
+                                   N_Package_Instantiation,
+                                   N_Subprogram_Body,
+                                   N_Procedure_Instantiation,
+                                   N_Task_Type_Declaration)
             then
                Cannot_Inline
                  ("cannot inline & (non-allowed declaration)?", D, Subp);
@@ -2550,13 +2542,13 @@ package body Sem_Ch6 is
          while Present (S) loop
             Stat_Count := Stat_Count + 1;
 
-            if Nkind (S) = N_Abort_Statement
-              or else Nkind (S) = N_Asynchronous_Select
-              or else Nkind (S) = N_Conditional_Entry_Call
-              or else Nkind (S) = N_Delay_Relative_Statement
-              or else Nkind (S) = N_Delay_Until_Statement
-              or else Nkind (S) = N_Selective_Accept
-              or else Nkind (S) = N_Timed_Entry_Call
+            if Nkind_In (S, N_Abort_Statement,
+                            N_Asynchronous_Select,
+                            N_Conditional_Entry_Call,
+                            N_Delay_Relative_Statement,
+                            N_Delay_Until_Statement,
+                            N_Selective_Accept,
+                            N_Timed_Entry_Call)
             then
                Cannot_Inline
                  ("cannot inline & (non-allowed statement)?", S, Subp);
@@ -2821,7 +2813,7 @@ package body Sem_Ch6 is
       --  checks on inlining (forbidden declarations, handlers, etc).
 
       if Stat_Count > Max_Size
-        and then not Is_Always_Inlined (Subp)
+        and then not Has_Pragma_Inline_Always (Subp)
       then
          Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
          return;
@@ -2917,7 +2909,7 @@ package body Sem_Ch6 is
       then
          null;
 
-      elsif Is_Always_Inlined (Subp) then
+      elsif Has_Pragma_Inline_Always (Subp) then
 
          --  Remove last character (question mark) to make this into an error,
          --  because the Inline_Always pragma cannot be obeyed.
@@ -3828,11 +3820,11 @@ package body Sem_Ch6 is
          Decl := Unit_Declaration_Node (Subp);
       end if;
 
-      if Nkind (Decl) = N_Subprogram_Body
-        or else Nkind (Decl) = N_Subprogram_Body_Stub
-        or else Nkind (Decl) = N_Subprogram_Declaration
-        or else Nkind (Decl) = N_Abstract_Subprogram_Declaration
-        or else Nkind (Decl) = N_Subprogram_Renaming_Declaration
+      if Nkind_In (Decl, N_Subprogram_Body,
+                         N_Subprogram_Body_Stub,
+                         N_Subprogram_Declaration,
+                         N_Abstract_Subprogram_Declaration,
+                         N_Subprogram_Renaming_Declaration)
       then
          Spec := Specification (Decl);
 
@@ -4023,9 +4015,9 @@ package body Sem_Ch6 is
          --  Don't count exception junk
 
            or else
-             ((Nkind (Last_Stm) = N_Goto_Statement
-                 or else Nkind (Last_Stm) = N_Label
-                 or else Nkind (Last_Stm) = N_Object_Declaration)
+             (Nkind_In (Last_Stm, N_Goto_Statement,
+                                   N_Label,
+                                   N_Object_Declaration)
                 and then Exception_Junk (Last_Stm))
            or else Nkind (Last_Stm) in N_Push_xxx_Label
            or else Nkind (Last_Stm) in N_Pop_xxx_Label
@@ -4111,7 +4103,6 @@ package body Sem_Ch6 is
          elsif Kind = N_Case_Statement then
             declare
                Case_Alt : Node_Id;
-
             begin
                Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
                while Present (Case_Alt) loop
@@ -4247,12 +4238,15 @@ package body Sem_Ch6 is
          --  Otherwise we have the case of a procedure marked No_Return
 
          else
+            if not Raise_Exception_Call then
                Error_Msg_N
-              ("?implied return after this statement will raise Program_Error",
+                 ("?implied return after this statement " &
+                  "will raise Program_Error",
                   Last_Stm);
                Error_Msg_NE
-              ("?procedure & is marked as No_Return",
+                 ("\?procedure & is marked as No_Return!",
                   Last_Stm, Proc);
+            end if;
 
             declare
                RE : constant Node_Id :=
@@ -6146,9 +6140,8 @@ package body Sem_Ch6 is
                then
                   return True;
 
-               elsif (Nkind (N) = N_Private_Type_Declaration
-                       or else
-                      Nkind (N) = N_Private_Extension_Declaration)
+               elsif Nkind_In (N, N_Private_Type_Declaration,
+                                  N_Private_Extension_Declaration)
                  and then Present (Defining_Identifier (N))
                  and then T = Full_View (Defining_Identifier (N))
                then
@@ -6303,9 +6296,10 @@ package body Sem_Ch6 is
          --  operation in a type derivation on for a generic actual.
 
          if Nkind (Parent (Typ)) /= N_Full_Type_Declaration
-           and then Nkind (Parent (Def_Id)) /= N_Subtype_Declaration
-           and then Nkind (Parent (Def_Id)) /= N_Task_Type_Declaration
-           and then Nkind (Parent (Def_Id)) /= N_Protected_Type_Declaration
+           and then
+             not Nkind_In (Parent (Def_Id), N_Subtype_Declaration,
+                                            N_Task_Type_Declaration,
+                                            N_Protected_Type_Declaration)
          then
             Collect_Abstract_Interfaces (Typ, Ifaces_List);
 
@@ -6838,6 +6832,10 @@ package body Sem_Ch6 is
       Default     : Node_Id;
       Ptype       : Entity_Id;
 
+      --  The following are used for setting Is_Only_Out_
+      Num_Out_Params  : Nat       := 0;
+      First_Out_Param : Entity_Id := Empty;
+
       function Is_Class_Wide_Default (D : Node_Id) return Boolean;
       --  Check whether the default has a class-wide type. After analysis the
       --  default has the type of the formal, so we must also check explicitly
@@ -6895,8 +6893,8 @@ package body Sem_Ch6 is
                elsif Is_Value_Type (Formal_Type) then
                   null;
 
-               elsif Nkind (Parent (T)) /= N_Access_Function_Definition
-                 and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
+               elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
+                                               N_Access_Procedure_Definition)
                then
                   Error_Msg_N ("invalid use of incomplete type", Param_Spec);
 
@@ -7075,10 +7073,24 @@ package body Sem_Ch6 is
                   Apply_Scalar_Range_Check (Default, Formal_Type);
                end if;
             end if;
+
+         elsif Ekind (Formal) = E_Out_Parameter then
+            Num_Out_Params := Num_Out_Params + 1;
+
+            if Num_Out_Params = 1 then
+               First_Out_Param := Formal;
+            end if;
+
+         elsif Ekind (Formal) = E_In_Out_Parameter then
+            Num_Out_Params := Num_Out_Params + 1;
          end if;
 
          Next (Param_Spec);
       end loop;
+
+      if Present (First_Out_Param) and then Num_Out_Params = 1 then
+         Set_Is_Only_Out_Parameter (First_Out_Param);
+      end if;
    end Process_Formals;
 
    ----------------------------

gcc/ada/sem_ch6.ads

@@ -176,6 +176,16 @@ package Sem_Ch6 is
    --  access parameter are attached to the Related_Nod which comes from the
    --  context.
 
+   procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id);
+   --  If there is a separate spec for a subprogram or generic subprogram, the
+   --  formals of the body are treated as references to the corresponding
+   --  formals of the spec. This reference does not count as an actual use of
+   --  the formal, in order to diagnose formals that are unused in the body.
+   --  This procedure is also used in renaming_as_body declarations, where
+   --  the formals of the specification must be treated as body formals that
+   --  correspond to the previous subprogram declaration, and not as new
+   --  entities with their defining entry in the cross-reference information.
+
    procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id);
    --  If the formals of a subprogram are unconstrained, build a subtype
    --  declaration that uses the bounds or discriminants of the actual to