This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
committed: Ada updates
- From: Arnaud Charlet <charlet at ACT-Europe dot FR>
- To: gcc-patches at gcc dot gnu dot org
- Date: Mon, 24 Nov 2003 15:29:00 +0100
- Subject: committed: Ada updates
Tested on x86-linux
--
2003-11-24 Jose Ruiz <ruiz@act-europe.fr>
* Makefile.in:
Use 5zintman.ads for VxWorks targets. This file avoid confusion between
signals and interrupts.
* 5zintman.ads: New File.
* 5zintman.adb: Replace Exception_Interrupts by Exception_Signals, and
add exception signals to the set of unmasked signals.
* 5ztaprop.adb:
Use Abort_Task_Signal instead of Abort_Task_Interrupt to avoid confusion
between signals and interrupts.
Add to Unblocked_Signal_Mask the set of signals that are in
Keep_Unmasked.
* 7sinmaop.adb:
Adding a check to see whether the Interrupt_ID we want to unmask is in
the range of Keep_Unmasked (in procedure Interrupt_Self_Process). The
reason is that the index type of the Keep_Unmasked array is not always
Interrupt_ID; it may be a subtype of Interrupt_ID.
2003-11-24 Gary Dismukes <dismukes@gnat.com>
* exp_util.adb:
(Remove_Side_Effects): Condition constantness of object created for a
an unchecked type conversion on the constantness of the expression
to ensure the correct value for 'Constrained when passing components
of view-converted class-wide objects.
2003-11-24 Robert Dewar <dewar@gnat.com>
* par-load.adb (Load): Improve handling of misspelled and missing units
Removes several cases of compilation abandoned messages
* lib.adb: (Remove_Unit): New procedure
* lib.ads: (Remove_Unit): New procedure
* lib-load.adb: Minor reformatting
2003-11-24 Vincent Celier <celier@gnat.com>
* make.adb:
(Gnatmake, Initialize): Call Usage instead of Makeusg directly
(Marking_Label): Label to mark processed source files. Incremented for
each executable.
(Gnatmake): Increase Marking_Labet for each executable
(Is_Marked): Compare against marking label
(Mark): Mark with marking label
2003-11-24 Jerome Guitton <guitton@act-europe.fr>
* s-thread.ads:
Move the declaration of the TSD for System.Threads to System.Soft_Links.
Add some comments.
* Makefile.in: Added target pair for s-thread.adb for cert runtime.
(rts-cert): build a single relocatable object for the run-time lib.
Fix perms.
2003-11-24 Vasiliy Fofanov <fofanov@act-europe.fr>
* Make-lang.in:
Use gnatls rather than gcc to obtain the location of GNAT RTL for
crosstools build.
2003-11-24 Sergey Rybin <rybin@act-europe.fr>
* opt.adb (Tree_Write): Gnat_Version_String is now a function, so we
can not use it as before (that is, as a variable) when dumping it into
the tree file. Add a local variable to store the result of this
function and to be used as the string to be written into the tree.
* scn.adb (Initialize_Scanner): Add comments explaining the recent
changes.
* sinput.adb (Source_First, Source_Last): In case of
Internal_Source_File, replace returning attributes of
Internal_Source_Ptr (which is wrong) with returning attributes of
Internal_Source.
2003-11-24 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb:
(New_Concatenation_Op): Proper name for New_Binary_Operator, only
used for implicit concatenation operators.
Code cleanup.
* sem_elab.adb:
(Check_Elab_Call): Set No_Elaboration_Check appropriately on calls in
task bodies that are in the scope of a Suppress pragma.
(Check_A Call): Use the flag to prevent spurious elaboration checks.
* sinfo.ads, sinfo.adb:
New flag No_Elaboration_Check on function/procedure calls, to properly
suppress checks on calls in task bodies that are within a local suppress
pragma.
* exp_ch4.adb:
(Expand_Concatenate_Other): Use the proper integer type for the
expression for the upper bound, to avoid universal_integer computations
when possible.
--
Index: 5zintman.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5zintman.adb,v
retrieving revision 1.6
diff -u -p -r1.6 5zintman.adb
--- 5zintman.adb 21 Oct 2003 13:41:52 -0000 1.6
+++ 5zintman.adb 24 Nov 2003 11:49:36 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@@ -62,22 +62,27 @@ package body System.Interrupt_Management
use System.OS_Interface;
use type Interfaces.C.int;
- type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
- Exception_Interrupts : constant Interrupt_List (1 .. 4) :=
- (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
+ type Signal_List is array (Signal_ID range <>) of Signal_ID;
+ Exception_Signals : constant Signal_List (1 .. 4) :=
+ (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
- -- Keep these variables global so that they are initialized only once.
+ -- Keep these variables global so that they are initialized only once
+ -- What are "these variables" ???, I see only one
Exception_Action : aliased struct_sigaction;
- ----------------------
- -- Notify_Exception --
- ----------------------
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
procedure Notify_Exception (signo : Signal);
-- Identify the Ada exception to be raised using
-- the information when the system received a synchronous signal.
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
procedure Notify_Exception (signo : Signal) is
Mask : aliased sigset_t;
Result : int;
@@ -126,10 +131,10 @@ package body System.Interrupt_Management
old_act : aliased struct_sigaction;
begin
- for J in Exception_Interrupts'Range loop
+ for J in Exception_Signals'Range loop
Result :=
sigaction
- (Signal (Exception_Interrupts (J)), Exception_Action'Access,
+ (Signal (Exception_Signals (J)), Exception_Action'Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
end loop;
@@ -160,15 +165,15 @@ begin
-- Change this if you want to use another signal for task abort.
-- SIGTERM might be a good one.
- Abort_Task_Interrupt := SIGABRT;
+ Abort_Task_Signal := SIGABRT;
Exception_Action.sa_handler := Notify_Exception'Address;
Exception_Action.sa_flags := SA_ONSTACK;
Result := sigemptyset (mask'Access);
pragma Assert (Result = 0);
- for J in Exception_Interrupts'Range loop
- Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J)));
+ for J in Exception_Signals'Range loop
+ Result := sigaddset (mask'Access, Signal (Exception_Signals (J)));
pragma Assert (Result = 0);
end loop;
@@ -185,5 +190,15 @@ begin
Reserve (J) := True;
end if;
end loop;
+
+ -- Add exception signals to the set of unmasked signals
+
+ for J in Exception_Signals'Range loop
+ Keep_Unmasked (Exception_Signals (J)) := True;
+ end loop;
+
+ -- The abort signal must also be unmasked
+
+ Keep_Unmasked (Abort_Task_Signal) := True;
end;
end System.Interrupt_Management;
Index: 5ztaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5ztaprop.adb,v
retrieving revision 1.8
diff -u -p -r1.8 5ztaprop.adb
--- 5ztaprop.adb 21 Oct 2003 13:41:53 -0000 1.8
+++ 5ztaprop.adb 24 Nov 2003 11:49:36 -0000
@@ -45,8 +45,8 @@ with System.Tasking.Debug;
with System.Interrupt_Management;
-- used for Keep_Unmasked
--- Abort_Task_Interrupt
--- Interrupt_ID
+-- Abort_Task_Signal
+-- Signal_ID
-- Initialize_Interrupts
with System.Soft_Links;
@@ -262,7 +262,7 @@ package body System.Task_Primitives.Oper
Result :=
sigaction
- (Signal (Interrupt_Management.Abort_Task_Interrupt),
+ (Signal (Interrupt_Management.Abort_Task_Signal),
act'Unchecked_Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
@@ -1008,7 +1008,7 @@ package body System.Task_Primitives.Oper
begin
Result := kill (T.Common.LL.Thread,
- Signal (Interrupt_Management.Abort_Task_Interrupt));
+ Signal (Interrupt_Management.Abort_Task_Signal));
pragma Assert (Result = 0);
end Abort_Task;
@@ -1125,6 +1125,13 @@ package body System.Task_Primitives.Oper
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
+
+ for J in Interrupt_Management.Signal_ID loop
+ if System.Interrupt_Management.Keep_Unmasked (J) then
+ Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
Environment_Task_ID := Environment_Task;
Index: 7sinmaop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/7sinmaop.adb,v
retrieving revision 1.4
diff -u -p -r1.4 7sinmaop.adb
--- 7sinmaop.adb 21 Oct 2003 13:41:53 -0000 1.4
+++ 7sinmaop.adb 24 Nov 2003 11:49:36 -0000
@@ -325,11 +325,16 @@ begin
Storage_Elements.To_Address
(Storage_Elements.Integer_Address (SIG_IGN));
- for I in Interrupt_ID loop
- if Keep_Unmasked (I) then
- Result := sigaddset (mask'Access, Signal (I));
+ for J in Interrupt_ID loop
+
+ -- We need to check whether J is in Keep_Unmasked because
+ -- the index type of the Keep_Unmasked array is not always
+ -- Interrupt_ID; it may be a subtype of Interrupt_ID.
+
+ if J in Keep_Unmasked'Range and then Keep_Unmasked (J) then
+ Result := sigaddset (mask'Access, Signal (J));
pragma Assert (Result = 0);
- Result := sigdelset (allmask'Access, Signal (I));
+ Result := sigdelset (allmask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
Index: exp_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch4.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_ch4.adb
--- exp_ch4.adb 4 Nov 2003 12:51:45 -0000 1.10
+++ exp_ch4.adb 24 Nov 2003 11:49:36 -0000
@@ -1472,7 +1472,7 @@ package body Exp_Ch4 is
-- their base type, Ind_Typ their index type, and Arr_Typ the original
-- array type to which the concatenantion operator applies, then the
-- following subprogram is constructed:
- --
+
-- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
-- L : Ind_Typ;
-- begin
@@ -1489,7 +1489,7 @@ package body Exp_Ch4 is
-- else
-- return Sn;
-- end if;
- --
+
-- declare
-- P : Ind_Typ;
-- H : Ind_Typ :=
@@ -1516,9 +1516,9 @@ package body Exp_Ch4 is
-- P := Ind_Typ'Succ (P);
-- end loop;
-- end if;
- --
+
-- ...
- --
+
-- if Sn'Length /= 0 then
-- P := Sn'First;
-- loop
@@ -1528,7 +1528,7 @@ package body Exp_Ch4 is
-- P := Ind_Typ'Succ (P);
-- end loop;
-- end if;
- --
+
-- return R;
-- end;
-- end Cnn;]
@@ -1598,7 +1598,9 @@ package body Exp_Ch4 is
-- Builds reference to identifier L.
function L_Pos return Node_Id;
- -- Builds expression Ind_Typ'Pos (L).
+ -- Builds expression Integer_Type'(Ind_Typ'Pos (L)).
+ -- We qualify the expression to avoid universal_integer computations
+ -- whenever possible, in the expression for the upper bound H.
function L_Succ return Node_Id;
-- Builds expression Ind_Typ'Succ (L).
@@ -1743,12 +1745,31 @@ package body Exp_Ch4 is
-----------
function L_Pos return Node_Id is
+ Target_Type : Entity_Id;
+
begin
+ -- If the index type is an enumeration type, the computation
+ -- can be done in standard integer. Otherwise, choose a large
+ -- enough integer type.
+
+ if Is_Enumeration_Type (Ind_Typ)
+ or else Root_Type (Ind_Typ) = Standard_Integer
+ or else Root_Type (Ind_Typ) = Standard_Short_Integer
+ or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer
+ then
+ Target_Type := Standard_Integer;
+ else
+ Target_Type := Root_Type (Ind_Typ);
+ end if;
+
return
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Ind_Typ, Loc),
- Attribute_Name => Name_Pos,
- Expressions => New_List (L));
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => New_Reference_To (Target_Type, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Ind_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (L)));
end L_Pos;
------------
Index: exp_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_util.adb,v
retrieving revision 1.15
diff -u -p -r1.15 exp_util.adb
--- exp_util.adb 21 Oct 2003 13:41:59 -0000 1.15
+++ exp_util.adb 24 Nov 2003 11:49:37 -0000
@@ -3510,7 +3510,7 @@ package body Exp_Util is
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
Object_Definition => New_Reference_To (Exp_Type, Loc),
- Constant_Present => True,
+ Constant_Present => not Is_Variable (Exp),
Expression => Relocate_Node (Exp));
Set_Assignment_OK (E);
Index: lib.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib.adb,v
retrieving revision 1.8
diff -u -p -r1.8 lib.adb
--- lib.adb 10 Nov 2003 17:29:59 -0000 1.8
+++ lib.adb 24 Nov 2003 11:49:37 -0000
@@ -870,6 +870,17 @@ package body Lib is
return Int (Units.Last) - Int (Main_Unit) + 1;
end Num_Units;
+ -----------------
+ -- Remove_Unit --
+ -----------------
+
+ procedure Remove_Unit (U : Unit_Number_Type) is
+ begin
+ if U = Units.Last then
+ Units.Decrement_Last;
+ end if;
+ end Remove_Unit;
+
----------------------------------
-- Replace_Linker_Option_String --
----------------------------------
Index: lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib.ads,v
retrieving revision 1.7
diff -u -p -r1.7 lib.ads
--- lib.ads 10 Nov 2003 17:29:59 -0000 1.7
+++ lib.ads 24 Nov 2003 11:49:37 -0000
@@ -417,6 +417,10 @@ package Lib is
function Num_Units return Nat;
-- Number of units currently in unit table
+ procedure Remove_Unit (U : Unit_Number_Type);
+ -- Remove unit U from unit table. Currently this is effective only
+ -- if U is the last unit currently stored in the unit table.
+
function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean;
-- Returns True if the entity E is declared in the main unit, or, in
-- its corresponding spec, or one of its subunits. Entities declared
Index: lib-load.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib-load.adb,v
retrieving revision 1.8
diff -u -p -r1.8 lib-load.adb
--- lib-load.adb 20 Nov 2003 09:53:58 -0000 1.8
+++ lib-load.adb 24 Nov 2003 11:49:37 -0000
@@ -688,14 +688,11 @@ package body Lib.Load is
procedure Make_Instance_Unit (N : Node_Id) is
Sind : constant Source_File_Index := Source_Index (Main_Unit);
-
begin
Units.Increment_Last;
-
Units.Table (Units.Last) := Units.Table (Main_Unit);
Units.Table (Units.Last).Cunit := Library_Unit (N);
Units.Table (Units.Last).Generate_Code := True;
-
Units.Table (Main_Unit).Cunit := N;
Units.Table (Main_Unit).Unit_Name :=
Get_Body_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N))));
@@ -713,7 +710,6 @@ package body Lib.Load is
is
Sunit : constant Node_Id := Cunit (Spec_Unit);
Bunit : constant Node_Id := Cunit (Body_Unit);
-
begin
-- The spec is irrelevant if the body is a subprogram body, and the
-- spec is other than a subprogram spec or generic subprogram spec.
@@ -725,7 +721,6 @@ package body Lib.Load is
Nkind (Unit (Bunit)) = N_Subprogram_Body
and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration
and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration;
-
end Spec_Is_Irrelevant;
--------------------
@@ -735,9 +730,7 @@ package body Lib.Load is
procedure Version_Update (U : Node_Id; From : Node_Id) is
Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U);
Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From);
-
begin
-
if Source_Index (Fnum) /= No_Source_File then
Units.Table (Unum).Version :=
Units.Table (Unum).Version
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.24
diff -u -p -r1.24 make.adb
--- make.adb 21 Nov 2003 10:46:37 -0000 1.24
+++ make.adb 24 Nov 2003 11:49:37 -0000
@@ -24,12 +24,6 @@
-- --
------------------------------------------------------------------------------
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Command_Line; use Ada.Command_Line;
-
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.Case_Util; use GNAT.Case_Util;
-
with ALI; use ALI;
with ALI.Util; use ALI.Util;
with Csets;
@@ -65,6 +59,12 @@ with System.HTable;
with Targparm;
with Tempdir;
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Command_Line; use Ada.Command_Line;
+
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.Case_Util; use GNAT.Case_Util;
+
package body Make is
use ASCII;
@@ -480,6 +480,9 @@ package body Make is
-- Marking Routines --
----------------------
+ Marking_Label : Byte := 1;
+ -- Value to mark the source files
+
procedure Mark (Source_File : File_Name_Type);
-- Mark Source_File. Marking is used to signal that Source_File has
-- already been inserted in the Q.
@@ -2233,7 +2236,9 @@ package body Make is
-------------
function Compile
- (S : Name_Id; L : Name_Id; Args : Argument_List) return Process_Id
+ (S : Name_Id;
+ L : Name_Id;
+ Args : Argument_List) return Process_Id
is
Comp_Args : Argument_List (Args'First .. Args'Last + 8);
Comp_Next : Integer := Args'First;
@@ -3692,7 +3697,7 @@ package body Make is
else
-- Output usage information if no files to compile
- Makeusg;
+ Usage;
Exit_Program (E_Fatal);
end if;
end if;
@@ -4228,6 +4233,18 @@ package body Make is
Multiple_Main_Loop : for N_File in 1 .. Osint.Number_Of_Files loop
+ -- Increase the marking label to be sure to check sources
+ -- for all executables.
+
+ Marking_Label := Marking_Label + 1;
+
+ -- Make sure it is not 0, which is the default value for
+ -- a file that has never been marked.
+
+ if Marking_Label = 0 then
+ Marking_Label := 1;
+ end if;
+
-- First, find the executable name and path
Executable := No_File;
@@ -5573,7 +5590,7 @@ package body Make is
end loop Scan_Args;
if Usage_Requested then
- Makeusg;
+ Usage;
end if;
-- Test for trailing -P switch
@@ -5695,6 +5712,10 @@ package body Make is
Make_Failed (Exception_Message (Err));
end;
end if;
+
+ -- Set the marking label to a value that is not zero
+
+ Marking_Label := 1;
end Initialize;
-----------------------------------
@@ -5707,10 +5728,11 @@ package body Make is
Into_Q : Boolean)
is
Put_In_Q : Boolean := Into_Q;
- Unit : Com.Unit_Data;
- Sfile : Name_Id;
+ Unit : Com.Unit_Data;
+ Sfile : Name_Id;
+
Extending : constant Boolean :=
- Projects.Table (The_Project).Extends /= No_Project;
+ Projects.Table (The_Project).Extends /= No_Project;
function Check_Project (P : Project_Id) return Boolean;
-- Returns True if P is The_Project or a project extended by
@@ -6044,7 +6066,7 @@ package body Make is
function Is_Marked (Source_File : File_Name_Type) return Boolean is
begin
- return Get_Name_Table_Byte (Source_File) /= 0;
+ return Get_Name_Table_Byte (Source_File) = Marking_Label;
end Is_Marked;
----------
@@ -6228,7 +6250,7 @@ package body Make is
procedure Mark (Source_File : File_Name_Type) is
begin
- Set_Name_Table_Byte (Source_File, 1);
+ Set_Name_Table_Byte (Source_File, Marking_Label);
end Mark;
--------------------
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.54
diff -u -p -r1.54 Makefile.in
--- Makefile.in 20 Nov 2003 09:53:58 -0000 1.54
+++ Makefile.in 24 Nov 2003 11:49:37 -0000
@@ -461,6 +461,7 @@ ifeq ($(strip $(filter-out alpha% dec vx
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -487,6 +488,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -524,6 +526,7 @@ ifeq ($(strip $(filter-out powerpc% wrs
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -593,6 +596,7 @@ ifeq ($(strip $(filter-out powerpc% wrs
s-soflin.ads<2ssoflin.ads \
s-stalib.adb<1sstalib.adb \
s-stalib.ads<1sstalib.ads \
+ s-thread.adb<5zthread.adb \
s-thrini.ads<2sthrini.ads \
s-thrini.adb<5zthrini.adb \
s-tiitho.adb<5ztiitho.adb \
@@ -619,6 +623,7 @@ ifeq ($(strip $(filter-out powerpc% wrs
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -692,7 +697,7 @@ ifeq ($(strip $(filter-out powerpc% wrs
s-soflin.ads<2ssoflin.ads \
s-stalib.adb<1sstalib.adb \
s-stalib.ads<1sstalib.ads \
- s-thrini.adb<5zthrini.adb \
+ s-thread.adb<5zthread.adb \
s-thrini.ads<2sthrini.ads \
s-thrini.adb<5zthrini.adb \
s-tiitho.adb<5ytiitho.adb \
@@ -736,6 +741,7 @@ ifeq ($(strip $(filter-out sparc% wrs vx
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -764,6 +770,7 @@ ifeq ($(strip $(filter-out xscale% coff
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -792,6 +799,7 @@ ifeq ($(strip $(filter-out mips% wrs vx%
a-numaux.ads<4znumaux.ads \
s-inmaop.adb<7sinmaop.adb \
s-interr.adb<5zinterr.adb \
+ s-intman.ads<5zintman.ads \
s-intman.adb<5zintman.adb \
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
@@ -2055,8 +2063,10 @@ rts-cert: force
../../../$(GCC_FOR_TARGET) -B../../../ $(TARGET_LIBGCC2_CFLAGS) \
$(ALL_CFLAGS) $(GNATLIBCFLAGS_FOR_C) -c ../adainclude/$(f).c \
-I../adainclude $(INCLUDES_FOR_SUBDIR) -I../../../ ;) \
- $(AR) $(AR_FLAGS) libgnat$(arext) \
- $(addsuffix .o,$(CERT_LEVEL_B_C_FILES))
+ ../../../xgcc -B../../../ *.o -o libgnat ; \
+ $(CHMOD) a-wx *.ali ; \
+ $(RM) *.o ; \
+ $(MV) libgnat libgnat.o
rts-none: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.57
diff -u -p -r1.57 Make-lang.in
--- Make-lang.in 20 Nov 2003 10:08:51 -0000 1.57
+++ Make-lang.in 24 Nov 2003 11:49:37 -0000
@@ -290,10 +290,10 @@ regnattools:
# use host-gcc host-gnatmake host-gnatbind host-gnatlink
# put the host RTS dir first in the PATH to hide the default runtime
# files that are among the sources
-RTS_DIR:=$(dir $(subst \,/,$(shell $(CC) -print-libgcc-file-name)))
+RTS_DIR:=$(strip $(subst \,/,$(shell gnatls -v | grep adalib )))
cross-gnattools: force
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS)\
- ADA_INCLUDES="-I$(RTS_DIR)adainclude -I$(RTS_DIR)adalib" \
+ ADA_INCLUDES="-I$(RTS_DIR)../adainclude -I$(RTS_DIR)" \
GNATMAKE="gnatmake" \
GNATBIND="gnatbind" \
GNATLINK="gnatlink" \
Index: opt.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/opt.adb,v
retrieving revision 1.6
diff -u -p -r1.6 opt.adb
--- opt.adb 21 Oct 2003 13:42:10 -0000 1.6
+++ opt.adb 24 Nov 2003 11:49:37 -0000
@@ -186,6 +186,7 @@ package body Opt is
----------------
procedure Tree_Write is
+ Version_String : String := Gnat_Version_String;
begin
Tree_Write_Int (ASIS_Version_Number);
Tree_Write_Bool (Brief_Output);
@@ -202,9 +203,9 @@ package body Opt is
Tree_Write_Bool (Assertions_Enabled);
Tree_Write_Bool (Enable_Overflow_Checks);
Tree_Write_Bool (Full_List);
- Tree_Write_Int (Int (Gnat_Version_String'Length));
- Tree_Write_Data (Gnat_Version_String'Address,
- Gnat_Version_String'Length);
+ Tree_Write_Int (Int (Version_String'Length));
+ Tree_Write_Data (Version_String'Address,
+ Version_String'Length);
Tree_Write_Data (Distribution_Stub_Mode'Address,
Distribution_Stub_Mode_Type'Object_Size / Storage_Unit);
Tree_Write_Bool (Immediate_Errors);
Index: par-load.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-load.adb,v
retrieving revision 1.5
diff -u -p -r1.5 par-load.adb
--- par-load.adb 21 Oct 2003 13:42:10 -0000 1.5
+++ par-load.adb 24 Nov 2003 11:49:37 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 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- --
@@ -42,6 +42,8 @@ with Sinput.L; use Sinput.L;
with Stylesw; use Stylesw;
with Validsw; use Validsw;
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
separate (Par)
procedure Load is
@@ -188,26 +190,45 @@ begin
or else
Name_Buffer (1) = 'g')
then
- -- In the predefined file case, we know the user did not construct
- -- their own package, but we got the wrong one. This means that the
- -- name supplied by the user crunched to something we recognized,
- -- but then the file did not contain the unit expected. Most likely
- -- this is due to a misspelling, e.g.
-
- -- with Ada.Calender;
-
- -- This crunches to a-calend, which indeed contains the unit
- -- Ada.Calendar, and we can diagnose the misspelling. This is
- -- a simple heuristic, but it catches many common cases of
- -- misspelling of predefined unit names without needing a full
- -- list of them.
-
- Error_Msg_Name_1 := Expected_Unit (Cur_Unum);
- Error_Msg ("% is not a predefined library unit!", Loc);
- Error_Msg_Name_1 := Unit_Name (Cur_Unum);
- Error_Msg ("possible misspelling of %!", Loc);
-
- -- Non-predefined file name case
+ declare
+ Expect_Name : constant Name_Id := Expected_Unit (Cur_Unum);
+ Actual_Name : constant Name_Id := Unit_Name (Cur_Unum);
+
+ begin
+ Error_Msg_Name_1 := Expect_Name;
+ Error_Msg ("% is not a predefined library unit!", Loc);
+
+ -- In the predefined file case, we know the user did not
+ -- construct their own package, but we got the wrong one.
+ -- This means that the name supplied by the user crunched
+ -- to something we recognized, but then the file did not
+ -- contain the unit expected. Most likely this is due to
+ -- a misspelling, e.g.
+
+ -- with Ada.Calender;
+
+ -- This crunches to a-calend, which indeed contains the unit
+ -- Ada.Calendar, and we can diagnose the misspelling. This
+ -- is a simple heuristic, but it catches many common cases
+ -- of misspelling of predefined unit names without needing
+ -- a full list of them.
+
+ -- Before actually issinying the message, we will check that the
+ -- unit name is indeed a plausible misspelling of the one we got.
+
+ if Is_Bad_Spelling_Of
+ (Found => Get_Name_String (Expect_Name),
+ Expect => Get_Name_String (Actual_Name))
+ then
+ Error_Msg_Name_1 := Actual_Name;
+ Error_Msg ("possible misspelling of %!", Loc);
+ end if;
+ end;
+
+ -- Non-predefined file name case. In this case we generate a message
+ -- and then we quit, because we are in big trouble, and if we try
+ -- to continue compilation, we get into some nasty situations
+ -- (for example in some subunit cases).
else
Error_Msg ("file { does not contain expected unit!", Loc);
@@ -217,7 +238,10 @@ begin
Error_Msg ("found unit $!", Loc);
end if;
- raise Unrecoverable_Error;
+ -- In both cases, remove the unit if it is the last unit (which it
+ -- normally (always?) will be) so that it is out of the way later.
+
+ Remove_Unit (Cur_Unum);
end if;
-- If current unit is a body, load its corresponding spec
Index: scn.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/scn.adb,v
retrieving revision 1.9
diff -u -p -r1.9 scn.adb
--- scn.adb 21 Nov 2003 10:46:37 -0000 1.9
+++ scn.adb 24 Nov 2003 11:49:37 -0000
@@ -261,7 +261,9 @@ package body Scn is
begin
Scanner.Initialize_Scanner (Unit, Index);
- -- Set default for Comes_From_Source. All nodes built now until we
+ -- Set default for Comes_From_Source (except if we are going to process
+ -- an artificial string internally created within the compiler and
+ -- placed into internal source duffer). All nodes built now until we
-- reenter the analyzer will have Comes_From_Source set to True
if Index /= Internal_Source_File then
@@ -279,6 +281,16 @@ package body Scn is
-- Because of the License stuff above, Scng.Initialize_Scanner cannot
-- call Scan. Scan initial token (note this initializes Prev_Token,
-- Prev_Token_Ptr).
+
+ -- There are two reasons not to do the Scan step in case if we
+ -- initialize the scanner for the internal source buffer:
+
+ -- - The artificial string may not be created by the compiler in this
+ -- buffer when we call Initialize_Scanner
+
+ -- - For these artificial strings a special way of scanning is used, so
+ -- the standard step of the scanner may just break the algorithm of
+ -- processing these strings.
if Index /= Internal_Source_File then
Scan;
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.22
diff -u -p -r1.22 sem_ch3.adb
--- sem_ch3.adb 20 Nov 2003 09:54:01 -0000 1.22
+++ sem_ch3.adb 24 Nov 2003 11:49:38 -0000
@@ -548,9 +548,9 @@ package body Sem_Ch3 is
-- Create new modular type. Verify that modulus is in bounds and is
-- a power of two (implementation restriction).
- procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id);
+ procedure New_Concatenation_Op (Typ : Entity_Id);
-- Create an abbreviated declaration for an operator in order to
- -- materialize minimally operators on derived types.
+ -- materialize concatenation on array types.
procedure Ordinary_Fixed_Point_Type_Declaration
(T : Entity_Id;
@@ -2865,7 +2865,7 @@ package body Sem_Ch3 is
if Number_Dimensions (T) = 1
and then not Is_Packed_Array_Type (T)
then
- New_Binary_Operator (Name_Op_Concat, T);
+ New_Concatenation_Op (T);
end if;
-- In the case of an unconstrained array the parser has already
@@ -3068,7 +3068,7 @@ package body Sem_Ch3 is
and then not Is_Derived_Type (Parent_Type)
and then not Is_Package (Scope (Base_Type (Parent_Type)))
then
- New_Binary_Operator (Name_Op_Concat, Derived_Type);
+ New_Concatenation_Op (Derived_Type);
end if;
end Build_Derived_Array_Type;
@@ -10945,11 +10945,11 @@ package body Sem_Ch3 is
end Modular_Type_Declaration;
- -------------------------
- -- New_Binary_Operator --
- -------------------------
+ --------------------------
+ -- New_Concatenation_Op --
+ --------------------------
- procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id) is
+ procedure New_Concatenation_Op (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Op : Entity_Id;
@@ -10971,26 +10971,26 @@ package body Sem_Ch3 is
return Formal;
end Make_Op_Formal;
- -- Start of processing for New_Binary_Operator
+ -- Start of processing for New_Concatenation_Op
begin
- Op := Make_Defining_Operator_Symbol (Loc, Op_Name);
+ Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat);
Set_Ekind (Op, E_Operator);
Set_Scope (Op, Current_Scope);
Set_Etype (Op, Typ);
- Set_Homonym (Op, Get_Name_Entity_Id (Op_Name));
+ Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat));
Set_Is_Immediately_Visible (Op);
Set_Is_Intrinsic_Subprogram (Op);
Set_Has_Completion (Op);
Append_Entity (Op, Current_Scope);
- Set_Name_Entity_Id (Op_Name, Op);
+ Set_Name_Entity_Id (Name_Op_Concat, Op);
Append_Entity (Make_Op_Formal (Typ, Op), Op);
Append_Entity (Make_Op_Formal (Typ, Op), Op);
- end New_Binary_Operator;
+ end New_Concatenation_Op;
-------------------------------------------
-- Ordinary_Fixed_Point_Type_Declaration --
Index: sem_elab.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_elab.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sem_elab.adb
--- sem_elab.adb 22 Oct 2003 09:28:08 -0000 1.10
+++ sem_elab.adb 24 Nov 2003 11:49:38 -0000
@@ -325,6 +325,16 @@ package body Sem_Elab is
-- we ignore this flag.
begin
+ -- If the call is known to be within a local Suppress Elaboration
+ -- pragma, nothing to check. This can happen in task bodies.
+
+ if (Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement)
+ and then No_Elaboration_Check (N)
+ then
+ return;
+ end if;
+
-- Go to parent for derived subprogram, or to original subprogram
-- in the case of a renaming (Alias covers both these cases)
@@ -826,10 +836,41 @@ package body Sem_Elab is
(N : Node_Id;
Outer_Scope : Entity_Id := Empty)
is
- Nam : Node_Id;
Ent : Entity_Id;
P : Node_Id;
+ function Get_Called_Ent return Entity_Id;
+ -- Retrieve called entity. If this is a call to a protected subprogram,
+ -- entity is a selected component. The callable entity may be absent,
+ -- in which case there is no check to perform. This happens with
+ -- non-analyzed calls in nested generics.
+
+ --------------------
+ -- Get_Called_Ent --
+ --------------------
+
+ function Get_Called_Ent return Entity_Id is
+ Nam : Node_Id;
+
+ begin
+ Nam := Name (N);
+
+ if No (Nam) then
+ return Empty;
+
+ elsif Nkind (Nam) = N_Selected_Component then
+ return Entity (Selector_Name (Nam));
+
+ elsif not Is_Entity_Name (Nam) then
+ return Empty;
+
+ else
+ return Entity (Nam);
+ end if;
+ end Get_Called_Ent;
+
+ -- Start of processing for Check_Elab_Call
+
begin
-- For an entry call, check relevant restriction
@@ -1014,6 +1055,26 @@ package body Sem_Elab is
exit;
+ elsif Nkind (P) = N_Task_Body then
+
+ -- The check is deferred until Check_Task_Activation
+ -- but we need to capture local suppress pragmas
+ -- that may inhibit checks on this call.
+
+ Ent := Get_Called_Ent;
+
+ if No (Ent) then
+ return;
+
+ elsif Elaboration_Checks_Suppressed (Current_Scope)
+ or else Elaboration_Checks_Suppressed (Ent)
+ or else Elaboration_Checks_Suppressed (Scope (Ent))
+ then
+ Set_No_Elaboration_Check (N);
+ end if;
+
+ return;
+
-- Static model, call is not in elaboration code, we
-- never need to worry, because in the static model
-- the top level caller always takes care of things.
@@ -1027,25 +1088,7 @@ package body Sem_Elab is
end if;
end if;
- -- Retrieve called entity. If this is a call to a protected subprogram,
- -- the entity is a selected component.
- -- The callable entity may be absent, in which case there is nothing
- -- to do. This happens with non-analyzed calls in nested generics.
-
- Nam := Name (N);
-
- if No (Nam) then
- return;
-
- elsif Nkind (Nam) = N_Selected_Component then
- Ent := Entity (Selector_Name (Nam));
-
- elsif not Is_Entity_Name (Nam) then
- return;
-
- else
- Ent := Entity (Nam);
- end if;
+ Ent := Get_Called_Ent;
if No (Ent) then
return;
Index: sinfo.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.adb,v
retrieving revision 1.10
diff -u -p -r1.10 sinfo.adb
--- sinfo.adb 14 Nov 2003 10:24:43 -0000 1.10
+++ sinfo.adb 24 Nov 2003 11:49:38 -0000
@@ -1764,6 +1764,15 @@ package body Sinfo is
return Flag7 (N);
end No_Ctrl_Actions;
+ function No_Elaboration_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ return Flag14 (N);
+ end No_Elaboration_Check;
+
function No_Entities_Ref_In_Spec
(N : Node_Id) return Boolean is
begin
@@ -4186,6 +4195,15 @@ package body Sinfo is
or else NT (N).Nkind = N_Assignment_Statement);
Set_Flag7 (N, Val);
end Set_No_Ctrl_Actions;
+
+ procedure Set_No_Elaboration_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Procedure_Call_Statement);
+ Set_Flag14 (N, Val);
+ end Set_No_Elaboration_Check;
procedure Set_No_Entities_Ref_In_Spec
(N : Node_Id; Val : Boolean := True) is
Index: sinfo.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinfo.ads,v
retrieving revision 1.15
diff -u -p -r1.15 sinfo.ads
--- sinfo.ads 20 Nov 2003 09:54:02 -0000 1.15
+++ sinfo.ads 24 Nov 2003 11:49:38 -0000
@@ -1266,6 +1266,13 @@ package Sinfo is
-- where the generated assignments are more initialisations than real
-- assignments.
+ -- No_Elaboration_Check (Flag14-Sem)
+ -- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates
+ -- that no elaboration check is needed on the call, because it appears
+ -- in the context of a local Suppress pragma. This is used on calls
+ -- within task bodies, where the actual elaboration checks are applied
+ -- after analysis, when the local scope stack is not present.
+
-- No_Entities_Ref_In_Spec (Flag8-Sem)
-- Present in N_With_Clause nodes. Set if the with clause is on the
-- package or subprogram spec where the main unit is the corresponding
@@ -4043,6 +4050,7 @@ package Sinfo is
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
-- Do_Tag_Check (Flag13-Sem)
+ -- No_Elaboration_Check (Flag14-Sem)
-- Parameter_List_Truncated (Flag17-Sem)
-- ABE_Is_Certain (Flag18-Sem)
-- plus fields for expression
@@ -4073,6 +4081,7 @@ package Sinfo is
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
-- Do_Tag_Check (Flag13-Sem)
+ -- No_Elaboration_Check (Flag14-Sem)
-- Parameter_List_Truncated (Flag17-Sem)
-- ABE_Is_Certain (Flag18-Sem)
-- plus fields for expression
@@ -7391,6 +7400,9 @@ package Sinfo is
function No_Ctrl_Actions
(N : Node_Id) return Boolean; -- Flag7
+ function No_Elaboration_Check
+ (N : Node_Id) return Boolean; -- Flag14
+
function No_Entities_Ref_In_Spec
(N : Node_Id) return Boolean; -- Flag8
@@ -8165,6 +8177,9 @@ package Sinfo is
procedure Set_No_Ctrl_Actions
(N : Node_Id; Val : Boolean := True); -- Flag7
+ procedure Set_No_Elaboration_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag14
+
procedure Set_No_Entities_Ref_In_Spec
(N : Node_Id; Val : Boolean := True); -- Flag8
@@ -8600,6 +8615,7 @@ package Sinfo is
pragma Inline (Next_Rep_Item);
pragma Inline (Next_Use_Clause);
pragma Inline (No_Ctrl_Actions);
+ pragma Inline (No_Elaboration_Check);
pragma Inline (No_Entities_Ref_In_Spec);
pragma Inline (No_Initialization);
pragma Inline (No_Truncation);
@@ -8854,6 +8870,7 @@ package Sinfo is
pragma Inline (Set_Next_Named_Actual);
pragma Inline (Set_Next_Use_Clause);
pragma Inline (Set_No_Ctrl_Actions);
+ pragma Inline (Set_No_Elaboration_Check);
pragma Inline (Set_No_Entities_Ref_In_Spec);
pragma Inline (Set_No_Initialization);
pragma Inline (Set_No_Truncation);
Index: sinput.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinput.adb,v
retrieving revision 1.7
diff -u -p -r1.7 sinput.adb
--- sinput.adb 21 Nov 2003 10:46:37 -0000 1.7
+++ sinput.adb 24 Nov 2003 11:49:38 -0000
@@ -1111,7 +1111,7 @@ package body Sinput is
function Source_First (S : SFI) return Source_Ptr is
begin
if S = Internal_Source_File then
- return Internal_Source_Ptr'First;
+ return Internal_Source'First;
else
return Source_File.Table (S).Source_First;
end if;
@@ -1120,7 +1120,7 @@ package body Sinput is
function Source_Last (S : SFI) return Source_Ptr is
begin
if S = Internal_Source_File then
- return Internal_Source_Ptr'Last;
+ return Internal_Source'Last;
else
return Source_File.Table (S).Source_Last;
end if;
Index: s-thread.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-thread.ads,v
retrieving revision 1.3
diff -u -p -r1.3 s-thread.ads
--- s-thread.ads 10 Nov 2003 17:30:00 -0000 1.3
+++ s-thread.ads 24 Nov 2003 11:49:38 -0000
@@ -38,6 +38,10 @@
-- VxWorks AE653 with the restricted / cert runtime
with Ada.Exceptions;
+-- used for Exception_Occurrence
+
+with System.Soft_Links;
+-- used for TSD
package System.Threads is
@@ -137,27 +141,6 @@ package System.Threads is
private
- ------------------------
- -- Task Specific Data --
- ------------------------
-
- type ATSD is limited record
- Jmpbuf_Address : Address := Null_Address;
- -- Address of jump buffer used to store the address of the
- -- current longjmp/setjmp buffer for exception management.
- -- These buffers are threaded into a stack, and the address
- -- here is the top of the stack. A null address means that
- -- no exception handler is currently active.
-
- Sec_Stack_Addr : Address := Null_Address;
- -- Address of currently allocated secondary stack
-
- Current_Excep : aliased EO;
- -- Exception occurrence that contains the information for the
- -- current exception. Note that any exception in the same task
- -- destroys this information, so the data in this variable must
- -- be copied out before another exception can occur.
-
- end record;
+ type ATSD is new System.Soft_Links.TSD;
end System.Threads;