Skip to content

R
riscv-gcc-1
Commit 7b76e805 by Robert Dewar Committed by Arnaud Charlet
Options

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
parent 7d304f61
Showing with 93 additions and 45 deletions
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;
......
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)
......
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);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment