Skip to content

R
riscv-gcc-1
Commit 65356e64 by Arnaud Charlet
Options

[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
parent f2b7f367
Showing with 577 additions and 127 deletions
gcc/ada/5bml-tgt.adb
......@@ -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);
......
gcc/ada/5zthrini.adb
......@@ -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
......@@ -61,6 +63,19 @@ package body System.Threads.Initialization is
-- 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
......
gcc/ada/ChangeLog
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.
......
gcc/ada/Make-lang.in
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/bindgen.adb
......@@ -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
......
gcc/ada/checks.adb
......@@ -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));
......
gcc/ada/exp_aggr.adb
......@@ -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 --
--------------------------
......
gcc/ada/gnatlbr.adb
......@@ -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
......
gcc/ada/gnatlink.adb
......@@ -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;
......
gcc/ada/lib-writ.adb
......@@ -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;
---------------
......
gcc/ada/mdll-utl.adb
......@@ -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;
......
gcc/ada/osint.ads
......@@ -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.
......
gcc/ada/par-ch4.adb
......@@ -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;
......
gcc/ada/s-thread.adb
......@@ -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;
gcc/ada/sem_aggr.adb
......@@ -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);
......
gcc/ada/sem_ch3.adb
......@@ -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;
......
gcc/ada/sem_ch4.adb
......@@ -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
......
gcc/ada/sem_ch8.adb
......@@ -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
......
gcc/ada/sem_ch9.adb
......@@ -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);
......
gcc/ada/sem_res.adb
......@@ -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
......
gcc/ada/sinfo.adb
......@@ -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);
......
gcc/ada/sinfo.ads
......@@ -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
......
gcc/ada/sprint.adb
......@@ -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;
......
gcc/ada/vms_conv.ads
......@@ -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;
......
gcc/ada/vms_data.ads
......@@ -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 --
----------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment