From: Arnaud Charlet Date: Thu, 27 Apr 2017 09:22:04 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=7a71a7c4bbb2041be244646acec0b2a363bc9282;p=gcc.git [multiple changes] 2017-04-27 Hristian Kirtchev * sem.adb (Analyze): Diagnose an illegal iterated component association. * sem_util.ads, sem_util.adb (Diagnose_Iterated_Component_Association): New routine. 2017-04-27 Bob Duff * adaint.c (__gnat_get_current_dir): Return 0 in length if getcwd fails. * a-direct.adb, g-dirope.adb, osint.adb, s-os_lib.adb: Raise exception if getcwd failed. 2017-04-27 Yannick Moy * exp_dbug.adb, exp_dbug.ads (Get_External_Name): Prefix ghost entities with special prefix. 2017-04-27 Hristian Kirtchev * debug.adb Change the documentation of switch -gnatd.s. * exp_ch7.adb (Make_Transient_Block): Transient blocks do not need to manage the secondary stack when an enclosing scope already performs this functionality (aka relaxed management). Switch -gnatd.s may be used to force strict management in which case the block will manage the secondary stack unconditionally. Add a guard to stop the traversal when encountering a package or a subprogram scope. 2017-04-27 Ed Schonberg * sem_res.adb (Resolve_Call): Refine further the handling of limited views of return types in function calls. If the function that returns a limited view appears in the current unit, we do not replace its type by the non-limited view because this transformation is performed int the back-end. However, the type of the call itself must be the non-limited view, to prevent spurious resolution errors. 2017-04-27 Ed Schonberg * einfo,ads, einfo.adb (Class_Wide_Preconds, Class_Wide_Postconds): Removed, proposed implementation using generics for class-wide preconditions proved impractical. (Class_Wide_Clone): New attribute of subprogram. Designates subprogram created for primitive operations with class-wide pre/postconditions that contain calls to other primitives. The clone holds the body of the original primitive, but the pre/postonditions do not apply to it. The original body is rewritten as a wrapper for a call to the clone. (Is_Class_Wide_Clone): New flag to identify a Class_Wide_Clone. If the flag is set, no code for the corresponding pre/postconditions is inserted into its body. 2017-04-27 Bob Duff * exp_prag.adb, par-prag.adb, sem_ch13.adb: Ignore Scalar_Storage_Order if -gnatI is given. * sem_prag.adb (Analyze_Pragma): Ignore Default_Scalar_Storage_Order if -gnatI is given. From-SVN: r247298 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f6bf798fe54..510d9149c2a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,65 @@ +2017-04-27 Hristian Kirtchev + + * sem.adb (Analyze): Diagnose an illegal iterated component + association. + * sem_util.ads, sem_util.adb + (Diagnose_Iterated_Component_Association): New routine. + +2017-04-27 Bob Duff + + * adaint.c (__gnat_get_current_dir): Return 0 in length if + getcwd fails. + * a-direct.adb, g-dirope.adb, osint.adb, s-os_lib.adb: Raise + exception if getcwd failed. + +2017-04-27 Yannick Moy + + * exp_dbug.adb, exp_dbug.ads (Get_External_Name): Prefix ghost + entities with special prefix. + +2017-04-27 Hristian Kirtchev + + * debug.adb Change the documentation of switch -gnatd.s. + * exp_ch7.adb (Make_Transient_Block): Transient blocks do not need + to manage the secondary stack when an enclosing scope already + performs this functionality (aka relaxed management). Switch + -gnatd.s may be used to force strict management in which case + the block will manage the secondary stack unconditionally. Add + a guard to stop the traversal when encountering a package or a + subprogram scope. + +2017-04-27 Ed Schonberg + + * sem_res.adb (Resolve_Call): Refine further the handling of + limited views of return types in function calls. If the function + that returns a limited view appears in the current unit, + we do not replace its type by the non-limited view because + this transformation is performed int the back-end. However, + the type of the call itself must be the non-limited view, to + prevent spurious resolution errors. + +2017-04-27 Ed Schonberg + + * einfo,ads, einfo.adb (Class_Wide_Preconds, Class_Wide_Postconds): + Removed, proposed implementation using generics for class-wide + preconditions proved impractical. + (Class_Wide_Clone): New attribute of subprogram. Designates + subprogram created for primitive operations with class-wide + pre/postconditions that contain calls to other primitives. The + clone holds the body of the original primitive, but the + pre/postonditions do not apply to it. The original body is + rewritten as a wrapper for a call to the clone. + (Is_Class_Wide_Clone): New flag to identify a Class_Wide_Clone. If + the flag is set, no code for the corresponding pre/postconditions + is inserted into its body. + +2017-04-27 Bob Duff + + * exp_prag.adb, par-prag.adb, sem_ch13.adb: Ignore + Scalar_Storage_Order if -gnatI is given. + * sem_prag.adb (Analyze_Pragma): Ignore + Default_Scalar_Storage_Order if -gnatI is given. + 2017-04-27 Claire Dross * a-cofuba.ads (Add): Take as an additional input parameter diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb index 766415428ec..010daf62a52 100644 --- a/gcc/ada/a-direct.adb +++ b/gcc/ada/a-direct.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2017, 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- -- @@ -528,6 +528,10 @@ package body Ada.Directories is begin Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); + if Path_Len = 0 then + raise Use_Error with "current directory does not exist"; + end if; + -- We need to resolve links because of RM A.16(47), which requires -- that we not return alternative names for files. diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 5cc84caedeb..b1da3e25dd2 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2015, Free Software Foundation, Inc. * + * Copyright (C) 1992-2017, 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- * @@ -613,7 +613,16 @@ __gnat_get_current_dir (char *dir, int *length) WS2SC (dir, wdir, GNAT_MAX_PATH_LEN); #else - getcwd (dir, *length); + char* result = getcwd (dir, *length); + /* If the current directory does not exist, set length = 0 + to indicate error. That can't happen on windows, where + you can't delete a directory if it is the current + directory of some process. */ + if (!result) + { + *length = 0; + return; + } #endif *length = strlen (dir); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index f6ea3509906..46f19ca2e06 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -109,7 +109,7 @@ package body Debug is -- d.p Use original Ada 95 semantics for Bit_Order (disable AI95-0133) -- d.q Suppress optimizations on imported 'in' -- d.r Enable OK_To_Reorder_Components in non-variant records - -- d.s Minimize secondary stack Mark and Release calls + -- d.s Strict secondary stack management -- d.t Disable static allocation of library level dispatch tables -- d.u Enable Modify_Tree_For_C (update tree for c) -- d.v Enable OK_To_Reorder_Components in variant records @@ -572,6 +572,11 @@ package body Debug is -- d.r Forces the flag OK_To_Reorder_Components to be set in all record -- base types that have no discriminants. + -- d.s The compiler no longer attempts to optimize the calls to secondary + -- stack management routines SS_Mark and SS_Release. As a result, each + -- transient block tasked with secondary stack management will fulfill + -- its role unconditionally. + -- d.s The compiler does not generate calls to secondary stack management -- routines SS_Mark and SS_Release for a transient block when there is -- an enclosing scoping construct which already manages the secondary diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 5638bc09e08..452473b241a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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,10 +272,7 @@ package body Einfo is -- Validated_Object Node36 - -- Class_Wide_Preconds List38 - - -- Class_Wide_Postconds List39 - + -- Class_Wide_Clone Node38 -- SPARK_Pragma Node40 -- Original_Protected_Subprogram Node41 @@ -621,7 +618,7 @@ package body Einfo is -- Has_Private_Extension Flag300 -- Ignore_SPARK_Mode_Pragmas Flag301 - -- (unused) Flag302 + -- Is_Class_Wide_Clone Flag302 -- (unused) Flag303 -- (unused) Flag304 -- (unused) Flag305 @@ -873,17 +870,11 @@ package body Einfo is return Flag31 (Id); end Checks_May_Be_Suppressed; - function Class_Wide_Postconds (Id : E) return S is - begin - pragma Assert (Is_Subprogram (Id)); - return List39 (Id); - end Class_Wide_Postconds; - - function Class_Wide_Preconds (Id : E) return S is + function Class_Wide_Clone (Id : E) return E is begin pragma Assert (Is_Subprogram (Id)); - return List38 (Id); - end Class_Wide_Preconds; + return Node38 (Id); + end Class_Wide_Clone; function Class_Wide_Type (Id : E) return E is begin @@ -2141,6 +2132,11 @@ package body Einfo is return Flag73 (Id); end Is_Child_Unit; + function Is_Class_Wide_Clone (Id : E) return B is + begin + return Flag302 (Id); + end Is_Class_Wide_Clone; + function Is_Class_Wide_Equivalent_Type (Id : E) return B is begin return Flag35 (Id); @@ -3958,17 +3954,11 @@ package body Einfo is Set_Flag31 (Id, V); end Set_Checks_May_Be_Suppressed; - procedure Set_Class_Wide_Preconds (Id : E; V : S) is - begin - pragma Assert (Is_Subprogram (Id)); - Set_List38 (Id, V); - end Set_Class_Wide_Preconds; - - procedure Set_Class_Wide_Postconds (Id : E; V : S) is + procedure Set_Class_Wide_Clone (Id : E; V : E) is begin pragma Assert (Is_Subprogram (Id)); - Set_List39 (Id, V); - end Set_Class_Wide_Postconds; + Set_Node38 (Id, V); + end Set_Class_Wide_Clone; procedure Set_Class_Wide_Type (Id : E; V : E) is begin @@ -5266,6 +5256,11 @@ package body Einfo is Set_Flag73 (Id, V); end Set_Is_Child_Unit; + procedure Set_Is_Class_Wide_Clone (Id : E; V : B := True) is + begin + Set_Flag302 (Id, V); + end Set_Is_Class_Wide_Clone; + procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True) is begin Set_Flag35 (Id, V); @@ -10982,11 +10977,8 @@ package body Einfo is procedure Write_Field38_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Function - | E_Procedure - => - Write_Str ("Class_Wide_Preconditions"); - + when E_Function | E_Procedure => + Write_Str ("class-wide clone"); when others => Write_Str ("Field38??"); end case; @@ -10999,11 +10991,6 @@ package body Einfo is procedure Write_Field39_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Function - | E_Procedure - => - Write_Str ("Class_Wide_Postcondition"); - when others => Write_Str ("Field39??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 3f9ddac4346..d403928e299 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -625,16 +625,12 @@ package Einfo is -- tables must be consulted to determine if there actually is an active -- Suppress or Unsuppress pragma that applies to the entity. --- Class_Wide_Preconds (List38) --- Defined on subprograms. Holds the list of class-wide precondition --- functions inherited from ancestors. Each such function is an --- instantiation of the generic function generated from an explicit --- aspect specification for a class-wide precondition. A type is an --- ancestor of itself, and therefore a root type has such an instance --- on its own list. - --- Class_Wide_Postconds (List39) --- Ditto for class-wide postconditions. +-- Class_Wide_Clone (Node38) +-- Defined on subprogram entities. Set if the subprogram has a class-wide +-- ore- or postcondition, and the expression contains calls to other +-- primitive funtions of the type. Used to implement properly the +-- semantics of inherited operations whose class-wide condition may +-- be different from that of the ancestor (See AI012-0195). -- Class_Wide_Type (Node9) -- Defined in all type entities. For a tagged type or subtype, returns @@ -2360,6 +2356,12 @@ package Einfo is -- Defined in all entities. Set only for defining entities of program -- units that are child units (but False for subunits). +-- Is_Class_Wide_Clone (Flag302) +-- Defined on subprogram entities. Set for subprograms built in order +-- to implement properly the inheritance of class-wide pre- or post- +-- conditions when the condition contains calls to other primitives +-- of the ancestor type. Used to implement AI12-0195. + -- Is_Class_Wide_Equivalent_Type (Flag35) -- Defined in record types and subtypes. Set to True, if the type acts -- as a class-wide equivalent type, i.e. the Equivalent_Type field of @@ -6045,8 +6047,7 @@ package Einfo is -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) - -- Class_Wide_Preconds (List38) - -- Class_Wide_Postconds (List39) + -- Class_Wide_Clone (Node38) -- SPARK_Pragma (Node40) -- Original_Protected_Subprogram (Node41) -- Body_Needed_For_SAL (Flag40) @@ -6362,8 +6363,7 @@ package Einfo is -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) - -- Class_Wide_Preconds (List38) - -- Class_Wide_Postconds (List39) + -- Class_Wide_Clone (Node38) -- SPARK_Pragma (Node40) -- Original_Protected_Subprogram (Node41) -- Body_Needed_For_SAL (Flag40) @@ -6926,8 +6926,7 @@ package Einfo is function Can_Never_Be_Null (Id : E) return B; function Can_Use_Internal_Rep (Id : E) return B; function Checks_May_Be_Suppressed (Id : E) return B; - function Class_Wide_Postconds (Id : E) return S; - function Class_Wide_Preconds (Id : E) return S; + function Class_Wide_Clone (Id : E) return E; function Class_Wide_Type (Id : E) return E; function Cloned_Subtype (Id : E) return E; function Component_Alignment (Id : E) return C; @@ -7143,6 +7142,7 @@ package Einfo is function Is_Character_Type (Id : E) return B; function Is_Checked_Ghost_Entity (Id : E) return B; function Is_Child_Unit (Id : E) return B; + function Is_Class_Wide_Clone (Id : E) return B; function Is_Class_Wide_Equivalent_Type (Id : E) return B; function Is_Compilation_Unit (Id : E) return B; function Is_Completely_Hidden (Id : E) return B; @@ -7615,8 +7615,7 @@ package Einfo is procedure Set_Can_Never_Be_Null (Id : E; V : B := True); procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True); procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True); - procedure Set_Class_Wide_Postconds (Id : E; V : S); - procedure Set_Class_Wide_Preconds (Id : E; V : S); + procedure Set_Class_Wide_Clone (Id : E; V : E); procedure Set_Class_Wide_Type (Id : E; V : E); procedure Set_Cloned_Subtype (Id : E; V : E); procedure Set_Component_Alignment (Id : E; V : C); @@ -7828,6 +7827,7 @@ package Einfo is procedure Set_Is_Character_Type (Id : E; V : B := True); procedure Set_Is_Checked_Ghost_Entity (Id : E; V : B := True); procedure Set_Is_Child_Unit (Id : E; V : B := True); + procedure Set_Is_Class_Wide_Clone (Id : E; V : B := True); procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True); procedure Set_Is_Compilation_Unit (Id : E; V : B := True); procedure Set_Is_Completely_Hidden (Id : E; V : B := True); @@ -8421,8 +8421,7 @@ package Einfo is pragma Inline (Can_Never_Be_Null); pragma Inline (Can_Use_Internal_Rep); pragma Inline (Checks_May_Be_Suppressed); - pragma Inline (Class_Wide_Preconds); - pragma Inline (Class_Wide_Postconds); + pragma Inline (Class_Wide_Clone); pragma Inline (Class_Wide_Type); pragma Inline (Cloned_Subtype); pragma Inline (Component_Bit_Offset); @@ -8634,6 +8633,7 @@ package Einfo is pragma Inline (Is_Character_Type); pragma Inline (Is_Checked_Ghost_Entity); pragma Inline (Is_Child_Unit); + pragma Inline (Is_Class_Wide_Clone); pragma Inline (Is_Class_Wide_Equivalent_Type); pragma Inline (Is_Class_Wide_Type); pragma Inline (Is_Compilation_Unit); @@ -8946,8 +8946,7 @@ package Einfo is pragma Inline (Set_Can_Never_Be_Null); pragma Inline (Set_Can_Use_Internal_Rep); pragma Inline (Set_Checks_May_Be_Suppressed); - pragma Inline (Set_Class_Wide_Postconds); - pragma Inline (Set_Class_Wide_Preconds); + pragma Inline (Set_Class_Wide_Clone); pragma Inline (Set_Class_Wide_Type); pragma Inline (Set_Cloned_Subtype); pragma Inline (Set_Component_Bit_Offset); @@ -9150,6 +9149,7 @@ package Einfo is pragma Inline (Set_Is_Character_Type); pragma Inline (Set_Is_Checked_Ghost_Entity); pragma Inline (Set_Is_Child_Unit); + pragma Inline (Set_Is_Class_Wide_Clone); pragma Inline (Set_Is_Class_Wide_Equivalent_Type); pragma Inline (Set_Is_Compilation_Unit); pragma Inline (Set_Is_Completely_Hidden); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index e15223367f3..397bf1a2b73 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -8275,31 +8275,27 @@ package body Exp_Ch7 is function Manages_Sec_Stack (Id : Entity_Id) return Boolean is begin - -- An exception handler with a choice parameter utilizes a dummy - -- block to provide a declarative region. Such a block should not be - -- considered because it never manifests in the tree and can never - -- release the secondary stack. - - if Ekind (Id) = E_Block - and then Uses_Sec_Stack (Id) - and then not Is_Exception_Handler (Id) - then - return True; + case Ekind (Id) is - -- Loops are intentionally excluded because they undergo special - -- treatment, see Establish_Transient_Scope. + -- An exception handler with a choice parameter utilizes a dummy + -- block to provide a declarative region. Such a block should not + -- be considered because it never manifests in the tree and can + -- never release the secondary stack. - elsif Ekind_In (Id, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure) - and then Uses_Sec_Stack (Id) - then - return True; + when E_Block => + return + Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id); - else - return False; - end if; + when E_Entry + | E_Entry_Family + | E_Function + | E_Procedure + => + return Uses_Sec_Stack (Id); + + when others => + return False; + end case; end Manages_Sec_Stack; -- Local variables @@ -8326,14 +8322,11 @@ package body Exp_Ch7 is Scop := Scope (Trans_Id); while Present (Scop) loop - if Scop = Standard_Standard then - exit; - -- The transient block must manage the secondary stack when the - -- block appears within a loop in order to reclaim the memory at - -- each iteration. + -- It should not be possible to reach Standard without hitting one + -- of the other cases first unless Standard was manually pushed. - elsif Ekind (Scop) = E_Loop then + if Scop = Standard_Standard then exit; -- The transient block is within a function which returns on the @@ -8351,15 +8344,36 @@ package body Exp_Ch7 is Set_Uses_Sec_Stack (Trans_Id, False); exit; - -- When requested, the transient block does not need to manage the - -- secondary stack when there exists an enclosing block, entry, - -- entry family, function, or a procedure which already does that. + -- The transient block must manage the secondary stack when the + -- block appears within a loop in order to reclaim the memory at + -- each iteration. + + elsif Ekind (Scop) = E_Loop then + exit; + + -- The transient block does not need to manage the secondary stack + -- when there is an enclosing construct which already does that. -- This optimization saves on SS_Mark and SS_Release calls but may -- allow objects to live a little longer than required. - elsif Debug_Flag_Dot_S and then Manages_Sec_Stack (Scop) then + -- The transient block must manage the secondary stack when switch + -- -gnatd.s (strict management) is in effect. + + elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then Set_Uses_Sec_Stack (Trans_Id, False); exit; + + -- Prevent the search from going too far because transient blocks + -- are bounded by packages and subprogram scopes. + + elsif Ekind_In (Scop, E_Entry, + E_Entry_Family, + E_Function, + E_Package, + E_Procedure, + E_Subprogram_Body) + then + exit; end if; Scop := Scope (Scop); diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index ede7e2ebc78..dc1f884d525 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2017, 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- -- @@ -892,6 +892,27 @@ package body Exp_Dbug is Add_Str_To_Name_Buffer (Suffix); end if; + -- Add a special prefix to distinguish Ghost entities. In Ignored Ghost + -- mode, these entities should not leak in the "living" space and they + -- should be removed by the compiler in a post-processing pass. Thus, + -- the prefix allows anyone to check that the final executable indeed + -- does not contain such entities, in such a case. Do not insert this + -- prefix for compilation units, whose name is used as a basis for the + -- name of the generated elaboration procedure and (when appropriate) + -- the executable produced. Only insert this prefix once, for Ghost + -- entities declared inside other Ghost entities. Three leading + -- underscores are used so that "___ghost_" is a unique substring of + -- names produced for Ghost entities, while "__ghost_" can appear in + -- names of entities inside a child/local package called "Ghost". + + if Is_Ghost_Entity (E) + and then not Is_Compilation_Unit (E) + and then (Name_Len < 9 + or else Name_Buffer (1 .. 9) /= "___ghost_") + then + Insert_Str_In_Name_Buffer ("___ghost_", 1); + end if; + Name_Buffer (Name_Len + 1) := ASCII.NUL; end Get_External_Name; diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index b160caf62a9..53ef033b104 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2017, 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- -- @@ -76,6 +76,12 @@ package Exp_Dbug is -- qualification for such entities. In particular this means that direct -- local variables of a procedure are not qualified. + -- For Ghost entities, the encoding adds a prefix "___ghost_" to aid the + -- detection of leaks of Ignored Ghost entities in the "living" space. + -- Ignored Ghost entities and any code associated with them should be + -- removed by the compiler in a post-processing pass. As a result, + -- object files should not contain any occurrences of this prefix. + -- As an example of the local name convention, consider a procedure V.W -- with a local variable X, and a nested block Y containing an entity Z. -- The fully qualified names of the entities X and Z are: diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index da6a4c3ab8b..6ec4718f409 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -162,19 +162,23 @@ package body Exp_Prag is --------------------- procedure Expand_N_Pragma (N : Node_Id) is - Pname : constant Name_Id := Pragma_Name (N); + Pname : constant Name_Id := Pragma_Name (N); + Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname); begin -- Rewrite pragma ignored by Ignore_Pragma to null statement, so that - -- the back end or the expander here does not get overenthusiastic and - -- start processing such a pragma! + -- the back end doesn't see it. The same goes for pragma + -- Default_Scalar_Storage_Order if the -gnatI switch was given. - if Should_Ignore_Pragma_Sem (N) then + if Should_Ignore_Pragma_Sem (N) + or else (Prag_Id = Pragma_Default_Scalar_Storage_Order + and then Ignore_Rep_Clauses) + then Rewrite (N, Make_Null_Statement (Sloc (N))); return; end if; - case Get_Pragma_Id (Pname) is + case Prag_Id is -- Pragmas requiring special expander action diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb index 3b745b1c0ae..bc34202970a 100644 --- a/gcc/ada/g-dirope.adb +++ b/gcc/ada/g-dirope.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2014, AdaCore -- +-- Copyright (C) 1998-2017, AdaCore -- -- -- -- 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- -- @@ -29,6 +29,7 @@ -- -- ------------------------------------------------------------------------------ +with Ada.IO_Exceptions; with Ada.Characters.Handling; with Ada.Strings.Fixed; @@ -573,6 +574,11 @@ package body GNAT.Directory_Operations is begin Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); + if Path_Len = 0 then + raise Ada.IO_Exceptions.Use_Error + with "current directory does not exist"; + end if; + Last := (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last); diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 8e958c5f8a9..566a23480d3 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -1550,6 +1550,10 @@ package body Osint is begin Get_Current_Dir (Buffer'Address, Path_Len'Address); + if Path_Len = 0 then + raise Program_Error; + end if; + if Buffer (Path_Len) /= Directory_Separator then Path_Len := Path_Len + 1; Buffer (Path_Len) := Directory_Separator; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 6296f7b9c7c..64267430240 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -292,9 +292,13 @@ begin return Pragma_Node; end if; - -- Ignore pragma previously flagged by Ignore_Pragma + -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma + -- Default_Scalar_Storage_Order if the -gnatI switch was given. - if Should_Ignore_Pragma_Par (Prag_Name) then + if Should_Ignore_Pragma_Par (Prag_Name) + or else (Prag_Id = Pragma_Default_Scalar_Storage_Order + and then Ignore_Rep_Clauses) + then return Pragma_Node; end if; diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 014f6b4d66b..da357e78ddb 100644 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2016, AdaCore -- +-- Copyright (C) 1995-2017, AdaCore -- -- -- -- 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- -- @@ -2191,6 +2191,10 @@ package body System.OS_Lib is begin Get_Current_Dir (Buffer'Address, Path_Len'Address); + if Path_Len = 0 then + raise Program_Error; + end if; + if Buffer (Path_Len) /= Directory_Separator then Path_Len := Path_Len + 1; Buffer (Path_Len) := Directory_Separator; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 7ad34ee3182..9cde60eb180 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -654,6 +654,15 @@ package body Sem is => null; + -- A quantified expression with a missing "all" or "some" qualifier + -- looks identical to an iterated component association. By language + -- definition, the latter must be present within array aggregates. If + -- this is not the case, then the iterated component association is + -- really an illegal quantified expression. Diagnose this scenario. + + when N_Iterated_Component_Association => + Diagnose_Iterated_Component_Association (N); + -- For the remaining node types, we generate compiler abort, because -- these nodes are always analyzed within the Sem_Chn routines and -- there should never be a case of making a call to the main Analyze @@ -704,7 +713,6 @@ package body Sem is | N_Function_Specification | N_Generic_Association | N_Index_Or_Discriminant_Constraint - | N_Iterated_Component_Association | N_Iteration_Scheme | N_Mod_Clause | N_Modular_Type_Definition diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 9ce5f6619f0..6ecb12760f4 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4670,8 +4670,10 @@ package body Sem_Ch13 is when Attribute_Alignment | Attribute_Bit_Order | Attribute_Component_Size + | Attribute_Default_Scalar_Storage_Order | Attribute_Machine_Radix | Attribute_Object_Size + | Attribute_Scalar_Storage_Order | Attribute_Size | Attribute_Small | Attribute_Stream_Size diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c9c18e0038c..92a0059523f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3427,13 +3427,14 @@ package body Sem_Prag is procedure Analyze_Pragma (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Prag_Id : Pragma_Id; Pname : Name_Id := Pragma_Name (N); -- Name of the source pragma, or name of the corresponding aspect for -- pragmas which originate in a source aspect. In the latter case, the -- name may be different from the pragma name. + Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname); + Pragma_Exit : exception; -- This exception is used to exit pragma processing completely. It -- is used when an error is detected, and no further processing is @@ -10529,9 +10530,13 @@ package body Sem_Prag is Check_Restriction_No_Use_Of_Pragma (N); - -- Ignore pragma if Ignore_Pragma applies + -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma + -- Default_Scalar_Storage_Order if the -gnatI switch was given. - if Should_Ignore_Pragma_Sem (N) then + if Should_Ignore_Pragma_Sem (N) + or else (Prag_Id = Pragma_Default_Scalar_Storage_Order + and then Ignore_Rep_Clauses) + then return; end if; @@ -10557,7 +10562,6 @@ package body Sem_Prag is -- Here to start processing for recognized pragma - Prag_Id := Get_Pragma_Id (Pname); Pname := Original_Aspect_Pragma_Name (N); -- Capture setting of Opt.Uneval_Old diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4afba9e653f..de5053c5158 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -6102,17 +6102,24 @@ package body Sem_Res is -- If the called function is not declared in the main unit and it -- returns the limited view of type then use the available view (as -- is done in Try_Object_Operation) to prevent back-end confusion; - -- the call must appear in a context where the nonlimited view is - -- available. If the called function is in the extended main unit - -- then no action is needed, because the back end handles this case. - - if not In_Extended_Main_Code_Unit (Nam) - and then From_Limited_With (Etype (Nam)) + -- for the function entity itself. The call must appear in a context + -- where the nonlimited view is available. If the function entity is + -- in the extended main unit then no action is needed, because the + -- back end handles this case. In either case the type of the call + -- is the nonlimited view. + + if From_Limited_With (Etype (Nam)) + and then Present (Available_View (Etype (Nam))) then - Set_Etype (Nam, Available_View (Etype (Nam))); - end if; + Set_Etype (N, Available_View (Etype (Nam))); - Set_Etype (N, Etype (Nam)); + if not In_Extended_Main_Code_Unit (Nam) then + Set_Etype (Nam, Available_View (Etype (Nam))); + end if; + + else + Set_Etype (N, Etype (Nam)); + end if; end if; -- In the case where the call is to an overloaded subprogram, Analyze diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index de8dcedf5ba..00dfd6d99fe 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6023,12 +6023,52 @@ package body Sem_Util is end if; end Designate_Same_Unit; - ------------------------------------------ - -- function Dynamic_Accessibility_Level -- - ------------------------------------------ + --------------------------------------------- + -- Diagnose_Iterated_Component_Association -- + --------------------------------------------- + + procedure Diagnose_Iterated_Component_Association (N : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + Aggr : Node_Id; + + begin + -- Determine whether the iterated component association appears within + -- an aggregate. If this is the case, raise Program_Error because the + -- iterated component association cannot be left in the tree as is and + -- must always be processed by the related aggregate. + + Aggr := N; + while Present (Aggr) loop + if Nkind (Aggr) = N_Aggregate then + raise Program_Error; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Aggr) then + exit; + end if; + + Aggr := Parent (Aggr); + end loop; + + -- At this point it is known that the iterated component association is + -- not within an aggregate. This is really a quantified expression with + -- a missing "all" or "some" quantifier. + + Error_Msg_N ("missing quantifier", Def_Id); + + -- Rewrite the iterated component association as True to prevent any + -- cascaded errors. + + Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N))); + Analyze (N); + end Diagnose_Iterated_Component_Association; + + --------------------------------- + -- Dynamic_Accessibility_Level -- + --------------------------------- function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is - E : Entity_Id; Loc : constant Source_Ptr := Sloc (Expr); function Make_Level_Literal (Level : Uint) return Node_Id; @@ -6041,11 +6081,16 @@ package body Sem_Util is function Make_Level_Literal (Level : Uint) return Node_Id is Result : constant Node_Id := Make_Integer_Literal (Loc, Level); + begin Set_Etype (Result, Standard_Natural); return Result; end Make_Level_Literal; + -- Local variables + + E : Entity_Id; + -- Start of processing for Dynamic_Accessibility_Level begin diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2b6a362cbc3..761814645aa 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -545,6 +545,10 @@ package Sem_Util is -- these names is supposed to be a selected component name, an expanded -- name, a defining program unit name or an identifier. + procedure Diagnose_Iterated_Component_Association (N : Node_Id); + -- Emit an error if iterated component association N is actually an illegal + -- quantified expression lacking a quantifier. + function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id; -- Expr should be an expression of an access type. Builds an integer -- literal except in cases involving anonymous access types where