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

[multiple changes] 

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

	* 5bml-tgt.adb (Build_Dynamic_Library): Use
	Osint.Include_Dir_Default_Prefix instead of
	Sdefault.Include_Dir_Default_Name.

	* gnatlbr.adb: Update Copyright notice
	(Gnatlbr): : Use Osint.Include_Dir_Default_Prefix instead of
	Sdefault.Include_Dir_Default_Name and Osint.Object_Dir_Default_Prefix
	instead of Sdefault.Object_Dir_Default_Name

	* gnatlink.adb:
	(Process_Binder_File): Never suppress the option following -Xlinker

	* mdll-utl.adb:
	(Gcc): Use Osint.Object_Dir_Default_Prefix instead of
	Sdefault.Object_Dir_Default_Name.

	* osint.ads, osint.adb:
	(Include_Dir_Default_Prefix, Object_Dir_Default_Prefix): New functions
	Minor reformatting.

	* vms_conv.ads: Minor reformating
	Remove GNAT STANDARD and GNAT PSTA

	* vms_conv.adb:
	Allow GNAT MAKE to have several files on the command line.
	(Init_Object_Dirs): Use Osint.Object_Dir_Default_Prefix instead of
	Sdefault.Object_Dir_Default_Name.
	Minor Reformating
	Remove data for GNAT STANDARD

	* vms_data.ads:
	Add new compiler qualifier /PRINT_STANDARD (-gnatS)
	Remove data for GNAT STANDARD
	Remove options and documentation for -gnatwb/-gnatwB: these warning
	options no longer exist.

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

	* 5zthrini.adb: (Init_RTS): Made visible

	* 5zthrini.adb:
	(Register): Removed unnecessary call to taskVarGet that checked whether
	 an ATSD was already set as a task var for the argument thread.

	* s-thread.adb:
	Updated comment to reflect that this is a VxWorks version
	Added context clause for System.Threads.Initialization
	Added call to System.Threads.Initialization.Init_RTS

2003-11-13  Jerome Guitton  <guitton@act-europe.fr>

	* 5zthrini.adb:
	(Init_RTS): New procedure, for the initialization of the run-time lib.

	* s-thread.adb:
	Remove dependancy on System.Init, so that this file can be used in the
	AE653 sequential run-time lib.

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

	* bindgen.adb: Minor reformatting

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

	* checks.adb:
	(Apply_Discriminant_Check): Do no apply check if target type is derived
	from source type with no applicable constraint.

	* lib-writ.adb:
	(Ensure_System_Dependency): Do not apply the style checks that may have
	been specified for the main unit.

	* sem_ch8.adb:
	(Find_Selected_Component): Further improvement in error message, with
	RM reference.

	* sem_res.adb:
	(Resolve): Handle properly the case of an illegal overloaded protected
	procedure.

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

	* exp_aggr.adb:
	(Has_Default_Init_Comps): New function to check the presence of
	default initialization in an aggregate.
	(Build_Record_Aggr_Code): Recursively expand the ancestor in case of
	extension aggregate of a limited record. In addition, a new formal
	was added to do not initialize the record controller (if any) during
	this recursive expansion of ancestors.
	(Init_Controller): Add support for limited record components.
	(Expand_Record_Aggregate): In case of default initialized components
	convert the aggregate into a set of assignments.

	* par-ch4.adb (P_Aggregate_Or_Paren_Expr): Update the comment
	describing the new syntax.
	Nothing else needed to be done because this subprogram delegates part of
	its work to P_Precord_Or_Array_Component_Association.
	(P_Record_Or_Array_Component_Association): Give support to the new
	syntax for default initialization of components.

	* sem_aggr.adb:
	(Resolve_Aggregate): Relax the strictness of the frontend in case of
	limited aggregates.
	(Resolve_Record_Aggregate): Give support to default initialized
	components.
	(Get_Value): In case of default initialized components, duplicate
	the corresponding default expression (from the record type
	declaration). In case of default initialization in the *others*
	choice, do not check that all components have the same type.
	(Resolve_Extension_Aggregate): Give support to limited extension
	aggregates.

	* sem_ch3.adb:
	(Check_Initialization): Relax the strictness of the front-end in case
	of aggregate and extension aggregates. This test is now done in
	Get_Value in a per-component manner.

	* sem_ch4.adb (Analyze_Allocator): Don't post an error if the
	expression corresponds to a limited aggregate. This test is now done
	in Get_Value.

	* sinfo.ads, sinfo.adb (N_Component_Association): Addition of
	Box_Present flag.

	* sprint.adb (Sprint_Node_Actual): Modified to print an mbox if
	present in an N_Component_Association node

2003-11-13  Thomas Quinot  <quinot@act-europe.fr>

	* sem_ch9.adb (Analyze_Accept_Statement): A procedure hides a
	type-conformant entry only if they are homographs.

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

	* Make-lang.in: Makefile automatically updated

From-SVN: r73596
This commit is contained in:
Arnaud Charlet 2003-11-14 11:24:47 +01:00
parent f2b7f367d5
commit 65356e64cf
27 changed files with 2722 additions and 3125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/ada/5bml-tgt.adb
View File

@ -35,10 +35,10 @@ with Ada.Text_IO; use Ada.Text_IO;
with MLib.Fil;
with MLib.Utl;
with Namet; use Namet;
with Osint; use Osint;
with Opt;
with Output; use Output;
with Prj.Com;
with Sdefault;
package body MLib.Tgt is
@ -175,9 +175,9 @@ package body MLib.Tgt is
Last : Natural;
begin
Open (File, In_File,
Sdefault.Include_Dir_Default_Name.all &
"/s-osinte.ads");
Open
(File, In_File,
Include_Dir_Default_Prefix & "/s-osinte.ads");
while not End_Of_File (File) loop
Get_Line (File, Line, Last);

24
gcc/ada/5zthrini.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2003 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- --
@ -36,8 +36,8 @@
with System.Secondary_Stack;
with System.Storage_Elements;
with System.Soft_Links;
with Interfaces.C;
with Unchecked_Conversion;
package body System.Threads.Initialization is
@ -45,6 +45,8 @@ package body System.Threads.Initialization is
package SSS renames System.Secondary_Stack;
package SSL renames System.Soft_Links;
procedure Initialize_Task_Hooks;
-- Register the appropriate hooks (Register and Reset_TSD) to the
-- underlying OS, so that they will be called when a task is created
@ -60,6 +62,19 @@ package body System.Threads.Initialization is
procedure Initialize_Task_Hooks is separate;
-- Separate, as these hooks are different for AE653 and VxWorks 5.5.
--------------
-- Init_RTS --
--------------
procedure Init_RTS is
begin
SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
SSL.Get_Current_Excep := Get_Current_Excep'Access;
SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
end Init_RTS;
--------------
-- Register --
--------------
@ -76,9 +91,7 @@ package body System.Threads.Initialization is
-- (depending on configRecord.c, allocation could be disabled).
-- Otherwise, everything could have been done in Thread_Body_Enter.
if OSI.taskIdVerify (T) = OSI.ERROR
or else OSI.taskVarGet (T, Current_ATSD'Access) /= OSI.ERROR
then
if OSI.taskIdVerify (T) = OSI.ERROR then
return OSI.ERROR;
end if;
@ -102,6 +115,7 @@ package body System.Threads.Initialization is
begin
Initialize_Task_Hooks;
Init_RTS;
-- Register the environment task
declare

138
gcc/ada/ChangeLog
View File

@ -1,3 +1,141 @@
2003-11-13 Vincent Celier <celier@gnat.com>
* 5bml-tgt.adb (Build_Dynamic_Library): Use
Osint.Include_Dir_Default_Prefix instead of
Sdefault.Include_Dir_Default_Name.
* gnatlbr.adb: Update Copyright notice
(Gnatlbr): : Use Osint.Include_Dir_Default_Prefix instead of
Sdefault.Include_Dir_Default_Name and Osint.Object_Dir_Default_Prefix
instead of Sdefault.Object_Dir_Default_Name
* gnatlink.adb:
(Process_Binder_File): Never suppress the option following -Xlinker
* mdll-utl.adb:
(Gcc): Use Osint.Object_Dir_Default_Prefix instead of
Sdefault.Object_Dir_Default_Name.
* osint.ads, osint.adb:
(Include_Dir_Default_Prefix, Object_Dir_Default_Prefix): New functions
Minor reformatting.
* vms_conv.ads: Minor reformating
Remove GNAT STANDARD and GNAT PSTA
* vms_conv.adb:
Allow GNAT MAKE to have several files on the command line.
(Init_Object_Dirs): Use Osint.Object_Dir_Default_Prefix instead of
Sdefault.Object_Dir_Default_Name.
Minor Reformating
Remove data for GNAT STANDARD
* vms_data.ads:
Add new compiler qualifier /PRINT_STANDARD (-gnatS)
Remove data for GNAT STANDARD
Remove options and documentation for -gnatwb/-gnatwB: these warning
options no longer exist.
2003-11-13 Ed Falis <falis@gnat.com>
* 5zthrini.adb: (Init_RTS): Made visible
* 5zthrini.adb:
(Register): Removed unnecessary call to taskVarGet that checked whether
an ATSD was already set as a task var for the argument thread.
* s-thread.adb:
Updated comment to reflect that this is a VxWorks version
Added context clause for System.Threads.Initialization
Added call to System.Threads.Initialization.Init_RTS
2003-11-13 Jerome Guitton <guitton@act-europe.fr>
* 5zthrini.adb:
(Init_RTS): New procedure, for the initialization of the run-time lib.
* s-thread.adb:
Remove dependancy on System.Init, so that this file can be used in the
AE653 sequential run-time lib.
2003-11-13 Robert Dewar <dewar@gnat.com>
* bindgen.adb: Minor reformatting
2003-11-13 Ed Schonberg <schonberg@gnat.com>
* checks.adb:
(Apply_Discriminant_Check): Do no apply check if target type is derived
from source type with no applicable constraint.
* lib-writ.adb:
(Ensure_System_Dependency): Do not apply the style checks that may have
been specified for the main unit.
* sem_ch8.adb:
(Find_Selected_Component): Further improvement in error message, with
RM reference.
* sem_res.adb:
(Resolve): Handle properly the case of an illegal overloaded protected
procedure.
2003-11-13 Javier Miranda <miranda@gnat.com>
* exp_aggr.adb:
(Has_Default_Init_Comps): New function to check the presence of
default initialization in an aggregate.
(Build_Record_Aggr_Code): Recursively expand the ancestor in case of
extension aggregate of a limited record. In addition, a new formal
was added to do not initialize the record controller (if any) during
this recursive expansion of ancestors.
(Init_Controller): Add support for limited record components.
(Expand_Record_Aggregate): In case of default initialized components
convert the aggregate into a set of assignments.
* par-ch4.adb (P_Aggregate_Or_Paren_Expr): Update the comment
describing the new syntax.
Nothing else needed to be done because this subprogram delegates part of
its work to P_Precord_Or_Array_Component_Association.
(P_Record_Or_Array_Component_Association): Give support to the new
syntax for default initialization of components.
* sem_aggr.adb:
(Resolve_Aggregate): Relax the strictness of the frontend in case of
limited aggregates.
(Resolve_Record_Aggregate): Give support to default initialized
components.
(Get_Value): In case of default initialized components, duplicate
the corresponding default expression (from the record type
declaration). In case of default initialization in the *others*
choice, do not check that all components have the same type.
(Resolve_Extension_Aggregate): Give support to limited extension
aggregates.
* sem_ch3.adb:
(Check_Initialization): Relax the strictness of the front-end in case
of aggregate and extension aggregates. This test is now done in
Get_Value in a per-component manner.
* sem_ch4.adb (Analyze_Allocator): Don't post an error if the
expression corresponds to a limited aggregate. This test is now done
in Get_Value.
* sinfo.ads, sinfo.adb (N_Component_Association): Addition of
Box_Present flag.
* sprint.adb (Sprint_Node_Actual): Modified to print an mbox if
present in an N_Component_Association node
2003-11-13 Thomas Quinot <quinot@act-europe.fr>
* sem_ch9.adb (Analyze_Accept_Statement): A procedure hides a
type-conformant entry only if they are homographs.
2003-11-13 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
2003-11-12 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
* adadecode.c: Use <> form of include for ctype.h.

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

File diff suppressed because it is too large Load Diff

1
gcc/ada/bindgen.adb
View File

@ -1895,6 +1895,7 @@ package body Bindgen is
procedure Gen_Output_File (Filename : String) is
Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
begin
-- Acquire settings for Interrupt_State pragmas

20
gcc/ada/checks.adb
View File

@ -1183,6 +1183,26 @@ package body Checks is
if No (DconS) then
return;
end if;
-- A further optimization: if T_Typ is derived from S_Typ
-- without imposing a constraint, no check is needed.
if Nkind (Original_Node (Parent (T_Typ))) =
N_Full_Type_Declaration
then
declare
Type_Def : Node_Id :=
Type_Definition
(Original_Node (Parent (T_Typ)));
begin
if Nkind (Type_Def) = N_Derived_Type_Definition
and then Is_Entity_Name (Subtype_Indication (Type_Def))
and then Entity (Subtype_Indication (Type_Def)) = S_Typ
then
return;
end if;
end;
end if;
end if;
DconT := First_Elmt (Discriminant_Constraint (T_Typ));

153
gcc/ada/exp_aggr.adb
View File

@ -70,6 +70,10 @@ package body Exp_Aggr is
-- statement of variant part will usually be small and probably in near
-- sorted order.
function Has_Default_Init_Comps (N : Node_Id) return Boolean;
-- N is an aggregate (record or array). Checks the presence of
-- default initialization (<>) in any component.
------------------------------------------------------
-- Local subprograms for Record Aggregate Expansion --
------------------------------------------------------
@ -97,12 +101,13 @@ package body Exp_Aggr is
-- assignments component per component.
function Build_Record_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty)
return List_Id;
(N : Node_Id;
Typ : Entity_Id;
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
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
@ -113,6 +118,8 @@ package body Exp_Aggr is
-- object declaration and dynamic allocation cases, it contains
-- an entity that allows to know if the value being created needs to be
-- attached to the final list in case of pragma finalize_Storage_Only.
-- Is_Limited_Ancestor_Expansion indicates that the function has been
-- called recursively to expand the limited ancestor to avoid copying it.
function Has_Mutable_Components (Typ : Entity_Id) return Boolean;
-- Return true if one of the component is of a discriminated type with
@ -1269,12 +1276,13 @@ package body Exp_Aggr is
----------------------------
function Build_Record_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty)
return List_Id
(N : Node_Id;
Typ : Entity_Id;
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
Is_Limited_Ancestor_Expansion : Boolean := False)
return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
L : constant List_Id := New_List;
@ -1540,20 +1548,50 @@ package body Exp_Aggr is
Selector_Name => Make_Identifier (Loc, Name_uController));
Set_Assignment_OK (Ref);
if Init_Pr then
Append_List_To (L,
Build_Initialization_Call (Loc,
Id_Ref => Ref,
Typ => RTE (RE_Record_Controller),
In_Init_Proc => Within_Init_Proc));
end if;
-- Give support to default initialization of limited types and
-- components
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
Name_Initialize), Loc),
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
if (Nkind (Target) = N_Identifier
and then Is_Limited_Type (Etype (Target)))
or else (Nkind (Target) = N_Selected_Component
and then Is_Limited_Type (Etype (Selector_Name (Target))))
or else (Nkind (Target) = N_Unchecked_Type_Conversion
and then Is_Limited_Type (Etype (Target)))
then
if Init_Pr then
Append_List_To (L,
Build_Initialization_Call (Loc,
Id_Ref => Ref,
Typ => RTE (RE_Limited_Record_Controller),
In_Init_Proc => Within_Init_Proc));
end if;
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To
(Find_Prim_Op (RTE (RE_Limited_Record_Controller),
Name_Initialize), Loc),
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
else
if Init_Pr then
Append_List_To (L,
Build_Initialization_Call (Loc,
Id_Ref => Ref,
Typ => RTE (RE_Record_Controller),
In_Init_Proc => Within_Init_Proc));
end if;
Append_To (L,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller),
Name_Initialize), Loc),
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
end if;
Append_To (L,
Make_Attach_Call (
@ -1648,6 +1686,21 @@ package body Exp_Aggr is
Check_Ancestor_Discriminants (Entity (A));
end if;
-- If the ancestor part is a limited type, a recursive call
-- expands the ancestor.
elsif Is_Limited_Type (Etype (A)) then
Ancestor_Is_Expression := True;
Append_List_To (Start_L,
Build_Record_Aggr_Code (
N => Expression (A),
Typ => Etype (Expression (A)),
Target => Target,
Flist => Flist,
Obj => Obj,
Is_Limited_Ancestor_Expansion => True));
-- If the ancestor part is an expression "E", we generate
-- T(tmp) := E;
@ -1767,6 +1820,22 @@ package body Exp_Aggr is
while Present (Comp) loop
Selector := Entity (First (Choices (Comp)));
-- Default initialization of a limited component
if Box_Present (Comp)
and then Is_Limited_Type (Etype (Selector))
then
Append_List_To (L,
Build_Initialization_Call (Loc,
Id_Ref => Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Occurrence_Of (Selector,
Loc)),
Typ => Etype (Selector)));
goto Next_Comp;
end if;
-- ???
if Ekind (Selector) /= E_Discriminant
@ -1900,6 +1969,8 @@ package body Exp_Aggr is
end;
end if;
<<Next_Comp>>
Next (Comp);
end loop;
@ -1997,7 +2068,9 @@ package body Exp_Aggr is
-- In the Has_Controlled component case, all the intermediate
-- controllers must be initialized
if Has_Controlled_Component (Typ) then
if Has_Controlled_Component (Typ)
and not Is_Limited_Ancestor_Expansion
then
declare
Inner_Typ : Entity_Id;
Outer_Typ : Entity_Id;
@ -4082,6 +4155,9 @@ package body Exp_Aggr is
then
Convert_To_Assignments (N, Typ);
elsif Has_Default_Init_Comps (N) then
Convert_To_Assignments (N, Typ);
elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then
Convert_To_Assignments (N, Typ);
@ -4402,6 +4478,31 @@ package body Exp_Aggr is
end if;
end Expand_Record_Aggregate;
----------------------------
-- Has_Default_Init_Comps --
----------------------------
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);
if No (Comps) then
return False;
end if;
C := First (Comps);
while Present (C) loop
if Box_Present (C) then
return True;
end if;
Next (C);
end loop;
return False;
end Has_Default_Init_Comps;
--------------------------
-- Is_Delayed_Aggregate --
--------------------------

7
gcc/ada/gnatlbr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1997-2003 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- --
@ -47,7 +47,6 @@ with GNAT.OS_Lib; use GNAT.OS_Lib;
with Gnatvsn; use Gnatvsn;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with Osint; use Osint;
with Sdefault; use Sdefault;
with System;
procedure GnatLbr is
@ -192,7 +191,7 @@ begin
-- there are two.
--
Include_Dirs := 0;
Include_Dir_Name := String_Access (Include_Dir_Default_Name);
Include_Dir_Name := new String'(Include_Dir_Default_Prefix);
Get_Next_Dir_In_Path_Init (String_Access (Include_Dir_Name));
loop
@ -208,7 +207,7 @@ begin
end loop;
Object_Dirs := 0;
Object_Dir_Name := String_Access (Object_Dir_Default_Name);
Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
Get_Next_Dir_In_Path_Init (String_Access (Object_Dir_Name));
loop

21
gcc/ada/gnatlink.adb
View File

@ -619,6 +619,10 @@ procedure Gnatlink is
GNAT_Shared : Boolean := False;
-- Save state of -shared option.
Xlinker_Was_Previous : Boolean := False;
-- Indicate that "-Xlinker" was the option preceding the current
-- option. If True, then the current option is never suppressed.
-- Rollback data
-- These data items are used to store current binder file context.
@ -936,8 +940,17 @@ procedure Gnatlink is
-- Process switches and options
if Next_Line (Nfirst .. Nlast) /= End_Info then
Xlinker_Was_Previous := False;
loop
if Next_Line (Nfirst .. Nlast) = "-static" then
if Xlinker_Was_Previous
or else Next_Line (Nfirst .. Nlast) = "-Xlinker"
then
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) :=
new String'(Next_Line (Nfirst .. Nlast));
elsif Next_Line (Nfirst .. Nlast) = "-static" then
GNAT_Static := True;
elsif Next_Line (Nfirst .. Nlast) = "-shared" then
@ -946,9 +959,7 @@ procedure Gnatlink is
-- Add binder options only if not already set on the command
-- line. This rule is a way to control the linker options order.
elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast))
or else Next_Line (Nfirst .. Nlast) = "-Xlinker"
then
elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast)) then
if Nlast > Nfirst + 2 and then
Next_Line (Nfirst .. Nfirst + 1) = "-L"
then
@ -1125,6 +1136,8 @@ procedure Gnatlink is
end if;
end if;
Xlinker_Was_Previous := Next_Line (Nfirst .. Nlast) = "-Xlinker";
Get_Next_Line;
exit when Next_Line (Nfirst .. Nlast) = End_Info;

5
gcc/ada/lib-writ.adb
View File

@ -91,6 +91,8 @@ package body Lib.Writ is
System_Fname : File_Name_Type;
-- File name for system spec if needed for dummy entry
Save_Style : constant Boolean := Style_Check;
begin
-- Nothing to do if we already compiled System
@ -133,9 +135,12 @@ package body Lib.Writ is
Error_Location => No_Location);
-- Parse system.ads so that the checksum is set right
-- Style checks are not applied.
Style_Check := False;
Initialize_Scanner (Units.Last, System_Source_File_Index);
Discard_List (Par (Configuration_Pragmas => False));
Style_Check := Save_Style;
end Ensure_System_Dependency;
---------------

6
gcc/ada/mdll-utl.adb
View File

@ -30,7 +30,7 @@ with Ada.Text_IO;
with Ada.Exceptions;
with GNAT.Directory_Operations;
with Sdefault;
with Osint;
package body MDLL.Utl is
@ -155,7 +155,7 @@ package body MDLL.Utl is
Base_File : String := "";
Build_Lib : Boolean := False)
is
use Sdefault;
use Osint;
Arguments : OS_Lib.Argument_List
(1 .. 5 + Files'Length + Options'Length);
@ -167,7 +167,7 @@ package body MDLL.Utl is
Out_V : aliased String := Output_File;
Bas_Opt : aliased String := "-Wl,--base-file," & Base_File;
Lib_Opt : aliased String := "-mdll";
Lib_Dir : aliased String := "-L" & Object_Dir_Default_Name.all;
Lib_Dir : aliased String := "-L" & Object_Dir_Default_Prefix;
begin
A := A + 1;

146
gcc/ada/osint.adb
View File

@ -41,9 +41,12 @@ with GNAT.HTable;
package body Osint is
Running_Program : Program_Type := Unspecified;
Program_Set : Boolean := False;
-- comment required here ???
Std_Prefix : String_Ptr;
Program_Set : Boolean := False;
-- comment required here ???
Std_Prefix : String_Ptr;
-- Standard prefix, computed dynamically the first time Relocate_Path
-- is called, and cached for subsequent calls.
@ -66,8 +69,7 @@ package body Osint is
function Append_Suffix_To_File_Name
(Name : Name_Id;
Suffix : String)
return Name_Id;
Suffix : String) return Name_Id;
-- Appends Suffix to Name and returns the new name.
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
@ -81,14 +83,14 @@ package body Osint is
-- The executable must be located in a directory called "bin", or
-- under root/lib/gcc-lib/..., or under root/libexec/gcc/... Thus, if
-- the executable is stored in directory "/foo/bar/bin", this routine
-- returns "/foo/bar/".
-- Return "" if the location is not recognized as described above.
-- returns "/foo/bar/". Return "" if the location is not recognized
-- as described above.
function Update_Path (Path : String_Ptr) return String_Ptr;
-- Update the specified path to replace the prefix with the location
-- where GNAT is installed. See the file prefix.c in GCC for details.
procedure Write_With_Check (A : Address; N : Integer);
procedure Write_With_Check (A : Address; N : Integer);
-- Writes N bytes from buffer starting at address A to file whose FD is
-- stored in Output_FD, and whose file name is stored as a File_Name_Type
-- in Output_File_Name. A check is made for disk full, and if this is
@ -99,8 +101,7 @@ package body Osint is
(N : File_Name_Type;
T : File_Type;
Dir : Natural;
Name : String)
return File_Name_Type;
Name : String) return File_Name_Type;
-- See if the file N whose name is Name exists in directory Dir. Dir is
-- an index into the Lib_Search_Directories table if T = Library.
-- Otherwise if T = Source, Dir is an index into the
@ -112,8 +113,7 @@ package body Osint is
function To_Path_String_Access
(Path_Addr : Address;
Path_Len : Integer)
return String_Access;
Path_Len : Integer) return String_Access;
-- Converts a C String to an Ada String. Are we doing this to avoid
-- withing Interfaces.C.Strings ???
@ -218,17 +218,15 @@ package body Osint is
Equal => "=");
function Smart_Find_File
(N : File_Name_Type;
T : File_Type)
return File_Name_Type;
(N : File_Name_Type;
T : File_Type) return File_Name_Type;
-- Exactly like Find_File except that if File_Cache_Enabled is True this
-- routine looks first in the hash table to see if the full name of the
-- file is already available.
function Smart_File_Stamp
(N : File_Name_Type;
T : File_Type)
return Time_Stamp_Type;
(N : File_Name_Type;
T : File_Type) return Time_Stamp_Type;
-- Takes the same parameter as the routine above (N is a file name
-- without any prefix directory information) and behaves like File_Stamp
-- except that if File_Cache_Enabled is True this routine looks first in
@ -591,8 +589,7 @@ package body Osint is
function Append_Suffix_To_File_Name
(Name : Name_Id;
Suffix : String)
return Name_Id
Suffix : String) return Name_Id
is
begin
Get_Name_String (Name);
@ -785,7 +782,7 @@ package body Osint is
return new String'("");
end Get_Install_Dir;
-- Beginning of Executable_Prefix
-- Start of processing for Executable_Prefix
begin
Osint.Fill_Arg (Exec_Name'Address, 0);
@ -799,7 +796,7 @@ package body Osint is
end if;
end loop;
-- If you are here, the user has typed the executable name with no
-- If we come here, the user has typed the executable name with no
-- directory prefix.
return Get_Install_Dir (GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name).all);
@ -890,9 +887,8 @@ package body Osint is
---------------
function Find_File
(N : File_Name_Type;
T : File_Type)
return File_Name_Type
(N : File_Name_Type;
T : File_Type) return File_Name_Type
is
begin
Get_Name_String (N);
@ -1089,8 +1085,7 @@ package body Osint is
-- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
function Get_Next_Dir_In_Path
(Search_Path : String_Access)
return String_Access
(Search_Path : String_Access) return String_Access
is
Lower_Bound : Positive := Search_Path_Pos;
Upper_Bound : Positive;
@ -1143,8 +1138,7 @@ package body Osint is
function Get_RTS_Search_Dir
(Search_Dir : String;
File_Type : Search_File_Type)
return String_Ptr
File_Type : Search_File_Type) return String_Ptr
is
procedure Get_Current_Dir
(Dir : System.Address;
@ -1299,6 +1293,28 @@ package body Osint is
end if;
end Get_RTS_Search_Dir;
--------------------------------
-- Include_Dir_Default_Prefix --
--------------------------------
function Include_Dir_Default_Prefix return String is
Include_Dir : String_Access :=
String_Access (Update_Path (Include_Dir_Default_Name));
begin
if Include_Dir = null then
return "";
else
declare
Result : constant String := Include_Dir.all;
begin
Free (Include_Dir);
return Result;
end;
end if;
end Include_Dir_Default_Prefix;
----------------
-- Initialize --
----------------
@ -1409,8 +1425,7 @@ package body Osint is
(N : File_Name_Type;
T : File_Type;
Dir : Natural;
Name : String)
return File_Name_Type
Name : String) return File_Name_Type
is
Dir_Name : String_Ptr;
@ -1451,9 +1466,8 @@ package body Osint is
-------------------------------
function Matching_Full_Source_Name
(N : File_Name_Type;
T : Time_Stamp_Type)
return File_Name_Type
(N : File_Name_Type;
T : Time_Stamp_Type) return File_Name_Type
is
begin
Get_Name_String (N);
@ -1680,6 +1694,28 @@ package body Osint is
return Number_File_Names;
end Number_Of_Files;
-------------------------------
-- Object_Dir_Default_Prefix --
-------------------------------
function Object_Dir_Default_Prefix return String is
Object_Dir : String_Access :=
String_Access (Update_Path (Object_Dir_Default_Name));
begin
if Object_Dir = null then
return "";
else
declare
Result : constant String := Object_Dir.all;
begin
Free (Object_Dir);
return Result;
end;
end if;
end Object_Dir_Default_Prefix;
----------------------
-- Object_File_Name --
----------------------
@ -1768,8 +1804,7 @@ package body Osint is
function Read_Default_Search_Dirs
(Search_Dir_Prefix : String_Access;
Search_File : String_Access;
Search_Dir_Default_Name : String_Access)
return String_Access
Search_Dir_Default_Name : String_Access) return String_Access
is
Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
@ -1888,8 +1923,7 @@ package body Osint is
function Read_Library_Info
(Lib_File : File_Name_Type;
Fatal_Err : Boolean := False)
return Text_Buffer_Ptr
Fatal_Err : Boolean := False) return Text_Buffer_Ptr
is
Lib_FD : File_Descriptor;
-- The file descriptor for the current library file. A negative value
@ -2201,9 +2235,8 @@ package body Osint is
----------------------
function Smart_File_Stamp
(N : File_Name_Type;
T : File_Type)
return Time_Stamp_Type
(N : File_Name_Type;
T : File_Type) return Time_Stamp_Type
is
Time_Stamp : Time_Stamp_Type;
@ -2228,8 +2261,7 @@ package body Osint is
function Smart_Find_File
(N : File_Name_Type;
T : File_Type)
return File_Name_Type
T : File_Type) return File_Name_Type
is
Full_File_Name : File_Name_Type;
@ -2320,13 +2352,11 @@ package body Osint is
function To_Canonical_Dir_Spec
(Host_Dir : String;
Prefix_Style : Boolean)
return String_Access
Prefix_Style : Boolean) return String_Access
is
function To_Canonical_Dir_Spec
(Host_Dir : Address;
Prefix_Flag : Integer)
return Address;
Prefix_Flag : Integer) return Address;
pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
C_Host_Dir : String (1 .. Host_Dir'Length + 1);
@ -2362,13 +2392,11 @@ package body Osint is
function To_Canonical_File_List
(Wildcard_Host_File : String;
Only_Dirs : Boolean)
return String_Access_List_Access
Only_Dirs : Boolean) return String_Access_List_Access
is
function To_Canonical_File_List_Init
(Host_File : Address;
Only_Dirs : Integer)
return Integer;
Only_Dirs : Integer) return Integer;
pragma Import (C, To_Canonical_File_List_Init,
"__gnat_to_canonical_file_list_init");
@ -2421,8 +2449,7 @@ package body Osint is
----------------------------
function To_Canonical_File_Spec
(Host_File : String)
return String_Access
(Host_File : String) return String_Access
is
function To_Canonical_File_Spec (Host_File : Address) return Address;
pragma Import
@ -2457,8 +2484,7 @@ package body Osint is
----------------------------
function To_Canonical_Path_Spec
(Host_Path : String)
return String_Access
(Host_Path : String) return String_Access
is
function To_Canonical_Path_Spec (Host_Path : Address) return Address;
pragma Import
@ -2492,13 +2518,11 @@ package body Osint is
function To_Host_Dir_Spec
(Canonical_Dir : String;
Prefix_Style : Boolean)
return String_Access
Prefix_Style : Boolean) return String_Access
is
function To_Host_Dir_Spec
(Canonical_Dir : Address;
Prefix_Flag : Integer)
return Address;
Prefix_Flag : Integer) return Address;
pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
@ -2528,8 +2552,7 @@ package body Osint is
----------------------------
function To_Host_File_Spec
(Canonical_File : String)
return String_Access
(Canonical_File : String) return String_Access
is
function To_Host_File_Spec (Canonical_File : Address) return Address;
pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
@ -2559,8 +2582,7 @@ package body Osint is
function To_Path_String_Access
(Path_Addr : Address;
Path_Len : Integer)
return String_Access
Path_Len : Integer) return String_Access
is
subtype Path_String is String (1 .. Path_Len);
type Path_String_Access is access Path_String;

8
gcc/ada/osint.ads
View File

@ -217,6 +217,14 @@ package Osint is
-- Search Dir Routines --
-------------------------
function Include_Dir_Default_Prefix return String;
-- Return the directory of the run-time library sources, as modified
-- by update_path.
function Object_Dir_Default_Prefix return String;
-- Return the directory of the run-time library ALI and object files, as
-- modified by update_path.
procedure Add_Default_Search_Dirs;
-- This routine adds the default search dirs indicated by the
-- environment variables and sdefault package.

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

@ -28,6 +28,8 @@ pragma Style_Checks (All_Checks);
-- Turn off subprogram body ordering check. Subprograms are in order
-- by RM section rather than alphabetical
with Hostparm; use Hostparm;
separate (Par)
package body Ch4 is
@ -1116,6 +1118,7 @@ package body Ch4 is
-- POSITIONAL_ARRAY_AGGREGATE ::=
-- (EXPRESSION, EXPRESSION {, EXPRESSION})
-- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
-- | (EXPRESSION {, EXPRESSION}, others => <>)
-- NAMED_ARRAY_AGGREGATE ::=
-- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
@ -1354,6 +1357,7 @@ package body Ch4 is
-- RECORD_COMPONENT_ASSOCIATION ::=
-- [COMPONENT_CHOICE_LIST =>] EXPRESSION
-- | COMPONENT_CHOICE_LIST => <>
-- COMPONENT_CHOICE_LIST =>
-- component_SELECTOR_NAME {| component_SELECTOR_NAME}
@ -1361,6 +1365,7 @@ package body Ch4 is
-- ARRAY_COMPONENT_ASSOCIATION ::=
-- DISCRETE_CHOICE_LIST => EXPRESSION
-- | DISCRETE_CHOICE_LIST => <>
-- Note: this routine only handles the named cases, including others.
-- Cases where the component choice list is not present have already
@ -1376,7 +1381,27 @@ package body Ch4 is
Set_Choices (Assoc_Node, P_Discrete_Choice_List);
Set_Sloc (Assoc_Node, Token_Ptr);
TF_Arrow;
Set_Expression (Assoc_Node, P_Expression);
if Token = Tok_Box then
if not Extensions_Allowed then
Error_Msg_SP
("Limited aggregates are an Ada0X extension");
if OpenVMS then
Error_Msg_SP
("\unit must be compiled with " &
"'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
else
Error_Msg_SP
("\unit must be compiled with -gnatX switch");
end if;
end if;
Set_Box_Present (Assoc_Node);
Scan; -- Past box
else
Set_Expression (Assoc_Node, P_Expression);
end if;
return Assoc_Node;
end P_Record_Or_Array_Component_Association;

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

@ -31,13 +31,14 @@
-- --
------------------------------------------------------------------------------
-- This is the VxWorks/Cert version of this package
-- This is the VxWorks version of this package
with System.Init;
with System.Secondary_Stack;
with Unchecked_Conversion;
with System.Threads.Initialization;
package body System.Threads is
package SSS renames System.Secondary_Stack;
@ -48,6 +49,12 @@ package body System.Threads is
function From_Address is
new Unchecked_Conversion (Address, ATSD_Access);
procedure Init_Float;
pragma Import (C, Init_Float, "__gnat_init_float");
procedure Install_Handler;
pragma Import (C, Install_Handler, "__gnat_install_handler");
-----------------------
-- Get_Current_Excep --
-----------------------
@ -122,8 +129,8 @@ package body System.Threads is
SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size);
Current_ATSD := Process_ATSD_Address;
System.Init.Install_Handler;
System.Init.Init_Float;
Install_Handler;
Init_Float;
end Thread_Body_Enter;
----------------------------------
@ -136,6 +143,7 @@ package body System.Threads is
pragma Unreferenced (EO);
begin
-- No action for this target
null;
end Thread_Body_Exceptional_Exit;
@ -146,7 +154,10 @@ package body System.Threads is
procedure Thread_Body_Leave is
begin
-- No action for this target
null;
end Thread_Body_Leave;
begin
System.Threads.Initialization.Init_RTS;
end System.Threads;

154
gcc/ada/sem_aggr.adb
View File

@ -866,7 +866,9 @@ package body Sem_Aggr is
Error_Msg_N ("aggregate type cannot have limited component", N);
Explain_Limited_Type (Typ, N);
elsif Is_Limited_Type (Typ) then
elsif Is_Limited_Type (Typ)
and not Extensions_Allowed
then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
@ -1913,7 +1915,9 @@ package body Sem_Aggr is
Error_Msg_N ("type of extension aggregate must be tagged", N);
return;
elsif Is_Limited_Type (Typ) then
elsif Is_Limited_Type (Typ)
and not Extensions_Allowed
then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
return;
@ -2017,7 +2021,19 @@ package body Sem_Aggr is
--
-- This variable is updated as a side effect of function Get_Value
procedure Add_Association (Component : Entity_Id; Expr : Node_Id);
Mbox_Present : Boolean := False;
Others_Mbox : Boolean := False;
-- Variables used in case of default initialization to provide a
-- functionality similar to Others_Etype. Mbox_Present indicates
-- that the component takes its default initialization; Others_Mbox
-- indicates that at least one component takes its default initiali-
-- zation. Similar to Others_Etype, they are also updated as a side
-- effect of function Get_Value.
procedure Add_Association
(Component : Entity_Id;
Expr : Node_Id;
Box_Present : Boolean := False);
-- Builds a new N_Component_Association node which associates
-- Component to expression Expr and adds it to the new association
-- list New_Assoc_List being built.
@ -2064,7 +2080,11 @@ package body Sem_Aggr is
-- Add_Association --
---------------------
procedure Add_Association (Component : Entity_Id; Expr : Node_Id) is
procedure Add_Association
(Component : Entity_Id;
Expr : Node_Id;
Box_Present : Boolean := False)
is
Choice_List : constant List_Id := New_List;
New_Assoc : Node_Id;
@ -2072,8 +2092,9 @@ package body Sem_Aggr is
Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List);
New_Assoc :=
Make_Component_Association (Sloc (Expr),
Choices => Choice_List,
Expression => Expr);
Choices => Choice_List,
Expression => Expr,
Box_Present => Box_Present);
Append (New_Assoc, New_Assoc_List);
end Add_Association;
@ -2174,7 +2195,37 @@ package body Sem_Aggr is
Expr : Node_Id := Empty;
Selector_Name : Node_Id;
procedure Check_Non_Limited_Type;
-- Relax check to allow the default initialization of limited types.
-- For example:
-- record
-- C : Lim := (..., others => <>);
-- end record;
procedure Check_Non_Limited_Type is
begin
if Is_Limited_Type (Etype (Compon))
and then Comes_From_Source (Compon)
and then not In_Instance_Body
then
if Extensions_Allowed
and then Present (Expression (Assoc))
and then Nkind (Expression (Assoc)) = N_Aggregate
then
null;
else
Error_Msg_N
("initialization not allowed for limited types", N);
Explain_Limited_Type (Etype (Compon), Compon);
end if;
end if;
end Check_Non_Limited_Type;
begin
Mbox_Present := False;
if Present (From) then
Assoc := First (From);
else
@ -2186,14 +2237,6 @@ package body Sem_Aggr is
while Present (Selector_Name) loop
if Nkind (Selector_Name) = N_Others_Choice then
if Consider_Others_Choice and then No (Expr) then
if Present (Others_Etype) and then
Base_Type (Others_Etype) /= Base_Type (Etype (Compon))
then
Error_Msg_N ("components in OTHERS choice must " &
"have same type", Selector_Name);
end if;
Others_Etype := Etype (Compon);
-- We need to duplicate the expression for each
-- successive component covered by the others choice.
@ -2202,10 +2245,34 @@ package body Sem_Aggr is
-- indispensable otherwise, because each one must be
-- expanded individually to preserve side-effects.
if Expander_Active then
return New_Copy_Tree (Expression (Assoc));
if Box_Present (Assoc) then
Others_Mbox := True;
Mbox_Present := True;
if Expander_Active then
return New_Copy_Tree (Expression (Parent (Compon)));
else
return Expression (Parent (Compon));
end if;
else
return Expression (Assoc);
Check_Non_Limited_Type;
if Present (Others_Etype) and then
Base_Type (Others_Etype) /= Base_Type (Etype
(Compon))
then
Error_Msg_N ("components in OTHERS choice must " &
"have same type", Selector_Name);
end if;
Others_Etype := Etype (Compon);
if Expander_Active then
return New_Copy_Tree (Expression (Assoc));
else
return Expression (Assoc);
end if;
end if;
end if;
@ -2216,10 +2283,27 @@ package body Sem_Aggr is
-- components are grouped together with a "|" choice.
-- For instance "filed1 | filed2 => Expr"
if Present (Next (Selector_Name)) then
Expr := New_Copy_Tree (Expression (Assoc));
if Box_Present (Assoc) then
Mbox_Present := True;
-- Duplicate the default expression of the component
-- from the record type declaration
if Present (Next (Selector_Name)) then
Expr := New_Copy_Tree
(Expression (Parent (Compon)));
else
Expr := Expression (Parent (Compon));
end if;
else
Expr := Expression (Assoc);
Check_Non_Limited_Type;
if Present (Next (Selector_Name)) then
Expr := New_Copy_Tree (Expression (Assoc));
else
Expr := Expression (Assoc);
end if;
end if;
Generate_Reference (Compon, Selector_Name);
@ -2753,7 +2837,18 @@ package body Sem_Aggr is
Component := Node (Component_Elmt);
Expr := Get_Value (Component, Component_Associations (N), True);
if No (Expr) then
if Mbox_Present and then Is_Limited_Type (Etype (Component)) then
-- In case of default initialization of a limited component we
-- pass the limited component to the expander. The expander will
-- generate calls to the corresponding initialization subprograms.
Add_Association
(Component => Component,
Expr => Empty,
Box_Present => True);
elsif No (Expr) then
Error_Msg_NE ("no value supplied for component &!", N, Component);
else
Resolve_Aggr_Expr (Expr, Component);
@ -2783,7 +2878,9 @@ package body Sem_Aggr is
Typech := Empty;
if Nkind (Selectr) = N_Others_Choice then
if No (Others_Etype) then
if No (Others_Etype)
and then not Others_Mbox
then
Error_Msg_N
("OTHERS must represent at least one component", Selectr);
end if;
@ -2804,8 +2901,10 @@ package body Sem_Aggr is
-- component supplied by a previous expansion.
if No (New_Assoc) then
if Box_Present (Parent (Selectr)) then
null;
if Chars (Selectr) /= Name_uTag
elsif Chars (Selectr) /= Name_uTag
and then Chars (Selectr) /= Name_uParent
and then Chars (Selectr) /= Name_uController
then
@ -2827,8 +2926,13 @@ package body Sem_Aggr is
Typech := Base_Type (Etype (Component));
elsif Typech /= Base_Type (Etype (Component)) then
Error_Msg_N
("components in choice list must have same type", Selectr);
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);

16
gcc/ada/sem_ch3.adb
View File

@ -6234,9 +6234,19 @@ package body Sem_Ch3 is
or else Is_Limited_Composite (T))
and then not In_Instance
then
Error_Msg_N
("cannot initialize entities of limited type", Exp);
Explain_Limited_Type (T, Exp);
-- Relax the strictness of the front-end in case of limited
-- aggregates and extension aggregates.
if Extensions_Allowed
and then (Nkind (Exp) = N_Aggregate
or else Nkind (Exp) = N_Extension_Aggregate)
then
null;
else
Error_Msg_N
("cannot initialize entities of limited type", Exp);
Explain_Limited_Type (T, Exp);
end if;
end if;
end Check_Initialization;

3
gcc/ada/sem_ch4.adb
View File

@ -338,7 +338,8 @@ package body Sem_Ch4 is
Check_Restriction (No_Protected_Type_Allocators, N);
end if;
if Is_Limited_Type (Type_Id)
if Nkind (Expression (E)) /= N_Aggregate
and then Is_Limited_Type (Type_Id)
and then Comes_From_Source (N)
and then not In_Instance_Body
then

7
gcc/ada/sem_ch8.adb
View File

@ -4063,10 +4063,9 @@ package body Sem_Ch8 is
if Is_Access_Type (P_Type)
and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type
then
Error_Msg_Node_2 := Selector_Name (N);
Error_Msg_NE (
"\incomplete type& has no visible component&", P,
Designated_Type (P_Type));
Error_Msg_N
("\dereference must not be of an incomplete type " &
"('R'M 3.10.1)", P);
end if;
else

1
gcc/ada/sem_ch9.adb
View File

@ -294,6 +294,7 @@ package body Sem_Ch9 is
while Present (E1) loop
if Ekind (E1) = E_Procedure
and then Chars (E1) = Chars (Entry_Nam)
and then Type_Conformant (E1, Entry_Nam)
then
Error_Msg_N ("entry name is not visible", N);

22
gcc/ada/sem_res.adb
View File

@ -1940,9 +1940,25 @@ package body Sem_Res is
if Is_Overloaded (N)
and then Nkind (N) = N_Function_Call
then
Error_Msg_Node_2 := Typ;
Error_Msg_NE ("no visible interpretation of&" &
" matches expected type&", N, Name (N));
declare
Subp_Name : Node_Id;
begin
if Is_Entity_Name (Name (N)) then
Subp_Name := Name (N);
elsif Nkind (Name (N)) = N_Selected_Component then
-- Protected operation: retrieve operation name.
Subp_Name := Selector_Name (Name (N));
else
raise Program_Error;
end if;
Error_Msg_Node_2 := Typ;
Error_Msg_NE ("no visible interpretation of&" &
" matches expected type&", N, Subp_Name);
end;
if All_Errors_Mode then
declare

2
gcc/ada/sinfo.adb
View File

@ -297,6 +297,7 @@ package body Sinfo is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_Association
or else NT (N).Nkind = N_Formal_Package_Declaration
or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
return Flag15 (N);
@ -2729,6 +2730,7 @@ package body Sinfo is
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_Association
or else NT (N).Nkind = N_Formal_Package_Declaration
or else NT (N).Nkind = N_Formal_Subprogram_Declaration);
Set_Flag15 (N, Val);

1
gcc/ada/sinfo.ads
View File

@ -3008,6 +3008,7 @@ package Sinfo is
-- Choices (List1)
-- Loop_Actions (List2-Sem)
-- Expression (Node3)
-- Box_Present (Flag15)
-- Note: this structure is used for both record component associations
-- and array component associations, since the two cases aren't always

6
gcc/ada/sprint.adb
View File

@ -928,7 +928,11 @@ package body Sprint is
Set_Debug_Sloc;
Sprint_Bar_List (Choices (Node));
Write_Str (" => ");
Sprint_Node (Expression (Node));
if Box_Present (Node) then
Write_Str_With_Col_Check ("<>");
else
Sprint_Node (Expression (Node));
end if;
when N_Component_Clause =>
Write_Indent;

1371
gcc/ada/vms_conv.adb
View File

File diff suppressed because it is too large Load Diff

9
gcc/ada/vms_conv.ads
View File

@ -25,7 +25,7 @@
------------------------------------------------------------------------------
-- This package is part of the GNAT driver. It contains a procedure
-- VMS_Conversion to convert the command line in VMS form to the wquivalent
-- VMS_Conversion to convert the command line in VMS form to the equivalent
-- command line with switches for the GNAT tools that the GNAT driver will
-- invoke.
--
@ -97,9 +97,9 @@ package VMS_Conv is
type Command_Type is
(Bind, Chop, Clean, Compile, Elim, Find, Krunch, Library, Link, List,
Make, Name, Preprocess, Pretty, Shared, Standard, Stub, Xref, Undefined);
Make, Name, Preprocess, Pretty, Shared, Stub, Xref, Undefined);
type Alternate_Command is (Comp, Ls, Kr, Pp, Prep, Psta);
type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
-- Alternate command libel for non VMS system
Corresponding_To : constant array (Alternate_Command) of Command_Type :=
@ -107,8 +107,7 @@ package VMS_Conv is
Ls => List,
Kr => Krunch,
Prep => Preprocess,
Pp => Pretty,
Psta => Standard);
Pp => Pretty);
-- Mapping of alternate commands to commands
subtype Real_Command_Type is Command_Type range Bind .. Xref;

46
gcc/ada/vms_data.ads
View File

@ -1591,6 +1591,17 @@ package VMS_Data is
-- communicated to the compiler through logical names
-- ADA_PRJ_INCLUDE_FILE and ADA_PRJ_OBJECTS_FILE.
S_GCC_Psta : aliased constant S := "/PRINT_STANDARD " &
"-gnatS";
-- /PRINT_STANDARD
--
-- cause the compiler to output a representation of package Standard
-- in a form very close to standard Ada. It is not quite possible to
-- do this and remain entirely Standard (since new numeric base types
-- cannot be created in standard Ada), but the output is easily
-- readable to any Ada programmer, and is useful to determine the
-- characteristics of target dependent types in package Standard.
S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" &
"VERBOSE " &
"-gnatv " &
@ -2278,10 +2289,6 @@ package VMS_Data is
"-gnatwA " &
"ALL_GCC " &
"-Wall " &
"BIASED_ROUNDING " &
"-gnatwb " &
"NOBIASED_ROUNDING " &
"-gnatwB " &
"CONDITIONALS " &
"-gnatwc " &
"NOCONDITIONALS " &
@ -2399,30 +2406,6 @@ package VMS_Data is
-- backend. Most of these are not relevant
-- to Ada.
--
-- BIASED_ROUNDING Activate warnings on biased rounding.
-- If a static floating-point expression has
-- a value that is exactly half way between
-- two adjacent machine numbers, then the
-- rules of Ada (Ada Reference Manual,
-- para 4.9(38)) require that this rounding
-- be done away from zero, even if the normal
-- unbiased rounding rules at run time would
-- require rounding towards zero.
--
-- This warning message alerts you to such
-- instances where compile-time rounding and
-- run-time rounding are not equivalent.
-- If it is important to get proper run-time
-- rounding, then you can force this by
-- making one of the operands into a
-- variable. The default is that such
-- warnings are not generated. Note that
-- /WARNINGS=ALL does not affect the setting
-- of this warning option.
--
-- NOBIASED_ROUNDING Suppress warnings on biased rounding.
-- Disable warnings on biased rounding.
--
-- CONDITIONALS Activate warnings for conditional
-- Expressions used in tests that are known
-- to be True or False at compile time. The
@ -2820,6 +2803,7 @@ package VMS_Data is
S_GCC_OptX 'Access,
S_GCC_Polling 'Access,
S_GCC_Project 'Access,
S_GCC_Psta 'Access,
S_GCC_Report 'Access,
S_GCC_ReportX 'Access,
S_GCC_Repinfo 'Access,
@ -4643,12 +4627,6 @@ package VMS_Data is
S_Shared_Verb 'Access,
S_Shared_ZZZZZ 'Access);
--------------------------------
-- Switches for GNAT STANDARD --
--------------------------------
Standard_Switches : aliased constant Switches := (1 .. 0 => null);
----------------------------
-- Switches for GNAT STUB --
----------------------------