Skip to content

R
riscv-gcc-1
Commit 75965852 by Arnaud Charlet
Options

[multiple changes] 

2012-07-12  Vasiliy Fofanov  <fofanov@adacore.com>

	* vms_data.ads: Add VMS qualifiers for -gnatn1/2 switches.

2012-07-12  Thomas Quinot  <quinot@adacore.com>

	* exp_ch5.adb, exp_pakd.adb, rtsfind.ads, freeze.adb, sem_util.adb,
	sem_util.ads, exp_aggr.adb
	(Exp_Aggr.Packed_Array_Aggregate_Handled): Simplify processing
	for reverse storage order aggregate.
	(Exp_Pakd.Byte_Swap): New utility routine used by...
	(Exp_Pakd.Expand_Bit_Packed_Element_Set,
	Expand_Packed_Element_Reference): For the case of a free-standing
	packed array with reverse storage order, perform byte swapping.
	(Rtsfind): Make new entities RE_Bswap_{16,32,64} available.
	(Freeze.Check_Component_Storage_Order): New utility routine
	to enforce legality rules for nested composite types whose
	enclosing composite has an explicitly defined Scalar_Storage_Order
	attribute.
	(Sem_Util.In_Reverse_Storage_Order_Object): Renamed from
	Sem_Util.In_Reverse_Storage_Order_Record, as SSO now applies to
	array types as well.
	(Exp_Ch5.Expand_Assign_Array): Remove now unnecessary kludge
	for change of scalar storage order in assignments. The Lhs and
	Rhs now always have the same scalar storage order.

2012-07-12  Hristian Kirtchev  <kirtchev@adacore.com>

	* g-debpoo.adb (Allocate): Add local constant
	No_Element. Initialize the allocated memory chunk to No_Element.

2012-07-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly
	the case of an instance of a child unit where a formal derived
	type DT is an extension of a type T declared in a parent unit,
	and the actual in the instance of the child is the type T declared
	in the parent instance, and that actual is not a derived type.

2012-07-12  Eric Botcazou  <ebotcazou@adacore.com>
	    Tristan Gingold  <gingold@adacore.com>

	* system-hpux-ia64.ads: Enable ZCX by default.
	* gcc-interface/Makefile.in: Use alternate stack on ia64-hpux.
	Change soext to .so.

From-SVN: r189439
parent 727e7b1a
Showing with 250 additions and 59 deletions
gcc/ada/ChangeLog
2012-07-12 Vasiliy Fofanov <fofanov@adacore.com>
* vms_data.ads: Add VMS qualifiers for -gnatn1/2 switches.
2012-07-12 Thomas Quinot <quinot@adacore.com>
* exp_ch5.adb, exp_pakd.adb, rtsfind.ads, freeze.adb, sem_util.adb,
sem_util.ads, exp_aggr.adb
(Exp_Aggr.Packed_Array_Aggregate_Handled): Simplify processing
for reverse storage order aggregate.
(Exp_Pakd.Byte_Swap): New utility routine used by...
(Exp_Pakd.Expand_Bit_Packed_Element_Set,
Expand_Packed_Element_Reference): For the case of a free-standing
packed array with reverse storage order, perform byte swapping.
(Rtsfind): Make new entities RE_Bswap_{16,32,64} available.
(Freeze.Check_Component_Storage_Order): New utility routine
to enforce legality rules for nested composite types whose
enclosing composite has an explicitly defined Scalar_Storage_Order
attribute.
(Sem_Util.In_Reverse_Storage_Order_Object): Renamed from
Sem_Util.In_Reverse_Storage_Order_Record, as SSO now applies to
array types as well.
(Exp_Ch5.Expand_Assign_Array): Remove now unnecessary kludge
for change of scalar storage order in assignments. The Lhs and
Rhs now always have the same scalar storage order.
2012-07-12 Hristian Kirtchev <kirtchev@adacore.com>
* g-debpoo.adb (Allocate): Add local constant
No_Element. Initialize the allocated memory chunk to No_Element.
2012-07-12 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly
the case of an instance of a child unit where a formal derived
type DT is an extension of a type T declared in a parent unit,
and the actual in the instance of the child is the type T declared
in the parent instance, and that actual is not a derived type.
2012-07-12 Eric Botcazou <ebotcazou@adacore.com>
Tristan Gingold <gingold@adacore.com>
* system-hpux-ia64.ads: Enable ZCX by default.
* gcc-interface/Makefile.in: Use alternate stack on ia64-hpux.
Change soext to .so.
2012-07-12 Robert Dewar <dewar@adacore.com>
* s-atopri.adb, s-atopri.ads: Minor reformatting.
......
gcc/ada/exp_aggr.adb
......@@ -6123,35 +6123,7 @@ package body Exp_Aggr is
Expr : Node_Id;
-- Next expression from positional parameters of aggregate
Enclosing_Aggregate : Node_Id;
In_Reverse_Storage_Order_Record : Boolean;
-- True if we are within an aggregate of a record type with
-- reversed storage order.
begin
-- Determine whether we are in a reversed storage order record
-- aggregate.
In_Reverse_Storage_Order_Record := False;
Enclosing_Aggregate := Parent (N);
while Present (Enclosing_Aggregate) loop
if Nkind (Enclosing_Aggregate) = N_Component_Association then
null;
elsif Nkind (Enclosing_Aggregate) /= N_Aggregate then
exit;
elsif Is_Record_Type (Etype (Enclosing_Aggregate))
and then Reverse_Storage_Order (Etype (Enclosing_Aggregate))
then
In_Reverse_Storage_Order_Record := True;
exit;
end if;
Enclosing_Aggregate := Parent (Enclosing_Aggregate);
end loop;
-- For little endian, we fill up the low order bits of the target
-- value. For big endian we fill up the high order bits of the
-- target value (which is a left justified modular value).
......@@ -6164,7 +6136,7 @@ package body Exp_Aggr is
if Bytes_Big_Endian
xor Debug_Flag_8
xor In_Reverse_Storage_Order_Record
xor Reverse_Storage_Order (Base_Type (Typ))
then
Shift := Csiz * (Len - 1);
Incr := -Csiz;
......
gcc/ada/exp_ch5.adb
......@@ -344,15 +344,6 @@ package body Exp_Ch5 is
elsif Has_Controlled_Component (L_Type) then
Loop_Required := True;
-- If changing scalar storage order and assigning a bit packed array,
-- force loop expansion.
elsif Is_Bit_Packed_Array (L_Type)
and then (In_Reverse_Storage_Order_Record (Rhs) /=
In_Reverse_Storage_Order_Record (Lhs))
then
Loop_Required := True;
-- If object is atomic, we cannot tolerate a loop
elsif Is_Atomic_Object (Act_Lhs)
......
gcc/ada/exp_pakd.adb
......@@ -543,6 +543,42 @@ package body Exp_Pakd is
-- array type on the fly). Such actions are inserted into the tree
-- directly using Insert_Action.
function Byte_Swap (N : Node_Id) return Node_Id;
-- Wrap N in a call to a byte swapping function, with appropriate type
-- conversions.
---------------
-- Byte_Swap --
---------------
function Byte_Swap (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
T : constant Entity_Id := Etype (N);
Swap_RE : RE_Id;
Swap_F : Entity_Id;
begin
pragma Assert (Esize (T) > 8);
if Esize (T) <= 16 then
Swap_RE := RE_Bswap_16;
elsif Esize (T) <= 32 then
Swap_RE := RE_Bswap_32;
else pragma Assert (Esize (T) <= 64);
Swap_RE := RE_Bswap_64;
end if;
Swap_F := RTE (Swap_RE);
return Unchecked_Convert_To
(T,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Swap_F, Loc),
Parameter_Associations =>
New_List (Unchecked_Convert_To (Etype (Swap_F), N))));
end Byte_Swap;
------------------------------
-- Compute_Linear_Subscript --
------------------------------
......@@ -1304,6 +1340,12 @@ package body Exp_Pakd is
-- contains the value. Otherwise Rhs_Val_Known is set False, and
-- the Rhs_Val is undefined.
Require_Byte_Swapping : Boolean := False;
-- True if byte swapping required, for the Reverse_Storage_Order case
-- when the packed array is a free-standing object. (If it is part
-- of a composite type, and therefore potentially not aligned on a byte
-- boundary, the swapping is done by the back-end).
function Get_Shift return Node_Id;
-- Function used to get the value of Shift, making sure that it
-- gets duplicated if the function is called more than once.
......@@ -1415,6 +1457,11 @@ package body Exp_Pakd is
-- Obj := atyp!((Obj and Mask1) or (shift_left (rhs, Shift)))
-- or in the case of a freestanding Reverse_Storage_Order object,
-- Obj := Swap (atyp!((Swap (Obj) and Mask1)
-- or (shift_left (rhs, Shift))))
-- where Mask1 is obtained by shifting Cmask left Shift bits
-- and then complementing the result.
......@@ -1485,6 +1532,14 @@ package body Exp_Pakd is
Set_Etype (Obj, T);
Set_Etype (New_Lhs, T);
Set_Etype (New_Rhs, T);
if Reverse_Storage_Order (Base_Type (Atyp))
and then Esize (T) > 8
and then not In_Reverse_Storage_Order_Object (Obj)
then
Require_Byte_Swapping := True;
New_Rhs := Byte_Swap (New_Rhs);
end if;
end;
-- First we deal with the "and"
......@@ -1615,6 +1670,11 @@ package body Exp_Pakd is
end;
end if;
if Require_Byte_Swapping then
Set_Etype (New_Rhs, Etype (Obj));
New_Rhs := Byte_Swap (New_Rhs);
end if;
-- Now do the rewrite
Rewrite (N,
......@@ -1977,6 +2037,17 @@ package body Exp_Pakd is
Lit := Make_Integer_Literal (Loc, Cmask);
Set_Print_In_Hex (Lit);
-- Byte swapping required for the Reverse_Storage_Order case, but
-- only for a free-standing object (see note on Require_Byte_Swapping
-- in Expand_Bit_Packed_Element_Set).
if Reverse_Storage_Order (Atyp)
and then Esize (Atyp) > 8
and then not In_Reverse_Storage_Order_Object (Obj)
then
Obj := Byte_Swap (Obj);
end if;
-- We generate a shift right to position the field, followed by a
-- masking operation to extract the bit field, and we finally do an
-- unchecked conversion to convert the result to the required target.
......@@ -2726,7 +2797,7 @@ package body Exp_Pakd is
-- We also have to adjust if the storage order is reversed
if Bytes_Big_Endian xor In_Reverse_Storage_Order_Record (Obj) then
if Bytes_Big_Endian xor Reverse_Storage_Order (Base_Type (Atyp)) then
Shift :=
Make_Op_Subtract (Loc,
Left_Opnd => Make_Integer_Literal (Loc, Osiz - Csiz),
......
gcc/ada/freeze.adb
......@@ -88,6 +88,14 @@ package body Freeze is
-- Apply legality checks to address clauses for object declarations,
-- at the point the object is frozen.
procedure Check_Component_Storage_Order
(Encl_Type : Entity_Id;
Comp : Entity_Id);
-- For an Encl_Type that has a Scalar_Storage_Order attribute definition
-- clause, verify that the component type is compatible. For arrays,
-- Comp is Empty; for records, it is the entity of the component under
-- consideration.
procedure Check_Strict_Alignment (E : Entity_Id);
-- E is a base type. If E is tagged or has a component that is aliased
-- or tagged or contains something this is aliased or tagged, set
......@@ -1008,6 +1016,60 @@ package body Freeze is
Set_Size_Known_At_Compile_Time (T, Size_Known (T));
end Check_Compile_Time_Size;
-----------------------------------
-- Check_Component_Storage_Order --
-----------------------------------
procedure Check_Component_Storage_Order
(Encl_Type : Entity_Id;
Comp : Entity_Id)
is
Comp_Type : Entity_Id;
Comp_Def : Node_Id;
Err_Node : Node_Id;
ADC : Node_Id;
begin
-- Record case
if Present (Comp) then
Err_Node := Comp;
Comp_Type := Etype (Comp);
Comp_Def := Component_Definition (Parent (Comp));
-- Array case
else
Err_Node := Encl_Type;
Comp_Type := Component_Type (Encl_Type);
Comp_Def := Component_Definition
(Type_Definition (Declaration_Node (Encl_Type)));
end if;
-- Note: the Reverse_Storage_Order flag is set on the base type,
-- but the attribute definition clause is attached to the first
-- subtype.
Comp_Type := Base_Type (Comp_Type);
ADC := Get_Attribute_Definition_Clause
(First_Subtype (Comp_Type),
Attribute_Scalar_Storage_Order);
if (Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type))
and then
(No (ADC) or else Reverse_Storage_Order (Encl_Type)
/= Reverse_Storage_Order (Etype (Comp_Type)))
then
Error_Msg_N
("component type must have same scalar storage order as "
& "enclosing composite", Err_Node);
elsif Aliased_Present (Comp_Def) then
Error_Msg_N ("aliased component not permitted for type with "
& "explicit Scalar_Storage_Order", Err_Node);
end if;
end Check_Component_Storage_Order;
-----------------------------
-- Check_Debug_Info_Needed --
-----------------------------
......@@ -2202,12 +2264,21 @@ package body Freeze is
end if;
-- Warn if there is a Scalar_Storage_Order but no component clause
-- (or pragma Pack).
if not Placed_Component then
if not (Placed_Component or else Is_Packed (Rec)) then
Error_Msg_N
("?scalar storage order specified but no component clause",
ADC);
end if;
-- Check attribute on component types
Comp := First_Component (Rec);
while Present (Comp) loop
Check_Component_Storage_Order (Rec, Comp);
Next_Component (Comp);
end loop;
end if;
-- Deal with Bit_Order aspect specifying a non-default bit order
......@@ -2215,7 +2286,7 @@ package body Freeze is
ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
if Present (ADC) and then Base_Type (Rec) = Rec then
if not Placed_Component then
if not (Placed_Component or else Is_Packed (Rec)) then
Error_Msg_N ("?bit order specification has no effect", ADC);
Error_Msg_N
("\?since no component clauses were specified", ADC);
......@@ -3672,6 +3743,14 @@ package body Freeze is
end if;
end if;
-- Check for scalar storage order
if Present (Get_Attribute_Definition_Clause
(E, Attribute_Scalar_Storage_Order))
then
Check_Component_Storage_Order (E, Empty);
end if;
-- Processing that is done only for subtypes
else
......
gcc/ada/g-debpoo.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
......@@ -668,9 +668,10 @@ package body GNAT.Debug_Pools is
-- terms of wasted memory). To do that, all we should have to do it to
-- set the size of this array to the page size. See mprotect().
P : Ptr;
No_Element : constant Storage_Element := 0;
Current : Byte_Count;
P : Ptr;
Trace : Traceback_Htable_Elem_Ptr;
begin
......@@ -693,15 +694,16 @@ package body GNAT.Debug_Pools is
-- Use standard (i.e. through malloc) allocations. This automatically
-- raises Storage_Error if needed. We also try once more to physically
-- release memory, so that even marked blocks, in the advanced scanning,
-- are freed.
-- are freed. Initialize the storage array to avoid bogus warnings by
-- valgrind.
begin
P := new Local_Storage_Array;
P := new Local_Storage_Array'(others => No_Element);
exception
when Storage_Error =>
Free_Physically (Pool);
P := new Local_Storage_Array;
P := new Local_Storage_Array'(others => No_Element);
end;
Storage_Address :=
......
gcc/ada/gcc-interface/Makefile.in
......@@ -2014,7 +2014,7 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(targ))),)
s-osinte.ads<s-osinte-hpux.ads \
s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
system.ads<system-hpux-ia64.ads \
$(ATOMICS_TARGET_PAIRS) \
......@@ -2024,10 +2024,11 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(targ))),)
mlib-tgt-specific.adb<mlib-tgt-specific-ia64-hpux.adb
MISCLIB=
EH_MECHANISM=-gcc
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
GMEM_LIB = gmemlib
soext = .sl
soext = .so
SO_OPTS = -Wl,+h,
LIBRARY_VERSION := $(LIB_VERSION)
endif
......
gcc/ada/rtsfind.ads
......@@ -215,6 +215,7 @@ package Rtsfind is
System_Aux_DEC,
System_Bit_Ops,
System_Boolean_Array_Operations,
System_Byte_Swapping,
System_Checked_Pools,
System_Compare_Array_Signed_16,
System_Compare_Array_Signed_32,
......@@ -772,6 +773,10 @@ package Rtsfind is
RE_Vector_Nxor, -- System_Boolean_Array_Operations,
RE_Vector_Xor, -- System_Boolean_Array_Operations,
RE_Bswap_16, -- System.Byte_Swapping
RE_Bswap_32, -- System.Byte_Swapping
RE_Bswap_64, -- System.Byte_Swapping
RE_Checked_Pool, -- System.Checked_Pools
RE_Compare_Array_S8, -- System.Compare_Array_Signed_8
......@@ -1996,6 +2001,10 @@ package Rtsfind is
RE_Vector_Nxor => System_Boolean_Array_Operations,
RE_Vector_Xor => System_Boolean_Array_Operations,
RE_Bswap_16 => System_Byte_Swapping,
RE_Bswap_32 => System_Byte_Swapping,
RE_Bswap_64 => System_Byte_Swapping,
RE_Compare_Array_S8 => System_Compare_Array_Signed_8,
RE_Compare_Array_S8_Unaligned => System_Compare_Array_Signed_8,
......
gcc/ada/sem_ch12.adb
......@@ -10821,6 +10821,17 @@ package body Sem_Ch12 is
Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
end if;
-- An unusual case: the actual is a type declared in a parent unit,
-- but is not a formal type so there is no instance_of for it.
-- Retrieve it by analyzing the record extension.
elsif Is_Child_Unit (Scope (A_Gen_T))
and then In_Open_Scopes (Scope (Act_T))
and then Is_Generic_Instance (Scope (Act_T))
then
Analyze (Subtype_Mark (Def));
Ancestor := Entity (Subtype_Mark (Def));
else
Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
end if;
......
gcc/ada/sem_util.adb
......@@ -6306,11 +6306,12 @@ package body Sem_Util is
end In_Parameter_Specification;
-------------------------------------
-- In_Reverse_Storage_Order_Record --
-- In_Reverse_Storage_Order_Object --
-------------------------------------
function In_Reverse_Storage_Order_Record (N : Node_Id) return Boolean is
function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
Pref : Node_Id;
Btyp : Entity_Id := Empty;
begin
Pref := N;
......@@ -6331,10 +6332,14 @@ package body Sem_Util is
end case;
end loop;
return Present (Pref)
and then Is_Record_Type (Etype (Pref))
and then Reverse_Storage_Order (Etype (Pref));
end In_Reverse_Storage_Order_Record;
if Present (Pref) then
Btyp := Base_Type (Etype (Pref));
end if;
return Present (Btyp)
and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
and then Reverse_Storage_Order (Btyp);
end In_Reverse_Storage_Order_Object;
--------------------------------------
-- In_Subprogram_Or_Concurrent_Unit --
......
gcc/ada/sem_util.ads
......@@ -742,9 +742,9 @@ package Sem_Util is
function In_Parameter_Specification (N : Node_Id) return Boolean;
-- Returns True if node N belongs to a parameter specification
function In_Reverse_Storage_Order_Record (N : Node_Id) return Boolean;
-- Returns True if N denotes a component or subcomponent in a record object
-- that has Reverse_Storage_Order.
function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean;
-- Returns True if N denotes a component or subcomponent in a record or
-- array that has Reverse_Storage_Order.
function In_Subprogram_Or_Concurrent_Unit return Boolean;
-- Determines if the current scope is within a subprogram compilation unit
......
gcc/ada/system-hpux-ia64.ads
......@@ -7,7 +7,7 @@
-- S p e c --
-- (HP-UX/ia64 Version) --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
......@@ -138,6 +138,6 @@ private
Always_Compatible_Rep : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
end System;
gcc/ada/vms_data.ads
......@@ -1789,6 +1789,10 @@ package VMS_Data is
S_GCC_Inline : aliased constant S := "/INLINE=" &
"PRAGMA " &
"-gnatn " &
"PRAGMA_LEVEL_1 " &
"-gnatn1 " &
"PRAGMA_LEVEL_2 " &
"-gnatn2 " &
"FULL " &
"-gnatN " &
"SUPPRESS " &
......
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