Commit 83b77c5c by Arnaud Charlet

[multiple changes]

2017-09-07  Arnaud Charlet  <charlet@adacore.com>

	* sem_prag.adb (Collect_States_And_Objects): Detect also instances of
	single concurrent objects.

2017-09-07  Javier Miranda  <miranda@adacore.com>

	* s-regexp.ads: Fix documentation of the globbing grammar.

2017-09-07  Gary Dismukes  <dismukes@adacore.com>

	* a-tags.ads, einfo.ads, exp_disp.ads: Minor reformatting.

2017-09-07  Arnaud Charlet  <charlet@adacore.com>

	* gnat1drv.adb (Gnat1drv): Enable pragma Ignore_Pragma (Global)
	in CodePeer mode, to support more legacy code automatically.

2017-09-07  Ed Schonberg  <schonberg@adacore.com>

	* exp_disp.adb (Replace_Formals): If thr formal is classwide,
	and thus not a controlling argument, preserve its type after
	rewriting because it may appear in an nested call with a classwide
	parameter.

2017-09-07  Arnaud Charlet  <charlet@adacore.com>

	* comperr.adb (Delete_SCIL_Files): Handle case of
	N_Package_Instantiation.

2017-09-07  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb (Remove_Private_With_Clause): If a private with
	clause for a unit U appears in a context that includes a regular
	with_clause on U, rewrite the redundant private clause into a null
	statement, rather than removing it altogether from the context,
	so that ASIS tools can reconstruct the original source.

2017-09-07  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Check_Aspect_At_Freeze_Point): The expression
	for aspect Small can be of any real type (not only a universal
	real literal) as long as it is a static constant.

2017-09-07  Thomas Quinot  <quinot@adacore.com>

	* par_sco.adb: Minor reformatting.

From-SVN: r251840
parent e9cb2231
2017-09-07 Arnaud Charlet <charlet@adacore.com> 2017-09-07 Arnaud Charlet <charlet@adacore.com>
* sem_prag.adb (Collect_States_And_Objects): Detect also instances of
single concurrent objects.
2017-09-07 Javier Miranda <miranda@adacore.com>
* s-regexp.ads: Fix documentation of the globbing grammar.
2017-09-07 Gary Dismukes <dismukes@adacore.com>
* a-tags.ads, einfo.ads, exp_disp.ads: Minor reformatting.
2017-09-07 Arnaud Charlet <charlet@adacore.com>
* gnat1drv.adb (Gnat1drv): Enable pragma Ignore_Pragma (Global)
in CodePeer mode, to support more legacy code automatically.
2017-09-07 Ed Schonberg <schonberg@adacore.com>
* exp_disp.adb (Replace_Formals): If thr formal is classwide,
and thus not a controlling argument, preserve its type after
rewriting because it may appear in an nested call with a classwide
parameter.
2017-09-07 Arnaud Charlet <charlet@adacore.com>
* comperr.adb (Delete_SCIL_Files): Handle case of
N_Package_Instantiation.
2017-09-07 Ed Schonberg <schonberg@adacore.com>
* sem_ch10.adb (Remove_Private_With_Clause): If a private with
clause for a unit U appears in a context that includes a regular
with_clause on U, rewrite the redundant private clause into a null
statement, rather than removing it altogether from the context,
so that ASIS tools can reconstruct the original source.
2017-09-07 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Check_Aspect_At_Freeze_Point): The expression
for aspect Small can be of any real type (not only a universal
real literal) as long as it is a static constant.
2017-09-07 Thomas Quinot <quinot@adacore.com>
* par_sco.adb: Minor reformatting.
2017-09-07 Arnaud Charlet <charlet@adacore.com>
* s-parame-ae653.ads: Removed. * s-parame-ae653.ads: Removed.
2017-09-07 Nicolas Roche <roche@adacore.com> 2017-09-07 Nicolas Roche <roche@adacore.com>
......
...@@ -557,13 +557,13 @@ private ...@@ -557,13 +557,13 @@ private
-- --
-- "This" is the object whose dispatch table is being initialized. Prim_T -- "This" is the object whose dispatch table is being initialized. Prim_T
-- is the primary tag of such object. Interface_T is the interface tag for -- is the primary tag of such object. Interface_T is the interface tag for
-- which the secondary dispatch table is being initialized, Offset_Value -- which the secondary dispatch table is being initialized. Offset_Value
-- is the distance from "This" to the object component containing the tag -- is the distance from "This" to the object component containing the tag
-- of the secondary dispatch table (a zero value means that this interface -- of the secondary dispatch table (a zero value means that this interface
-- shares the primary dispatch table). Offset_Func references a function -- shares the primary dispatch table). Offset_Func references a function
-- that must be called to evaluate the offset at runtime. This routine also -- that must be called to evaluate the offset at run time. This routine
-- takes care of registering these values in the table of interfaces of the -- also takes care of registering these values in the table of interfaces
-- type. -- of the type.
procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive);
-- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's
......
...@@ -476,7 +476,9 @@ package body Comperr is ...@@ -476,7 +476,9 @@ package body Comperr is
when N_Package_Body => when N_Package_Body =>
Unit_Name := Corresponding_Spec (Main); Unit_Name := Corresponding_Spec (Main);
when N_Package_Renaming_Declaration => when N_Package_Renaming_Declaration
| N_Package_Instantiation
=>
Unit_Name := Defining_Unit_Name (Main); Unit_Name := Defining_Unit_Name (Main);
-- No SCIL file generated for generic package declarations -- No SCIL file generated for generic package declarations
......
...@@ -357,10 +357,10 @@ package Einfo is ...@@ -357,10 +357,10 @@ package Einfo is
-- Access_Disp_Table_Elab_Flag (Node30) [implementation base type only] -- Access_Disp_Table_Elab_Flag (Node30) [implementation base type only]
-- Defined in E_Record_Type and E_Record_Subtype entities. Set in tagged -- Defined in E_Record_Type and E_Record_Subtype entities. Set in tagged
-- types whose dispatch table elaboration must be completed at runtime by -- types whose dispatch table elaboration must be completed at run time
-- the IP routine to point to its pending elaboration flag entity. This -- by the IP routine to point to its pending elaboration flag entity.
-- flag is needed when the elaboration of the dispatch table relies on -- This flag is needed when the elaboration of the dispatch table relies
-- attribute 'Position applied to an object of the type; it is used by -- on attribute 'Position applied to an object of the type; it is used by
-- the IP routine to avoid performing this elaboration twice. -- the IP routine to avoid performing this elaboration twice.
-- Activation_Record_Component (Node31) -- Activation_Record_Component (Node31)
......
...@@ -701,6 +701,16 @@ package body Exp_Disp is ...@@ -701,6 +701,16 @@ package body Exp_Disp is
while Present (F) loop while Present (F) loop
if F = Entity (N) then if F = Entity (N) then
Rewrite (N, New_Copy_Tree (A)); Rewrite (N, New_Copy_Tree (A));
-- If the formal is class-wide, and thus not a
-- controlling argument, preserve its type because
-- it may appear in a nested call with a class-wide
-- parameter.
if Is_Class_Wide_Type (Etype (F)) then
Set_Etype (N, Etype (F));
end if;
exit; exit;
end if; end if;
......
...@@ -216,7 +216,7 @@ package Exp_Disp is ...@@ -216,7 +216,7 @@ package Exp_Disp is
function Elab_Flag_Needed (Typ : Entity_Id) return Boolean; function Elab_Flag_Needed (Typ : Entity_Id) return Boolean;
-- Return True if the elaboration of the tagged type Typ is completed at -- Return True if the elaboration of the tagged type Typ is completed at
-- runtime by the execution of code located in the IP routine and the -- run time by the execution of code located in the IP routine and the
-- expander must generate an extra elaboration flag to avoid performing -- expander must generate an extra elaboration flag to avoid performing
-- such elaboration twice. -- such elaboration twice.
......
...@@ -264,7 +264,11 @@ procedure Gnat1drv is ...@@ -264,7 +264,11 @@ procedure Gnat1drv is
Restrict.Restrictions.Set (Max_Asynchronous_Select_Nesting) := True; Restrict.Restrictions.Set (Max_Asynchronous_Select_Nesting) := True;
Restrict.Restrictions.Value (Max_Asynchronous_Select_Nesting) := 0; Restrict.Restrictions.Value (Max_Asynchronous_Select_Nesting) := 0;
-- Suppress division by zero and access checks since they are handled -- Enable pragma Ignore_Pragma (Global) to support legacy code
Set_Name_Table_Boolean3 (Name_Id'(Name_Find ("global")), True);
-- Suppress division by zero checks since they are handled
-- implicitly by CodePeer. -- implicitly by CodePeer.
-- Turn off dynamic elaboration checks: generates inconsistencies in -- Turn off dynamic elaboration checks: generates inconsistencies in
......
...@@ -214,8 +214,8 @@ package body Par_SCO is ...@@ -214,8 +214,8 @@ package body Par_SCO is
-- Parameter D, when present, indicates the dominant of the first -- Parameter D, when present, indicates the dominant of the first
-- declaration or statement within N. -- declaration or statement within N.
-- Why is Traverse_Sync_Definition commented specificaly and -- Why is Traverse_Sync_Definition commented specifically, whereas
-- the others are not??? -- the others are not???
procedure Traverse_Generic_Package_Declaration (N : Node_Id); procedure Traverse_Generic_Package_Declaration (N : Node_Id);
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1998-2010, AdaCore -- -- Copyright (C) 1998-2017, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -83,14 +83,18 @@ package System.Regexp is ...@@ -83,14 +83,18 @@ package System.Regexp is
-- regexp ::= term -- regexp ::= term
-- term ::= elmt -- term ::= elmt
-- term ::= elmt elmt ... -- concatenation (elmt then elmt) -- term ::= elmt elmt ... -- concatenation (elmt then elmt)
-- term ::= * -- any string of 0 or more characters
-- term ::= ? -- matches any character
-- term ::= [char char ...] -- matches any character listed
-- term ::= [char - char] -- matches any character in given range
-- term ::= {elmt, elmt, ...} -- alternation (matches any of elmt) -- term ::= {elmt, elmt, ...} -- alternation (matches any of elmt)
-- elmt ::= * -- any string of 0 or more characters
-- elmt ::= ? -- matches any character
-- elmt ::= char
-- elmt ::= [^ char char ...] -- matches any character not listed
-- elmt ::= [char char ...] -- matches any character listed
-- elmt ::= [char - char] -- matches any character in given range
-- \char is also supported by this grammar.
-- Important note : This package was mainly intended to match regular -- Important note : This package was mainly intended to match regular
-- expressions against file names. The whole string has to match the -- expressions against file names. The whole string has to match the
-- regular expression. If only a substring matches, then the function -- regular expression. If only a substring matches, then the function
......
...@@ -6638,13 +6638,16 @@ package body Sem_Ch10 is ...@@ -6638,13 +6638,16 @@ package body Sem_Ch10 is
-- If private_with_clause is redundant, remove it from context, -- If private_with_clause is redundant, remove it from context,
-- as a small optimization to subsequent handling of private_with -- as a small optimization to subsequent handling of private_with
-- clauses in other nested packages. -- clauses in other nested packages. We replace the clause with
-- a null statement, which is otherwise ignored by the rest of
-- the compiler, so that ASIS tools can reconstruct the source.
if In_Regular_With_Clause (Entity (Name (Item))) then if In_Regular_With_Clause (Entity (Name (Item))) then
declare declare
Nxt : constant Node_Id := Next (Item); Nxt : constant Node_Id := Next (Item);
begin begin
Remove (Item); Rewrite (Item, Make_Null_Statement (Sloc (Item)));
Analyze (Item);
Item := Nxt; Item := Nxt;
end; end;
......
...@@ -9280,7 +9280,10 @@ package body Sem_Ch13 is ...@@ -9280,7 +9280,10 @@ package body Sem_Ch13 is
T := Standard_Integer; T := Standard_Integer;
when Aspect_Small => when Aspect_Small =>
T := Universal_Real; -- Note that the expression can be of any real type (not just
-- a real universal literal) as long as it is a static constant.
T := Any_Real;
-- For a simple storage pool, we have to retrieve the type of the -- For a simple storage pool, we have to retrieve the type of the
-- pool object associated with the aspect's corresponding attribute -- pool object associated with the aspect's corresponding attribute
......
...@@ -3066,7 +3066,7 @@ package body Sem_Prag is ...@@ -3066,7 +3066,7 @@ package body Sem_Prag is
States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id)); States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
end if; end if;
-- Collect all objects the appear in the visible declarations of the -- Collect all objects that appear in the visible declarations of the
-- related package. -- related package.
if Present (Visible_Declarations (Pack_Spec)) then if Present (Visible_Declarations (Pack_Spec)) then
...@@ -3076,6 +3076,9 @@ package body Sem_Prag is ...@@ -3076,6 +3076,9 @@ package body Sem_Prag is
and then Nkind (Decl) = N_Object_Declaration and then Nkind (Decl) = N_Object_Declaration
then then
Append_New_Elmt (Defining_Entity (Decl), States_And_Objs); Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
elsif Is_Single_Concurrent_Type_Declaration (Decl) then
Append_New_Elmt (Anonymous_Object (Defining_Entity (Decl)),
States_And_Objs);
end if; end if;
Next (Decl); Next (Decl);
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment