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

[multiple changes]

Browse Source 
2003-11-17  Jerome Guitton  <guitton@act-europe.fr>

	* 5zthrini.adb: Remove the call to Init_RTS at elaboration, as it is
	already called in System.Threads.

	* 5ztiitho.adb (Initialize_Task_Hooks): Remove the registration of the
	environment task, as it has been moved to System.Threads.Initialization.

2003-11-17  Arnaud Charlet  <charlet@act-europe.fr>

	* adaint.c (__gnatlib_install_locks): Only reference
	__gnat_install_locks on VMS, since other platforms can avoid using
	--enable-threads=gnat

2003-11-17  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* ada-tree.h: (TYPE_IS_PACKED_ARRAY_TYPE_P): New macro.

	* decl.c (gnat_to_gnu_entity, case E_Array_Subtype): Set
	TYPE_PACKED_ARRAY_TYPE_P.
	(validate_size): Do not verify size if TYPE_IS_PACKED_ARRAY_TYPE_P.

	Part of PR ada/12806
	* utils.c (float_type_for_precision): Renamed from float_type_for_size.
	Use GET_MODE_PRECISION instead of GET_MODE_BITSIZE.

2003-11-17  Vincent Celier  <celier@gnat.com>

	* gnatchop.adb (Error_Msg): New Boolean parameter Warning, defaulted
	to False.
	Do not set exit status to Failure when Warning is True.
	(Gnatchop): Make errors "no compilation units found" and
	"no source files written" warnings only.

	* make.adb (Gnatmake): When using a project file, set
	Look_In_Primary_Dir to False.
	(Configuration_Pragmas_Switch): Check for Global_Configuration_Pragmas
	and Local_Configuration_Pragmas in the project where they are declared
	not an extending project which might have inherited them.

	* osint.adb (Locate_File): If Name is already an absolute path, do not
	look for a directory.

	* par-ch10.adb (P_Compilation_Unit): If source contains no token, and
	-gnats (Check_Syntax) is used, issue only a warning, not an error.

	* prj.adb (Register_Default_Naming_Scheme): Add new component Project
	in objects of type Variable_Value.

	* prj.ads: (Variable_Value): New component Project

	* prj-nmsc.adb (Ada_Check.Warn_If_Not_Sources): No warning if source
	is in a project extended by Project.

	* prj-proc.adb (Add_Attributes): New parameter Project. Set component
	Project of Variable_Values to this new parameter value.
	(Expression): Set component Project of Variable_Values.
	(Process_Declarative_Items): Call Add_Attributes with parameter Project.
	Set the component Project in array elements.

2003-11-17  Sergey Rybin  <rybin@act-europe.fr>

	* errout.adb: (Initialize): Add initialization for error nodes.

	* sem_ch12.adb (Initialize): Add missing initializations for
	Exchanged_Views and Hidden_Entities.

2003-11-17  Ed Schonberg  <schonberg@gnat.com>

	* sem_ch12.adb (Copy_Generic_Node): Preserve entity when copying an
	already instantiated tree for use in subsequent inlining.
	(Analyze_Associations, Instantiate_Formal_Subprogram,
	Instantiate_Object): improve error message for mismatch in
	instantiations.

	* sem_ch6.adb (Build_Body_To_Inline): Major cleanup to handle
	instantiations of subprograms declared in instances.

2003-11-17  Javier Miranda  <miranda@gnat.com>

	* sem_ch4.adb (Analyze_Allocator): Previous modification must be
	executed only under the Extensions_Allowed flag.

2003-11-17  Robert Dewar  <dewar@gnat.com>

	* a-exexda.adb (Address_Image): Fix documentation to indicate leading
	zeroes suppressed.
	(Address_Image): Fix bug of returning 0x instead of 0x0
	Minor reformatting (function specs).

	* einfo.ads: Minor fix for documentation of Is_Bit_Packed_Array
	(missed case of 33-63)

	* freeze.adb, sem_ch13.adb: Properly check size of packed bit array

	* s-thread.adb: Add comments for pragma Restriction

	* exp_aggr.adb, g-debuti.adb, par-ch4.adb, sem_aggr.adb,
	sem_ch6.adb, sprint.adb, xref_lib.adb: Minor reformatting

2003-11-17  Ed Falis  <falis@gnat.com>

	* s-thread.adb: Added No_Tasking restriction for this implementation.

2003-11-17  Emmanuel Briot  <briot@act-europe.fr>

	* xref_lib.adb (Parse_Identifier_Info): Add handling of generic
	instanciation references in the parent type description.

2003-11-17  GNAT Script  <nobody@gnat.com>

	* Make-lang.in: Makefile automatically updated

From-SVN: r73672
This commit is contained in:
Arnaud Charlet 2003-11-17 15:58:17 +01:00
parent 638dcaa0b0
commit d05ef0ab60
29 changed files with 2619 additions and 1634 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
gcc/ada/5zthrini.adb
View File

@ -115,7 +115,6 @@ package body System.Threads.Initialization is
begin
Initialize_Task_Hooks;
Init_RTS;
-- Register the environment task
declare

3
gcc/ada/5ztiitho.adb
View File

@ -46,7 +46,4 @@ procedure Initialize_Task_Hooks is
Result : OSI.STATUS;
begin
taskCreateHookAdd (Register'Access);
-- Register the environment task
Result := Register (OSI.taskIdSelf);
pragma Assert (Result /= -1);
end Initialize_Task_Hooks;

3614
gcc/ada/Make-lang.in
View File

File diff suppressed because it is too large Load Diff

29
gcc/ada/a-exexda.adb
View File

@ -41,9 +41,8 @@ package body Exception_Data is
-----------------------
function Address_Image (A : System.Address) return String;
-- Returns at string of the form 0xhhhhhhhhh for 32-bit addresses
-- or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are
-- in lower case.
-- Returns at string of the form 0xhhhhhhhhh for an address, with
-- leading zeros suppressed. Hex characters a-f are in lower case.
procedure Append_Info_Nat
(N : Natural;
@ -66,22 +65,19 @@ package body Exception_Data is
-- we then use three intermediate functions :
function Basic_Exception_Information
(X : Exception_Occurrence)
return String;
(X : Exception_Occurrence) return String;
-- Returns the basic exception information string associated with a
-- given exception occurrence. This is the common part shared by both
-- Exception_Information and Tailored_Exception_Infomation.
function Basic_Exception_Traceback
(X : Exception_Occurrence)
return String;
(X : Exception_Occurrence) return String;
-- Returns an image of the complete call chain associated with an
-- exception occurence in its most basic form, that is as a raw sequence
-- of hexadecimal binary addresses.
function Tailored_Exception_Traceback
(X : Exception_Occurrence)
return String;
(X : Exception_Occurrence) return String;
-- Returns an image of the complete call chain associated with an
-- exception occurrence, either in its basic form if no decorator is
-- in place, or as formatted by the decorator otherwise.
@ -121,10 +117,11 @@ package body Exception_Data is
begin
P := S'Last;
N := To_Integer (A);
while N /= 0 loop
loop
S (P) := H (Integer (N mod 16));
P := P - 1;
N := N / 16;
exit when N = 0;
end loop;
S (P - 1) := '0';
@ -184,8 +181,7 @@ package body Exception_Data is
---------------------------------
function Basic_Exception_Information
(X : Exception_Occurrence)
return String
(X : Exception_Occurrence) return String
is
Name : constant String := Exception_Name (X);
Msg : constant String := Exception_Message (X);
@ -251,8 +247,7 @@ package body Exception_Data is
-------------------------------
function Basic_Exception_Traceback
(X : Exception_Occurrence)
return String
(X : Exception_Occurrence) return String
is
Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19;
-- Maximum length of the information string we are building, with :
@ -460,8 +455,7 @@ package body Exception_Data is
----------------------------------
function Tailored_Exception_Traceback
(X : Exception_Occurrence)
return String
(X : Exception_Occurrence) return String
is
-- We indeed reference the decorator *wrapper* from here and not the
-- decorator itself. The purpose of the local variable Wrapper is to
@ -491,8 +485,7 @@ package body Exception_Data is
------------------------------------
function Tailored_Exception_Information
(X : Exception_Occurrence)
return String
(X : Exception_Occurrence) return String
is
-- The tailored exception information is simply the basic information
-- associated with the tailored call chain backtrace.

8
gcc/ada/ada-tree.h
View File

@ -72,10 +72,14 @@ struct lang_type GTY(())
#define TYPE_FAT_POINTER_P(NODE) \
(TREE_CODE (NODE) == RECORD_TYPE && TYPE_IS_FAT_POINTER_P (NODE))
/* For integral types, nonzero if this is a packed array type. Such
types should not be extended to a larger size. */
/* For integral types and array types, nonzero if this is a packed array type.
Such types should not be extended to a larger size. */
#define TYPE_PACKED_ARRAY_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE)
#define TYPE_IS_PACKED_ARRAY_TYPE_P(NODE) \
((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \
&& TYPE_PACKED_ARRAY_TYPE_P (NODE))
/* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that
is not equal to two to the power of its mode's size. */
#define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (INTEGER_TYPE_CHECK (NODE))

6
gcc/ada/adaint.c
View File

@ -2465,13 +2465,15 @@ __gnat_copy_attribs (char *from, char *to, int mode)
extern void __gnat_install_locks (void (*) (void), void (*) (void));
/* This function offers a hook for libgnarl to set the
locking subprograms for libgcc_eh. */
locking subprograms for libgcc_eh.
This is only needed on OpenVMS, since other platforms use standard
--enable-threads=posix option, or similar. */
void
__gnatlib_install_locks (void (*lock) (void) ATTRIBUTE_UNUSED,
void (*unlock) (void) ATTRIBUTE_UNUSED)
{
#ifdef IN_RTS
#if defined (IN_RTS) && defined (VMS)
__gnat_install_locks (lock, unlock);
/* There is a bootstrap path issue if adaint is build with this
symbol unresolved for the stage1 compiler. Since the compiler

17
gcc/ada/decl.c
View File

@ -1992,6 +1992,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
debug_no_type_hash = 0;
TYPE_CONVENTION_FORTRAN_P (gnu_type)
= (Convention (gnat_entity) == Convention_Fortran);
TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
= Is_Packed_Array_Type (gnat_entity);
/* If our size depends on a placeholder and the maximum size doesn't
overflow, use it. */
@ -5752,11 +5754,6 @@ validate_size (Uint uint_size,
else
gnat_error_node = gnat_object;
/* Don't give errors on packed array types; we'll be giving the error on
the type itself soon enough. */
if (Is_Packed_Array_Type (gnat_object))
gnat_error_node = Empty;
/* Return 0 if no size was specified, either because Esize was not Present or
the specified size was zero. */
if (No (uint_size) || uint_size == No_Uint)
@ -5791,11 +5788,11 @@ validate_size (Uint uint_size,
return 0;
}
/* If this is an integral type, the front-end has verified the size, so we
need not do it here (which would entail checking against the bounds).
However, if this is an aliased object, it may not be smaller than the
type of the object. */
if (INTEGRAL_TYPE_P (gnu_type) && ! TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
/* If this is an integral type or a packed array type, the front-end has
verified the size, so we need not do it here (which would entail
checking against the bounds). However, if this is an aliased object, it
may not be smaller than the type of the object. */
if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
&& ! (kind == VAR_DECL && Is_Aliased (gnat_object)))
return size;

6
gcc/ada/einfo.ads
View File

@ -1660,9 +1660,9 @@ package Einfo is
-- Is_Bit_Packed_Array (Flag122) [implementation base type only]
-- Present in all entities. This flag is set for a packed array
-- type that is bit packed (i.e. the component size is known by the
-- front end and is in the range 1-7, 9-15, or 17-31). Is_Packed is
-- always set if Is_Bit_Packed_Array is set, but it is possible for
-- Is_Packed to be set without Is_Bit_Packed_Array or the case of an
-- front end and is in the range 1-7, 9-15, 17-31, or 33-63). Is_Packed
-- is always set if Is_Bit_Packed_Array is set, but it is possible for
-- Is_Packed to be set without Is_Bit_Packed_Array for the case of an
-- array having one or more index types that are enumeration types
-- with non-standard enumeration representations.

6
gcc/ada/errout.adb
View File

@ -1408,6 +1408,12 @@ package body Errout is
Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last;
end if;
-- Set all (???) the error nodes to Empty:
Error_Msg_Node_1 := Empty;
Error_Msg_Node_2 := Empty;
end Initialize;
-----------------

37
gcc/ada/exp_aggr.adb
View File

@ -106,8 +106,7 @@ package body Exp_Aggr is
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
Is_Limited_Ancestor_Expansion : Boolean := False)
return List_Id;
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id;
-- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type
-- of the aggregate. Target is an expression containing the
-- location on which the component by component assignments will
@ -175,8 +174,7 @@ package body Exp_Aggr is
Into : Node_Id;
Scalar_Comp : Boolean;
Indices : List_Id := No_List;
Flist : Node_Id := Empty)
return List_Id;
Flist : Node_Id := Empty) return List_Id;
-- This recursive routine returns a list of statements containing the
-- loops and assignments that are needed for the expansion of the array
-- aggregate N.
@ -207,8 +205,7 @@ package body Exp_Aggr is
Typ : Entity_Id;
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty)
return List_Id;
Obj : Entity_Id := Empty) return List_Id;
-- N is a nested (record or array) aggregate that has been marked
-- with 'Delay_Expansion'. Typ is the expected type of the
-- aggregate and Target is a (duplicable) expression that will
@ -225,8 +222,7 @@ package body Exp_Aggr is
function Make_OK_Assignment_Statement
(Sloc : Source_Ptr;
Name : Node_Id;
Expression : Node_Id)
return Node_Id;
Expression : Node_Id) return Node_Id;
-- This is like Make_Assignment_Statement, except that Assignment_OK
-- is set in the left operand. All assignments built by this unit
-- use this routine. This is needed to deal with assignments to
@ -405,8 +401,7 @@ package body Exp_Aggr is
Into : Node_Id;
Scalar_Comp : Boolean;
Indices : List_Id := No_List;
Flist : Node_Id := Empty)
return List_Id
Flist : Node_Id := Empty) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Index_Base : constant Entity_Id := Base_Type (Etype (Index));
@ -1281,8 +1276,7 @@ package body Exp_Aggr is
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
Is_Limited_Ancestor_Expansion : Boolean := False)
return List_Id
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
L : constant List_Id := New_List;
@ -1333,8 +1327,7 @@ package body Exp_Aggr is
Typ : Entity_Id;
F : Node_Id;
Attach : Node_Id;
Init_Pr : Boolean)
return List_Id;
Init_Pr : Boolean) return List_Id;
-- returns the list of statements necessary to initialize the internal
-- controller of the (possible) ancestor typ into target and attach
-- it to finalization list F. Init_Pr conditions the call to the
@ -1530,8 +1523,7 @@ package body Exp_Aggr is
Typ : Entity_Id;
F : Node_Id;
Attach : Node_Id;
Init_Pr : Boolean)
return List_Id
Init_Pr : Boolean) return List_Id
is
L : constant List_Id := New_List;
Ref : Node_Id;
@ -2434,8 +2426,7 @@ package body Exp_Aggr is
function Flatten
(N : Node_Id;
Ix : Node_Id;
Ixb : Node_Id)
return Boolean;
Ixb : Node_Id) return Boolean;
-- Convert the aggregate into a purely positional form if possible.
function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
@ -2448,8 +2439,7 @@ package body Exp_Aggr is
function Flatten
(N : Node_Id;
Ix : Node_Id;
Ixb : Node_Id)
return Boolean
Ixb : Node_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb));
@ -4485,6 +4475,7 @@ package body Exp_Aggr is
function Has_Default_Init_Comps (N : Node_Id) return Boolean is
Comps : constant List_Id := Component_Associations (N);
C : Node_Id;
begin
pragma Assert (Nkind (N) = N_Aggregate
or else Nkind (N) = N_Extension_Aggregate);
@ -4533,8 +4524,7 @@ package body Exp_Aggr is
Typ : Entity_Id;
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty)
return List_Id
Obj : Entity_Id := Empty) return List_Id
is
begin
if Is_Record_Type (Etype (N)) then
@ -4558,8 +4548,7 @@ package body Exp_Aggr is
function Make_OK_Assignment_Statement
(Sloc : Source_Ptr;
Name : Node_Id;
Expression : Node_Id)
return Node_Id
Expression : Node_Id) return Node_Id
is
begin
Set_Assignment_OK (Name);

30
gcc/ada/freeze.adb
View File

@ -1817,16 +1817,19 @@ package body Freeze is
-- fields with component clauses, where we must check the size.
-- This is not done till the freeze point, since for fixed-point
-- types, we do not know the size until the type is frozen.
-- Similar processing applies to bit packed arrays.
if Is_First_Subtype (Rec) then
Comp := First_Component (Rec);
while Present (Comp) loop
if Present (Component_Clause (Comp))
and then Is_Fixed_Point_Type (Etype (Comp))
and then (Is_Fixed_Point_Type (Etype (Comp))
or else
Is_Bit_Packed_Array (Etype (Comp)))
then
Check_Size
(Component_Clause (Comp),
(Component_Name (Component_Clause (Comp)),
Etype (Comp),
Esize (Comp),
Junk);
@ -2382,6 +2385,29 @@ package body Freeze is
end if;
end if;
-- For bit-packed arrays, check the size
if Is_Bit_Packed_Array (E)
and then Known_Esize (E)
then
declare
Discard : Boolean;
SizC : constant Node_Id := Size_Clause (E);
begin
-- It is not clear if it is possible to have no size
-- clause at this stage, but this is not worth worrying
-- about. Post the error on the entity name in the size
-- clause if present, else on the type entity itself.
if Present (SizC) then
Check_Size (Name (SizC), E, Esize (E), Discard);
else
Check_Size (E, E, Esize (E), Discard);
end if;
end;
end if;
-- Check one common case of a size given where the array
-- needs to be packed, but was not so the size cannot be
-- honored. This would of course be caught by the backend,

16
gcc/ada/g-debuti.adb
View File

@ -39,9 +39,11 @@ package body GNAT.Debug_Utilities is
H : constant array (0 .. 15) of Character := "0123456789ABCDEF";
-- Table of hex digits
--------------------------
-- Image (address case) --
--------------------------
-----------
-- Image --
-----------
-- Address case
function Image (A : Address) return Image_String is
S : Image_String;
@ -71,9 +73,11 @@ package body GNAT.Debug_Utilities is
return S;
end Image;
-------------------------
-- Image (string case) --
-------------------------
-----------
-- Image --
-----------
-- String case
function Image (S : String) return String is
W : String (1 .. 2 * S'Length + 2);

11
gcc/ada/gnatchop.adb
View File

@ -207,7 +207,7 @@ procedure Gnatchop is
-- Local subprograms --
-----------------------
procedure Error_Msg (Message : String);
procedure Error_Msg (Message : String; Warning : Boolean := False);
-- Produce an error message on standard error output
procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time);
@ -337,10 +337,13 @@ procedure Gnatchop is
-- Error_Msg --
---------------
procedure Error_Msg (Message : String) is
procedure Error_Msg (Message : String; Warning : Boolean := False) is
begin
Put_Line (Standard_Error, Message);
if not Warning then
Set_Exit_Status (Failure);
end if;
if Exit_On_Error then
raise Terminate_Program;
@ -1687,7 +1690,7 @@ begin
if Unit.Last = 0 then
if not Write_gnat_adc then
Error_Msg ("no compilation units found");
Error_Msg ("no compilation units found", Warning => True);
end if;
goto No_Files_Written;
@ -1739,7 +1742,7 @@ begin
-- been written.
if not Write_gnat_adc then
Error_Msg ("no source files written");
Error_Msg ("no source files written", Warning => True);
end if;
return;

16
gcc/ada/make.adb
View File

@ -3001,7 +3001,8 @@ package body Make is
if Global_Attribute_Present then
declare
Path : constant String :=
Absolute_Path (Global_Attribute.Value, Main_Project);
Absolute_Path
(Global_Attribute.Value, Global_Attribute.Project);
begin
if not Is_Regular_File (Path) then
Make_Failed
@ -3033,7 +3034,8 @@ package body Make is
if Local_Attribute_Present then
declare
Path : constant String :=
Absolute_Path (Local_Attribute.Value, For_Project);
Absolute_Path
(Local_Attribute.Value, Local_Attribute.Project);
begin
if not Is_Regular_File (Path) then
Make_Failed
@ -3725,6 +3727,16 @@ package body Make is
And_Save => False);
end if;
else
-- If we use a project file, we have already checked that a main
-- specified on the command line with directory information has the
-- path name corresponding to a correct source in the project tree.
-- So, we don't need the directory information to be taken into
-- account by Find_File, and in fact it may lead to take the wrong
-- sources for other compilation units, when there are extending
-- projects.
Opt.Look_In_Primary_Dir := False;
end if;
-- If the user wants a program without a main subprogram, add the

12
gcc/ada/osint.adb
View File

@ -50,6 +50,11 @@ package body Osint is
-- Standard prefix, computed dynamically the first time Relocate_Path
-- is called, and cached for subsequent calls.
Empty : aliased String := "";
No_Dir : constant String_Ptr := Empty'Access;
-- Used in Locate_File as a fake directory when Name is already an
-- absolute path.
-------------------------------------
-- Use of Name_Find and Name_Enter --
-------------------------------------
@ -1430,7 +1435,12 @@ package body Osint is
Dir_Name : String_Ptr;
begin
if T = Library then
-- If Name is already an absolute path, do not look for a directory
if Is_Absolute_Path (Name) then
Dir_Name := No_Dir;
elsif T = Library then
Dir_Name := Lib_Search_Directories.Table (Dir);
else pragma Assert (T /= Config);

5
gcc/ada/par-ch10.adb
View File

@ -299,10 +299,15 @@ package body Ch10 is
elsif Bad_Spelling_Of (Tok_With) then
Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
else
if Operating_Mode = Check_Syntax and then Token = Tok_EOF then
Error_Msg_SC ("?file contains no compilation units");
else
Error_Msg_SC ("compilation unit expected");
Cunit_Error_Flag := True;
Resync_Cunit;
end if;
-- If we are at an end of file, then just quit, the above error
-- message was complaint enough.

1
gcc/ada/par-ch4.adb
View File

@ -1402,6 +1402,7 @@ package body Ch4 is
else
Set_Expression (Assoc_Node, P_Expression);
end if;
return Assoc_Node;
end P_Record_Or_Array_Component_Association;

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

@ -991,8 +991,8 @@ package body Prj.Nmsc is
The_Unit_Data := Units.Table (The_Unit_Id);
if Specs then
if The_Unit_Data.File_Names (Specification).Project /=
Project
if not Check_Project
(The_Unit_Data.File_Names (Specification).Project)
then
Error_Msg
(Project,
@ -1001,8 +1001,8 @@ package body Prj.Nmsc is
end if;
else
if The_Unit_Data.File_Names (Com.Body_Part).Project /=
Project
if not Check_Project
(The_Unit_Data.File_Names (Com.Body_Part).Project)
then
Error_Msg
(Project,

44
gcc/ada/prj-proc.adb
View File

@ -56,7 +56,8 @@ package body Prj.Proc is
-- arguments are not null string.
procedure Add_Attributes
(Decl : in out Declarations;
(Project : Project_Id;
Decl : in out Declarations;
First : Attribute_Node_Id);
-- Add all attributes, starting with First, with their default
-- values to the package or project with declarations Decl.
@ -66,21 +67,18 @@ package body Prj.Proc is
From_Project_Node : Project_Node_Id;
Pkg : Package_Id;
First_Term : Project_Node_Id;
Kind : Variable_Kind)
return Variable_Value;
Kind : Variable_Kind) return Variable_Value;
-- From N_Expression project node From_Project_Node, compute the value
-- of an expression and return it as a Variable_Value.
function Imported_Or_Extended_Project_From
(Project : Project_Id;
With_Name : Name_Id)
return Project_Id;
With_Name : Name_Id) return Project_Id;
-- Find an imported or extended project of Project whose name is With_Name
function Package_From
(Project : Project_Id;
With_Name : Name_Id)
return Package_Id;
With_Name : Name_Id) return Package_Id;
-- Find the package of Project whose name is With_Name
procedure Process_Declarative_Items
@ -143,7 +141,8 @@ package body Prj.Proc is
--------------------
procedure Add_Attributes
(Decl : in out Declarations;
(Project : Project_Id;
Decl : in out Declarations;
First : Attribute_Node_Id)
is
The_Attribute : Attribute_Node_Id := First;
@ -171,7 +170,8 @@ package body Prj.Proc is
when Single =>
New_Attribute :=
(Kind => Single,
(Project => Project,
Kind => Single,
Location => No_Location,
Default => True,
Value => Empty_String);
@ -180,7 +180,8 @@ package body Prj.Proc is
when List =>
New_Attribute :=
(Kind => List,
(Project => Project,
Kind => List,
Location => No_Location,
Default => True,
Values => Nil_String);
@ -225,8 +226,7 @@ package body Prj.Proc is
From_Project_Node : Project_Node_Id;
Pkg : Package_Id;
First_Term : Project_Node_Id;
Kind : Variable_Kind)
return Variable_Value
Kind : Variable_Kind) return Variable_Value
is
The_Term : Project_Node_Id := First_Term;
-- The term in the expression list
@ -241,6 +241,7 @@ package body Prj.Proc is
-- Reference to the last string elements in Result, when Kind is List.
begin
Result.Project := Project;
Result.Location := Location_Of (First_Term);
-- Process each term of the expression, starting with First_Term
@ -536,14 +537,16 @@ package body Prj.Proc is
Expression_Kind_Of (The_Current_Term) = List
then
The_Variable :=
(Kind => List,
(Project => Project,
Kind => List,
Location => No_Location,
Default => True,
Values => Nil_String);
else
The_Variable :=
(Kind => Single,
(Project => Project,
Kind => Single,
Location => No_Location,
Default => True,
Value => Empty_String);
@ -739,8 +742,7 @@ package body Prj.Proc is
function Imported_Or_Extended_Project_From
(Project : Project_Id;
With_Name : Name_Id)
return Project_Id
With_Name : Name_Id) return Project_Id
is
Data : constant Project_Data := Projects.Table (Project);
List : Project_List := Data.Imported_Projects;
@ -779,8 +781,7 @@ package body Prj.Proc is
function Package_From
(Project : Project_Id;
With_Name : Name_Id)
return Package_Id
With_Name : Name_Id) return Package_Id
is
Data : constant Project_Data := Projects.Table (Project);
Result : Package_Id := Data.Decl.Packages;
@ -1035,7 +1036,8 @@ package body Prj.Proc is
-- Set the default values of the attributes
Add_Attributes
(Packages.Table (New_Pkg).Decl,
(Project,
Packages.Table (New_Pkg).Decl,
Package_Attributes.Table
(Package_Id_Of (Current_Item)).First_Attribute);
@ -1260,6 +1262,8 @@ package body Prj.Proc is
Array_Elements.Table (New_Element) :=
Array_Elements.Table (Orig_Element);
Array_Elements.Table (New_Element).Value.Project :=
Project;
-- Adjust the Next link
@ -1856,7 +1860,7 @@ package body Prj.Proc is
Processed_Data.Extended_By := Extended_By;
Processed_Data.Naming := Standard_Naming_Data;
Add_Attributes (Processed_Data.Decl, Attribute_First);
Add_Attributes (Project, Processed_Data.Decl, Attribute_First);
With_Clause := First_With_Clause_Of (From_Project_Node);
while With_Clause /= Empty_Node loop

6
gcc/ada/prj.adb
View File

@ -306,7 +306,8 @@ package body Prj is
Element :=
(Index => Lang,
Index_Case_Sensitive => False,
Value => (Kind => Single,
Value => (Project => No_Project,
Kind => Single,
Location => No_Location,
Default => False,
Value => Default_Spec_Suffix),
@ -341,7 +342,8 @@ package body Prj is
Element :=
(Index => Lang,
Index_Case_Sensitive => False,
Value => (Kind => Single,
Value => (Project => No_Project,
Kind => Single,
Location => No_Location,
Default => False,
Value => Default_Body_Suffix),

12
gcc/ada/prj.ads
View File

@ -77,6 +77,10 @@ package Prj is
function Empty_String return Name_Id;
type Project_Id is new Nat;
No_Project : constant Project_Id := 0;
-- Id of a Project File
type String_List_Id is new Nat;
Nil_String : constant String_List_Id := 0;
type String_Element is record
@ -107,6 +111,7 @@ package Prj is
-- while processing the project tree (unknown package name).
type Variable_Value (Kind : Variable_Kind := Undefined) is record
Project : Project_Id := No_Project;
Location : Source_Ptr := No_Location;
Default : Boolean := False;
case Kind is
@ -122,7 +127,8 @@ package Prj is
-- Default is True if the current value is the default one for the variable
Nil_Variable_Value : constant Variable_Value :=
(Kind => Undefined,
(Project => No_Project,
Kind => Undefined,
Location => No_Location,
Default => False);
-- Value of a non existing variable or array element
@ -303,10 +309,6 @@ package Prj is
-- Returns True if Left and Right are the same naming scheme
-- not considering Specs and Bodies.
type Project_Id is new Nat;
No_Project : constant Project_Id := 0;
-- Id of a Project File
type Project_List is new Nat;
Empty_Project_List : constant Project_List := 0;
-- A list of project files.

5
gcc/ada/s-thread.adb
View File

@ -33,6 +33,11 @@
-- This is the VxWorks version of this package
pragma Restrictions (No_Tasking);
-- The VxWorks version of this package is intended only for programs
-- which do not use Ada tasking. This restriction ensures that this
-- will be checked by the binder.
with System.Secondary_Stack;
with Unchecked_Conversion;

12
gcc/ada/sem_aggr.adb
View File

@ -2202,6 +2202,10 @@ package body Sem_Aggr is
-- C : Lim := (..., others => <>);
-- end record;
----------------------------
-- Check_Non_Limited_Type --
----------------------------
procedure Check_Non_Limited_Type is
begin
if Is_Limited_Type (Etype (Compon))
@ -2223,6 +2227,8 @@ package body Sem_Aggr is
end if;
end Check_Non_Limited_Type;
-- Start of processing for Get_Value
begin
Mbox_Present := False;
@ -2254,8 +2260,8 @@ package body Sem_Aggr is
else
return Expression (Parent (Compon));
end if;
else
else
Check_Non_Limited_Type;
if Present (Others_Etype) and then
@ -2295,8 +2301,8 @@ package body Sem_Aggr is
else
Expr := Expression (Parent (Compon));
end if;
else
else
Check_Non_Limited_Type;
if Present (Next (Selector_Name)) then
@ -2926,13 +2932,11 @@ package body Sem_Aggr is
Typech := Base_Type (Etype (Component));
elsif Typech /= Base_Type (Etype (Component)) then
if not Box_Present (Parent (Selectr)) then
Error_Msg_N
("components in choice list must have same type",
Selectr);
end if;
end if;
Next (Selectr);

74
gcc/ada/sem_ch12.adb
View File

@ -760,6 +760,8 @@ package body Sem_Ch12 is
Actual_Types : constant Elist_Id := New_Elmt_List;
Assoc : constant List_Id := New_List;
Defaults : constant Elist_Id := New_Elmt_List;
Gen_Unit : constant Entity_Id := Defining_Entity
(Parent (F_Copy));
Actuals : List_Id;
Actual : Node_Id;
Formal : Node_Id;
@ -985,8 +987,11 @@ package body Sem_Ch12 is
Defining_Identifier (Analyzed_Formal));
if No (Match) then
Error_Msg_NE ("missing actual for instantiation of &",
Error_Msg_NE
("missing actual&",
Instantiation_Node, Defining_Identifier (Formal));
Error_Msg_NE ("\in instantiation of & declared#",
Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
else
@ -1071,9 +1076,10 @@ package body Sem_Ch12 is
if No (Match) then
Error_Msg_NE
("missing actual for instantiation of&",
Instantiation_Node,
Defining_Identifier (Formal));
("missing actual&",
Instantiation_Node, Defining_Identifier (Formal));
Error_Msg_NE ("\in instantiation of & declared#",
Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
@ -1105,8 +1111,17 @@ package body Sem_Ch12 is
end loop;
if Num_Actuals > Num_Matched then
Error_Msg_N
("unmatched actuals in instantiation", Instantiation_Node);
if Present (Selector_Name (Actual)) then
Error_Msg_NE
("unmatched actual&",
Actual, Selector_Name (Actual));
Error_Msg_NE ("\in instantiation of& declared#",
Actual, Gen_Unit);
else
Error_Msg_NE
("unmatched actual in instantiation of& declared#",
Actual, Gen_Unit);
end if;
end if;
elsif Present (Actuals) then
@ -4641,19 +4656,37 @@ package body Sem_Ch12 is
else
-- If the associated node is still defined, the entity in
-- it is global, and must be copied to the instance.
-- If this copy is being made for a body to inline, it is
-- applied to an instantiated tree, and the entity is already
-- present and must be also preserved.
if Present (Get_Associated_Node (N)) then
if Nkind (Get_Associated_Node (N)) = Nkind (N) then
Set_Entity (New_N, Entity (Get_Associated_Node (N)));
declare
Assoc : constant Node_Id := Get_Associated_Node (N);
begin
if Present (Assoc) then
if Nkind (Assoc) = Nkind (N) then
Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N);
elsif Nkind (Get_Associated_Node (N)) = N_Function_Call then
Set_Entity (New_N, Entity (Name (Get_Associated_Node (N))));
elsif Nkind (Assoc) = N_Function_Call then
Set_Entity (New_N, Entity (Name (Assoc)));
elsif (Nkind (Assoc) = N_Defining_Identifier
or else Nkind (Assoc) = N_Defining_Character_Literal
or else Nkind (Assoc) = N_Defining_Operator_Symbol)
and then Expander_Active
then
-- Inlining case: we are copying a tree that contains
-- global entities, which are preserved in the copy
-- to be used for subsequent inlining.
null;
else
Set_Entity (New_N, Empty);
end if;
end if;
end;
end if;
-- For expanded name, we must copy the Prefix and Selector_Name
@ -5618,6 +5651,8 @@ package body Sem_Ch12 is
Generic_Flags.Init;
Generic_Renamings_HTable.Reset;
Circularity_Detected := False;
Exchanged_Views := No_Elist;
Hidden_Entities := No_Elist;
end Initialize;
----------------------------
@ -6586,8 +6621,10 @@ package body Sem_Ch12 is
else
Error_Msg_NE
("missing actual for instantiation of &",
Instantiation_Node, Formal_Sub);
("missing actual&", Instantiation_Node, Formal_Sub);
Error_Msg_NE
("\in instantiation of & declared#",
Instantiation_Node, Scope (Analyzed_S));
Abandon_Instantiation (Instantiation_Node);
end if;
@ -6729,8 +6766,12 @@ package body Sem_Ch12 is
if No (Actual) then
Error_Msg_NE
("missing actual for instantiation of &",
("missing actual&",
Instantiation_Node, Formal_Id);
Error_Msg_NE
("\in instantiation of & declared#",
Instantiation_Node,
Scope (Defining_Identifier (Analyzed_Formal)));
Abandon_Instantiation (Instantiation_Node);
end if;
@ -6893,8 +6934,11 @@ package body Sem_Ch12 is
else
Error_Msg_NE
("missing actual for instantiation of &",
("missing actual&",
Instantiation_Node, Formal_Id);
Error_Msg_NE ("\in instantiation of & declared#",
Instantiation_Node,
Scope (Defining_Identifier (Analyzed_Formal)));
if Is_Scalar_Type
(Etype (Defining_Identifier (Analyzed_Formal)))

76
gcc/ada/sem_ch13.adb
View File

@ -1881,7 +1881,7 @@ package body Sem_Ch13 is
Biased : Boolean;
Max_Bit_So_Far : Uint;
-- Records the maximum bit position so far. If all field positoins
-- Records the maximum bit position so far. If all field positions
-- are monotonically increasing, then we can skip the circuit for
-- checking for overlap, since no overlap is possible.
@ -2153,10 +2153,9 @@ package body Sem_Ch13 is
CC, Rectype);
end if;
-- This information is also set in the
-- corresponding component of the base type,
-- found by accessing the Original_Record_Component
-- link if it is present.
-- This information is also set in the corresponding
-- component of the base type, found by accessing the
-- Original_Record_Component link if it is present.
Ocomp := Original_Record_Component (Comp);
@ -2848,21 +2847,68 @@ package body Sem_Ch13 is
begin
Biased := False;
-- Immediate return if size is same as standard size or if composite
-- item, or generic type, or type with previous errors.
-- Dismiss cases for generic types or types with previous errors
if No (UT)
or else UT = Any_Type
or else Is_Generic_Type (UT)
or else Is_Generic_Type (Root_Type (UT))
or else Is_Composite_Type (UT)
or else (Known_Esize (UT) and then Siz = Esize (UT))
then
return;
-- Check case of bit packed array
elsif Is_Array_Type (UT)
and then Known_Static_Component_Size (UT)
and then Is_Bit_Packed_Array (UT)
then
declare
Asiz : Uint;
Indx : Node_Id;
Ityp : Entity_Id;
begin
Asiz := Component_Size (UT);
Indx := First_Index (UT);
loop
Ityp := Etype (Indx);
-- If non-static bound, then we are not in the business of
-- trying to check the length, and indeed an error will be
-- issued elsewhere, since sizes of non-static array types
-- cannot be set implicitly or explicitly.
if not Is_Static_Subtype (Ityp) then
return;
end if;
-- Otherwise accumulate next dimension
Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) -
Expr_Value (Type_Low_Bound (Ityp)) +
Uint_1);
Next_Index (Indx);
exit when No (Indx);
end loop;
if Asiz <= Siz then
return;
else
Error_Msg_Uint_1 := Asiz;
Error_Msg_NE
("size for& too small, minimum allowed is ^", N, T);
end if;
end;
-- All other composite types are ignored
elsif Is_Composite_Type (UT) then
return;
-- For fixed-point types, don't check minimum if type is not frozen,
-- since type is not known till then
-- at freeze time.
-- since we don't know all the characteristics of the type that can
-- affect the size (e.g. a specified small) till freeze time.
elsif Is_Fixed_Point_Type (UT)
and then not Is_Frozen (UT)
@ -2872,6 +2918,14 @@ package body Sem_Ch13 is
-- Cases for which a minimum check is required
else
-- Ignore if specified size is correct for the type
if Known_Esize (UT) and then Siz = Esize (UT) then
return;
end if;
-- Otherwise get minimum size
M := UI_From_Int (Minimum_Size (UT));
if Siz < M then

9
gcc/ada/sem_ch4.adb
View File

@ -338,14 +338,19 @@ package body Sem_Ch4 is
Check_Restriction (No_Protected_Type_Allocators, N);
end if;
if Nkind (Expression (E)) /= N_Aggregate
and then Is_Limited_Type (Type_Id)
if Is_Limited_Type (Type_Id)
and then Comes_From_Source (N)
and then not In_Instance_Body
then
if Extensions_Allowed
and then Nkind (Expression (E)) = N_Aggregate
then
null;
else
Error_Msg_N ("initialization not allowed for limited types", N);
Explain_Limited_Type (Type_Id, N);
end if;
end if;
Analyze_And_Resolve (Expression (E), Type_Id);

136
gcc/ada/sem_ch6.adb
View File

@ -82,11 +82,7 @@ package body Sem_Ch6 is
-- Analyze a generic subprogram body. N is the body to be analyzed,
-- and Gen_Id is the defining entity Id for the corresponding spec.
function Build_Body_To_Inline
(N : Node_Id;
Subp : Entity_Id;
Orig_Body : Node_Id)
return Boolean;
procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);
-- If a subprogram has pragma Inline and inlining is active, use generic
-- machinery to build an unexpanded body for the subprogram. This body is
-- subsequenty used for inline expansions at call sites. If subprogram can
@ -132,8 +128,7 @@ package body Sem_Ch6 is
function Is_Non_Overriding_Operation
(Prev_E : Entity_Id;
New_E : Entity_Id)
return Boolean;
New_E : Entity_Id) return Boolean;
-- Enforce the rule given in 12.3(18): a private operation in an instance
-- overrides an inherited operation only if the corresponding operation
-- was overriding in the generic. This can happen for primitive operations
@ -156,8 +151,7 @@ package body Sem_Ch6 is
(T1 : Entity_Id;
T2 : Entity_Id;
Ctype : Conformance_Type;
Get_Inst : Boolean := False)
return Boolean;
Get_Inst : Boolean := False) return Boolean;
-- Check that two formal parameter types conform, checking both
-- for equality of base types, and where required statically
-- matching subtypes, depending on the setting of Ctype.
@ -1142,9 +1136,7 @@ package body Sem_Ch6 is
(Front_End_Inlining
or else Configurable_Run_Time_Mode)))
then
if Build_Body_To_Inline (N, Spec_Id, Copy_Separate_Tree (N)) then
null;
end if;
Build_Body_To_Inline (N, Spec_Id);
end if;
-- Now we can go on to analyze the body
@ -1492,12 +1484,7 @@ package body Sem_Ch6 is
-- Build_Body_To_Inline --
--------------------------
function Build_Body_To_Inline
(N : Node_Id;
Subp : Entity_Id;
Orig_Body : Node_Id)
return Boolean
is
procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Original_Body : Node_Id;
Body_To_Analyze : Node_Id;
@ -1732,7 +1719,7 @@ package body Sem_Ch6 is
if Nkind (Decl) = N_Subprogram_Declaration
and then Present (Body_To_Inline (Decl))
then
return True; -- Done already.
return; -- Done already.
-- Functions that return unconstrained composite types will require
-- secondary stack handling, and cannot currently be inlined.
@ -1744,64 +1731,13 @@ package body Sem_Ch6 is
then
Cannot_Inline
("cannot inline & (unconstrained return type)?", N, Subp);
return False;
return;
end if;
-- We need to capture references to the formals in order to substitute
-- the actuals at the point of inlining, i.e. instantiation. To treat
-- the formals as globals to the body to inline, we nest it within
-- a dummy parameterless subprogram, declared within the real one.
Original_Body := Orig_Body;
-- Within an instance, the current tree is already the result of
-- a generic copy, and not what we need for subsequent inlining.
-- We create the required body by doing an instantiating copy, to
-- obtain the proper partially analyzed tree.
if In_Instance then
if No (Generic_Parent (Specification (N))) then
return False;
elsif Is_Child_Unit (Scope (Current_Scope)) then
return False;
elsif Scope (Current_Scope) = Cunit_Entity (Main_Unit) then
-- compiling an instantiation. There is no point in generating
-- bodies to inline, because they will not be used.
return False;
else
Body_To_Analyze :=
Copy_Generic_Node
(Generic_Parent (Specification (N)), Empty,
Instantiating => True);
end if;
-- Case of not in an instance
else
Body_To_Analyze :=
Copy_Generic_Node (Original_Body, Empty,
Instantiating => False);
end if;
Set_Parameter_Specifications (Specification (Original_Body), No_List);
Set_Defining_Unit_Name (Specification (Original_Body),
Make_Defining_Identifier (Sloc (N), New_Internal_Name ('S')));
Set_Corresponding_Spec (Original_Body, Empty);
if Ekind (Subp) = E_Function then
Set_Subtype_Mark (Specification (Original_Body),
New_Occurrence_Of (Etype (Subp), Sloc (N)));
end if;
if Present (Declarations (Orig_Body))
and then Has_Excluded_Declaration (Declarations (Orig_Body))
if Present (Declarations (N))
and then Has_Excluded_Declaration (Declarations (N))
then
return False;
return;
end if;
if Present (Handled_Statement_Sequence (N)) then
@ -1810,12 +1746,12 @@ package body Sem_Ch6 is
("cannot inline& (exception handler)?",
First (Exception_Handlers (Handled_Statement_Sequence (N))),
Subp);
return False;
return;
elsif
Has_Excluded_Statement
(Statements (Handled_Statement_Sequence (N)))
then
return False;
return;
end if;
end if;
@ -1827,16 +1763,36 @@ package body Sem_Ch6 is
and then not Is_Always_Inlined (Subp)
then
Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
return False;
return;
end if;
if Has_Pending_Instantiation then
Cannot_Inline
("cannot inline& (forward instance within enclosing body)?",
N, Subp);
return False;
return;
end if;
-- Within an instance, the body to inline must be treated as a nested
-- generic, so that the proper global references are preserved.
if In_Instance then
Save_Env (Scope (Current_Scope), Scope (Current_Scope));
Original_Body := Copy_Generic_Node (N, Empty, True);
else
Original_Body := Copy_Separate_Tree (N);
end if;
-- We need to capture references to the formals in order to substitute
-- the actuals at the point of inlining, i.e. instantiation. To treat
-- the formals as globals to the body to inline, we nest it within
-- a dummy parameterless subprogram, declared within the real one.
Set_Parameter_Specifications (Specification (Original_Body), No_List);
Set_Defining_Unit_Name (Specification (Original_Body),
Make_Defining_Identifier (Sloc (N), New_Internal_Name ('S')));
Set_Corresponding_Spec (Original_Body, Empty);
Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
-- Set return type of function, which is also global and does not need
@ -1866,7 +1822,10 @@ package body Sem_Ch6 is
Set_Body_To_Inline (Decl, Original_Body);
Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
Set_Is_Inlined (Subp);
return True;
if In_Instance then
Restore_Env;
end if;
end Build_Body_To_Inline;
-------------------
@ -2972,8 +2931,7 @@ package body Sem_Ch6 is
(T1 : Entity_Id;
T2 : Entity_Id;
Ctype : Conformance_Type;
Get_Inst : Boolean := False)
return Boolean
Get_Inst : Boolean := False) return Boolean
is
Type_1 : Entity_Id := T1;
Type_2 : Entity_Id := T2;
@ -3475,8 +3433,7 @@ package body Sem_Ch6 is
function Fully_Conformant_Expressions
(Given_E1 : Node_Id;
Given_E2 : Node_Id)
return Boolean
Given_E2 : Node_Id) return Boolean
is
E1 : constant Node_Id := Original_Node (Given_E1);
E2 : constant Node_Id := Original_Node (Given_E2);
@ -3849,8 +3806,7 @@ package body Sem_Ch6 is
function Fully_Conformant_Discrete_Subtypes
(Given_S1 : Node_Id;
Given_S2 : Node_Id)
return Boolean
Given_S2 : Node_Id) return Boolean
is
S1 : constant Node_Id := Original_Node (Given_S1);
S2 : constant Node_Id := Original_Node (Given_S2);
@ -3942,8 +3898,7 @@ package body Sem_Ch6 is
function Is_Non_Overriding_Operation
(Prev_E : Entity_Id;
New_E : Entity_Id)
return Boolean
New_E : Entity_Id) return Boolean
is
Formal : Entity_Id;
F_Typ : Entity_Id;
@ -3956,8 +3911,7 @@ package body Sem_Ch6 is
function Types_Correspond
(P_Type : Entity_Id;
N_Type : Entity_Id)
return Boolean;
N_Type : Entity_Id) return Boolean;
-- Returns true if and only if the types (or designated types
-- in the case of anonymous access types) are the same or N_Type
-- is derived directly or indirectly from P_Type.
@ -4005,8 +3959,7 @@ package body Sem_Ch6 is
function Types_Correspond
(P_Type : Entity_Id;
N_Type : Entity_Id)
return Boolean
N_Type : Entity_Id) return Boolean
is
Prev_Type : Entity_Id := Base_Type (P_Type);
New_Type : Entity_Id := Base_Type (N_Type);
@ -5245,7 +5198,6 @@ package body Sem_Ch6 is
function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
Result : Boolean;
begin
Check_Conformance (New_Id, Old_Id, Type_Conformant, False, Result);
return Result;

1
gcc/ada/sprint.adb
View File

@ -928,6 +928,7 @@ package body Sprint is
Set_Debug_Sloc;
Sprint_Bar_List (Choices (Node));
Write_Str (" => ");
if Box_Present (Node) then
Write_Str_With_Col_Check ("<>");
else

6
gcc/ada/utils.c
View File

@ -148,7 +148,7 @@ static tree merge_sizes (tree, tree, tree, int, int);
static tree compute_related_constant (tree, tree);
static tree split_plus (tree, tree *);
static int value_zerop (tree);
static tree float_type_for_size (int, enum machine_mode);
static tree float_type_for_precision (int, enum machine_mode);
static tree convert_to_fat_pointer (tree, tree);
static tree convert_to_thin_pointer (tree, tree);
static tree make_descriptor_field (const char *,tree, tree, tree);
@ -1992,7 +1992,7 @@ gnat_type_for_size (unsigned precision, int unsignedp)
/* Likewise for floating-point types. */
static tree
float_type_for_size (int precision, enum machine_mode mode)
float_type_for_precision (int precision, enum machine_mode mode)
{
tree t;
char type_name[20];
@ -2023,7 +2023,7 @@ tree
gnat_type_for_mode (enum machine_mode mode, int unsignedp)
{
if (GET_MODE_CLASS (mode) == MODE_FLOAT)
return float_type_for_size (GET_MODE_BITSIZE (mode), mode);
return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
else
return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
}