mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-25 10:20:43 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2010-06-22  Robert Dewar  <dewar@adacore.com>

	* lib-writ.ads, errout.adb, einfo.adb, einfo.ads: Minor reformatting.

2010-06-22  Vincent Celier  <celier@adacore.com>

	* adaint.c (__gnat_locate_regular_file): If a directory in the path is
	empty, make it the current working directory.

2010-06-22  Thomas Quinot  <quinot@adacore.com>

	* sem_ch3.adb (Build_Derived_Record_Type): When deriving a tagged
	private type with discriminants, make sure the parent type is frozen.

2010-06-22  Eric Botcazou  <ebotcazou@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_Bit>: Deal
	with packed array references specially.
	* exp_ch4.adb (Expand_N_Indexed_Component): Do not convert a reference
	to a component of a bit packed array if it is the prefix of 'Bit.
	* exp_pakd.ads (Expand_Packed_Bit_Reference): Declare.
	* exp_pakd.adb (Expand_Packed_Bit_Reference): New procedure.  Expand a
	'Bit reference, where the prefix involves a packed array reference.
	(Get_Base_And_Bit_Offset): New helper, extracted from...
	(Expand_Packed_Address_Reference): ...here.  Call above procedure to
	get the outer object and offset expression.

From-SVN: r161160
This commit is contained in:
Arnaud Charlet 2010-06-22 12:07:05 +02:00
parent 5c52bf3ba4
commit 47d3b920ce
11 changed files with 290 additions and 189 deletions

27
gcc/ada/ChangeLog

@ -1,3 +1,30 @@
2010-06-22 Robert Dewar <dewar@adacore.com>
* lib-writ.ads, errout.adb, einfo.adb, einfo.ads: Minor reformatting.
2010-06-22 Vincent Celier <celier@adacore.com>
* adaint.c (__gnat_locate_regular_file): If a directory in the path is
empty, make it the current working directory.
2010-06-22 Thomas Quinot <quinot@adacore.com>
* sem_ch3.adb (Build_Derived_Record_Type): When deriving a tagged
private type with discriminants, make sure the parent type is frozen.
2010-06-22 Eric Botcazou <ebotcazou@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_Bit>: Deal
with packed array references specially.
* exp_ch4.adb (Expand_N_Indexed_Component): Do not convert a reference
to a component of a bit packed array if it is the prefix of 'Bit.
* exp_pakd.ads (Expand_Packed_Bit_Reference): Declare.
* exp_pakd.adb (Expand_Packed_Bit_Reference): New procedure. Expand a
'Bit reference, where the prefix involves a packed array reference.
(Get_Base_And_Bit_Offset): New helper, extracted from...
(Expand_Packed_Address_Reference): ...here. Call above procedure to
get the outer object and offset expression.
2010-06-22 Thomas Quinot <quinot@adacore.com>
* exp_attr.adb, lib-writ.ads, bindgen.adb: Minor reformatting.

22
gcc/ada/adaint.c

@ -2788,12 +2788,6 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
for (;;)
{
for (; *path_val == PATH_SEPARATOR; path_val++)
;
if (*path_val == 0)
return 0;
/* Skip the starting quote */
if (*path_val == '"')
@ -2802,7 +2796,14 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
*ptr++ = *path_val++;
ptr--;
/* If directory is empty, it is the current directory*/
if (ptr == file_path)
{
*ptr = '.';
}
else
ptr--;
/* Skip the ending quote */
@ -2816,6 +2817,13 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
if (__gnat_is_regular_file (file_path))
return xstrdup (file_path);
if (*path_val == 0)
return 0;
/* Skip path separator */
path_val++;
}
}

4
gcc/ada/einfo.adb

@ -5755,9 +5755,7 @@ package body Einfo is
function Get_Full_View (T : Entity_Id) return Entity_Id is
begin
if Ekind (T) = E_Incomplete_Type
and then Present (Full_View (T))
then
if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
return Full_View (T);
elsif Is_Class_Wide_Type (T)

6
gcc/ada/einfo.ads

@ -6821,9 +6821,9 @@ package Einfo is
-- Add an entity to the list of entities declared in the scope V
function Get_Full_View (T : Entity_Id) return Entity_Id;
-- If T is an incomplete type and the full declaration has been
-- seen, or is the name of a class_wide type whose root is incomplete.
-- return the corresponding full declaration.
-- If T is an incomplete type and the full declaration has been seen, or
-- is the name of a class_wide type whose root is incomplete, return the
-- corresponding full declaration, else return T itself.
function Is_Entity_Name (N : Node_Id) return Boolean;
-- Test if the node N is the name of an entity (i.e. is an identifier,

181
gcc/ada/errout.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -176,25 +176,24 @@ package body Errout is
-- If the message should be generated (the normal case) False is returned.
procedure Unwind_Internal_Type (Ent : in out Entity_Id);
-- This procedure is given an entity id for an internal type, i.e.
-- a type with an internal name. It unwinds the type to try to get
-- to something reasonably printable, generating prefixes like
-- "subtype of", "access to", etc along the way in the buffer. The
-- value in Ent on return is the final name to be printed. Hopefully
-- this is not an internal name, but in some internal name cases, it
-- is an internal name, and has to be printed anyway (although in this
-- case the message has been killed if possible). The global variable
-- Class_Flag is set to True if the resulting entity should have
-- 'Class appended to its name (see Add_Class procedure), and is
-- otherwise unchanged.
-- This procedure is given an entity id for an internal type, i.e. a type
-- with an internal name. It unwinds the type to try to get to something
-- reasonably printable, generating prefixes like "subtype of", "access
-- to", etc along the way in the buffer. The value in Ent on return is the
-- final name to be printed. Hopefully this is not an internal name, but in
-- some internal name cases, it is an internal name, and has to be printed
-- anyway (although in this case the message has been killed if possible).
-- The global variable Class_Flag is set to True if the resulting entity
-- should have 'Class appended to its name (see Add_Class procedure), and
-- is otherwise unchanged.
procedure VMS_Convert;
-- This procedure has no effect if called when the host is not OpenVMS.
-- If the host is indeed OpenVMS, then the error message stored in
-- Msg_Buffer is scanned for appearances of switch names which need
-- converting to corresponding VMS qualifier names. See Gnames/Vnames
-- table in Errout spec for precise definition of the conversion that
-- is performed by this routine in OpenVMS mode.
-- This procedure has no effect if called when the host is not OpenVMS. If
-- the host is indeed OpenVMS, then the error message stored in Msg_Buffer
-- is scanned for appearances of switch names which need converting to
-- corresponding VMS qualifier names. See Gnames/Vnames table in Errout
-- spec for precise definition of the conversion that is performed by this
-- routine in OpenVMS mode.
-----------------------
-- Change_Error_Text --
@ -242,10 +241,10 @@ package body Errout is
---------------
-- Error_Msg posts a flag at the given location, except that if the
-- Flag_Location points within a generic template and corresponds
-- to an instantiation of this generic template, then the actual
-- message will be posted on the generic instantiation, along with
-- additional messages referencing the generic declaration.
-- Flag_Location points within a generic template and corresponds to an
-- instantiation of this generic template, then the actual message will be
-- posted on the generic instantiation, along with additional messages
-- referencing the generic declaration.
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
Sindex : Source_File_Index;
@ -256,8 +255,8 @@ package body Errout is
-- template in instantiation case, otherwise unchanged).
begin
-- It is a fatal error to issue an error message when scanning from
-- the internal source buffer (see Sinput for further documentation)
-- It is a fatal error to issue an error message when scanning from the
-- internal source buffer (see Sinput for further documentation)
pragma Assert (Sinput.Source /= Internal_Source_Ptr);
@ -267,8 +266,8 @@ package body Errout is
return;
end if;
-- If we already have messages, and we are trying to place a message
-- at No_Location or in package Standard, then just ignore the attempt
-- If we already have messages, and we are trying to place a message at
-- No_Location or in package Standard, then just ignore the attempt
-- since we assume that what is happening is some cascaded junk. Note
-- that this is safe in the sense that proceeding will surely bomb.
@ -284,24 +283,23 @@ package body Errout is
Test_Style_Warning_Serious_Msg (Msg);
Orig_Loc := Original_Location (Flag_Location);
-- If the current location is in an instantiation, the issue arises
-- of whether to post the message on the template or the instantiation.
-- If the current location is in an instantiation, the issue arises of
-- whether to post the message on the template or the instantiation.
-- The way we decide is to see if we have posted the same message
-- on the template when we compiled the template (the template is
-- always compiled before any instantiations). For this purpose,
-- we use a separate table of messages. The reason we do this is
-- twofold:
-- The way we decide is to see if we have posted the same message on
-- the template when we compiled the template (the template is always
-- compiled before any instantiations). For this purpose, we use a
-- separate table of messages. The reason we do this is twofold:
-- First, the messages can get changed by various processing
-- including the insertion of tokens etc, making it hard to
-- do the comparison.
-- Second, we will suppress a warning on a template if it is
-- not in the current extended source unit. That's reasonable
-- and means we don't want the warning on the instantiation
-- here either, but it does mean that the main error table
-- would not in any case include the message.
-- Second, we will suppress a warning on a template if it is not in
-- the current extended source unit. That's reasonable and means we
-- don't want the warning on the instantiation here either, but it
-- does mean that the main error table would not in any case include
-- the message.
if Flag_Location = Orig_Loc then
Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location));
@ -310,8 +308,8 @@ package body Errout is
-- Here we have an instance message
else
-- Delete if debug flag off, and this message duplicates a
-- message already posted on the corresponding template
-- Delete if debug flag off, and this message duplicates a message
-- already posted on the corresponding template
if not Debug_Flag_GG then
for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop
@ -373,9 +371,9 @@ package body Errout is
-- instantiation error message can be repeated, pointing to each
-- of the relevant instantiations.
-- Note: the instantiation mechanism is also shared for inlining
-- of subprogram bodies when front end inlining is done. In this
-- case the messages have the form:
-- Note: the instantiation mechanism is also shared for inlining of
-- subprogram bodies when front end inlining is done. In this case the
-- messages have the form:
-- in inlined body at ...
-- original error message
@ -385,9 +383,8 @@ package body Errout is
-- warning: in inlined body at
-- warning: original warning message
-- OK, this is the case where we have an instantiation error, and
-- we need to generate the error on the instantiation, rather than
-- on the template.
-- OK, here we have an instantiation error, and we need to generate the
-- error on the instantiation, rather than on the template.
declare
Actual_Error_Loc : Source_Ptr;
@ -396,9 +393,9 @@ package body Errout is
-- location where all error messages will actually be posted.
Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;
-- Save possible location set for caller's message. We need to
-- use Error_Msg_Sloc for the location of the instantiation error
-- but we have to preserve a possible original value.
-- Save possible location set for caller's message. We need to use
-- Error_Msg_Sloc for the location of the instantiation error but we
-- have to preserve a possible original value.
X : Source_File_Index;
@ -417,10 +414,9 @@ package body Errout is
exit when Instantiation (X) = No_Location;
end loop;
-- Since we are generating the messages at the instantiation
-- point in any case, we do not want the references to the
-- bad lines in the instance to be annotated with the location
-- of the instantiation.
-- Since we are generating the messages at the instantiation point in
-- any case, we do not want the references to the bad lines in the
-- instance to be annotated with the location of the instantiation.
Suppress_Instance_Location := True;
Msg_Cont_Status := False;
@ -679,10 +675,10 @@ package body Errout is
Expander_Active := False;
end if;
-- Set the fatal error flag in the unit table unless we are
-- in Try_Semantics mode. This stops the semantics from being
-- performed if we find a serious error. This is skipped if we
-- are currently dealing with the configuration pragma file.
-- Set the fatal error flag in the unit table unless we are in
-- Try_Semantics mode. This stops the semantics from being performed
-- if we find a serious error. This is skipped if we are currently
-- dealing with the configuration pragma file.
if not Try_Semantics and then Current_Source_Unit /= No_Unit then
Set_Fatal_Error (Get_Source_Unit (Sptr));
@ -722,10 +718,10 @@ package body Errout is
return;
end if;
-- Return without doing anything if message is killed and this
-- is not the first error message. The philosophy is that if we
-- get a weird error message and we already have had a message,
-- then we hope the weird message is a junk cascaded message
-- Return without doing anything if message is killed and this is not
-- the first error message. The philosophy is that if we get a weird
-- error message and we already have had a message, then we hope the
-- weird message is a junk cascaded message
if Kill_Message
and then not All_Errors_Mode
@ -749,15 +745,15 @@ package body Errout is
return;
end if;
-- If the flag location is in the main extended source unit
-- then for sure we want the warning since it definitely belongs
-- If the flag location is in the main extended source unit then for
-- sure we want the warning since it definitely belongs
if In_Extended_Main_Source_Unit (Sptr) then
null;
-- If the flag location is not in the main extended source unit,
-- then we want to eliminate the warning, unless it is in the
-- extended main code unit and we want warnings on the instance.
-- If the flag location is not in the main extended source unit, then
-- we want to eliminate the warning, unless it is in the extended
-- main code unit and we want warnings on the instance.
elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then
null;
@ -1325,13 +1321,12 @@ package body Errout is
S := Sloc (F);
-- The following circuit is a bit subtle. When we have parenthesized
-- expressions, then the Sloc will not record the location of the
-- paren, but we would like to post the flag on the paren. So what
-- we do is to crawl up the tree from the First_Node, adjusting the
-- Sloc value for any parentheses we know are present. Yes, we know
-- this circuit is not 100% reliable (e.g. because we don't record
-- all possible paren level values), but this is only for an error
-- message so it is good enough.
-- expressions, then the Sloc will not record the location of the paren,
-- but we would like to post the flag on the paren. So what we do is to
-- crawl up the tree from the First_Node, adjusting the Sloc value for
-- any parentheses we know are present. Yes, we know this circuit is not
-- 100% reliable (e.g. because we don't record all possible paren level
-- values), but this is only for an error message so it is good enough.
Node_Loop : loop
Paren_Loop : for J in 1 .. Paren_Count (F) loop
@ -1378,8 +1373,8 @@ package body Errout is
Cur_Msg := No_Error_Msg;
List_Pragmas.Init;
-- Initialize warnings table, if all warnings are suppressed, supply
-- an initial dummy entry covering all possible source locations.
-- Initialize warnings table, if all warnings are suppressed, supply an
-- initial dummy entry covering all possible source locations.
Warnings.Init;
Specific_Warnings.Init;
@ -2100,12 +2095,12 @@ package body Errout is
Flen := Flen + 1;
end loop;
-- Loop through file names to find matching one. This is a bit slow,
-- but we only do it in error situations so it is not so terrible.
-- Note that if the loop does not exit, then the desired case will
-- be left set to Mixed_Case, this can happen if the name was not
-- in canonical form, and gets canonicalized on VMS. Possibly we
-- could fix this by unconditinally canonicalizing these names ???
-- Loop through file names to find matching one. This is a bit slow, but
-- we only do it in error situations so it is not so terrible. Note that
-- if the loop does not exit, then the desired case will be left set to
-- Mixed_Case, this can happen if the name was not in canonical form,
-- and gets canonicalized on VMS. Possibly we could fix this by
-- unconditinally canonicalizing these names ???
for J in 1 .. Last_Source_File loop
Get_Name_String (Full_Debug_Name (J));
@ -2185,9 +2180,9 @@ package body Errout is
K := Nkind (Error_Msg_Node_1);
-- If we have operator case, skip quotes since name of operator
-- itself will supply the required quotations. An operator can be
-- an applied use in an expression or an explicit operator symbol,
-- or an identifier whose name indicates it is an operator.
-- itself will supply the required quotations. An operator can be an
-- applied use in an expression or an explicit operator symbol, or an
-- identifier whose name indicates it is an operator.
if K in N_Op
or else K = N_Operator_Symbol
@ -2333,8 +2328,8 @@ package body Errout is
Set_Msg_Node (Ent);
Add_Class;
-- If Ent is an anonymous subprogram type, there is no name
-- to print, so remove enclosing quotes.
-- If Ent is an anonymous subprogram type, there is no name to print,
-- so remove enclosing quotes.
if Buffer_Ends_With ("""") then
Buffer_Remove ("""");
@ -2343,8 +2338,8 @@ package body Errout is
end if;
end if;
-- If the original type did not come from a predefined
-- file, add the location where the type was defined.
-- If the original type did not come from a predefined file, add the
-- location where the type was defined.
if Sloc (Error_Msg_Node_1) > Standard_Location
and then
@ -2521,9 +2516,9 @@ package body Errout is
Set_Casing (Mixed_Case);
else
-- Determine if the reference we are dealing with corresponds
-- to text at the point of the error reference. This will often
-- be the case for simple identifier references, and is the case
-- Determine if the reference we are dealing with corresponds to
-- text at the point of the error reference. This will often be
-- the case for simple identifier references, and is the case
-- where we can copy the spelling from the source.
Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc));
@ -2536,8 +2531,8 @@ package body Errout is
Src_Ptr := Src_Ptr + 1;
end loop;
-- If we get through the loop without a mismatch, then output
-- the name the way it is spelled in the source program
-- If we get through the loop without a mismatch, then output the
-- name the way it is spelled in the source program
if Ref_Ptr > Name_Len then
Src_Ptr := Src_Loc;

37
gcc/ada/exp_attr.adb

@ -1206,6 +1206,20 @@ package body Exp_Attr is
Analyze_And_Resolve (N, RTE (RE_AST_Handler));
end AST_Entry;
---------
-- Bit --
---------
-- We compute this if a packed array reference was present, otherwise we
-- leave the computation up to the back end.
when Attribute_Bit =>
if Involves_Packed_Array_Reference (Pref) then
Expand_Packed_Bit_Reference (N);
else
Apply_Universal_Integer_Attribute_Checks (N);
end if;
------------------
-- Bit_Position --
------------------
@ -1218,8 +1232,7 @@ package body Exp_Attr is
-- in generated code (i.e. the prefix is an identifier that
-- references the component or discriminant entity).
when Attribute_Bit_Position => Bit_Position :
declare
when Attribute_Bit_Position => Bit_Position : declare
CE : Entity_Id;
begin
@ -3232,9 +3245,9 @@ package body Exp_Attr is
-- For enumeration types with a standard representation, Pos is
-- handled by the back end.
-- For enumeration types, with a non-standard representation we
-- generate a call to the _Rep_To_Pos function created when the
-- type was frozen. The call has the form
-- For enumeration types, with a non-standard representation we generate
-- a call to the _Rep_To_Pos function created when the type was frozen.
-- The call has the form
-- _rep_to_pos (expr, flag)
@ -3541,6 +3554,7 @@ package body Exp_Attr is
------------------
when Attribute_Range_Length => Range_Length : begin
-- The only special processing required is for the case where
-- Range_Length is applied to an enumeration type with holes.
-- In this case we transform
@ -4257,8 +4271,7 @@ package body Exp_Attr is
-- 2. For floating-point, generate call to attribute function
-- 3. For other cases, deal with constraint checking
when Attribute_Succ => Succ :
declare
when Attribute_Succ => Succ : declare
Etyp : constant Entity_Id := Base_Type (Ptyp);
begin
@ -4350,8 +4363,7 @@ package body Exp_Attr is
-- Transforms X'Tag into a direct reference to the tag of X
when Attribute_Tag => Tag :
declare
when Attribute_Tag => Tag : declare
Ttyp : Entity_Id;
Prefix_Is_Type : Boolean;
@ -4598,8 +4610,7 @@ package body Exp_Attr is
-- with a non-standard representation we use the _Pos_To_Rep array that
-- was created when the type was frozen.
when Attribute_Val => Val :
declare
when Attribute_Val => Val : declare
Etyp : constant Entity_Id := Base_Type (Entity (Pref));
begin
@ -4662,8 +4673,7 @@ package body Exp_Attr is
-- The code for valid is dependent on the particular types involved.
-- See separate sections below for the generated code in each case.
when Attribute_Valid => Valid :
declare
when Attribute_Valid => Valid : declare
Btyp : Entity_Id := Base_Type (Ptyp);
Tst : Node_Id;
@ -5267,7 +5277,6 @@ package body Exp_Attr is
-- that the result is in range.
when Attribute_Aft |
Attribute_Bit |
Attribute_Max_Size_In_Storage_Elements
=>
Apply_Universal_Integer_Attribute_Checks (N);

4
gcc/ada/exp_ch4.adb

@ -4883,7 +4883,7 @@ package body Exp_Ch4 is
-- The second expression in a 'Read attribute reference
-- The prefix of an address or size attribute reference
-- The prefix of an address or bit or size attribute reference
-- The following circuit detects these exceptions
@ -4907,6 +4907,8 @@ package body Exp_Ch4 is
elsif Nkind (Parnt) = N_Attribute_Reference
and then (Attribute_Name (Parnt) = Name_Address
or else
Attribute_Name (Parnt) = Name_Bit
or else
Attribute_Name (Parnt) = Name_Size)
and then Prefix (Parnt) = Child
then

169
gcc/ada/exp_pakd.adb

@ -455,6 +455,15 @@ package body Exp_Pakd is
-- expression whose type is the implementation type used to represent
-- the packed array. Aexp is analyzed and resolved on entry and on exit.
procedure Get_Base_And_Bit_Offset
(N : Node_Id;
Base : out Node_Id;
Offset : out Node_Id);
-- Given a node N for a name which involves a packed array reference,
-- return the base object of the reference and build an expression of
-- type Standard.Integer representing the zero-based offset in bits
-- from Base'Address to the first bit of the reference.
function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean;
-- There are two versions of the Set routines, the ones used when the
-- object is known to be sufficiently well aligned given the number of
@ -1663,18 +1672,11 @@ package body Exp_Pakd is
procedure Expand_Packed_Address_Reference (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ploc : Source_Ptr;
Pref : Node_Id;
Expr : Node_Id;
Term : Node_Id;
Atyp : Entity_Id;
Subscr : Node_Id;
Base : Node_Id;
Offset : Node_Id;
begin
Pref := Prefix (N);
Expr := Empty;
-- We build up an expression serially that has the form
-- We build an expression that has the form
-- outer_object'Address
-- + (linear-subscript * component_size for each array reference
@ -1682,49 +1684,7 @@ package body Exp_Pakd is
-- + ...
-- + ...) / Storage_Unit;
-- Some additional conversions are required to deal with the addition
-- operation, which is not normally visible to generated code.
loop
Ploc := Sloc (Pref);
if Nkind (Pref) = N_Indexed_Component then
Convert_To_Actual_Subtype (Prefix (Pref));
Atyp := Etype (Prefix (Pref));
Compute_Linear_Subscript (Atyp, Pref, Subscr);
Term :=
Make_Op_Multiply (Ploc,
Left_Opnd => Subscr,
Right_Opnd =>
Make_Attribute_Reference (Ploc,
Prefix => New_Occurrence_Of (Atyp, Ploc),
Attribute_Name => Name_Component_Size));
elsif Nkind (Pref) = N_Selected_Component then
Term :=
Make_Attribute_Reference (Ploc,
Prefix => Selector_Name (Pref),
Attribute_Name => Name_Bit_Position);
else
exit;
end if;
Term := Convert_To (RTE (RE_Integer_Address), Term);
if No (Expr) then
Expr := Term;
else
Expr :=
Make_Op_Add (Ploc,
Left_Opnd => Expr,
Right_Opnd => Term);
end if;
Pref := Prefix (Pref);
end loop;
Get_Base_And_Bit_Offset (Prefix (N), Base, Offset);
Rewrite (N,
Unchecked_Convert_To (RTE (RE_Address),
@ -1732,18 +1692,47 @@ package body Exp_Pakd is
Left_Opnd =>
Unchecked_Convert_To (RTE (RE_Integer_Address),
Make_Attribute_Reference (Loc,
Prefix => Pref,
Prefix => Base,
Attribute_Name => Name_Address)),
Right_Opnd =>
Make_Op_Divide (Loc,
Left_Opnd => Expr,
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit)))));
Unchecked_Convert_To (RTE (RE_Integer_Address),
Make_Op_Divide (Loc,
Left_Opnd => Offset,
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit))))));
Analyze_And_Resolve (N, RTE (RE_Address));
end Expand_Packed_Address_Reference;
---------------------------------
-- Expand_Packed_Bit_Reference --
---------------------------------
procedure Expand_Packed_Bit_Reference (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Base : Node_Id;
Offset : Node_Id;
begin
-- We build an expression that has the form
-- (linear-subscript * component_size for each array reference
-- + field'Bit_Position for each record field
-- + ...
-- + ...) mod Storage_Unit;
Get_Base_And_Bit_Offset (Prefix (N), Base, Offset);
Rewrite (N,
Unchecked_Convert_To (Universal_Integer,
Make_Op_Mod (Loc,
Left_Opnd => Offset,
Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
Analyze_And_Resolve (N, Universal_Integer);
end Expand_Packed_Bit_Reference;
------------------------------------
-- Expand_Packed_Boolean_Operator --
------------------------------------
@ -2229,6 +2218,70 @@ package body Exp_Pakd is
end Expand_Packed_Not;
-----------------------------
-- Get_Base_And_Bit_Offset --
-----------------------------
procedure Get_Base_And_Bit_Offset
(N : Node_Id;
Base : out Node_Id;
Offset : out Node_Id)
is
Loc : Source_Ptr;
Term : Node_Id;
Atyp : Entity_Id;
Subscr : Node_Id;
begin
Base := N;
Offset := Empty;
-- We build up an expression serially that has the form
-- linear-subscript * component_size for each array reference
-- + field'Bit_Position for each record field
-- + ...
loop
Loc := Sloc (Base);
if Nkind (Base) = N_Indexed_Component then
Convert_To_Actual_Subtype (Prefix (Base));
Atyp := Etype (Prefix (Base));
Compute_Linear_Subscript (Atyp, Base, Subscr);
Term :=
Make_Op_Multiply (Loc,
Left_Opnd => Subscr,
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Atyp, Loc),
Attribute_Name => Name_Component_Size));
elsif Nkind (Base) = N_Selected_Component then
Term :=
Make_Attribute_Reference (Loc,
Prefix => Selector_Name (Base),
Attribute_Name => Name_Bit_Position);
else
return;
end if;
if No (Offset) then
Offset := Term;
else
Offset :=
Make_Op_Add (Loc,
Left_Opnd => Offset,
Right_Opnd => Term);
end if;
Base := Prefix (Base);
end loop;
end Get_Base_And_Bit_Offset;
-------------------------------------
-- Involves_Packed_Array_Reference --
-------------------------------------

7
gcc/ada/exp_pakd.ads

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -272,4 +272,9 @@ package Exp_Pakd is
-- the prefix involves a packed array reference. This routine expands the
-- necessary code for performing the address reference in this case.
procedure Expand_Packed_Bit_Reference (N : Node_Id);
-- The node N is an attribute reference for the 'Bit reference, where the
-- prefix involves a packed array reference. This routine expands the
-- necessary code for performing the bit reference in this case.
end Exp_Pakd;

11
gcc/ada/lib-writ.ads

@ -696,14 +696,13 @@ package Lib.Writ is
-- reference data. See the spec of Par_SCO for full details of the format.
----------------------
-- Global variables --
-- Global Variables --
----------------------
-- The table structure defined here stores one entry for each
-- Interrupt_State pragma encountered either in the main source or
-- in an ancillary with'ed source. Since interrupt state values
-- have to be consistent across all units in a partition, we may
-- as well detect inconsistencies at compile time when we can.
-- The table defined here stores one entry for each Interrupt_State pragma
-- encountered either in the main source or in an ancillary with'ed source.
-- Since interrupt state values have to be consistent across all units in a
-- partition, we detect inconsistencies at compile time when we can.
type Interrupt_State_Entry is record
Interrupt_Number : Pos;

11
gcc/ada/sem_ch3.adb

@ -6790,6 +6790,13 @@ package body Sem_Ch3 is
Mark_Rewrite_Insertion (New_Decl);
Insert_Before (N, New_Decl);
-- In the tagged case, make sure ancestor is frozen appropriately
-- (see also non-discriminated case below).
if not Private_Extension or else Is_Interface (Parent_Base) then
Freeze_Before (New_Decl, Parent_Type);
end if;
-- Note that this call passes False for the Derive_Subps parameter
-- because subprogram derivation is deferred until after creating
-- the subtype (see below).
@ -6880,9 +6887,7 @@ package body Sem_Ch3 is
-- The declaration of a specific descendant of an interface type
-- freezes the interface type (RM 13.14).
if not Private_Extension
or else Is_Interface (Parent_Base)
then
if not Private_Extension or else Is_Interface (Parent_Base) then
Freeze_Before (N, Parent_Type);
end if;