a-stzsup.adb, [...]: Fix warnings for range tests optimized out.

2007-08-14  Robert Dewar  <dewar@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* a-stzsup.adb, nlists.adb, lib-util.adb, treepr.adb, 
	a-stwisu.adb, a-strsup.adb: Fix warnings for range
	tests optimized out.

	* exp_ch4.adb (Expand_N_In): Add warnings for range tests optimized out.
	(Get_Allocator_Final_List): For the case of an anonymous access type
	that has a specified Associated_Final_Chain, do not go up to the
	enclosing scope.
	(Expand_N_Type_Conversion): Test for the case of renamings of access
	parameters when deciding whether to apply a run-time accessibility
	check.
	(Convert_Aggr_In_Allocator): Use Insert_Actions to place expanded
	aggregate code before allocator, and ahead of declaration for
	temporary, to prevent access before elaboration when the allocator is
	an actual for an access parameter.
	(Expand_N_Type_Conversion): On an access type conversion involving an
	access parameter, do not apply an accessibility check when the
	operand's original node was an attribute other than 'Access. We now
	create access conversions for the expansion of 'Unchecked_Access and
	'Unrestricted_Access in certain cases and clearly accessibility should
	not be checked for those.

	* exp_ch6.ads, exp_ch6.adb (Add_Call_By_Copy_Code): For an actual that
	includes a type conversion of a packed component that has been expanded,
	recover the original expression for the object, and use this expression
	in the post-call assignment statement, so that the assignment is made
	to the object and not to a back-end temporary.
	(Freeze_Subprogram): In case of primitives of tagged types not defined
	at the library level force generation of code to register the primitive
	in the dispatch table. In addition some code reorganization has been
	done to leave the implementation clear.
	(Expand_Call): When expanding an inherited implicit conversion,
	preserve the type of the inherited function after the intrinsic
	operation has been expanded.

	* exp_ch2.ads, exp_ch2.adb
	(Expand_Entry_Parameter.In_Assignment_Context): An implicit dereference
	of an entry formal appearing in an assignment statement does not assign
	to the formal.
	(Expand_Current_Value): Instead of calling a routine to determine
	whether the prefix of an attribute reference should be optimized or
	not, prevent the optimization of such prefixes all together.

	* lib-xref.adb (Generate_Reference.Is_On_LHS): An indexed or selected
	component whose prefix is known to be of an access type is an implicit
	dereference and does not assign to the prefix.

From-SVN: r127411

gcc/ada/a-strsup.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2003-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 2003-2007, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -783,7 +783,7 @@ package body Ada.Strings.Superbounded is
       Index  : Positive) return Character
    is
    begin
-      if Index in 1 .. Source.Current_Length then
+      if Index <= Source.Current_Length then
          return Source.Data (Index);
       else
          raise Strings.Index_Error;

gcc/ada/a-stwisu.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2003-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 2003-2007, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -784,7 +784,7 @@ package body Ada.Strings.Wide_Superbounded is
       Index  : Positive) return Wide_Character
    is
    begin
-      if Index in 1 .. Source.Current_Length then
+      if Index <= Source.Current_Length then
          return Source.Data (Index);
       else
          raise Strings.Index_Error;

gcc/ada/a-stzsup.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2003-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 2003-2007, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -787,7 +787,7 @@ package body Ada.Strings.Wide_Wide_Superbounded is
       Index  : Positive) return Wide_Wide_Character
    is
    begin
-      if Index in 1 .. Source.Current_Length then
+      if Index <= Source.Current_Length then
          return Source.Data (Index);
       else
          raise Strings.Index_Error;

gcc/ada/exp_ch2.adb

@@ -32,15 +32,16 @@ with Exp_Smem; use Exp_Smem;
 with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
 with Exp_VFpt; use Exp_VFpt;
+with Namet;    use Namet;
 with Nmake;    use Nmake;
 with Opt;      use Opt;
 with Sem;      use Sem;
-with Sem_Attr; use Sem_Attr;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
 with Sem_Warn; use Sem_Warn;
 with Sinfo;    use Sinfo;
+with Snames;   use Snames;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 
@@ -90,13 +91,13 @@ package body Exp_Ch2 is
    procedure Expand_Entry_Parameter (N : Node_Id);
    --  A reference to an entry parameter is modified to be a reference to the
    --  corresponding component of the entry parameter record that is passed by
-   --  the runtime to the accept body procedure
+   --  the runtime to the accept body procedure.
 
    procedure Expand_Formal (N : Node_Id);
    --  A reference to a formal parameter of a protected subprogram is expanded
    --  into the corresponding formal of the unprotected procedure used to
    --  represent the operation within the protected object. In other cases
-   --  Expand_Formal is a noop.
+   --  Expand_Formal is a no-op.
 
    procedure Expand_Protected_Private (N : Node_Id);
    --  A reference to a private component of a protected type is expanded to a
@@ -156,11 +157,18 @@ package body Exp_Ch2 is
 
          and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
 
-         --  Same for attribute references that require a simple name prefix
+         --  Do not replace the prefixes of attribute references, since this
+         --  causes trouble with cases like 4'Size. Also for Name_Asm_Input and
+         --  Name_Asm_Output, don't do replacement anywhere, since we can have
+         --  lvalue references in the arguments.
 
          and then not (Nkind (Parent (N)) = N_Attribute_Reference
-                         and then Requires_Simple_Name_Prefix (
-                                    Attribute_Name (Parent (N))))
+                         and then
+                           (Attribute_Name (Parent (N)) = Name_Asm_Input
+                              or else
+                            Attribute_Name (Parent (N)) = Name_Asm_Output
+                              or else
+                            Prefix (Parent (N)) = N))
 
       then
          --  Case of Current_Value is a compile time known value
@@ -421,6 +429,11 @@ package body Exp_Ch2 is
 
       function In_Assignment_Context (N : Node_Id) return Boolean is
       begin
+         --  Case of use in a call
+
+         --  ??? passing a formal as actual for a mode IN formal is
+         --  considered as an assignment?
+
          if Nkind (Parent (N)) = N_Procedure_Call_Statement
            or else Nkind (Parent (N)) = N_Entry_Call_Statement
            or else
@@ -429,15 +442,25 @@ package body Exp_Ch2 is
          then
             return True;
 
+         --  Case of a parameter association: climb up to enclosing call
+
          elsif Nkind (Parent (N)) = N_Parameter_Association then
             return In_Assignment_Context (Parent (N));
 
+         --  Case of a selected component, indexed component or slice prefix:
+         --  climb up the tree, unless the prefix is of an access type (in
+         --  which case there is an implicit dereference, and the formal itself
+         --  is not being assigned to).
+
          elsif (Nkind (Parent (N)) = N_Selected_Component
                  or else Nkind (Parent (N)) = N_Indexed_Component
                  or else Nkind (Parent (N)) = N_Slice)
+           and then N = Prefix (Parent (N))
+           and then not Is_Access_Type (Etype (N))
            and then In_Assignment_Context (Parent (N))
          then
             return True;
+
          else
             return False;
          end if;
@@ -670,6 +693,8 @@ package body Exp_Ch2 is
    --  through an address clause is rewritten as dereference as well.
 
    function Param_Entity (N : Node_Id) return Entity_Id is
+      Renamed_Obj : Node_Id;
+
    begin
       --  Simple reference case
 
@@ -677,10 +702,22 @@ package body Exp_Ch2 is
          if Is_Formal (Entity (N)) then
             return Entity (N);
 
-         elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration
-           and then Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
-         then
-            return Entity (N);
+         --  Handle renamings of formal parameters and formals of tasks that
+         --  are rewritten as renamings.
+
+         elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then
+            Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N)));
+
+            if Is_Entity_Name (Renamed_Obj)
+              and then Is_Formal (Entity (Renamed_Obj))
+            then
+               return Entity (Renamed_Obj);
+
+            elsif
+              Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
+            then
+               return Entity (N);
+            end if;
          end if;
 
       else

gcc/ada/exp_ch2.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-1997 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -37,9 +37,10 @@ package Exp_Ch2 is
    --  Given an expression N, determines if the expression is a reference
    --  to a formal (of a subprogram or entry), and if so returns the Id
    --  of the corresponding formal entity, otherwise returns Empty. The
-   --  reason that this is in Exp_Ch2 is that it has to deal with the
-   --  case where the reference is to an entry formal, and has been
-   --  expanded already. Since Exp_Ch2 is in charge of the expansion, it
-   --  is best suited to knowing how to detect this case.
+   --  reason that this is in Exp_Ch2 is that it has to deal with the case
+   --  where the reference is to an entry formal, and has been expanded
+   --  already. Since Exp_Ch2 is in charge of the expansion, it is best
+   --  suited to knowing how to detect this case. Also handles the case
+   --  of references to renamings of formals.
 
 end Exp_Ch2;

gcc/ada/exp_ch6.ads

@@ -72,7 +72,7 @@ package Exp_Ch6 is
       --  Present if result type contains tasks. Master associated with
       --  calling context.
       BIP_Activation_Chain,
-      --  Present if result type contains tasks. Caller's activation chain.
+      --  Present if result type contains tasks. Caller's activation chain
       BIP_Object_Access);
       --  Present for all build-in-place functions. Address at which to place
       --  the return object, or null if BIP_Alloc_Form indicates
@@ -114,9 +114,9 @@ package Exp_Ch6 is
    --  expression applied to such a call; otherwise returns False.
 
    function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean;
-   --  Ada 2005 (AI-318-02): Returns True if N is an N_Return_Statement or
-   --  N_Extended_Return_Statement and it applies to a build-in-place function
-   --  or generic function.
+   --  Ada 2005 (AI-318-02): Returns True if N is an N_Simple_Return_Statement
+   --  or N_Extended_Return_Statement and it applies to a build-in-place
+   --  function or generic function.
 
    procedure Make_Build_In_Place_Call_In_Allocator
      (Allocator     : Node_Id;

gcc/ada/lib-util.adb

@@ -74,13 +74,19 @@ package body Lib.Util is
    --  Start of processing for Write_Info_Char_Code
 
    begin
-      if Code in 16#00# .. 16#7F# then
+      --  00 .. 7F
+
+      if Code <= 16#7F# then
          Write_Info_Char (Character'Val (Code));
 
-      elsif Code in 16#80# .. 16#FF# then
+      --  80 .. FF
+
+      elsif Code <= 16#FF# then
          Write_Info_Char ('U');
          Write_Info_Hex_Byte (Natural (Code));
 
+      --  0100 .. FFFF
+
       else
          Write_Info_Char ('W');
          Write_Info_Hex_Byte (Natural (Code / 256));

gcc/ada/lib-xref.adb

@@ -223,13 +223,20 @@ package body Lib.Xref is
       --   Prefix    Of an indexed or selected component that is present in a
       --             subtree rooted by an assignment statement. There is no
       --             restriction of nesting of components, thus cases such as
-      --             A.B(C).D are handled properly.
+      --             A.B (C).D are handled properly.
+      --             However a prefix of a dereference (either implicit or
+      --             explicit) is never considered as on a LHS.
 
       ---------------
       -- Is_On_LHS --
       ---------------
 
-      --  Couldn't we use Is_Lvalue or whatever it is called ???
+      --  ??? There are several routines here and there that perform a similar
+      --      (but subtly different) computation, which should be factored:
+
+      --      Sem_Util.May_Be_Lvalue
+      --      Sem_Util.Known_To_Be_Assigned
+      --      Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context
 
       function Is_On_LHS (Node : Node_Id) return Boolean is
          N : Node_Id := Node;
@@ -247,13 +254,28 @@ package body Lib.Xref is
 
          while Nkind (Parent (N)) /= N_Assignment_Statement loop
 
-            --  Check whether the parent is a component and the
-            --  current node is its prefix.
+            --  Check whether the parent is a component and the current node
+            --  is its prefix, but return False if the current node has an
+            --  access type, as in that case the selected or indexed component
+            --  is an implicit dereference, and the LHS is the designated
+            --  object, not the access object.
+
+            --  ??? case of a slice assignment?
+
+            --  ??? Note that in some cases this is called too early
+            --  (see comments in Sem_Ch8.Find_Direct_Name), at a point where
+            --  the tree is not fully typed yet. In that case we may lack
+            --  an Etype for N, and we must disable the check for an implicit
+            --  dereference. If the dereference is on an LHS, this causes a
+            --  false positive.
 
             if (Nkind (Parent (N)) = N_Selected_Component
                   or else
                 Nkind (Parent (N)) = N_Indexed_Component)
               and then Prefix (Parent (N)) = N
+              and then not (Present (Etype (N))
+                              and then
+                            Is_Access_Type (Etype (N)))
             then
                N := Parent (N);
             else
@@ -370,7 +392,7 @@ package body Lib.Xref is
          --  a left hand side. We also set the Referenced_As_LHS flag of a
          --  prefix of selected or indexed component.
 
-         if Ekind (E) = E_Variable
+         if (Ekind (E) = E_Variable or else Is_Formal (E))
            and then Is_On_LHS (N)
          then
             Set_Referenced_As_LHS (E);
@@ -1004,9 +1026,8 @@ package body Lib.Xref is
                end if;
             end if;
 
-            --  Collect inherited primitive operations that may be
-            --  declared in another unit and have no visible reference
-            --  in the current one.
+            --  Collect inherited primitive operations that may be declared in
+            --  another unit and have no visible reference in the current one.
 
             if Is_Type (Ent)
               and then Is_Tagged_Type (Ent)

gcc/ada/nlists.adb

@@ -304,7 +304,7 @@ package body Nlists is
       if List = No_List then
          return Empty;
       else
-         pragma Assert (List in First_List_Id .. Lists.Last);
+         pragma Assert (List <= Lists.Last);
          return Lists.Table (List).First;
       end if;
    end First;
@@ -630,7 +630,7 @@ package body Nlists is
 
    function Last (List : List_Id) return Node_Id is
    begin
-      pragma Assert (List in First_List_Id .. Lists.Last);
+      pragma Assert (List <= Lists.Last);
       return Lists.Table (List).Last;
    end Last;
 
@@ -1028,7 +1028,7 @@ package body Nlists is
 
    function Parent (List : List_Id) return Node_Id is
    begin
-      pragma Assert (List in First_List_Id .. Lists.Last);
+      pragma Assert (List <= Lists.Last);
       return Lists.Table (List).Parent;
    end Parent;
 
@@ -1355,7 +1355,7 @@ package body Nlists is
 
    procedure Set_Parent (List : List_Id; Node : Node_Id) is
    begin
-      pragma Assert (List in First_List_Id .. Lists.Last);
+      pragma Assert (List <= Lists.Last);
       Lists.Table (List).Parent := Node;
    end Set_Parent;
 

gcc/ada/treepr.adb

@@ -796,8 +796,7 @@ package body Treepr is
 
       Notes := False;
 
-      if N not in
-        Atree_Private_Part.Nodes.First .. Atree_Private_Part.Nodes.Last then
+      if N > Atree_Private_Part.Nodes.Last then
          Print_Str (" (no such node)");
          Print_Eol;
          return;