exp_ch5.adb (Expand_N_Assignment_Statement): Do left-side validity check right…

exp_ch5.adb (Expand_N_Assignment_Statement): Do left-side validity check right away so it does not get skipped for early...

2009-07-23  Robert Dewar  <dewar@adacore.com>

	* exp_ch5.adb (Expand_N_Assignment_Statement): Do left-side validity
	check right away so it does not get skipped for early returns, e.g.
	array assignments.
	(Expand_N_Assignment_Statement): Don't propagate Is_Known_Valid to
	left-side unless we really know the value is valid.

	* errout.adb, exp_ch3.adb, exp_disp.ads, sinfo.ads, exp_disp.adb: Minor
	reformatting. Minor code reorganization. Add comments.

From-SVN: r149978

gcc/ada/ChangeLog

 2009-07-23  Robert Dewar  <dewar@adacore.com>
 
+	* exp_ch5.adb (Expand_N_Assignment_Statement): Do left-side validity
+	check right away so it does not get skipped for early returns, e.g.
+	array assignments.
+	(Expand_N_Assignment_Statement): Don't propagate Is_Known_Valid to
+	left-side unless we really know the value is valid.
+
+	* errout.adb, exp_ch3.adb, exp_disp.ads, sinfo.ads, exp_disp.adb: Minor
+	reformatting. Minor code reorganization. Add comments.
+
+2009-07-23  Robert Dewar  <dewar@adacore.com>
+
 	* get_scos.adb (Skip_EOL): Fix error of mishandling end of line after
 	complex condition.
 

gcc/ada/errout.adb

@@ -1101,7 +1101,7 @@ package body Errout is
 
          if No_Warnings (N) or else No_Warnings (E) then
 
-            --  Disable as well continuation messages, if any.
+            --  Disable any continuation messages as well
 
             Last_Killed := True;
             return;

gcc/ada/exp_ch3.adb

@@ -2322,6 +2322,8 @@ package body Exp_Ch3 is
                   New_Reference_To
                     (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
 
+            --  Following code needs a comment ???
+
             if Generate_SCIL then
                Prepend_To (Init_Tags_List,
                  New_Scil_Node

gcc/ada/exp_ch5.adb

@@ -1483,6 +1483,20 @@ package body Exp_Ch5 is
          return;
       end if;
 
+      --  Defend against invalid subscripts on left side if we are in standard
+      --  validity checking mode. No need to do this if we are checking all
+      --  subscripts.
+
+      --  Note that we do this right away, because there are some early return
+      --  paths in this procedure, and this is required on all paths.
+
+      if Validity_Checks_On
+        and then Validity_Check_Default
+        and then not Validity_Check_Subscripts
+      then
+         Check_Valid_Lvalue_Subscripts (Lhs);
+      end if;
+
       --  Ada 2005 (AI-327): Handle assignment to priority of protected object
 
       --  Rewrite an assignment to X'Priority into a run-time call
@@ -2065,14 +2079,31 @@ package body Exp_Ch5 is
             --  Here the right side is valid, so it is fine. The case to deal
             --  with is when the left side is a local variable reference whose
             --  value is not currently known to be valid. If this is the case,
-            --  and the assignment appears in an unconditional context, then we
-            --  can mark the left side as now being valid.
+            --  and the assignment appears in an unconditional context, then
+            --  we can mark the left side as now being valid if one of these
+            --  conditions holds:
+
+            --    The expression of the right side has Do_Range_Check set so
+            --    that we know a range check will be performed. Note that it
+            --    can be the case that a range check is omitted because we
+            --    make the assumption that we can assume validity for operands
+            --    appearing in the right side in determining whether a range
+            --    check is required
+
+            --    The subtype of the right side matches the subtype of the
+            --    left side. In this case, even though we have not checked
+            --    the range of the right side, we know it is in range of its
+            --    subtype if the expression is valid.
 
             if Is_Local_Variable_Reference (Lhs)
               and then not Is_Known_Valid (Entity (Lhs))
               and then In_Unconditional_Context (N)
             then
-               Set_Is_Known_Valid (Entity (Lhs), True);
+               if Do_Range_Check (Rhs)
+                 or else Etype (Lhs) = Etype (Rhs)
+               then
+                  Set_Is_Known_Valid (Entity (Lhs), True);
+               end if;
             end if;
 
          --  Case where right side may be invalid in the sense of the RM
@@ -2145,17 +2176,6 @@ package body Exp_Ch5 is
          end if;
       end if;
 
-      --  Defend against invalid subscripts on left side if we are in standard
-      --  validity checking mode. No need to do this if we are checking all
-      --  subscripts.
-
-      if Validity_Checks_On
-        and then Validity_Check_Default
-        and then not Validity_Check_Subscripts
-      then
-         Check_Valid_Lvalue_Subscripts (Lhs);
-      end if;
-
    exception
       when RE_Not_Available =>
          return;

gcc/ada/exp_disp.adb

@@ -643,6 +643,8 @@ package body Exp_Disp is
          Typ := Non_Limited_View (Typ);
       end if;
 
+      --  Comment needed ???
+
       if Generate_SCIL then
          Insert_Action (Call_Node,
            New_Scil_Node
@@ -1611,9 +1613,8 @@ package body Exp_Disp is
 
    function Get_Scil_Node_Kind (Node : Node_Id) return Scil_Node_Kind is
    begin
-      pragma Assert (Nkind (Node) = N_Null_Statement
-        and then Is_Scil_Node (Node));
-
+      pragma Assert
+        (Nkind (Node) = N_Null_Statement and then Is_Scil_Node (Node));
       return Scil_Node_Kind'Val (UI_To_Int (Scil_Nkind (Node)));
    end Get_Scil_Node_Kind;
 
@@ -4242,6 +4243,8 @@ package body Exp_Disp is
                   New_Reference_To
                     (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
 
+            --  Comment needed ???
+
             if Generate_SCIL then
                Insert_Before (Last (Result),
                  New_Scil_Node
@@ -4313,6 +4316,8 @@ package body Exp_Disp is
                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
                                     Constraints => DT_Constr_List))));
 
+            --  Comment needed ???
+
             if Generate_SCIL then
                Insert_Before (Last (Result),
                  New_Scil_Node
@@ -4347,6 +4352,8 @@ package body Exp_Disp is
                             (RTE_Record_Component (RE_Prims_Ptr), Loc)),
                       Attribute_Name => Name_Address))));
 
+            --  Comment needed ???
+
             if Generate_SCIL then
                Insert_Before (Last (Result),
                  New_Scil_Node
@@ -5123,6 +5130,8 @@ package body Exp_Disp is
                 Expression => Make_Aggregate (Loc,
                   Expressions => DT_Aggr_List)));
 
+            --  Comment needed ???
+
             if Generate_SCIL then
                Insert_Before (Last (Result),
                  New_Scil_Node
@@ -5437,6 +5446,8 @@ package body Exp_Disp is
                 Expression => Make_Aggregate (Loc,
                   Expressions => DT_Aggr_List)));
 
+            --  Comment needed ???
+
             if Generate_SCIL then
                Insert_Before (Last (Result),
                  New_Scil_Node
@@ -6135,6 +6146,8 @@ package body Exp_Disp is
                             (RTE_Record_Component (RE_Prims_Ptr), Loc)),
                       Attribute_Name => Name_Address))));
 
+            --  Comment needed ???
+
             if Generate_SCIL then
                Insert_Before (Last (Result),
                  New_Scil_Node
@@ -6178,6 +6191,8 @@ package body Exp_Disp is
                             (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
                       Attribute_Name => Name_Address))));
 
+            --  Comment needed ???
+
             if Generate_SCIL then
                Insert_Before (Last (Result),
                  New_Scil_Node
@@ -6400,8 +6415,9 @@ package body Exp_Disp is
       Res : constant Node_Id := Duplicate_Subexpr (From);
    begin
       if Is_Access_Type (Etype (From)) then
-         return Make_Explicit_Dereference (Sloc (From),
-                  Prefix => Res);
+         return
+           Make_Explicit_Dereference (Sloc (From),
+             Prefix => Res);
       else
          return Res;
       end if;
@@ -6417,16 +6433,14 @@ package body Exp_Disp is
       Entity       : Entity_Id := Empty;
       Target_Prim  : Entity_Id := Empty) return Node_Id
    is
-      New_N : Node_Id;
-
+      New_N : constant Node_Id :=
+                New_Node (N_Null_Statement, Sloc (Related_Node));
    begin
-      New_N := New_Node (N_Null_Statement, Sloc (Related_Node));
       Set_Is_Scil_Node      (New_N);
       Set_Scil_Nkind        (New_N, UI_From_Int (Scil_Node_Kind'Pos (Nkind)));
       Set_Scil_Related_Node (New_N, Related_Node);
       Set_Entity            (New_N, Entity);
       Set_Scil_Target_Prim  (New_N, Target_Prim);
-
       return New_N;
    end New_Scil_Node;
 

gcc/ada/exp_disp.ads

@@ -34,8 +34,10 @@ package Exp_Disp is
    -- SCIL Node Type Definition --
    -------------------------------
 
-   type Scil_Node_Kind is (
-      Unused,
+   --  Comment required! ??? What is this type???
+
+   type Scil_Node_Kind is
+     (Unused,
       IP_Tag_Init,
       Dispatching_Call,
       Dispatch_Table_Object_Init,

gcc/ada/sinfo.ads

@@ -3842,6 +3842,12 @@ package Sinfo is
       --  Entity (Node4-Sem)
       --  Scil_Target_Prim (Node2-Sem)
 
+      --  What are the above Scil fields for, and what has this got to do with
+      --  null statements. MAJOR MISSING DOC HERE ??? All -Sem fields must be
+      --  individually documented in the list of -Sem fields at the start of
+      --  Sinfo, and we sure need significant documentation here explaining
+      --  what on earth is going on with null statements!
+
       ----------------
       -- 5.1  Label --
       ----------------
@@ -7234,6 +7240,8 @@ package Sinfo is
       N_Goto_Statement,
       N_Loop_Statement,
       N_Null_Statement,
+      --  N_Null_Statement now has an Entity field, but is not in N_Has_Entity.
+      --  Either fix this, or document this peculiar irregularity ???
       N_Raise_Statement,
       N_Requeue_Statement,
       N_Return_Statement, -- renamed as N_Simple_Return_Statement below