From 47d3b920ce09b27fca7dc6504640f6fe72fb16cf Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 22 Jun 2010 12:07:05 +0200 Subject: [PATCH] [multiple changes] 2010-06-22 Robert Dewar * lib-writ.ads, errout.adb, einfo.adb, einfo.ads: Minor reformatting. 2010-06-22 Vincent Celier * 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 * 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 * exp_attr.adb (Expand_N_Attribute_Reference) : 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 --- gcc/ada/ChangeLog | 27 ++++++++ gcc/ada/adaint.c | 22 +++++-- gcc/ada/einfo.adb | 4 +- gcc/ada/einfo.ads | 6 +- gcc/ada/errout.adb | 181 +++++++++++++++++++++++++-------------------------- gcc/ada/exp_attr.adb | 37 +++++++---- gcc/ada/exp_ch4.adb | 4 +- gcc/ada/exp_pakd.adb | 169 ++++++++++++++++++++++++++++++----------------- gcc/ada/exp_pakd.ads | 7 +- gcc/ada/lib-writ.ads | 11 ++-- gcc/ada/sem_ch3.adb | 11 +++- 11 files changed, 290 insertions(+), 189 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2791cc5..2b2728c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2010-06-22 Robert Dewar + + * lib-writ.ads, errout.adb, einfo.adb, einfo.ads: Minor reformatting. + +2010-06-22 Vincent Celier + + * 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 + + * 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 + + * exp_attr.adb (Expand_N_Attribute_Reference) : 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 * exp_attr.adb, lib-writ.ads, bindgen.adb: Minor reformatting. diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 5ceedd0..9379950 100644 --- a/gcc/ada/adaint.c +++ b/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++; } } diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index fd2eee3..07144c3 100644 --- a/gcc/ada/einfo.adb +++ b/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) diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 3eb3528..d5f43ae 100644 --- a/gcc/ada/einfo.ads +++ b/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, diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 651b43d..d71ebad 100644 --- a/gcc/ada/errout.adb +++ b/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; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index a88cf85..445baa0 100644 --- a/gcc/ada/exp_attr.adb +++ b/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); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index a74ba46..02a5ad4 100644 --- a/gcc/ada/exp_ch4.adb +++ b/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 diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index bf41756..be4669c 100644 --- a/gcc/ada/exp_pakd.adb +++ b/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 -- ------------------------------------- diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads index 0c2e815..bd21a30 100644 --- a/gcc/ada/exp_pakd.ads +++ b/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; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 8e8e321..5451432 100644 --- a/gcc/ada/lib-writ.ads +++ b/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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 09e5319..6fe2d64 100644 --- a/gcc/ada/sem_ch3.adb +++ b/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; -- 2.7.4