gnat1drv.adb (Gnat1drv): Properly set new flag Opt.Real_VMS_Target

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

	* gnat1drv.adb (Gnat1drv): Properly set new flag Opt.Real_VMS_Target

	* layout.adb (Resolve_Attribute, case 'Access): If designated type of
	context is a limited view, use non-limited view when available. If the
	non-limited view is an unconstrained array, this enforces consistency
	requirements in 3.10.2 (27).
	(Layout_Type): For an access type whose designated type is a limited
	view, examine its declaration to determine if it is an unconstrained
	array, and size the access type accordingly.
	(Layout_Type): Do not force 32-bits for convention c subprogram
	pointers in -gnatdm mode, only if real vms target.

	* sem_attr.adb (Analyze_Access_Attribute): Use new flag
	Has_Pragma_Inline_Always instead of obsolete function Is_Always_Inlined
	(Analyze_Access_Attribute,Attribute_Address): Remove checks for
	violations of the No_Implicit_Dynamic_Code restriction.
	(Resolve_Attribute, case 'Access): If designated type of context is a
	limited view, use non-limited view when available. If the non-limited
	view is an unconstrained array, this enforces consistency requirements
	in 3.10.2 (27).
	(Layout_Type): For an access type whose designated type is a limited
	view, examine its declaration to determine if it is an unconstrained
	array, and size the access type accordingly.

From-SVN: r130840

3 files changed, 93 insertions, 45 deletions

diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 743520ee799..dda21ce8e98 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -370,6 +370,12 @@ begin
          Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian;
       end if;
 
+      --  Deal with forcing OpenVMS switches Ture if debug flag M is set, but
+      --  record the setting of Targparm.Open_VMS_On_Target in True_VMS_Target
+      --  before doing this.
+
+      Opt.True_VMS_Target := Targparm.OpenVMS_On_Target;
+
       if Debug_Flag_M then
          Targparm.OpenVMS_On_Target := True;
          Hostparm.OpenVMS := True;
diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb
index f92a37d4d02..a3ed7579451 100644
--- a/gcc/ada/layout.adb
+++ b/gcc/ada/layout.adb
@@ -2300,6 +2300,8 @@ package body Layout is
    -----------------
 
    procedure Layout_Type (E : Entity_Id) is
+      Desig_Type : Entity_Id;
+
    begin
       --  For string literal types, for now, kill the size always, this
       --  is because gigi does not like or need the size to be set ???
@@ -2321,6 +2323,18 @@ package body Layout is
 
       if Is_Access_Type (E) then
 
+         Desig_Type :=  Underlying_Type (Designated_Type (E));
+
+         --  If we only have a limited view of the type, see whether the
+         --  non-limited view is available.
+
+         if From_With_Type (Designated_Type (E))
+           and then Ekind (Designated_Type (E)) = E_Incomplete_Type
+           and then Present (Non_Limited_View (Designated_Type (E)))
+         then
+            Desig_Type := Non_Limited_View (Designated_Type (E));
+         end if;
+
          --  If Esize already set (e.g. by a size clause), then nothing
          --  further to be done here.
 
@@ -2344,11 +2358,10 @@ package body Layout is
          --  a fat pointer is used (pointer-to-unconstrained array case),
          --  twice the address size to accommodate a fat pointer.
 
-         elsif Present (Underlying_Type (Designated_Type (E)))
-            and then Is_Array_Type (Underlying_Type (Designated_Type (E)))
-            and then not Is_Constrained (Underlying_Type (Designated_Type (E)))
-            and then not Has_Completion_In_Body (Underlying_Type
-                                                 (Designated_Type (E)))
+         elsif Present (Desig_Type)
+            and then Is_Array_Type (Desig_Type)
+            and then not Is_Constrained (Desig_Type)
+            and then not Has_Completion_In_Body (Desig_Type)
             and then not Debug_Flag_6
          then
             Init_Size (E, 2 * System_Address_Size);
@@ -2365,6 +2378,19 @@ package body Layout is
                  ("?this access type does not correspond to C pointer", E);
             end if;
 
+         --  If the designated type is a limited view it is unanalyzed. We
+         --  can examine the declaration itself to determine whether it will
+         --  need a fat pointer.
+
+         elsif Present (Desig_Type)
+            and then Present (Parent (Desig_Type))
+            and then Nkind (Parent (Desig_Type)) = N_Full_Type_Declaration
+            and then
+              Nkind (Type_Definition (Parent (Desig_Type)))
+                 = N_Unconstrained_Array_Definition
+         then
+            Init_Size (E, 2 * System_Address_Size);
+
          --  When the target is AAMP, access-to-subprogram types are fat
          --  pointers consisting of the subprogram address and a static
          --  link (with the exception of library-level access types,
@@ -2395,7 +2421,10 @@ package body Layout is
          --  for this purpose, since it would be weird not to inherit the size
          --  in this case.
 
-         if OpenVMS_On_Target
+         --  We do NOT do this if we are in -gnatdm mode on a non-VMS target
+         --  since in that case we want the normal pointer representation.
+
+         if Opt.True_VMS_Target
            and then (Convention (E) = Convention_C
                       or else
                      Convention (E) = Convention_CPP)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 1a0b0c82d4f..4bfce0c6cb9 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -534,14 +534,7 @@ package body Sem_Attr is
          if Is_Entity_Name (P)
            and then Is_Overloadable (Entity (P))
          then
-            --  Not allowed for nested subprograms if No_Implicit_Dynamic_Code
-            --  restriction set (since in general a trampoline is required).
-
-            if not Is_Library_Level_Entity (Entity (P)) then
-               Check_Restriction (No_Implicit_Dynamic_Code, P);
-            end if;
-
-            if Is_Always_Inlined (Entity (P)) then
+            if Has_Pragma_Inline_Always (Entity (P)) then
                Error_Attr_P
                  ("prefix of % attribute cannot be Inline_Always subprogram");
             end if;
@@ -1399,7 +1392,6 @@ package body Sem_Attr is
          then
             Error_Attr ("only allowed prefix for % attribute is Standard", P);
          end if;
-
       end Check_Standard_Prefix;
 
       ----------------------------
@@ -1921,10 +1913,6 @@ package body Sem_Attr is
 
             begin
                if Is_Subprogram (Ent) then
-                  if not Is_Library_Level_Entity (Ent) then
-                     Check_Restriction (No_Implicit_Dynamic_Code, P);
-                  end if;
-
                   Set_Address_Taken (Ent);
                   Kill_Current_Values (Ent);
 
@@ -1934,7 +1922,7 @@ package body Sem_Attr is
                   --  errors about implicit uses of Address in the dispatch
                   --  table initialization).
 
-                  if Is_Always_Inlined (Entity (P))
+                  if Has_Pragma_Inline_Always (Entity (P))
                     and then Comes_From_Source (P)
                   then
                      Error_Attr_P
@@ -2809,6 +2797,20 @@ package body Sem_Attr is
             Error_Attr_P ("prefix of % attribute must be tagged");
          end if;
 
+      ---------------
+      -- Fast_Math --
+      ---------------
+
+      when Attribute_Fast_Math =>
+         Check_E0;
+         Check_Standard_Prefix;
+
+         if Opt.Fast_Math then
+            Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+         else
+            Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+         end if;
+
       -----------
       -- First --
       -----------
@@ -3869,6 +3871,9 @@ package body Sem_Attr is
          if Comes_From_Source (N) then
             Check_Not_Incomplete_Type;
          end if;
+
+         --  Set appropriate type
+
          Set_Etype (N, RTE (RE_Tag));
 
       -----------------
@@ -6914,6 +6919,7 @@ package body Sem_Attr is
            Attribute_Elab_Spec                |
            Attribute_Enabled                  |
            Attribute_External_Tag             |
+           Attribute_Fast_Math                |
            Attribute_First_Bit                |
            Attribute_Input                    |
            Attribute_Last_Bit                 |
@@ -7439,6 +7445,26 @@ package body Sem_Attr is
                end if;
             end if;
 
+            Des_Btyp := Designated_Type (Btyp);
+
+            if Ada_Version >= Ada_05
+              and then Is_Incomplete_Type (Des_Btyp)
+            then
+               --  Ada 2005 (AI-412): If the (sub)type is a limited view of an
+               --  imported entity, and the non-limited view is visible, make
+               --  use of it. If it is an incomplete subtype, use the base type
+               --  in any case.
+
+               if From_With_Type (Des_Btyp)
+                 and then Present (Non_Limited_View (Des_Btyp))
+               then
+                  Des_Btyp := Non_Limited_View (Des_Btyp);
+
+               elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then
+                  Des_Btyp := Etype (Des_Btyp);
+               end if;
+            end if;
+
             if (Attr_Id = Attribute_Access
                   or else
                 Attr_Id = Attribute_Unchecked_Access)
@@ -7489,23 +7515,6 @@ package body Sem_Attr is
                   Nom_Subt := Base_Type (Nom_Subt);
                end if;
 
-               Des_Btyp := Designated_Type (Btyp);
-
-               if Ekind (Des_Btyp) = E_Incomplete_Subtype then
-
-                  --  Ada 2005 (AI-412): Subtypes of incomplete types visible
-                  --  through a limited with clause or regular incomplete
-                  --  subtypes.
-
-                  if From_With_Type (Des_Btyp)
-                    and then Present (Non_Limited_View (Des_Btyp))
-                  then
-                     Des_Btyp := Non_Limited_View (Des_Btyp);
-                  else
-                     Des_Btyp := Etype (Des_Btyp);
-                  end if;
-               end if;
-
                if Is_Tagged_Type (Designated_Type (Typ)) then
 
                   --  If the attribute is in the context of an access
@@ -7568,16 +7577,20 @@ package body Sem_Attr is
                --  (because access values must be assumed to designate mutable
                --  objects when designated type does not impose a constraint).
 
-               elsif not Subtypes_Statically_Match (Des_Btyp, Nom_Subt)
+               elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then
+                  null;
+
+               elsif Has_Discriminants (Designated_Type (Typ))
+                 and then not Is_Constrained (Des_Btyp)
                  and then
-                   not (Has_Discriminants (Designated_Type (Typ))
-                          and then not Is_Constrained (Des_Btyp)
-                          and then
-                            (Ada_Version < Ada_05
-                              or else
-                                not Has_Constrained_Partial_View
-                                      (Designated_Type (Base_Type (Typ)))))
+                   (Ada_Version < Ada_05
+                     or else
+                       not Has_Constrained_Partial_View
+                             (Designated_Type (Base_Type (Typ))))
                then
+                  null;
+
+               else
                   Error_Msg_F
                     ("object subtype must statically match "
                      & "designated subtype", P);