OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2010-10-07  Robert Dewar  <dewar@adacore.com>

	* sem_res.adb: Minor reformatting

2010-10-07  Olivier Ramonat  <ramonat@adacore.com>

	* gnat_ugn.texi: Minor editing.
	* opt.ads: Document that scripts rely on specific formats in opt.ads

2010-10-07  Robert Dewar  <dewar@adacore.com>

	* a-wichun.ads, a-wichun.adb (To_Lower_Case): New function
	(To_Upper_Case): Fix to be inverse of To_Lower_Case
	* a-zchuni.ads, a-zchuni.adb (To_Lower_Case): New function
	(To_Upper_Case): Fix to be inverse of To_Lower_Case

2010-10-07  Robert Dewar  <dewar@adacore.com>

	* a-wichha.adb, a-wichha.ads, a-zchhan.adb, a-zchhan.ads: New file.
	* impunit.adb: Add entries for a-wichha/a-zchhan
	* Makefile.rtl: Add entries for a-wichha/a-zchhan

2010-10-07  Vincent Celier  <celier@adacore.com>

	* make.adb (Check): Call Check_Source_Info_In_ALI with Project_Tree
	* makeutl.adb (Check_Source_Info_In_ALI): If there is at least one
	replaced source, check that none of the replaced sources are in the
	dependencies.
	* makeutl.ads (Check_Source_Info_In_ALI): New parameter Tree
	* prj-nmsc.adb (Remove_Source): New parameter Tree. If the source is
	replaced with a source with a different file name, put it in the hash
	table Replaced_Sources.
	(Add_Source): Call Remove_Source with Data.Tree. If there is at least
	one replaced source, check if it has the same file name as the current
	source; if it has, remove it from the hash table Replaced_Sources.
	* prj.adb (Reset): Reset hash table Tree.Replaced_Sources
	* prj.ads (Replaced_Source_HTable): New hash table
	(Project_Tree_Data): New components Replaced_Sources and
	Replaced_Source_Number.

2010-10-07  Ed Schonberg  <schonberg@adacore.com>

	* sem_elab.adb (Check_A_Call): After inserting elaboration check, set
	proper flag to prevent a double elaboration check on the same call.
	* exp_util.adb (Insert_Actions): If the enclosing node is an
	Expression_With_Actions and it has been analyzed already, find
	insertion point further up in the tree.

2010-10-07  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch13.adb (Analyze_Record_Representation_Clause): Alphabetize all
	local variables. Remove the general restriction which prohibits the
	application of record rep clauses to Unchecked_Union types. Add Ada
	2012 check to detect improper naming of an Unchecked_Union
	discriminant in record rep clause.
	* sem_prag.adb: Add with and use clause for Exp_Ch7.
	(Analyze_Pragma): Unchecked_Union case: Propagate the Unchecked_Union
	type to all invocations of Check_Component and Check_Variant.
	(Check_Component): Add formal parameters UU_Typ and In_Variant_Part.
	Rewritten.  Add Ada 2012 check to detect improper use of formal
	private types and private extensions as component types of an
	Unchecked_Union declared inside a generic body.
	(Check_Variant): Add formal parameter UU_Typ. Propagate the
	Unchecked_Union type to all calls of Check_Component. Signal that the
	current component comes from the variant part of an Unchecked_Union
	type.
	(Inside_Generic_Body): New routine.

2010-10-07  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch4.adb (Expand_Composite_Equality): When looking for a primitive
	equality operation for a record component, verify that both formals
	have the same type, and the result type is boolean.

2010-10-07  Vincent Celier  <celier@adacore.com>

	* gnatcmd.adb (Check_Files): When looking for the .ci file for a
	binder generated file, look for both b~xxx and b__xxx as gprbuild
	always uses b__ as the prefix of such files.

From-SVN: r165084
This commit is contained in:
Arnaud Charlet 2010-10-07 11:26:27 +02:00
parent b4a4936bdc
commit 72e9f2b94d
25 changed files with 977 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
gcc/ada/ChangeLog
View File

@ -1,3 +1,83 @@
2010-10-07 Robert Dewar <dewar@adacore.com>
* sem_res.adb: Minor reformatting
2010-10-07 Olivier Ramonat <ramonat@adacore.com>
* gnat_ugn.texi: Minor editing.
* opt.ads: Document that scripts rely on specific formats in opt.ads
2010-10-07 Robert Dewar <dewar@adacore.com>
* a-wichun.ads, a-wichun.adb (To_Lower_Case): New function
(To_Upper_Case): Fix to be inverse of To_Lower_Case
* a-zchuni.ads, a-zchuni.adb (To_Lower_Case): New function
(To_Upper_Case): Fix to be inverse of To_Lower_Case
2010-10-07 Robert Dewar <dewar@adacore.com>
* a-wichha.adb, a-wichha.ads, a-zchhan.adb, a-zchhan.ads: New file.
* impunit.adb: Add entries for a-wichha/a-zchhan
* Makefile.rtl: Add entries for a-wichha/a-zchhan
2010-10-07 Vincent Celier <celier@adacore.com>
* make.adb (Check): Call Check_Source_Info_In_ALI with Project_Tree
* makeutl.adb (Check_Source_Info_In_ALI): If there is at least one
replaced source, check that none of the replaced sources are in the
dependencies.
* makeutl.ads (Check_Source_Info_In_ALI): New parameter Tree
* prj-nmsc.adb (Remove_Source): New parameter Tree. If the source is
replaced with a source with a different file name, put it in the hash
table Replaced_Sources.
(Add_Source): Call Remove_Source with Data.Tree. If there is at least
one replaced source, check if it has the same file name as the current
source; if it has, remove it from the hash table Replaced_Sources.
* prj.adb (Reset): Reset hash table Tree.Replaced_Sources
* prj.ads (Replaced_Source_HTable): New hash table
(Project_Tree_Data): New components Replaced_Sources and
Replaced_Source_Number.
2010-10-07 Ed Schonberg <schonberg@adacore.com>
* sem_elab.adb (Check_A_Call): After inserting elaboration check, set
proper flag to prevent a double elaboration check on the same call.
* exp_util.adb (Insert_Actions): If the enclosing node is an
Expression_With_Actions and it has been analyzed already, find
insertion point further up in the tree.
2010-10-07 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch13.adb (Analyze_Record_Representation_Clause): Alphabetize all
local variables. Remove the general restriction which prohibits the
application of record rep clauses to Unchecked_Union types. Add Ada
2012 check to detect improper naming of an Unchecked_Union
discriminant in record rep clause.
* sem_prag.adb: Add with and use clause for Exp_Ch7.
(Analyze_Pragma): Unchecked_Union case: Propagate the Unchecked_Union
type to all invocations of Check_Component and Check_Variant.
(Check_Component): Add formal parameters UU_Typ and In_Variant_Part.
Rewritten. Add Ada 2012 check to detect improper use of formal
private types and private extensions as component types of an
Unchecked_Union declared inside a generic body.
(Check_Variant): Add formal parameter UU_Typ. Propagate the
Unchecked_Union type to all calls of Check_Component. Signal that the
current component comes from the variant part of an Unchecked_Union
type.
(Inside_Generic_Body): New routine.
2010-10-07 Ed Schonberg <schonberg@adacore.com>
* exp_ch4.adb (Expand_Composite_Equality): When looking for a primitive
equality operation for a record component, verify that both formals
have the same type, and the result type is boolean.
2010-10-07 Vincent Celier <celier@adacore.com>
* gnatcmd.adb (Check_Files): When looking for the .ci file for a
binder generated file, look for both b~xxx and b__xxx as gprbuild
always uses b__ as the prefix of such files.
2010-10-07 Thomas Quinot <quinot@adacore.com>
* sem_res.adb: Minor reformatting.

2
gcc/ada/Makefile.rtl
View File

@ -268,6 +268,7 @@ GNATRTL_NONTASKING_OBJS= \
a-tiunio$(objext) \
a-unccon$(objext) \
a-uncdea$(objext) \
a-wichha$(objext) \
a-wichun$(objext) \
a-widcha$(objext) \
a-witeio$(objext) \
@ -292,6 +293,7 @@ GNATRTL_NONTASKING_OBJS= \
a-wwboio$(objext) \
a-wwunio$(objext) \
a-zchara$(objext) \
a-zchhan$(objext) \
a-zchuni$(objext) \
a-zrstfi$(objext) \
a-ztcoau$(objext) \

186
gcc/ada/a-wichha.adb Executable file
View File

@ -0,0 +1,186 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . W I D E _ C H A R A C T E R S . H A N D L I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 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- --
-- 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 Ada.Wide_Characters.Unicode; use Ada.Wide_Characters.Unicode;
package body Ada.Wide_Characters.Handling is
---------------------
-- Is_Alphanumeric --
---------------------
function Is_Alphanumeric (Item : Wide_Character) return Boolean is
begin
return Is_Letter (Item) or else Is_Digit (Item);
end Is_Alphanumeric;
----------------
-- Is_Control --
----------------
function Is_Control (Item : Wide_Character) return Boolean is
begin
return Get_Category (Item) = Cc;
end Is_Control;
--------------
-- Is_Digit --
--------------
function Is_Digit (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Digit;
----------------
-- Is_Graphic --
----------------
function Is_Graphic (Item : Wide_Character) return Boolean is
begin
return not Is_Non_Graphic (Item);
end Is_Graphic;
--------------------------
-- Is_Hexadecimal_Digit --
--------------------------
function Is_Hexadecimal_Digit (Item : Wide_Character) return Boolean is
begin
return Is_Digit (Item)
or else Item in 'A' .. 'F'
or else Item in 'a' .. 'f';
end Is_Hexadecimal_Digit;
---------------
-- Is_Letter --
---------------
function Is_Letter (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Letter;
------------------------
-- Is_Line_Terminator --
------------------------
function Is_Line_Terminator (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Line_Terminator;
--------------
-- Is_Lower --
--------------
function Is_Lower (Item : Wide_Character) return Boolean is
begin
return Get_Category (Item) = Ll;
end Is_Lower;
-------------
-- Is_Mark --
-------------
function Is_Mark (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Mark;
--------------
-- Is_Other --
--------------
function Is_Other (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Other;
--------------------
-- Is_Punctuation --
--------------------
function Is_Punctuation (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Punctuation;
--------------
-- Is_Space --
--------------
function Is_Space (Item : Wide_Character) return Boolean
renames Ada.Wide_Characters.Unicode.Is_Space;
----------------
-- Is_Special --
----------------
function Is_Special (Item : Wide_Character) return Boolean is
begin
return Is_Graphic (Item) and then not Is_Alphanumeric (Item);
end Is_Special;
--------------
-- Is_Upper --
--------------
function Is_Upper (Item : Wide_Character) return Boolean is
begin
return Get_Category (Item) = Lu;
end Is_Upper;
--------------
-- To_Lower --
--------------
function To_Lower (Item : Wide_Character) return Wide_Character
renames Ada.Wide_Characters.Unicode.To_Lower_Case;
function To_Lower (Item : Wide_String) return Wide_String is
Result : Wide_String (Item'Range);
begin
for J in Result'Range loop
Result (J) := To_Lower (Item (J));
end loop;
return Result;
end To_Lower;
--------------
-- To_Upper --
--------------
function To_Upper (Item : Wide_Character) return Wide_Character
renames Ada.Wide_Characters.Unicode.To_Upper_Case;
function To_Upper (Item : Wide_String) return Wide_String is
Result : Wide_String (Item'Range);
begin
for J in Result'Range loop
Result (J) := To_Upper (Item (J));
end loop;
return Result;
end To_Upper;
end Ada.Wide_Characters.Handling;

120
gcc/ada/a-wichha.ads Executable file
View File

@ -0,0 +1,120 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . W I D E _ C H A R A C T E R S . H A N D L I N G --
-- --
-- S p e c --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
package Ada.Wide_Characters.Handling is
function Is_Control (Item : Wide_Character) return Boolean;
pragma Inline (Is_Control);
-- Returns True if the Wide_Character designated by Item is categorized as
-- other_control, otherwise returns false.
function Is_Letter (Item : Wide_Character) return Boolean;
pragma Inline (Is_Letter);
-- Returns True if the Wide_Character designated by Item is categorized as
-- letter_uppercase, letter_lowercase, letter_titlecase, letter_modifier,
-- letter_other, or number_letter. Otherwise returns false.
function Is_Lower (Item : Wide_Character) return Boolean;
pragma Inline (Is_Lower);
-- Returns True if the Wide_Character designated by Item is categorized as
-- letter_lowercase, otherwise returns false.
function Is_Upper (Item : Wide_Character) return Boolean;
pragma Inline (Is_Upper);
-- Returns True if the Wide_Character designated by Item is categorized as
-- letter_uppercase, otherwise returns false.
function Is_Digit (Item : Wide_Character) return Boolean;
pragma Inline (Is_Digit);
-- Returns True if the Wide_Character designated by Item is categorized as
-- number_decimal, otherwise returns false.
function Is_Decimal_Digit (Item : Wide_Character) return Boolean
renames Is_Digit;
function Is_Hexadecimal_Digit (Item : Wide_Character) return Boolean;
-- Returns True if the Wide_Character designated by Item is categorized as
-- number_decimal, or is in the range 'A' .. 'F' or 'a' .. 'f', otherwise
-- returns false.
function Is_Alphanumeric (Item : Wide_Character) return Boolean;
pragma Inline (Is_Alphanumeric);
-- Returns True if the Wide_Character designated by Item is categorized as
-- number_decimal, or is in the range 'A' .. 'F' or 'a' .. 'f', otherwise
-- returns false.
function Is_Special (Item : Wide_Character) return Boolean;
pragma Inline (Is_Special);
-- Returns True if the Wide_Character designated by Item is categorized
-- as graphic_character, but not categorized as letter_uppercase,
-- letter_lowercase, letter_titlecase, letter_modifier, letter_other,
-- number_letter, or number_decimal. Otherwise returns false.
function Is_Line_Terminator (Item : Wide_Character) return Boolean;
pragma Inline (Is_Line_Terminator);
-- Returns True if the Wide_Character designated by Item is categorized as
-- separator_line or separator_paragraph, or if Item is a conventional line
-- terminator character (CR, LF, VT, or FF). Otherwise returns false.
function Is_Mark (Item : Wide_Character) return Boolean;
pragma Inline (Is_Mark);
-- Returns True if the Wide_Character designated by Item is categorized as
-- mark_non_spacing or mark_spacing_combining, otherwise returns false.
function Is_Other (Item : Wide_Character) return Boolean;
pragma Inline (Is_Other);
-- Returns True if the Wide_Character designated by Item is categorized as
-- other_format, otherwise returns false.
function Is_Punctuation (Item : Wide_Character) return Boolean;
pragma Inline (Is_Punctuation);
-- Returns True if the Wide_Character designated by Item is categorized as
-- punctuation_connector, otherwise returns false.
function Is_Space (Item : Wide_Character) return Boolean;
pragma Inline (Is_Space);
-- Returns True if the Wide_Character designated by Item is categorized as
-- separator_space, otherwise returns false.
function Is_Graphic (Item : Wide_Character) return Boolean;
pragma Inline (Is_Graphic);
-- Returns True if the Wide_Character designated by Item is categorized as
-- graphic_character, otherwise returns false.
function To_Lower (Item : Wide_Character) return Wide_Character;
pragma Inline (To_Lower);
-- Returns the Simple Lowercase Mapping of the Wide_Character designated by
-- Item. If the Simple Lowercase Mapping does not exist for the
-- Wide_Character designated by Item, then the value of Item is returned.
function To_Lower (Item : Wide_String) return Wide_String;
-- Returns the result of applying the To_Lower Wide_Character to
-- Wide_Character conversion to each element of the Wide_String designated
-- by Item. The result is the null Wide_String if the value of the formal
-- parameter is the null Wide_String.
function To_Upper (Item : Wide_Character) return Wide_Character;
pragma Inline (To_Upper);
-- Returns the Simple Uppercase Mapping of the Wide_Character designated by
-- Item. If the Simple Uppercase Mapping does not exist for the
-- Wide_Character designated by Item, then the value of Item is returned.
function To_Upper (Item : Wide_String) return Wide_String;
-- Returns the result of applying the To_Upper Wide_Character to
-- Wide_Character conversion to each element of the Wide_String designated
-- by Item. The result is the null Wide_String if the value of the formal
-- parameter is the null Wide_String.
end Ada.Wide_Characters.Handling;

15
gcc/ada/a-wichun.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2005-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2005-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- --
@ -149,6 +149,19 @@ package body Ada.Wide_Characters.Unicode is
return G.Is_UTF_32_Space (G.Category (C));
end Is_Space;
-------------------
-- To_Lower_Case --
-------------------
function To_Lower_Case
(U : Wide_Character) return Wide_Character
is
begin
return
Wide_Character'Val
(G.UTF_32_To_Lower_Case (Wide_Character'Pos (U)));
end To_Lower_Case;
-------------------
-- To_Upper_Case --
-------------------

12
gcc/ada/a-wichun.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2005-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2005-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -176,7 +176,15 @@ package Ada.Wide_Characters.Unicode is
-- The following function is used to fold to upper case, as required by
-- the Ada 2005 standard rules for identifier case folding. Two
-- identifiers are equivalent if they are identical after folding all
-- letters to upper case using this routine.
-- letters to upper case using this routine. A corresponding function to
-- fold to lower case is also provided.
function To_Lower_Case (U : Wide_Character) return Wide_Character;
pragma Inline (To_Lower_Case);
-- If U represents an upper case letter, returns the corresponding lower
-- case letter, otherwise U is returned unchanged. The folding is locale
-- independent as defined by documents referenced in the note in section
-- 1 of ISO/IEC 10646:2003
function To_Upper_Case (U : Wide_Character) return Wide_Character;
pragma Inline (To_Upper_Case);

186
gcc/ada/a-zchhan.adb Executable file
View File

@ -0,0 +1,186 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . W I D E _ W I D E _ C H A R A C T E R S . H A N D L I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 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- --
-- 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 Ada.Wide_Wide_Characters.Unicode; use Ada.Wide_Wide_Characters.Unicode;
package body Ada.Wide_Wide_Characters.Handling is
---------------------
-- Is_Alphanumeric --
---------------------
function Is_Alphanumeric (Item : Wide_Wide_Character) return Boolean is
begin
return Is_Letter (Item) or else Is_Digit (Item);
end Is_Alphanumeric;
----------------
-- Is_Control --
----------------
function Is_Control (Item : Wide_Wide_Character) return Boolean is
begin
return Get_Category (Item) = Cc;
end Is_Control;
--------------
-- Is_Digit --
--------------
function Is_Digit (Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Digit;
----------------
-- Is_Graphic --
----------------
function Is_Graphic (Item : Wide_Wide_Character) return Boolean is
begin
return not Is_Non_Graphic (Item);
end Is_Graphic;
--------------------------
-- Is_Hexadecimal_Digit --
--------------------------
function Is_Hexadecimal_Digit (Item : Wide_Wide_Character) return Boolean is
begin
return Is_Digit (Item)
or else Item in 'A' .. 'F'
or else Item in 'a' .. 'f';
end Is_Hexadecimal_Digit;
---------------
-- Is_Letter --
---------------
function Is_Letter (Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Letter;
------------------------
-- Is_Line_Terminator --
------------------------
function Is_Line_Terminator (Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Line_Terminator;
--------------
-- Is_Lower --
--------------
function Is_Lower (Item : Wide_Wide_Character) return Boolean is
begin
return Get_Category (Item) = Ll;
end Is_Lower;
-------------
-- Is_Mark --
-------------
function Is_Mark (Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Mark;
--------------
-- Is_Other --
--------------
function Is_Other (Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Other;
--------------------
-- Is_Punctuation --
--------------------
function Is_Punctuation (Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Punctuation;
--------------
-- Is_Space --
--------------
function Is_Space (Item : Wide_Wide_Character) return Boolean
renames Ada.Wide_Wide_Characters.Unicode.Is_Space;
----------------
-- Is_Special --
----------------
function Is_Special (Item : Wide_Wide_Character) return Boolean is
begin
return Is_Graphic (Item) and then not Is_Alphanumeric (Item);
end Is_Special;
--------------
-- Is_Upper --
--------------
function Is_Upper (Item : Wide_Wide_Character) return Boolean is
begin
return Get_Category (Item) = Lu;
end Is_Upper;
--------------
-- To_Lower --
--------------
function To_Lower (Item : Wide_Wide_Character) return Wide_Wide_Character
renames Ada.Wide_Wide_Characters.Unicode.To_Lower_Case;
function To_Lower (Item : Wide_Wide_String) return Wide_Wide_String is
Result : Wide_Wide_String (Item'Range);
begin
for J in Result'Range loop
Result (J) := To_Lower (Item (J));
end loop;
return Result;
end To_Lower;
--------------
-- To_Upper --
--------------
function To_Upper (Item : Wide_Wide_Character) return Wide_Wide_Character
renames Ada.Wide_Wide_Characters.Unicode.To_Upper_Case;
function To_Upper (Item : Wide_Wide_String) return Wide_Wide_String is
Result : Wide_Wide_String (Item'Range);
begin
for J in Result'Range loop
Result (J) := To_Upper (Item (J));
end loop;
return Result;
end To_Upper;
end Ada.Wide_Wide_Characters.Handling;

126
gcc/ada/a-zchhan.ads Executable file
View File

@ -0,0 +1,126 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . W I D E _ W I D E _ C H A R A C T E R S . H A N D L I N G --
-- --
-- S p e c --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
package Ada.Wide_Wide_Characters.Handling is
function Is_Control (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Control);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as other_control, otherwise returns false.
function Is_Letter (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Letter);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as letter_uppercase, letter_lowercase, letter_titlecase,
-- letter_modifier, letter_other, or number_letter. Otherwise returns
-- false.
function Is_Lower (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Lower);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as letter_lowercase, otherwise returns false.
function Is_Upper (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Upper);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as letter_uppercase, otherwise returns false.
function Is_Digit (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Digit);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as number_decimal, otherwise returns false.
function Is_Decimal_Digit (Item : Wide_Wide_Character) return Boolean
renames Is_Digit;
function Is_Hexadecimal_Digit (Item : Wide_Wide_Character) return Boolean;
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as number_decimal, or is in the range 'A' .. 'F' or
-- 'a' .. 'f', otherwise returns false.
function Is_Alphanumeric (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Alphanumeric);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as letter_uppercase, letter_lowercase, letter_titlecase,
-- letter_modifier, letter_other, number_letter, or number_decimal.
-- Otherwise returns false.
function Is_Special (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Special);
-- Returns True if the Wide_Wide_Character designated by Item
-- is categorized as graphic_character, but not categorized as
-- letter_uppercase, letter_lowercase, letter_titlecase, letter_modifier,
-- letter_other, number_letter, or number_decimal. Otherwise returns false.
function Is_Line_Terminator (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Line_Terminator);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as separator_line or separator_paragraph, or if Item is a
-- conventional line terminator character (CR, LF, VT, or FF). Otherwise
-- returns false.
function Is_Mark (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Mark);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as mark_non_spacing or mark_spacing_combining, otherwise
-- returns false.
function Is_Other (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Other);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as other_format, otherwise returns false.
function Is_Punctuation (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Punctuation);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as punctuation_connector, otherwise returns false.
function Is_Space (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Space);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as separator_space, otherwise returns false.
function Is_Graphic (Item : Wide_Wide_Character) return Boolean;
pragma Inline (Is_Graphic);
-- Returns True if the Wide_Wide_Character designated by Item is
-- categorized as graphic_character, otherwise returns false.
function To_Lower (Item : Wide_Wide_Character) return Wide_Wide_Character;
pragma Inline (To_Lower);
-- Returns the Simple Lowercase Mapping of the Wide_Wide_Character
-- designated by Item. If the Simple Lowercase Mapping does not exist for
-- the Wide_Wide_Character designated by Item, then the value of Item is
-- returned.
function To_Lower (Item : Wide_Wide_String) return Wide_Wide_String;
-- Returns the result of applying the To_Lower Wide_Wide_Character to
-- Wide_Wide_Character conversion to each element of the Wide_Wide_String
-- designated by Item. The result is the null Wide_Wide_String if the value
-- of the formal parameter is the null Wide_Wide_String.
function To_Upper (Item : Wide_Wide_Character) return Wide_Wide_Character;
pragma Inline (To_Upper);
-- Returns the Simple Uppercase Mapping of the Wide_Wide_Character
-- designated by Item. If the Simple Uppercase Mapping does not exist for
-- the Wide_Wide_Character designated by Item, then the value of Item is
-- returned.
function To_Upper (Item : Wide_Wide_String) return Wide_Wide_String;
-- Returns the result of applying the To_Upper Wide_Wide_Character to
-- Wide_Wide_Character conversion to each element of the Wide_Wide_String
-- designated by Item. The result is the null Wide_Wide_String if the value
-- of the formal parameter is the null Wide_Wide_String.
end Ada.Wide_Wide_Characters.Handling;

15
gcc/ada/a-zchuni.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2005-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2005-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- --
@ -149,6 +149,19 @@ package body Ada.Wide_Wide_Characters.Unicode is
return G.Is_UTF_32_Space (G.Category (C));
end Is_Space;
-------------------
-- To_Lower_Case --
-------------------
function To_Lower_Case
(U : Wide_Wide_Character) return Wide_Wide_Character
is
begin
return
Wide_Wide_Character'Val
(G.UTF_32_To_Lower_Case (Wide_Wide_Character'Pos (U)));
end To_Lower_Case;
-------------------
-- To_Upper_Case --
-------------------

13
gcc/ada/a-zchuni.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2005-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2005-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- --
@ -173,7 +173,16 @@ package Ada.Wide_Wide_Characters.Unicode is
-- The following function is used to fold to upper case, as required by
-- the Ada 2005 standard rules for identifier case folding. Two
-- identifiers are equivalent if they are identical after folding all
-- letters to upper case using this routine.
-- letters to upper case using this routine. A fold to lower routine is
-- also provided.
function To_Lower_Case
(U : Wide_Wide_Character) return Wide_Wide_Character;
pragma Inline (To_Lower_Case);
-- If U represents an upper case letter, returns the corresponding lower
-- case letter, otherwise U is returned unchanged. The folding is locale
-- independent as defined by documents referenced in the note in section
-- 1 of ISO/IEC 10646:2003
function To_Upper_Case
(U : Wide_Wide_Character) return Wide_Wide_Character;

9
gcc/ada/exp_ch4.adb
View File

@ -2193,7 +2193,14 @@ package body Exp_Ch4 is
begin
Prim := First_Elmt (Collect_Primitive_Operations (Full_Type));
while Present (Prim) loop
if Chars (Node (Prim)) = Name_Op_Eq then
-- Locate primitive equality with the right signature
if Chars (Node (Prim)) = Name_Op_Eq
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
and then Etype (Node (Prim)) = Standard_Boolean
then
if Is_Abstract_Subprogram (Node (Prim)) then
return
Make_Raise_Program_Error (Loc,

10
gcc/ada/exp_util.adb
View File

@ -2451,11 +2451,15 @@ package body Exp_Util is
return;
-- Case of appearing within an Expressions_With_Actions node. We
-- prepend the actions to the list of actions already there.
-- prepend the actions to the list of actions already there, if
-- the node has not been analyzed yet. Otherwise find insertion
-- location further up the tree.
when N_Expression_With_Actions =>
Prepend_List (Ins_Actions, Actions (P));
return;
if not Analyzed (P) then
Prepend_List (Ins_Actions, Actions (P));
return;
end if;
-- Case of appearing in the condition of a while expression or
-- elsif. We insert the actions into the Condition_Actions field.

2
gcc/ada/gnat_ugn.texi
View File

@ -6980,10 +6980,12 @@ may generally be compiled using this switch (see the description of the
@option{-gnat83} and @option{-gnat95} switches for further
information).
@ifset PROEDITION
Note that even though Ada 2005 is the current official version of the
language, GNAT still compiles in Ada 95 mode by default, so if you are
using Ada 2005 features in your program, you must use this switch (or
the equivalent Ada_05 or Ada_2005 configuration pragmas).
@end ifset
@item -gnat12 or -gnat2012 (Ada 2012 mode)
@cindex @option{-gnat12} (@command{gcc})

2
gcc/ada/impunit.adb
View File

@ -177,6 +177,7 @@ package body Impunit is
-- harmless (and useful) to make then available in Ada 95 mode, since
-- they do not deal with Wide_Wide_Character.
"a-wichha", -- Ada.Wide_Characters.Handling
"a-stuten", -- Ada.Strings.UTF_Encoding
"a-suenco", -- Ada.Strings.UTF_Encoding.Conversions
"a-suesen", -- Ada.Strings.UTF_Encoding.String_Encoding
@ -426,6 +427,7 @@ package body Impunit is
"a-wwboio", -- Ada.Wide_Text_IO.Wide_Bounded_IO
"a-wwunio", -- Ada.Wide_Text_IO.Wide_Unbounded_IO
"a-zchara", -- Ada.Wide_Wide_Characters
"a-zchhan", -- Ada.Wide_Wide_Characters.Handling
"a-ztcoio", -- Ada.Wide_Wide_Text_IO.Complex_IO
"a-ztedit", -- Ada.Wide_Wide_Text_IO.Editing
"a-zttest", -- Ada.Wide_Wide_Text_IO.Text_Streams

2
gcc/ada/make.adb
View File

@ -1843,7 +1843,7 @@ package body Make is
elsif not Read_Only and then Main_Project /= No_Project then
if not Check_Source_Info_In_ALI (ALI) then
if not Check_Source_Info_In_ALI (ALI, Project_Tree) then
ALI := No_ALI_Id;
return;
end if;

33
gcc/ada/makeutl.adb
View File

@ -203,7 +203,10 @@ package body Makeutl is
-- Check_Source_Info_In_ALI --
------------------------------
function Check_Source_Info_In_ALI (The_ALI : ALI_Id) return Boolean is
function Check_Source_Info_In_ALI
(The_ALI : ALI_Id;
Tree : Project_Tree_Ref) return Boolean
is
Unit_Name : Name_Id;
begin
@ -242,7 +245,7 @@ package body Makeutl is
end loop;
end loop;
-- Loop to check subunits
-- Loop to check subunits and replaced sources
for D in ALIs.Table (The_ALI).First_Sdep ..
ALIs.Table (The_ALI).Last_Sdep
@ -253,8 +256,32 @@ package body Makeutl is
begin
Unit_Name := SD.Subunit_Name;
if Unit_Name /= No_Name then
if Unit_Name = No_Name then
-- Check if this source file has been replaced by a source with
-- a different file name.
if Tree /= null and then Tree.Replaced_Source_Number > 0 then
declare
Replacement : constant File_Name_Type :=
Replaced_Source_HTable.Get
(Tree.Replaced_Sources, SD.Sfile);
begin
if Replacement /= No_File then
if Verbose_Mode then
Write_Line
("source file" &
Get_Name_String (SD.Sfile) &
" has been replaced by " &
Get_Name_String (Replacement));
end if;
return False;
end if;
end;
end if;
else
-- For separates, the file is no longer associated with the
-- unit ("proc-sep.adb" is not associated with unit "proc.sep")
-- so we need to check whether the source file still exists in

4
gcc/ada/makeutl.ads
View File

@ -105,7 +105,9 @@ package Makeutl is
-- True if the unit is in one of the project file, but the file name is not
-- one of its source. Returns False otherwise.
function Check_Source_Info_In_ALI (The_ALI : ALI.ALI_Id) return Boolean;
function Check_Source_Info_In_ALI
(The_ALI : ALI.ALI_Id;
Tree : Project_Tree_Ref) return Boolean;
-- Check whether all file references in ALI are still valid (i.e. the
-- source files are still associated with the same units). Return True
-- if everything is still valid.

3
gcc/ada/opt.ads
View File

@ -78,6 +78,9 @@ package Opt is
-- GNAT
-- Default Ada version if no switch given. The Warnings off is to kill
-- constant condition warnings.
--
-- WARNING: some scripts rely on the format of this line of code. Any
-- change must be coordinated with the scripts requirements.
Ada_Version : Ada_Version_Type := Ada_Version_Default;
-- GNAT

36
gcc/ada/prj-nmsc.adb
View File

@ -482,7 +482,8 @@ package body Prj.Nmsc is
-- if file cannot be found.
procedure Remove_Source
(Id : Source_Id;
(Tree : Project_Tree_Ref;
Id : Source_Id;
Replaced_By : Source_Id);
-- Remove a file from the list of sources of a project. This might be
-- because the file is replaced by another one in an extending project,
@ -872,7 +873,16 @@ package body Prj.Nmsc is
Lang_Id.First_Source := Id;
if Source_To_Replace /= No_Source then
Remove_Source (Source_To_Replace, Id);
Remove_Source (Data.Tree, Source_To_Replace, Id);
end if;
if Data.Tree.Replaced_Source_Number > 0 and then
Replaced_Source_HTable.Get (Data.Tree.Replaced_Sources, Id.File) /=
No_File
then
Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File);
Data.Tree.Replaced_Source_Number :=
Data.Tree.Replaced_Source_Number - 1;
end if;
Files_Htable.Set (Data.File_To_Source, File_Name, Id);
@ -6193,7 +6203,7 @@ package body Prj.Nmsc is
(Project.Source_Names,
Source.File,
No_Name_Location);
Remove_Source (Source, No_Source);
Remove_Source (Data.Tree, Source, No_Source);
Error_Msg_Name_1 := Name_Id (Source.File);
Error_Msg
@ -6277,7 +6287,7 @@ package body Prj.Nmsc is
end if;
if Source.Path = No_Path_Information then
Remove_Source (Source, No_Source);
Remove_Source (Data.Tree, Source, No_Source);
end if;
end if;
@ -7589,7 +7599,8 @@ package body Prj.Nmsc is
-------------------
procedure Remove_Source
(Id : Source_Id;
(Tree : Project_Tree_Ref;
Id : Source_Id;
Replaced_By : Source_Id)
is
Source : Source_Id;
@ -7609,6 +7620,21 @@ package body Prj.Nmsc is
if Replaced_By /= No_Source then
Id.Replaced_By := Replaced_By;
Replaced_By.Declared_In_Interfaces := Id.Declared_In_Interfaces;
if Id.File /= Replaced_By.File then
declare
Replacement : constant File_Name_Type :=
Replaced_Source_HTable.Get (Tree.Replaced_Sources, Id.File);
begin
Replaced_Source_HTable.Set
(Tree.Replaced_Sources, Id.File, Replaced_By.File);
if Replacement = No_File then
Tree.Replaced_Source_Number :=
Tree.Replaced_Source_Number + 1;
end if;
end;
end if;
end if;
Id.In_Interfaces := False;

3
gcc/ada/prj.adb
View File

@ -898,6 +898,9 @@ package body Prj is
Array_Table.Init (Tree.Arrays);
Package_Table.Init (Tree.Packages);
Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
Replaced_Source_HTable.Reset (Tree.Replaced_Sources);
Tree.Replaced_Source_Number := 0;
Free_List (Tree.Projects, Free_Project => True);
Free_Units (Tree.Units_HT);

15
gcc/ada/prj.ads
View File

@ -1333,6 +1333,14 @@ package Prj is
-- Project_Tree_Data --
-----------------------
package Replaced_Source_HTable is new Simple_HTable
(Header_Num => Header_Num,
Element => File_Name_Type,
No_Element => No_File,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
type Private_Project_Tree_Data is private;
-- Data for a project tree that is used only by the Project Manager
@ -1347,6 +1355,13 @@ package Prj is
Packages : Package_Table.Instance;
Projects : Project_List;
Replaced_Sources : Replaced_Source_HTable.Instance;
-- The list of sources that have been replaced by sources with
-- different file names.
Replaced_Source_Number : Natural := 0;
-- The number of entries in Replaced_Sources
Units_HT : Units_Htable.Instance;
-- Unit name to Unit_Index (and from there so Source_Id)

40
gcc/ada/sem_ch13.adb
View File

@ -2506,16 +2506,16 @@ package body Sem_Ch13 is
-- for the remainder of this processing.
procedure Analyze_Record_Representation_Clause (N : Node_Id) is
Ident : constant Node_Id := Identifier (N);
Rectype : Entity_Id;
CC : Node_Id;
Posit : Uint;
Fbit : Uint;
Lbit : Uint;
Hbit : Uint := Uint_0;
Comp : Entity_Id;
Ocomp : Entity_Id;
Ident : constant Node_Id := Identifier (N);
Biased : Boolean;
CC : Node_Id;
Comp : Entity_Id;
Fbit : Uint;
Hbit : Uint := Uint_0;
Lbit : Uint;
Ocomp : Entity_Id;
Posit : Uint;
Rectype : Entity_Id;
CR_Pragma : Node_Id := Empty;
-- Points to N_Pragma node if Complete_Representation pragma present
@ -2543,10 +2543,6 @@ package body Sem_Ch13 is
("record type required, found}", Ident, First_Subtype (Rectype));
return;
elsif Is_Unchecked_Union (Rectype) then
Error_Msg_N
("record rep clause not allowed for Unchecked_Union", N);
elsif Scope (Rectype) /= Current_Scope then
Error_Msg_N ("type must be declared in this scope", N);
return;
@ -2722,6 +2718,24 @@ package body Sem_Ch13 is
Error_Msg_N
("component clause is for non-existent field", CC);
-- Ada 2012 (AI05-0026): Any name that denotes a
-- discriminant of an object of an unchecked union type
-- shall not occur within a record_representation_clause.
-- The general restriction of using record rep clauses on
-- Unchecked_Union types has now been lifted. Since it is
-- possible to introduce a record rep clause which mentions
-- the discriminant of an Unchecked_Union in non-Ada 2012
-- code, this check is applied to all versions of the
-- language.
elsif Ekind (Comp) = E_Discriminant
and then Is_Unchecked_Union (Rectype)
then
Error_Msg_N
("cannot reference discriminant of Unchecked_Union",
Component_Name (CC));
elsif Present (Component_Clause (Comp)) then
-- Diagnose duplicate rep clause, or check consistency

10
gcc/ada/sem_elab.adb
View File

@ -939,6 +939,16 @@ package body Sem_Elab is
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Elaborated,
Prefix => New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
-- Prevent duplicate elaboration checks on the same call,
-- which can happen if the body enclosing the call appears
-- itself in a call whose elaboration check is delayed.
if
Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
then
Set_No_Elaboration_Check (N);
end if;
end if;
-- Case of static elaboration model

122
gcc/ada/sem_prag.adb
View File

@ -37,6 +37,7 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Dist; use Exp_Dist;
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
@ -392,9 +393,14 @@ package body Sem_Prag is
procedure Check_At_Most_N_Arguments (N : Nat);
-- Check there are no more than N arguments present
procedure Check_Component (Comp : Node_Id);
-- Examine Unchecked_Union component for correct use of per-object
procedure Check_Component
(Comp : Node_Id;
UU_Typ : Entity_Id;
In_Variant_Part : Boolean := False);
-- Examine an Unchecked_Union component for correct use of per-object
-- constrained subtypes, and for restrictions on finalizable components.
-- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
-- should be set when Comp comes from a record variant.
procedure Check_Duplicated_Export_Name (Nam : Node_Id);
-- Nam is an N_String_Literal node containing the external name set by
@ -483,9 +489,10 @@ package body Sem_Prag is
-- and to library level instantiations), and they are simply ignored,
-- which is implemented by rewriting them as null statements.
procedure Check_Variant (Variant : Node_Id);
-- Check Unchecked_Union variant for lack of nested variants and
-- presence of at least one component.
procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
-- Check an Unchecked_Union variant for lack of nested variants and
-- presence of at least one component. UU_Typ is the related Unchecked_
-- Union type.
procedure Error_Pragma (Msg : String);
pragma No_Return (Error_Pragma);
@ -1094,39 +1101,80 @@ package body Sem_Prag is
-- Check_Component --
---------------------
procedure Check_Component (Comp : Node_Id) is
procedure Check_Component
(Comp : Node_Id;
UU_Typ : Entity_Id;
In_Variant_Part : Boolean := False)
is
Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
Sindic : constant Node_Id :=
Subtype_Indication (Component_Definition (Comp));
Typ : constant Entity_Id := Etype (Comp_Id);
function Inside_Generic_Body (Id : Entity_Id) return Boolean;
-- Determine whether entity Id appears inside a generic body
-------------------------
-- Inside_Generic_Body --
-------------------------
function Inside_Generic_Body (Id : Entity_Id) return Boolean is
S : Entity_Id := Id;
begin
while Present (S)
and then S /= Standard_Standard
loop
if Ekind (S) = E_Generic_Package
and then In_Package_Body (S)
then
return True;
end if;
S := Scope (S);
end loop;
return False;
end Inside_Generic_Body;
-- Start of processing for Check_Component
begin
if Nkind (Comp) = N_Component_Declaration then
declare
Sindic : constant Node_Id :=
Subtype_Indication (Component_Definition (Comp));
Typ : constant Entity_Id :=
Etype (Defining_Identifier (Comp));
begin
if Nkind (Sindic) = N_Subtype_Indication then
-- Ada 2005 (AI-216): If a component subtype is subject to a per-
-- object constraint, then the component type shall be an Unchecked_
-- Union.
-- Ada 2005 (AI-216): If a component subtype is subject to
-- a per-object constraint, then the component type shall
-- be an Unchecked_Union.
if Nkind (Sindic) = N_Subtype_Indication
and then Has_Per_Object_Constraint (Comp_Id)
and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
then
Error_Msg_N
("component subtype subject to per-object constraint " &
"must be an Unchecked_Union", Comp);
if Has_Per_Object_Constraint (Defining_Identifier (Comp))
and then
not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
then
Error_Msg_N ("component subtype subject to per-object" &
" constraint must be an Unchecked_Union", Comp);
end if;
end if;
-- Ada 2012 (AI05-0026): For an unchecked union type declared within
-- the body of a generic unit, or within the body of any of its
-- descendant library units, no part of the type of a component
-- declared in a variant_part of the unchecked union type shall be of
-- a formal private type or formal private extension declared within
-- the formal part of the generic unit.
if Is_Controlled (Typ) then
Error_Msg_N
("component of unchecked union cannot be controlled", Comp);
elsif Ada_Version >= Ada_2012
and then Inside_Generic_Body (UU_Typ)
and then In_Variant_Part
and then Is_Private_Type (Typ)
and then Is_Generic_Type (Typ)
then
Error_Msg_N
("component of Unchecked_Union cannot be of generic type", Comp);
elsif Has_Task (Typ) then
Error_Msg_N
("component of unchecked union cannot have tasks", Comp);
end if;
end;
elsif Needs_Finalization (Typ) then
Error_Msg_N
("component of Unchecked_Union cannot be controlled", Comp);
elsif Has_Task (Typ) then
Error_Msg_N
("component of Unchecked_Union cannot have tasks", Comp);
end if;
end Check_Component;
@ -1698,7 +1746,7 @@ package body Sem_Prag is
-- Check_Variant --
-------------------
procedure Check_Variant (Variant : Node_Id) is
procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
Clist : constant Node_Id := Component_List (Variant);
Comp : Node_Id;
@ -1712,7 +1760,7 @@ package body Sem_Prag is
Comp := First (Component_Items (Clist));
while Present (Comp) loop
Check_Component (Comp);
Check_Component (Comp, UU_Typ, In_Variant_Part => True);
Next (Comp);
end loop;
end Check_Variant;
@ -11971,7 +12019,7 @@ package body Sem_Prag is
Comp := First (Component_Items (Clist));
while Present (Comp) loop
Check_Component (Comp);
Check_Component (Comp, Typ);
Next (Comp);
end loop;
@ -11986,7 +12034,7 @@ package body Sem_Prag is
Variant := First (Variants (Vpart));
while Present (Variant) loop
Check_Variant (Variant);
Check_Variant (Variant, Typ);
Next (Variant);
end loop;
end if;

2
gcc/ada/sem_res.adb
View File

@ -1150,7 +1150,7 @@ package body Sem_Res is
begin
return Ekind (Btyp) = E_Access_Type
or else (Ekind (Btyp) = E_Access_Subprogram_Type
and then Comes_From_Source (Btyp));
and then Comes_From_Source (Btyp));
end Is_Definite_Access_Type;
----------------------