From: Arnaud Charlet Date: Tue, 26 Oct 2010 12:19:56 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d347f5722f311a63908da11d492428af8f4563a4;p=gcc.git [multiple changes] 2010-10-26 Robert Dewar * einfo.ads, einfo.adb (Is_Base_Type): New function, use it where appropriate. * exp_ch6.adb, exp_dbug.adb, exp_disp.adb, freeze.adb, lib-xref.adb, sem_aux.adb, sem_ch3.adb, sem_ch7.adb, sem_ch8.adb (Is_Base_Type): Use this new abstraction where appropriate. 2010-10-26 Ed Schonberg * sem_ch12.adb: Code clean up. 2010-10-26 Paul Hilfinger * exp_dbug.ads: Document effect of 'pragma Unchecked_Union' on debugging data. 2010-10-26 Ed Schonberg * sem_util.adb (Note_Possible_Modification): If the target of an assignment is the bound variable in an iterator, the domain of iteration, i.e. array or container, is modified as well. 2010-10-26 Bob Duff * Make-generated.in: Make the relevant make targets depend on ceinfo.adb and csinfo.adb. * csinfo.adb, ceinfo.adb: Make sure it raises an exception on failure, so when called from xeinfo, the failure will be noticed. * sinfo.ads: Update comments to reflect the fact that xsinfo runs csinfo * xsinfo.adb, xeinfo.adb: Run ceinfo to check for errors. Close files. 2010-10-26 Ed Schonberg * exp_ch4.adb: Set properly parent field of operands of concatenation. 2010-10-26 Ed Schonberg * sem_res.adb (Check_Infinite_Recursion): A recursive call within a conditional expression or a case expression should not generate an infinite recursion warning. From-SVN: r165946 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b979f650676..2bb9022bf41 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2010-10-26 Robert Dewar + + * einfo.ads, einfo.adb (Is_Base_Type): New function, use it where + appropriate. + * exp_ch6.adb, exp_dbug.adb, exp_disp.adb, freeze.adb, lib-xref.adb, + sem_aux.adb, sem_ch3.adb, sem_ch7.adb, sem_ch8.adb (Is_Base_Type): Use + this new abstraction where appropriate. + +2010-10-26 Ed Schonberg + + * sem_ch12.adb: Code clean up. + +2010-10-26 Paul Hilfinger + + * exp_dbug.ads: Document effect of 'pragma Unchecked_Union' on + debugging data. + +2010-10-26 Ed Schonberg + + * sem_util.adb (Note_Possible_Modification): If the target of an + assignment is the bound variable in an iterator, the domain of + iteration, i.e. array or container, is modified as well. + +2010-10-26 Bob Duff + + * Make-generated.in: Make the relevant make targets depend on + ceinfo.adb and csinfo.adb. + * csinfo.adb, ceinfo.adb: Make sure it raises an exception on failure, + so when called from xeinfo, the failure will be noticed. + * sinfo.ads: Update comments to reflect the fact that xsinfo runs csinfo + * xsinfo.adb, xeinfo.adb: Run ceinfo to check for errors. Close files. + +2010-10-26 Ed Schonberg + + * exp_ch4.adb: Set properly parent field of operands of concatenation. + +2010-10-26 Ed Schonberg + + * sem_res.adb (Check_Infinite_Recursion): A recursive call within a + conditional expression or a case expression should not generate an + infinite recursion warning. + 2010-10-26 Javier Miranda * einfo.ads, einfo.adb (Is_Overriding_Operation): Removed. diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in index 6942d7a5fcc..30ce14e916d 100644 --- a/gcc/ada/Make-generated.in +++ b/gcc/ada/Make-generated.in @@ -29,13 +29,13 @@ $(ADA_GEN_SUBDIR)/treeprs.ads : $(ADA_GEN_SUBDIR)/treeprs.adt $(ADA_GEN_SUBDIR)/ $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/treeprs (cd $(ADA_GEN_SUBDIR)/bldtools/treeprs; gnatmake -q xtreeprs ; ./xtreeprs ../../treeprs.ads ) -$(ADA_GEN_SUBDIR)/einfo.h : $(ADA_GEN_SUBDIR)/einfo.ads $(ADA_GEN_SUBDIR)/einfo.adb $(ADA_GEN_SUBDIR)/xeinfo.adb +$(ADA_GEN_SUBDIR)/einfo.h : $(ADA_GEN_SUBDIR)/einfo.ads $(ADA_GEN_SUBDIR)/einfo.adb $(ADA_GEN_SUBDIR)/xeinfo.adb $(ADA_GEN_SUBDIR)/ceinfo.adb -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/einfo $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/einfo/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/einfo (cd $(ADA_GEN_SUBDIR)/bldtools/einfo; gnatmake -q xeinfo ; ./xeinfo ../../einfo.h ) -$(ADA_GEN_SUBDIR)/sinfo.h : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/xsinfo.adb +$(ADA_GEN_SUBDIR)/sinfo.h : $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/sinfo.adb $(ADA_GEN_SUBDIR)/xsinfo.adb $(ADA_GEN_SUBDIR)/csinfo.adb -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/sinfo $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/sinfo/,$(notdir $^)) $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/sinfo diff --git a/gcc/ada/ceinfo.adb b/gcc/ada/ceinfo.adb index 78e3faeb8cd..47f134a37e2 100644 --- a/gcc/ada/ceinfo.adb +++ b/gcc/ada/ceinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -23,8 +23,12 @@ -- -- ------------------------------------------------------------------------------ --- Program to check consistency of einfo.ads and einfo.adb. Checks that --- field name usage is consistent, including comments mentioning fields. +-- Check consistency of einfo.ads and einfo.adb. Checks that field name usage +-- is consistent, including comments mentioning fields. + +-- Note that this is used both as a standalone program, and as a procedure +-- called by XEinfo. This raises an unhandled exception if it finds any +-- errors; we don't attempt any sophisticated error recovery. with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; @@ -42,6 +46,9 @@ procedure CEinfo is Infil : File_Type; Lineno : Natural := 0; + Err : exception; + -- Raised on error + Fieldnm : VString; Accessfunc : VString; Line : VString; @@ -126,6 +133,7 @@ begin Put_Line ("*** unknown field name " & Fieldnm & " at line " & Lineno); end if; + raise Err; end if; end if; end loop; @@ -153,6 +161,7 @@ begin Put_Line ("*** unknown field name " & Fieldnm & " at line " & Lineno); end if; + raise Err; end if; end loop; @@ -172,6 +181,7 @@ begin Put_Line ("*** incorrect field at line " & Lineno); Put_Line (" found field " & Accessfunc); Put_Line (" expecting field " & Get (Fields, Fieldnm)); + raise Err; end if; end loop; @@ -196,9 +206,12 @@ begin Put_Line ("*** incorrect field at line " & Lineno); Put_Line (" found field " & Accessfunc); Put_Line (" expecting field " & Get (Fields, Fieldnm)); + raise Err; end if; end loop; + Close (Infil); + Put_Line ("All tests completed successfully, no errors detected"); end CEinfo; diff --git a/gcc/ada/csinfo.adb b/gcc/ada/csinfo.adb index 6808dbef27e..ef319cff9e5 100644 --- a/gcc/ada/csinfo.adb +++ b/gcc/ada/csinfo.adb @@ -23,10 +23,13 @@ -- -- ------------------------------------------------------------------------------ --- Program to check consistency of sinfo.ads and sinfo.adb. Checks that field --- name usage is consistent and that assertion cross-reference lists are --- correct, as well as making sure that all the comments on field name usage --- are consistent. +-- Check consistency of sinfo.ads and sinfo.adb. Checks that field name usage +-- is consistent and that assertion cross-reference lists are correct, as well +-- as making sure that all the comments on field name usage are consistent. + +-- Note that this is used both as a standalone program, and as a procedure +-- called by XSinfo. This raises an unhandled exception if it finds any +-- errors; we don't attempt any sophisticated error recovery. with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; @@ -635,8 +638,4 @@ begin New_Line; Put_Line ("All tests completed successfully, no errors detected"); -exception - when Done => - null; - end CSinfo; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index e7f0b4f217d..d8b24a3d83a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -2996,7 +2996,7 @@ package body Einfo is procedure Set_Access_Disp_Table (Id : E; V : L) is begin - pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Tagged_Type (Id) and then Is_Base_Type (Id)); Set_Elist16 (Id, V); end Set_Access_Disp_Table; @@ -3018,7 +3018,7 @@ package body Einfo is procedure Set_Associated_Storage_Pool (Id : E; V : E) is begin - pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id)); Set_Node22 (Id, V); end Set_Associated_Storage_Pool; @@ -3082,7 +3082,7 @@ package body Einfo is procedure Set_C_Pass_By_Copy (Id : E; V : B := True) is begin - pragma Assert (Is_Record_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id)); Set_Flag125 (Id, V); end Set_C_Pass_By_Copy; @@ -3122,13 +3122,13 @@ package body Einfo is procedure Set_Component_Size (Id : E; V : U) is begin - pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id)); Set_Uint22 (Id, V); end Set_Component_Size; procedure Set_Component_Type (Id : E; V : E) is begin - pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id)); Set_Node20 (Id, V); end Set_Component_Type; @@ -3302,7 +3302,7 @@ package body Einfo is procedure Set_Dispatch_Table_Wrappers (Id : E; V : L) is begin - pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Tagged_Type (Id) and then Is_Base_Type (Id)); Set_Elist26 (Id, V); end Set_Dispatch_Table_Wrappers; @@ -3477,8 +3477,7 @@ package body Einfo is procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is begin pragma Assert - (Is_Access_Subprogram_Type (Id) - and then Id = Base_Type (Id)); + (Is_Access_Subprogram_Type (Id) and then Is_Base_Type (Id)); Set_Flag229 (Id, V); end Set_Can_Use_Internal_Rep; @@ -3489,7 +3488,7 @@ package body Einfo is procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); Set_Flag158 (Id, V); end Set_Finalize_Storage_Only; @@ -3597,7 +3596,7 @@ package body Einfo is procedure Set_Has_Atomic_Components (Id : E; V : B := True) is begin - pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id)); + pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id)); Set_Flag86 (Id, V); end Set_Has_Atomic_Components; @@ -3995,7 +3994,7 @@ package body Einfo is procedure Set_Has_Volatile_Components (Id : E; V : B := True) is begin - pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id)); + pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id)); Set_Flag87 (Id, V); end Set_Has_Volatile_Components; @@ -4118,7 +4117,7 @@ package body Einfo is procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is begin pragma Assert ((not V) - or else (Is_Array_Type (Id) and then Id = Base_Type (Id))); + or else (Is_Array_Type (Id) and then Is_Base_Type (Id))); Set_Flag122 (Id, V); end Set_Is_Bit_Packed_Array; @@ -4736,7 +4735,7 @@ package body Einfo is procedure Set_No_Pool_Assigned (Id : E; V : B := True) is begin - pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id)); Set_Flag131 (Id, V); end Set_No_Pool_Assigned; @@ -4749,13 +4748,13 @@ package body Einfo is procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is begin - pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id)); Set_Flag136 (Id, V); end Set_No_Strict_Aliasing; procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); Set_Flag58 (Id, V); end Set_Non_Binary_Modulus; @@ -4800,7 +4799,7 @@ package body Einfo is procedure Set_OK_To_Reorder_Components (Id : E; V : B := True) is begin pragma Assert - (Is_Record_Type (Id) and then Id = Base_Type (Id)); + (Is_Record_Type (Id) and then Is_Base_Type (Id)); Set_Flag239 (Id, V); end Set_OK_To_Reorder_Components; @@ -4974,7 +4973,7 @@ package body Einfo is procedure Set_Relative_Deadline_Variable (Id : E; V : E) is begin - pragma Assert (Is_Task_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Task_Type (Id) and then Is_Base_Type (Id)); Set_Node26 (Id, V); end Set_Relative_Deadline_Variable; @@ -5023,7 +5022,7 @@ package body Einfo is procedure Set_Reverse_Bit_Order (Id : E; V : B := True) is begin pragma Assert - (Is_Record_Type (Id) and then Id = Base_Type (Id)); + (Is_Record_Type (Id) and then Is_Base_Type (Id)); Set_Flag164 (Id, V); end Set_Reverse_Bit_Order; @@ -5209,7 +5208,7 @@ package body Einfo is procedure Set_Universal_Aliasing (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id) and then Id = Base_Type (Id)); + pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); Set_Flag216 (Id, V); end Set_Universal_Aliasing; @@ -6167,6 +6166,15 @@ package body Einfo is end if; end Invariant_Procedure; + ------------------ + -- Is_Base_Type -- + ------------------ + + function Is_Base_Type (Id : E) return Boolean is + begin + return Id = Base_Type (Id); + end Is_Base_Type; + --------------------- -- Is_Boolean_Type -- --------------------- @@ -6977,7 +6985,7 @@ package body Einfo is procedure Set_Component_Alignment (Id : E; V : C) is begin pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id)) - and then Id = Base_Type (Id)); + and then Is_Base_Type (Id)); case V is when Calign_Default => @@ -7264,7 +7272,7 @@ package body Einfo is begin if (Is_Array_Type (Id) or else Is_Record_Type (Id)) - and then Id = Base_Type (Id) + and then Is_Base_Type (Id) then Write_Str (Prefix); Write_Str ("Component_Alignment = "); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 026c1b2db42..e69dcea5cac 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1992,6 +1992,9 @@ package Einfo is -- Present in all type entities and in procedure entities. Set -- if a pragma Asynchronous applies to the entity. +-- Is_Base_Type (synthesized) +-- Applies to type and subtype entities. True if entity is a base type + -- Is_Bit_Packed_Array (Flag122) [implementation base type only] -- Present in all entities. This flag is set for a packed array type that -- is bit packed (i.e. the component size is known by the front end and @@ -6341,6 +6344,7 @@ package Einfo is function Has_Private_Ancestor (Id : E) return B; function Has_Private_Declaration (Id : E) return B; function Implementation_Base_Type (Id : E) return E; + function Is_Base_Type (Id : E) return B; function Is_Boolean_Type (Id : E) return B; function Is_Constant_Object (Id : E) return B; function Is_Discriminal (Id : E) return B; @@ -7976,6 +7980,7 @@ package Einfo is -- things here which are small, but not of the canonical attribute -- access/set format that can be handled by xeinfo. + pragma Inline (Is_Base_Type); pragma Inline (Is_Package_Or_Generic_Package); pragma Inline (Is_Volatile); pragma Inline (Is_Wrapper_Package); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index cfea0d6d6b6..cbd8a2eef3a 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2493,9 +2493,11 @@ package body Exp_Ch4 is Opnd_Typ := Etype (Opnd); -- The parent got messed up when we put the operands in a list, - -- so now put back the proper parent for the saved operand. + -- so now put back the proper parent for the saved operand, that + -- is to say the concatenation node, to make sure that each operand + -- is seen as a subexpression, e.g. if actions must be inserted. - Set_Parent (Opnd, Parent (Cnode)); + Set_Parent (Opnd, Cnode); -- Set will be True when we have setup one entry in the array diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 82a11d321ce..d4b5781a5e8 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -600,7 +600,7 @@ package body Exp_Ch6 is if Is_Derived_Type (Typ) and then not Is_Private_Type (Typ) and then In_Open_Scopes (Scope (Etype (Typ))) - and then Typ = Base_Type (Typ) + and then Is_Base_Type (Typ) then -- Subp overrides an inherited private operation if there is an -- inherited operation with a different name than Subp (see diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 610ac0e5520..ca36f14ad87 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-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- -- @@ -529,8 +529,7 @@ package body Exp_Dbug is -- Or if this is an enumeration base type - or else (Is_Enumeration_Type (E) - and then E = Base_Type (E)) + or else (Is_Enumeration_Type (E) and then Is_Base_Type (E)) -- Or if this is a dummy type for a renaming diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index b4cf44b6d1d..711795730f1 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -1323,9 +1323,8 @@ package Exp_Dbug is -- where discrim is the unqualified name of the variant. This field name is -- built by gigi (not by code in this unit). For Unchecked_Union record, - -- this discriminant will not appear in the record, and the debugger must - -- proceed accordingly (basically it can treat this case as it would a C - -- union). + -- this discriminant will not appear in the record (see Unchecked Unions, + -- below). -- The type corresponding to this field has a name that is obtained by -- concatenating the type name with the above string and is similar to a C @@ -1338,7 +1337,7 @@ package Exp_Dbug is -- The name of the union member is encoded to indicate the choices, and -- is a string given by the following grammar: - -- union_name ::= {choice} | others_choice + -- member_name ::= {choice} | others_choice -- choice ::= simple_choice | range_choice -- simple_choice ::= S number -- range_choice ::= R number T number @@ -1377,12 +1376,34 @@ package Exp_Dbug is -- V1 : Var; - -- In this case, the type var is represented as a struct with three fields, - -- the first two are "disc" and "m", representing the values of these - -- record components. - - -- The third field is a union of two types, with field names S1 and O. S1 - -- is a struct with fields "r" and "s", and O is a struct with fields "t". + -- In this case, the type var is represented as a struct with three fields. + -- The first two are "disc" and "m", representing the values of these + -- record components. The third field is a union of two types, with field + -- names S1 and O. S1 is a struct with fields "r" and "s", and O is a + -- struct with field "t". + + ---------------------- + -- Unchecked Unions -- + ---------------------- + + -- The encoding for variant records changes somewhat under the influence + -- of a "pragma Unchecked_Union" clause: + + -- 1. The discriminant will not be present in the record, although its + -- name is still used in the encodings. + -- 2. Variants containing a single component named "x" of type "T" may + -- be encoded, as in ordinary C unions, as a single field of the + -- enclosing union type named "x" of type "T", dispensing with the + -- enclosing struct. In this case, of course, the discriminant values + -- corresponding to the variant are unavailable. As for normal + -- variants, the field name "x" may be suffixed with ___XVL if it + -- has dynamic size. + + -- For example, the type Var in the preceding section, if followed by + -- "pragma Unchecked_Union (Var);" may be encoded as a struct with two + -- fields. The first is "m". The second field is a union of two types, + -- with field names S1 and "t". As before, S1 is a struct with fields + -- "r" and "s". "t" is a field of type Integer. ------------------------------------------------ -- Subprograms for Handling Variant Encodings -- diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index a4eccd61738..0395282f604 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -7359,7 +7359,7 @@ package body Exp_Disp is (Nkind (Parent (Typ)) = N_Private_Extension_Declaration and then Is_Generic_Type (Typ))) and then In_Open_Scopes (Scope (Etype (Typ))) - and then Typ = Base_Type (Typ) + and then Is_Base_Type (Typ) then Handle_Inherited_Private_Subprograms (Typ); end if; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index e9c715ef2b1..f7b40527395 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2062,9 +2062,7 @@ package body Freeze is -- Set OK_To_Reorder_Components depending on debug flags - if Rec = Base_Type (Rec) - and then Convention (Rec) = Convention_Ada - then + if Is_Base_Type (Rec) and then Convention (Rec) = Convention_Ada then if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V) or else (not Has_Discriminants (Rec) and then Debug_Flag_Dot_R) @@ -3818,9 +3816,7 @@ package body Freeze is -- these till the freeze-point since we need the small and range -- values. We only do these checks for base types - if Is_Ordinary_Fixed_Point_Type (E) - and then E = Base_Type (E) - then + if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then if Small_Value (E) < Ureal_2_M_80 then Error_Msg_Name_1 := Name_Small; Error_Msg_N @@ -3865,7 +3861,7 @@ package body Freeze is -- only to base types. if Present (Default_Pool) - and then E = Base_Type (E) + and then Is_Base_Type (E) and then not Has_Storage_Size_Clause (E) and then No (Associated_Storage_Pool (E)) then diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index b055304e589..81b724103f4 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -1172,7 +1172,7 @@ package body Lib.Xref is if Is_Type (Ent) and then Is_Tagged_Type (Ent) - and then Ent = Base_Type (Ent) + and then Is_Base_Type (Ent) and then In_Extended_Main_Source_Unit (Ent) then Generate_Prim_Op_References (Ent); @@ -1281,7 +1281,7 @@ package body Lib.Xref is if Is_Type (Ent) and then Is_Tagged_Type (Ent) and then Is_Derived_Type (Ent) - and then Ent = Base_Type (Ent) + and then Is_Base_Type (Ent) and then In_Extended_Main_Source_Unit (Ent) then declare diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index f19ead7117d..813ede844fb 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -48,7 +48,7 @@ package body Sem_Aux is -- If this is first subtype, or is a base type, then there is no -- ancestor subtype, so we return Empty to indicate this fact. - if Is_First_Subtype (Typ) or else Typ = Base_Type (Typ) then + if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then return Empty; end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 32058f0971c..cd66772d40b 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5501,6 +5501,7 @@ package body Sem_Ch12 is and then Is_Private_Type (Designated_Type (T)) and then not Has_Private_View (N) and then Present (Full_View (Designated_Type (T))) + and then Used_As_Generic_Actual (T) then Switch_View (Designated_Type (T)); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 76d60a42640..f208be484b1 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -11716,7 +11716,7 @@ package body Sem_Ch3 is Set_Direct_Primitive_Operations (Full, Direct_Primitive_Operations (Priv)); - if Priv = Base_Type (Priv) then + if Is_Base_Type (Priv) then Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); end if; end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index ce6184f270b..3c13d991466 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1500,7 +1500,7 @@ package body Sem_Ch7 is (Nkind (Parent (E)) = N_Private_Extension_Declaration and then Is_Generic_Type (E))) and then In_Open_Scopes (Scope (Etype (E))) - and then E = Base_Type (E) + and then Is_Base_Type (E) then if Is_Tagged_Type (E) then Op_List := Primitive_Operations (E); @@ -2010,7 +2010,7 @@ package body Sem_Ch7 is ------------------------------ procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is - Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv); + Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv); begin Set_Size_Info (Priv, (Full)); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 0fbd49a6c32..2abee094488 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6001,9 +6001,8 @@ package body Sem_Ch8 is while Present (Id) and then Id /= Priv_Id loop - if Is_Standard_Character_Type (Id) - and then Id = Base_Type (Id) - then + if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then + -- We replace the node with the literal itself, resolve as a -- character, and set the type correctly. @@ -6164,9 +6163,7 @@ package body Sem_Ch8 is when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor => while Id /= Priv_Id loop - if Valid_Boolean_Arg (Id) - and then Id = Base_Type (Id) - then + if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then Add_Implicit_Operator (Id); return True; end if; @@ -6180,7 +6177,7 @@ package body Sem_Ch8 is while Id /= Priv_Id loop if Is_Type (Id) and then not Is_Limited_Type (Id) - and then Id = Base_Type (Id) + and then Is_Base_Type (Id) then Add_Implicit_Operator (Standard_Boolean, Id); return True; @@ -6194,9 +6191,9 @@ package body Sem_Ch8 is when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge => while Id /= Priv_Id loop if (Is_Scalar_Type (Id) - or else (Is_Array_Type (Id) - and then Is_Scalar_Type (Component_Type (Id)))) - and then Id = Base_Type (Id) + or else (Is_Array_Type (Id) + and then Is_Scalar_Type (Component_Type (Id)))) + and then Is_Base_Type (Id) then Add_Implicit_Operator (Standard_Boolean, Id); return True; @@ -6216,9 +6213,7 @@ package body Sem_Ch8 is Name_Op_Divide | Name_Op_Expon => while Id /= Priv_Id loop - if Is_Numeric_Type (Id) - and then Id = Base_Type (Id) - then + if Is_Numeric_Type (Id) and then Is_Base_Type (Id) then Add_Implicit_Operator (Id); return True; end if; @@ -6230,8 +6225,9 @@ package body Sem_Ch8 is when Name_Op_Concat => while Id /= Priv_Id loop - if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1 - and then Id = Base_Type (Id) + if Is_Array_Type (Id) + and then Number_Dimensions (Id) = 1 + and then Is_Base_Type (Id) then Add_Implicit_Operator (Id); return True; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 784f6bd98c6..0358ade3616 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -819,8 +819,10 @@ package body Sem_Res is if Nkind_In (P, N_Or_Else, N_And_Then, - N_If_Statement, - N_Case_Statement) + N_Case_Expression, + N_Case_Statement, + N_Conditional_Expression, + N_If_Statement) then return False; @@ -5277,7 +5279,7 @@ package body Sem_Res is and then Check_Infinite_Recursion (N) then -- Here we detected and flagged an infinite recursion, so we do - -- not need to test the case below for further warnings. Also if + -- not need to test the case below for further warnings. Also, if -- we now have a raise SE node, we are all done. if Nkind (N) = N_Raise_Storage_Error then @@ -10095,7 +10097,7 @@ package body Sem_Res is -- this situation can arise in source code. elsif In_Instance or else In_Inlined_Body then - return True; + return True; -- Otherwise we need the conversion check diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 29826c0b6f7..6962018dea7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9648,6 +9648,29 @@ package body Sem_Util is if Modification_Comes_From_Source then Generate_Reference (Ent, Exp, 'm'); + + -- If the target of the assignment is the bound variable + -- in an iterator, indicate that the corresponding array + -- or container is also modified. + + if Ada_Version >= Ada_2012 + and then + Nkind (Parent (Ent)) = N_Iterator_Specification + then + declare + Domain : constant Node_Id := Name (Parent (Ent)); + + begin + -- TBD : in the full version of the construct, the + -- domain of iteration can be given by an expression. + + if Is_Entity_Name (Domain) then + Generate_Reference (Entity (Domain), Exp, 'm'); + Set_Is_True_Constant (Entity (Domain), False); + Set_Never_Set_In_Source (Entity (Domain), False); + end if; + end; + end if; end if; Check_Nested_Access (Ent); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 4a267fc852b..295b25a1f6c 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -100,10 +100,10 @@ package Sinfo is -- Finally, four utility programs must be run: - -- Run CSinfo to check that you have made the changes consistently. It - -- checks most of the rules given above, with clear error messages. This - -- utility reads sinfo.ads and sinfo.adb and generates a report to - -- standard output. + -- (Optional.) Run CSinfo to check that you have made the changes + -- consistently. It checks most of the rules given above. This utility + -- reads sinfo.ads and sinfo.adb and generates a report to standard + -- output. This step is optional because XSinfo runs CSinfo. -- Run XSinfo to create sinfo.h, the corresponding C header. This -- utility reads sinfo.ads and generates sinfo.h. Note that it does @@ -120,8 +120,8 @@ package Sinfo is -- spec of the Nmake package which contains functions for constructing -- nodes. - -- All of the above steps except CSinfo are done automatically by the - -- build scripts when you do a full bootstrap. + -- The above steps are done automatically by the build scripts when you do + -- a full bootstrap. -- Note: sometime we could write a utility that actually generated the body -- of sinfo from the spec instead of simply checking it, since, as noted diff --git a/gcc/ada/xeinfo.adb b/gcc/ada/xeinfo.adb index 1c76c316ed0..ba9ded9d5cc 100644 --- a/gcc/ada/xeinfo.adb +++ b/gcc/ada/xeinfo.adb @@ -57,6 +57,8 @@ with GNAT.Spitbol; use GNAT.Spitbol; with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean; +with CEinfo; + procedure XEinfo is package TB renames GNAT.Spitbol.Table_Boolean; @@ -241,6 +243,11 @@ procedure XEinfo is -- Start of processing for XEinfo begin + -- First run CEinfo to check for errors. Note that CEinfo is also a + -- stand-alone program that can be run separately. + + CEinfo; + Anchored_Mode := True; if Argument_Count > 0 then @@ -489,6 +496,9 @@ begin (Ofile, "/* End of einfo.h (C version of Einfo package specification) */"); + Close (InF); + Close (Ofile); + exception when Err => Put_Line (Standard_Error, Lineno & ". " & Line); diff --git a/gcc/ada/xsinfo.adb b/gcc/ada/xsinfo.adb index 691e9016b69..e3917a639b8 100644 --- a/gcc/ada/xsinfo.adb +++ b/gcc/ada/xsinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -35,10 +35,6 @@ -- sinfo.h Corresponding c header file --- Note: this program assumes that sinfo.ads has passed the error checks --- which are carried out by the CSinfo utility, so it does not duplicate --- these checks and assumes the source is correct. - -- An optional argument allows the specification of an output file name to -- override the default sinfo.h file name for the generated output file. @@ -50,6 +46,8 @@ with Ada.Text_IO; use Ada.Text_IO; with GNAT.Spitbol; use GNAT.Spitbol; with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; +with CSinfo; + procedure XSinfo is Done : exception; @@ -115,6 +113,11 @@ procedure XSinfo is -- Start of processing for XSinfo begin + -- First run CSinfo to check for errors. Note that CSinfo is also a + -- stand-alone program that can be run separately. + + CSinfo; + Set_Exit_Status (1); Anchored_Mode := True; @@ -238,10 +241,13 @@ begin Getline; end loop; + -- Can't get here; above loop only left via raise exception when Done => + Close (InS); Put_Line (Ofile, ""); + Close (Ofile); Set_Exit_Status (0); end XSinfo;