Commit 89a53f83 by Arnaud Charlet

[multiple changes]

2017-01-20  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Access_Type_Declaration): Protect access to the
	Entity attribute.
	* sem_ch10.adb (Install_Siblings): Skip processing malformed trees.
	* sem_cat.adb (Validate_Categoriztion_Dependency): Skip processing
	malformed trees.

2017-01-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specification, case
	Dynamic_Predicate): If the entity E is a subtype that inherits
	a static predicate for its parent P,, the inherited and the
	new predicate combine in the generated predicate function,
	and E only has a dynamic predicate.

2017-01-20  Tristan Gingold  <gingold@adacore.com>

	* s-boustr.ads, s-boustr.adb: New package.
	* Makefile.rtl: Add s-boustr.

2017-01-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* inline.adb (Process_Formals): Qualify the
	expression of a return statement when it yields a universal type.

2017-01-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* freeze.adb (Freeze_All): Freeze the default
	expressions of all eligible formal parameters that appear in
	entries, entry families, and protected subprograms.

From-SVN: r244701
parent 4f324de2
2017-01-20 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Access_Type_Declaration): Protect access to the
Entity attribute.
* sem_ch10.adb (Install_Siblings): Skip processing malformed trees.
* sem_cat.adb (Validate_Categoriztion_Dependency): Skip processing
malformed trees.
2017-01-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specification, case
Dynamic_Predicate): If the entity E is a subtype that inherits
a static predicate for its parent P,, the inherited and the
new predicate combine in the generated predicate function,
and E only has a dynamic predicate.
2017-01-20 Tristan Gingold <gingold@adacore.com>
* s-boustr.ads, s-boustr.adb: New package.
* Makefile.rtl: Add s-boustr.
2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
* inline.adb (Process_Formals): Qualify the
expression of a return statement when it yields a universal type.
2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
* freeze.adb (Freeze_All): Freeze the default
expressions of all eligible formal parameters that appear in
entries, entry families, and protected subprograms.
2017-01-20 Ed Schonberg <schonberg@adacore.com> 2017-01-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Check_Nonoverridable_Aspects); Refine check * sem_ch3.adb (Check_Nonoverridable_Aspects); Refine check
......
...@@ -493,6 +493,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -493,6 +493,7 @@ GNATRTL_NONTASKING_OBJS= \
s-bignum$(objext) \ s-bignum$(objext) \
s-bitops$(objext) \ s-bitops$(objext) \
s-boarop$(objext) \ s-boarop$(objext) \
s-boustr$(objext) \
s-bytswa$(objext) \ s-bytswa$(objext) \
s-carsi8$(objext) \ s-carsi8$(objext) \
s-carun8$(objext) \ s-carun8$(objext) \
......
...@@ -1688,9 +1688,6 @@ package body Freeze is ...@@ -1688,9 +1688,6 @@ package body Freeze is
-- as they are generated. -- as they are generated.
procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is
E : Entity_Id;
Decl : Node_Id;
procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id); procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id);
-- This is the internal recursive routine that does freezing of entities -- This is the internal recursive routine that does freezing of entities
-- (but NOT the analysis of default expressions, which should not be -- (but NOT the analysis of default expressions, which should not be
...@@ -1863,10 +1860,10 @@ package body Freeze is ...@@ -1863,10 +1860,10 @@ package body Freeze is
-- current package, but this body does not freeze incomplete -- current package, but this body does not freeze incomplete
-- types that may be declared in this private part. -- types that may be declared in this private part.
if (Nkind_In (Bod, N_Subprogram_Body, if (Nkind_In (Bod, N_Entry_Body,
N_Entry_Body,
N_Package_Body, N_Package_Body,
N_Protected_Body, N_Protected_Body,
N_Subprogram_Body,
N_Task_Body) N_Task_Body)
or else Nkind (Bod) in N_Body_Stub) or else Nkind (Bod) in N_Body_Stub)
and then and then
...@@ -1885,6 +1882,12 @@ package body Freeze is ...@@ -1885,6 +1882,12 @@ package body Freeze is
end loop; end loop;
end Freeze_All_Ent; end Freeze_All_Ent;
-- Local variables
Decl : Node_Id;
E : Entity_Id;
Item : Entity_Id;
-- Start of processing for Freeze_All -- Start of processing for Freeze_All
begin begin
...@@ -1925,33 +1928,28 @@ package body Freeze is ...@@ -1925,33 +1928,28 @@ package body Freeze is
elsif Nkind (Decl) = N_Subprogram_Declaration elsif Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl)) and then Present (Corresponding_Body (Decl))
and then and then
Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
= N_Subprogram_Renaming_Declaration N_Subprogram_Renaming_Declaration
then then
Build_And_Analyze_Renamed_Body Build_And_Analyze_Renamed_Body
(Decl, Corresponding_Body (Decl), After); (Decl, Corresponding_Body (Decl), After);
end if; end if;
end if; end if;
elsif Ekind (E) in Task_Kind -- Freeze the default expressions of entries, entry families, and
and then Nkind_In (Parent (E), N_Task_Type_Declaration, -- protected subprograms.
N_Single_Task_Declaration)
then
declare
Ent : Entity_Id;
begin elsif Is_Concurrent_Type (E) then
Ent := First_Entity (E); Item := First_Entity (E);
while Present (Ent) loop while Present (Item) loop
if Is_Entry (Ent) if (Is_Entry (Item) or else Is_Subprogram (Item))
and then not Default_Expressions_Processed (Ent) and then not Default_Expressions_Processed (Item)
then then
Process_Default_Expressions (Ent, After); Process_Default_Expressions (Item, After);
end if; end if;
Next_Entity (Ent); Next_Entity (Item);
end loop; end loop;
end;
end if; end if;
-- Historical note: We used to create a finalization master for an -- Historical note: We used to create a finalization master for an
......
...@@ -2483,13 +2483,12 @@ package body Inline is ...@@ -2483,13 +2483,12 @@ package body Inline is
-- errors, e.g. when the expression is a numeric literal and -- errors, e.g. when the expression is a numeric literal and
-- the context is private. If the expression is an aggregate, -- the context is private. If the expression is an aggregate,
-- use a qualified expression, because an aggregate is not a -- use a qualified expression, because an aggregate is not a
-- legal argument of a conversion. Ditto for numeric literals, -- legal argument of a conversion. Ditto for numeric literals
-- which must be resolved to a specific type. -- and attributes that yield a universal type, because those
-- must be resolved to a specific type.
if Nkind_In (Expression (N), N_Aggregate, if Nkind_In (Expression (N), N_Aggregate, N_Null)
N_Null, or else Yields_Universal_Type (Expression (N))
N_Real_Literal,
N_Integer_Literal)
then then
Ret := Ret :=
Make_Qualified_Expression (Sloc (N), Make_Qualified_Expression (Sloc (N),
......
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . B O U N D E D _ S T R I N G S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2016, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
package body System.Bounded_Strings is
------------
-- Append --
------------
procedure Append (X : in out Bounded_String; C : Character) is
begin
-- If we have too many characters to fit, simply drop them
if X.Length < X.Max_Length then
X.Length := X.Length + 1;
X.Chars (X.Length) := C;
end if;
end Append;
procedure Append (X : in out Bounded_String; S : String) is
begin
for C of S loop
Append (X, C);
end loop;
end Append;
--------------------
-- Append_Address --
--------------------
procedure Append_Address (X : in out Bounded_String; A : Address)
is
S : String (1 .. 18);
P : Natural;
use System.Storage_Elements;
N : Integer_Address;
H : constant array (Integer range 0 .. 15) of Character :=
"0123456789abcdef";
begin
P := S'Last;
N := To_Integer (A);
loop
S (P) := H (Integer (N mod 16));
P := P - 1;
N := N / 16;
exit when N = 0;
end loop;
S (P - 1) := '0';
S (P) := 'x';
Append (X, S (P - 1 .. S'Last));
end Append_Address;
---------------
-- To_String --
---------------
function To_String (X : Bounded_String) return String is
begin
return X.Chars (1 .. X.Length);
end To_String;
end System.Bounded_Strings;
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . B O U N D E D _ S T R I N G S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2016, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- A very simple implentation of bounded strings, used by tracebacks
package System.Bounded_Strings is
type Bounded_String (Max_Length : Natural) is limited private;
-- A string whose length is bounded by Max_Length. The bounded string is
-- empty at initialization.
procedure Append (X : in out Bounded_String; C : Character);
procedure Append (X : in out Bounded_String; S : String);
-- Append a character or a string to X. If the bounded string is full,
-- extra characters are simply dropped.
function To_String (X : Bounded_String) return String;
function "+" (X : Bounded_String) return String renames To_String;
-- Convert to a normal string
procedure Append_Address (X : in out Bounded_String; A : Address);
-- Append an address to X
private
type Bounded_String (Max_Length : Natural) is limited record
Length : Natural := 0;
-- Current length of the string
Chars : String (1 .. Max_Length);
-- String content
end record;
end System.Bounded_Strings;
...@@ -1026,6 +1026,9 @@ package body Sem_Cat is ...@@ -1026,6 +1026,9 @@ package body Sem_Cat is
-- generic instantiation. -- generic instantiation.
or else Error_Posted (Item)) or else Error_Posted (Item))
and then not (Try_Semantics
-- Skip processing malformed trees
and then Nkind (Name (Item)) not in N_Has_Entity)
then then
Entity_Of_Withed := Entity (Name (Item)); Entity_Of_Withed := Entity (Name (Item));
Check_Categorization_Dependencies Check_Categorization_Dependencies
......
...@@ -4209,6 +4209,9 @@ package body Sem_Ch10 is ...@@ -4209,6 +4209,9 @@ package body Sem_Ch10 is
or else Implicit_With (Item) or else Implicit_With (Item)
or else Limited_Present (Item) or else Limited_Present (Item)
or else Error_Posted (Item) or else Error_Posted (Item)
-- Skip processing malformed trees
or else (Try_Semantics
and then Nkind (Name (Item)) not in N_Has_Entity)
then then
null; null;
......
...@@ -2262,6 +2262,13 @@ package body Sem_Ch13 is ...@@ -2262,6 +2262,13 @@ package body Sem_Ch13 is
if A_Id = Aspect_Dynamic_Predicate then if A_Id = Aspect_Dynamic_Predicate then
Set_Has_Dynamic_Predicate_Aspect (E); Set_Has_Dynamic_Predicate_Aspect (E);
-- If the entity has a dynamic predicate, any inherited
-- static predicate becomes dynamic as well, and the
-- predicate function includes the conjunction of both.
Set_Has_Static_Predicate_Aspect (E, False);
elsif A_Id = Aspect_Static_Predicate then elsif A_Id = Aspect_Static_Predicate then
Set_Has_Static_Predicate_Aspect (E); Set_Has_Static_Predicate_Aspect (E);
end if; end if;
......
...@@ -1333,7 +1333,9 @@ package body Sem_Ch3 is ...@@ -1333,7 +1333,9 @@ package body Sem_Ch3 is
if Nkind (S) /= N_Subtype_Indication then if Nkind (S) /= N_Subtype_Indication then
Analyze (S); Analyze (S);
if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then if Present (Entity (S))
and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type
then
Set_Directly_Designated_Type (T, Entity (S)); Set_Directly_Designated_Type (T, Entity (S));
-- If the designated type is a limited view, we cannot tell if -- If the designated type is a limited view, we cannot tell if
......
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