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

sem_res.adb (Resolve_Selected_Component): do not generate a discriminant check if the selected component is a component... 

* sem_res.adb (Resolve_Selected_Component): do not generate a
	discriminant check if the selected component is a component of
	the argument of an initialization procedure.

	* trans.c (tree_transform, case of arithmetic operators): If result
	type is private, the gnu_type is the base type of the full view,
	given that the full view itself may be a subtype.

	* sem_res.adb: Minor reformatting

	* trans.c (tree_transform, case N_Real_Literal): Add missing third
	parameter in call to Machine (unknown horrible effects from this
	omission).

	* urealp.h: Add definition of Round_Even for call to Machine
	Add third parameter for Machine

	* sem_warn.adb (Check_One_Unit): Suppress warnings completely on
	predefined units in No_Run_Time mode.

	* misc.c (insn-codes.h): Now include.

	* a-except.adb: Preparation work for future integration of the GCC 3
	exception handling mechanism
	(Notify_Handled_Exception, Notify_Unhandled_Exception): New routines
	to factorize previous code sequences and make them externally callable,
	e.g. for the Ada personality routine when the GCC 3 mechanism is used.
	(Propagate_Exception, Raise_Current_Excep, Raise_From_Signal_Handler):
	Use the new notification routines.

	* prj-tree.ads (First_Choice_Of): Document the when others case

	* bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in
	HI-E mode, in order to support Ravenscar profile properly.

	* cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E
	mode on 32 bits targets.

	* fmap.adb: Initial version.

	* fmap.ads: Initial version.

	* fname-uf.adb (Get_File_Name): Use mapping if unit name mapped.
	If search is successfully done, add to mapping.

	* frontend.adb: Initialize the mapping if a -gnatem switch was used.

	* make.adb:
	(Gnatmake): Add new local variable Mapping_File_Name.
	 Create mapping file when using project file(s).
	 Delete mapping file before exiting.

	* opt.ads (Mapping_File_Name): New variable

	* osint.adb (Find_File): Use path name found in mapping, if any.

	* prj-env.adb (Create_Mapping_File): New procedure

	* prj-env.ads (Create_Mapping_File): New procedure.

	* switch.adb (Scan_Front_End_Switches): Add processing for -gnatem
	(Mapping_File)

	* usage.adb: Add entry for new switch -gnatem.

	* Makefile.in: Add dependencies for fmap.o.

	* sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit
	is a package instantiation rewritten as a package body.
	(Install_Withed_Unit): Undo previous change, now redundant.

	* layout.adb:
	(Compute_Length): Move conversion to Unsigned to callers.
	(Get_Max_Size): Convert Len expression to Unsigned after calls to
	Compute_Length and Determine_Range.
	(Layout_Array_Type): Convert Len expression to Unsigned after calls to
	Compute_Length and Determine_Range.
	Above changes fix problem with length computation for supernull arrays
	where Max (Len, 0) wasn't getting applied due to the Unsigned
	conversion used by Compute_Length.

	* rtsfind.ads:
	(OK_To_Use_In_No_Run_Time_Mode): Allow Ada.Exceptions and
	 System.Secondary_Stack.
	(OK_To_Use_In_Ravenscar_Mode): New table needed to implement Ravenscar
	 in HI-E mode.
	Remove unused entity RE_Exception_Data.

	* rtsfind.adb (RTE): Allow Ravenscar Profile in HI mode.

	* rident.ads (No_Secondary_Stack): New restriction.

From-SVN: r48168
This commit is contained in:
Geert Bosch 2001-12-19 01:31:42 +01:00
parent c6d96f20fd
commit 6510f4c98e
27 changed files with 991 additions and 160 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

114
gcc/ada/ChangeLog
View File

@ -1,3 +1,117 @@
2001-12-17 Ed Schonberg <schonber@gnat.com>
* sem_res.adb (Resolve_Selected_Component): do not generate a
discriminant check if the selected component is a component of
the argument of an initialization procedure.
* trans.c (tree_transform, case of arithmetic operators): If result
type is private, the gnu_type is the base type of the full view,
given that the full view itself may be a subtype.
2001-12-17 Robert Dewar <dewar@gnat.com>
* sem_res.adb: Minor reformatting
* trans.c (tree_transform, case N_Real_Literal): Add missing third
parameter in call to Machine (unknown horrible effects from this
omission).
* urealp.h: Add definition of Round_Even for call to Machine
Add third parameter for Machine
2001-12-17 Ed Schonberg <schonber@gnat.com>
* sem_warn.adb (Check_One_Unit): Suppress warnings completely on
predefined units in No_Run_Time mode.
2001-12-17 Richard Kenner <kenner@gnat.com>
* misc.c (insn-codes.h): Now include.
2001-12-17 Olivier Hainque <hainque@gnat.com>
* a-except.adb: Preparation work for future integration of the GCC 3
exception handling mechanism
(Notify_Handled_Exception, Notify_Unhandled_Exception): New routines
to factorize previous code sequences and make them externally callable,
e.g. for the Ada personality routine when the GCC 3 mechanism is used.
(Propagate_Exception, Raise_Current_Excep, Raise_From_Signal_Handler):
Use the new notification routines.
2001-12-17 Emmanuel Briot <briot@gnat.com>
* prj-tree.ads (First_Choice_Of): Document the when others case
2001-12-17 Arnaud Charlet <charlet@gnat.com>
* bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in
HI-E mode, in order to support Ravenscar profile properly.
* cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E
mode on 32 bits targets.
2001-12-17 Vincent Celier <celier@gnat.com>
* fmap.adb: Initial version.
* fmap.ads: Initial version.
* fname-uf.adb (Get_File_Name): Use mapping if unit name mapped.
If search is successfully done, add to mapping.
* frontend.adb: Initialize the mapping if a -gnatem switch was used.
* make.adb:
(Gnatmake): Add new local variable Mapping_File_Name.
Create mapping file when using project file(s).
Delete mapping file before exiting.
* opt.ads (Mapping_File_Name): New variable
* osint.adb (Find_File): Use path name found in mapping, if any.
* prj-env.adb (Create_Mapping_File): New procedure
* prj-env.ads (Create_Mapping_File): New procedure.
* switch.adb (Scan_Front_End_Switches): Add processing for -gnatem
(Mapping_File)
* usage.adb: Add entry for new switch -gnatem.
* Makefile.in: Add dependencies for fmap.o.
2001-12-17 Ed Schonberg <schonber@gnat.com>
* sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit
is a package instantiation rewritten as a package body.
(Install_Withed_Unit): Undo previous change, now redundant.
2001-12-17 Gary Dismukes <dismukes@gnat.com>
* layout.adb:
(Compute_Length): Move conversion to Unsigned to callers.
(Get_Max_Size): Convert Len expression to Unsigned after calls to
Compute_Length and Determine_Range.
(Layout_Array_Type): Convert Len expression to Unsigned after calls to
Compute_Length and Determine_Range.
Above changes fix problem with length computation for supernull arrays
where Max (Len, 0) wasn't getting applied due to the Unsigned
conversion used by Compute_Length.
2001-12-17 Arnaud Charlet <charlet@gnat.com>
* rtsfind.ads:
(OK_To_Use_In_No_Run_Time_Mode): Allow Ada.Exceptions and
System.Secondary_Stack.
(OK_To_Use_In_Ravenscar_Mode): New table needed to implement Ravenscar
in HI-E mode.
Remove unused entity RE_Exception_Data.
* rtsfind.adb (RTE): Allow Ravenscar Profile in HI mode.
* rident.ads (No_Secondary_Stack): New restriction.
2001-12-17 Joel Brobecker <brobecke@gnat.com>
* gnat_rm.texi: Fix minor typos. Found while reading the section

30
gcc/ada/Makefile.in
View File

@ -296,7 +296,7 @@ GNAT_ADA_OBJS = \
exp_code.o exp_dbug.o exp_disp.o exp_dist.o exp_fixd.o exp_aggr.o exp_imgv.o \
exp_intr.o exp_pakd.o exp_prag.o exp_smem.o \
exp_strm.o exp_tss.o exp_util.o exp_vfpt.o expander.o fname.o fname-uf.o \
freeze.o frontend.o gnat.o g-hesora.o g-htable.o g-os_lib.o \
fmap.o freeze.o frontend.o gnat.o g-hesora.o g-htable.o g-os_lib.o \
g-speche.o s-crc32.o get_targ.o gnatvsn.o \
hlo.o hostparm.o impunit.o \
interfac.o itypes.o inline.o krunch.o lib.o \
@ -326,7 +326,7 @@ GNATBIND_OBJS = \
alloc.o bcheck.o binde.o \
binderr.o bindgen.o bindusg.o \
butil.o casing.o csets.o \
debug.o fname.o gnat.o g-hesora.o g-htable.o \
debug.o fmap.o fname.o gnat.o g-hesora.o g-htable.o \
g-os_lib.o gnatbind.o gnatvsn.o hostparm.o \
krunch.o namet.o opt.o osint.o output.o rident.o s-crc32.o s-assert.o \
s-parame.o s-sopco3.o s-sopco4.o s-sopco5.o s-stache.o s-stalib.o \
@ -364,7 +364,7 @@ GNATCMD_RTL_OBJS = adaint.o argv.o raise.o exit.o final.o init.o \
s-stache.o s-sopco3.o s-sopco4.o s-sopco5.o \
s-strops.o s-soflin.o s-wchcon.o s-wchcnv.o s-wchjis.o s-unstyp.o
GNATCMD_OBJS = alloc.o debug.o fname.o gnatcmd.o gnatvsn.o hostparm.o \
GNATCMD_OBJS = alloc.o debug.o fmap.o fname.o gnatcmd.o gnatvsn.o hostparm.o \
krunch.o namet.o opt.o osint.o casing.o csets.o widechar.o \
output.o sdefault.o switch.o stylesw.o validsw.o table.o tree_io.o types.o \
$(GNATCMD_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
@ -394,7 +394,7 @@ GNATLINK_RTL_OBJS = \
s-memory.o s-traceb.o s-wchcnv.o s-wchcon.o s-wchjis.o
GNATLINK_OBJS = gnatlink.o link.o \
alloc.o debug.o gnatvsn.o hostparm.o namet.o \
alloc.o debug.o fmap.o gnatvsn.o hostparm.o namet.o \
opt.o osint.o output.o sdefault.o stylesw.o validsw.o \
switch.o table.o tree_io.o types.o widechar.o \
$(GNATLINK_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
@ -483,6 +483,7 @@ GNATLS_OBJS = \
einfo.o \
elists.o \
errout.o \
fmap.o \
fname.o \
gnatls.o \
gnatvsn.o \
@ -553,7 +554,7 @@ GNATMAKE_RTL_OBJS = adaint.o argv.o raise.o exit.o a-comlin.o \
GNATMAKE_OBJS = ali.o ali-util.o \
alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o einfo.o elists.o \
errout.o fname.o fname-uf.o fname-sf.o \
errout.o fmap.o fname.o fname-uf.o fname-sf.o \
gnatmake.o gnatvsn.o hostparm.o krunch.o lib.o make.o makeusg.o \
mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \
namet.o nlists.o opt.o osint.o output.o \
@ -706,7 +707,7 @@ GNATXREF_RTL_OBJS = \
s-valuti.o s-valuns.o s-valint.o s-wchcon.o s-wchjis.o s-wchcnv.o
GNATXREF_OBJS = gnatxref.o xr_tabls.o xref_lib.o \
alloc.o debug.o gnatvsn.o hostparm.o types.o output.o \
alloc.o debug.o fmap.o gnatvsn.o hostparm.o types.o output.o \
sdefault.o stylesw.o validsw.o tree_io.o opt.o table.o osint.o \
switch.o widechar.o namet.o \
$(GNATXREF_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
@ -729,7 +730,7 @@ GNATFIND_RTL_OBJS = \
s-valuns.o s-valuti.o s-wchcnv.o s-wchcon.o s-wchjis.o
GNATFIND_OBJS = gnatfind.o xr_tabls.o xref_lib.o \
alloc.o debug.o gnatvsn.o hostparm.o namet.o opt.o \
alloc.o debug.o fmap.o gnatvsn.o hostparm.o namet.o opt.o \
osint.o output.o sdefault.o stylesw.o validsw.o switch.o table.o \
tree_io.o types.o widechar.o \
$(GNATFIND_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
@ -3129,6 +3130,9 @@ fname.o : ada.ads a-except.ads alloc.ads debug.ads fname.ads fname.adb \
system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \
table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads
fmap.o : alloc.ads debug.ads fmap.ads fmap.adb hostparm.ads namet.ads opt.ads \
osint.ads output.ads table.ads table.adb tree_io.ads types.ads
fname-sf.o : alloc.ads casing.ads fname.ads fname-sf.ads fname-sf.adb \
fname-uf.ads gnat.ads g-os_lib.ads namet.ads osint.ads sfn_scan.ads \
system.ads s-exctab.ads s-stalib.ads s-stoele.ads table.ads types.ads \
@ -3522,12 +3526,12 @@ opt.o : ada.ads a-except.ads gnat.ads g-os_lib.ads gnatvsn.ads \
hostparm.ads opt.ads opt.adb system.ads s-exctab.ads s-stalib.ads \
s-wchcon.ads tree_io.ads types.ads unchconv.ads unchdeal.ads
osint.o : ada.ads a-except.ads a-uncdea.ads alloc.ads debug.ads gnat.ads \
g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads namet.ads opt.ads \
osint.ads osint.adb output.ads sdefault.ads system.ads s-assert.ads \
s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \
s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \
unchconv.ads unchdeal.ads
osint.o : ada.ads a-except.ads a-uncdea.ads alloc.ads debug.ads fmap.ads \
gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads namet.ads \
opt.ads osint.ads osint.adb output.ads sdefault.ads system.ads \
s-assert.ads s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads \
s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \
types.ads unchconv.ads unchdeal.ads
output.o : gnat.ads g-os_lib.ads output.ads output.adb system.ads \
s-exctab.ads s-stalib.ads types.ads unchconv.ads unchdeal.ads

158
gcc/ada/a-except.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- $Revision: 1.1 $
-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
@ -365,6 +365,34 @@ package body Ada.Exceptions is
-- Basic_Exc_Tback Or Tback_Decorator
-- if no decorator set otherwise
----------------------------------------------
-- Run-Time Exception Notification Routines --
----------------------------------------------
-- The notification routines described above are low level "handles" for
-- the debugger but what needs to be done at the notification points
-- always involves more than just calling one of these routines. The
-- routines below provide a common run-time interface for this purpose,
-- with variations depending on the handled/not handled status of the
-- occurrence. They are exported to be usable by the Ada exception
-- handling personality routine when the GCC 3 mechanism is used.
procedure Notify_Handled_Exception
(Handler : Code_Loc;
Is_Others : Boolean;
Low_Notify : Boolean);
pragma Export (C, Notify_Handled_Exception,
"__gnat_notify_handled_exception");
-- Routine to call when a handled occurrence is about to be propagated.
-- Low_Notify might be set to false to skip the low level debugger
-- notification, which is useful when the information it requires is
-- not available, like in the SJLJ case.
procedure Notify_Unhandled_Exception (Id : Exception_Id);
pragma Export (C, Notify_Unhandled_Exception,
"__gnat_notify_unhandled_exception");
-- Routine to call when an unhandled occurrence is about to be propagated.
--------------------------------
-- Import Run-Time C Routines --
--------------------------------
@ -953,29 +981,10 @@ package body Ada.Exceptions is
or else (Hrec.Id = Others_Id
and not Excep.Id.Not_Handled_By_Others)
then
-- Notify the debugger that we have found a handler
-- and are about to propagate an exception.
-- Perform the necessary notification tasks.
Notify_Exception
(Excep.Id, Hrec.Handler, Hrec.Id = Others_Id);
-- Output some exception information if necessary, as
-- specified by GNAT.Exception_Traces. Take care not to
-- output information about internal exceptions.
--
-- ??? The traceback entries we have at this point only
-- consist in the ones we stored while walking up the
-- stack *up to the handler*. All the frames above the
-- subprogram in which the handler is found are missing.
if Exception_Trace = Every_Raise
and then not Excep.Id.Not_Handled_By_Others
then
To_Stderr (Nline);
To_Stderr ("Exception raised");
To_Stderr (Nline);
To_Stderr (Tailored_Exception_Information (Excep.all));
end if;
Notify_Handled_Exception
(Hrec.Handler, Hrec.Id = Others_Id, True);
-- If we already encountered a finalization handler, then
-- reset the context to that handler, and enter it.
@ -1002,15 +1011,10 @@ package body Ada.Exceptions is
Pop_Frame (Mstate, Info);
end loop Main_Loop;
-- Fall through if no "real" exception handler found. First thing
-- is to call the dummy Unhandled_Exception routine with the stack
-- intact, so that the debugger can get control.
-- Fall through if no "real" exception handler found. First thing is to
-- perform the necessary notification tasks with the stack intact.
Unhandled_Exception;
-- Also make the appropriate Notify_Exception call for the debugger.
Notify_Exception (Excep.Id, Null_Loc, False);
Notify_Unhandled_Exception (Excep.Id);
-- If there were finalization handlers, then enter the top one.
-- Just because there is no handler does not mean we don't have
@ -1066,30 +1070,14 @@ package body Ada.Exceptions is
Call_Chain (Excep);
end if;
-- Perform the necessary notification tasks if this is not a
-- reraise. Actually ask to skip the low level debugger notification
-- call since we do not have the necessary information to "feed"
-- it properly.
if not Excep.Exception_Raised then
-- This is not a reraise.
Excep.Exception_Raised := True;
-- Output some exception information if necessary, as specified
-- by GNAT.Exception_Traces. Take care not to output information
-- about internal exceptions.
if Exception_Trace = Every_Raise
and then not Excep.Id.Not_Handled_By_Others
then
begin
-- This is in a block because of the call to
-- Tailored_Exception_Information which might
-- require an exception handler for secondary
-- stack cleanup.
To_Stderr (Nline);
To_Stderr ("Exception raised");
To_Stderr (Nline);
To_Stderr (Tailored_Exception_Information (Excep.all));
end;
end if;
Notify_Handled_Exception (Null_Loc, False, False);
end if;
builtin_longjmp (Jumpbuf_Ptr, 1);
@ -1112,8 +1100,7 @@ package body Ada.Exceptions is
Call_Chain (Get_Current_Excep.all);
end if;
Unhandled_Exception;
Notify_Exception (E, Null_Loc, False);
Notify_Unhandled_Exception (E);
Unhandled_Exception_Terminate;
end if;
end Raise_Current_Excep;
@ -1179,9 +1166,10 @@ package body Ada.Exceptions is
-- the signal handler that passed control here has already set the
-- machine state directly.
--
-- ??? Updates related to the implementation of automatic backtraces
-- have not been done here. Some action will be required when dealing
-- the remaining problems in ZCX mode (incomplete backtraces so far).
-- We also do not compute the backtrace for the occurrence since going
-- through the signal handler is far from trivial and it is not a
-- problem to fail providing a backtrace in the "raised from signal
-- handler" case.
-- If the jump buffer pointer is non-null, it means that a jump
-- buffer was allocated (obviously that happens only in the case
@ -1204,7 +1192,7 @@ package body Ada.Exceptions is
-- have no finalizations to do other than at the outer level.
else
Unhandled_Exception;
Notify_Unhandled_Exception (E);
Unhandled_Exception_Terminate;
end if;
end Raise_From_Signal_Handler;
@ -1833,6 +1821,58 @@ package body Ada.Exceptions is
null;
end Notify_Exception;
------------------------------
-- Notify_Handled_Exception --
------------------------------
procedure Notify_Handled_Exception
(Handler : Code_Loc;
Is_Others : Boolean;
Low_Notify : Boolean)
is
Excep : constant EOA := Get_Current_Excep.all;
begin
-- Notify the debugger that we have found a handler and are about to
-- propagate an exception, but only if specifically told to do so.
if Low_Notify then
Notify_Exception (Excep.Id, Handler, Is_Others);
end if;
-- Output some exception information if necessary, as specified by
-- GNAT.Exception_Traces. Take care not to output information about
-- internal exceptions.
--
-- ??? In the ZCX case, the traceback entries we have at this point
-- only include the ones we stored while walking up the stack *up to
-- the handler*. All the frames above the subprogram in which the
-- handler is found are missing.
if Exception_Trace = Every_Raise
and then not Excep.Id.Not_Handled_By_Others
then
To_Stderr (Nline);
To_Stderr ("Exception raised");
To_Stderr (Nline);
To_Stderr (Tailored_Exception_Information (Excep.all));
end if;
end Notify_Handled_Exception;
------------------------------
-- Notify_Handled_Exception --
------------------------------
procedure Notify_Unhandled_Exception (Id : Exception_Id) is
begin
-- Simply perform the two necessary low level notification calls.
Unhandled_Exception;
Notify_Exception (Id, Null_Loc, False);
end Notify_Unhandled_Exception;
-----------------------------------
-- Unhandled_Exception_Terminate --
-----------------------------------

61
gcc/ada/bindgen.adb
View File

@ -286,6 +286,7 @@ package body Bindgen is
---------------------
procedure Gen_Adainit_Ada is
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
begin
WBI (" procedure " & Ada_Init_Name.all & " is");
@ -347,7 +348,32 @@ package body Bindgen is
-- the routine call, rather than define the globals in the binder
-- file to deal with cross-library calls in some systems.
if not No_Run_Time_Specified then
if No_Run_Time_Specified then
-- Case of pragma No_Run_Time present. The only global variable
-- that might be needed (by the Ravenscar profile) is
-- the environment task's priority. Also no exception tables are
-- needed.
if Main_Priority /= No_Main_Priority then
WBI (" Main_Priority : Integer;");
WBI (" pragma Import (C, Main_Priority," &
" ""__gl_main_priority"");");
WBI ("");
end if;
WBI (" begin");
if Main_Priority /= No_Main_Priority then
Set_String (" Main_Priority := ");
Set_Int (Main_Priority);
Set_Char (';');
Write_Statement_Buffer;
else
WBI (" null;");
end if;
else
WBI ("");
WBI (" procedure Set_Globals");
WBI (" (Main_Priority : Integer;");
@ -383,7 +409,7 @@ package body Bindgen is
WBI (" Set_Globals");
Set_String (" (Main_Priority => ");
Set_Int (ALIs.Table (ALIs.First).Main_Priority);
Set_Int (Main_Priority);
Set_Char (',');
Write_Statement_Buffer;
@ -449,14 +475,6 @@ package body Bindgen is
WBI (" if Handler_Installed = 0 then");
WBI (" Install_Handler;");
WBI (" end if;");
-- Case of pragma No_Run_Time present. Globals are not needed since
-- there are no runtime routines to make use of them, and no routine
-- to store them in any case! Also no exception tables are needed.
else
WBI (" begin");
WBI (" null;");
end if;
Gen_Elab_Calls_Ada;
@ -469,6 +487,7 @@ package body Bindgen is
--------------------
procedure Gen_Adainit_C is
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
begin
WBI ("void " & Ada_Init_Name.all & " ()");
WBI ("{");
@ -493,9 +512,19 @@ package body Bindgen is
Write_Statement_Buffer;
-- Code for normal case (no pragma No_Run_Time in use)
if No_Run_Time_Specified then
-- Case where No_Run_Time pragma is present.
-- Set __gl_main_priority if needed for the Ravenscar profile.
if not No_Run_Time_Specified then
if Main_Priority /= No_Main_Priority then
Set_String (" extern int __gl_main_priority = ");
Set_Int (Main_Priority);
Set_Char (';');
Write_Statement_Buffer;
end if;
else
-- Code for normal case (no pragma No_Run_Time in use)
Gen_Exception_Table_C;
@ -510,7 +539,7 @@ package body Bindgen is
WBI (" __gnat_set_globals (");
Set_String (" ");
Set_Int (ALIs.Table (ALIs.First).Main_Priority);
Set_Int (Main_Priority);
Set_Char (',');
Tab_To (15);
Set_String ("/* Main_Priority */");
@ -584,12 +613,6 @@ package body Bindgen is
WBI (" {");
WBI (" __gnat_install_handler ();");
WBI (" }");
-- Case where No_Run_Time pragma is present (no globals required)
-- Nothing more needs to be done in this case.
else
null;
end if;
WBI ("");

35
gcc/ada/cstand.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- $Revision: 1.2 $
-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
@ -1003,14 +1003,27 @@ package body CStand is
-- Create type declaration for Duration, using a 64-bit size.
-- Delta is 1 nanosecond.
-- Except on 32 bits machine in No_Run_Time mode, in which case Duration
-- is a 32 bits value whose delta is 10E-4 seconds.
Build_Duration : declare
Dlo : constant Uint := Intval (Type_Low_Bound (Standard_Integer_64));
Dhi : constant Uint := Intval (Type_High_Bound (Standard_Integer_64));
Delta_Val : constant Ureal := UR_From_Components (Uint_1, Uint_9, 10);
Dlo : Uint;
Dhi : Uint;
Delta_Val : Ureal;
Use_32_Bits : constant Boolean :=
No_Run_Time and then System_Word_Size = 32;
begin
if Use_32_Bits then
Dlo := Intval (Type_Low_Bound (Standard_Integer_32));
Dhi := Intval (Type_High_Bound (Standard_Integer_32));
Delta_Val := UR_From_Components (Uint_1, Uint_4, 10);
else
Dlo := Intval (Type_Low_Bound (Standard_Integer_64));
Dhi := Intval (Type_High_Bound (Standard_Integer_64));
Delta_Val := UR_From_Components (Uint_1, Uint_9, 10);
end if;
Decl :=
Make_Full_Type_Declaration (Stloc,
Defining_Identifier => Standard_Duration,
@ -1024,9 +1037,15 @@ package body CStand is
High_Bound => Make_Real_Literal (Stloc,
Realval => Dhi * Delta_Val))));
Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type);
Set_Etype (Standard_Duration, Standard_Duration);
Init_Size (Standard_Duration, 64);
Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type);
Set_Etype (Standard_Duration, Standard_Duration);
if Use_32_Bits then
Init_Size (Standard_Duration, 32);
else
Init_Size (Standard_Duration, 64);
end if;
Set_Prim_Alignment (Standard_Duration);
Set_Delta_Value (Standard_Duration, Delta_Val);
Set_Small_Value (Standard_Duration, Delta_Val);

332
gcc/ada/fmap.adb Normal file
View File

@ -0,0 +1,332 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- F M A P --
-- --
-- B o d y --
-- --
-- $Revision$
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with GNAT.HTable;
with Namet; use Namet;
with Osint; use Osint;
with Output; use Output;
with Table;
with Unchecked_Conversion;
package body Fmap is
subtype Big_String is String (Positive);
type Big_String_Ptr is access all Big_String;
function To_Big_String_Ptr is new Unchecked_Conversion
(Source_Buffer_Ptr, Big_String_Ptr);
package File_Mapping is new Table.Table (
Table_Component_Type => File_Name_Type,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 1_000,
Table_Increment => 1_000,
Table_Name => "Fmap.File_Mapping");
-- Mapping table to map unit names to file names.
package Path_Mapping is new Table.Table (
Table_Component_Type => File_Name_Type,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 1_000,
Table_Increment => 1_000,
Table_Name => "Fmap.Path_Mapping");
-- Mapping table to map file names to path names
type Header_Num is range 0 .. 1_000;
function Hash (F : Unit_Name_Type) return Header_Num;
No_Entry : constant Int := -1;
-- Signals no entry in following table
package Unit_Hash_Table is new GNAT.HTable.Simple_HTable (
Header_Num => Header_Num,
Element => Int,
No_Element => No_Entry,
Key => Unit_Name_Type,
Hash => Hash,
Equal => "=");
-- Hash table to map unit names to file names. Used in conjunction with
-- table File_Mapping above.
package File_Hash_Table is new GNAT.HTable.Simple_HTable (
Header_Num => Header_Num,
Element => Int,
No_Element => No_Entry,
Key => File_Name_Type,
Hash => Hash,
Equal => "=");
-- Hash table to map file names to path names. Used in conjunction with
-- table Path_Mapping above.
---------
-- Add --
---------
procedure Add
(Unit_Name : Unit_Name_Type;
File_Name : File_Name_Type;
Path_Name : File_Name_Type) is
begin
File_Mapping.Increment_Last;
Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last);
File_Mapping.Table (File_Mapping.Last) := File_Name;
Path_Mapping.Increment_Last;
File_Hash_Table.Set (File_Name, Path_Mapping.Last);
Path_Mapping.Table (Path_Mapping.Last) := Path_Name;
end Add;
------------------
-- File_Name_Of --
------------------
function File_Name_Of (Unit : Unit_Name_Type) return File_Name_Type is
The_Index : constant Int := Unit_Hash_Table.Get (Unit);
begin
if The_Index = No_Entry then
return No_File;
else
return File_Mapping.Table (The_Index);
end if;
end File_Name_Of;
----------
-- Hash --
----------
function Hash (F : Unit_Name_Type) return Header_Num is
begin
return Header_Num (Int (F) rem Header_Num'Range_Length);
end Hash;
----------------
-- Initialize --
----------------
procedure Initialize (File_Name : String) is
Src : Source_Buffer_Ptr;
Hi : Source_Ptr;
BS : Big_String_Ptr;
SP : String_Ptr;
Deb : Positive := 1;
Fin : Natural := 0;
Uname : Unit_Name_Type;
Fname : Name_Id;
Pname : Name_Id;
procedure Empty_Tables;
-- Remove all entries in case of incorrect mapping file
procedure Get_Line;
-- Get a line from the mapping file
procedure Report_Truncated;
-- Report a warning when the mapping file is truncated
-- (number of lines is not a multiple of 3).
------------------
-- Empty_Tables --
------------------
procedure Empty_Tables is
begin
Unit_Hash_Table.Reset;
File_Hash_Table.Reset;
Path_Mapping.Set_Last (0);
File_Mapping.Set_Last (0);
end Empty_Tables;
--------------
-- Get_Line --
--------------
procedure Get_Line is
use ASCII;
begin
Deb := Fin + 1;
-- If not at the end of file, skip the end of line
while Deb < SP'Last
and then (SP (Deb) = CR
or else SP (Deb) = LF
or else SP (Deb) = EOF)
loop
Deb := Deb + 1;
end loop;
-- If not at the end of line, find the end of this new line
if Deb < SP'Last and then SP (Deb) /= EOF then
Fin := Deb;
while Fin < SP'Last
and then SP (Fin + 1) /= CR
and then SP (Fin + 1) /= LF
and then SP (Fin + 1) /= EOF
loop
Fin := Fin + 1;
end loop;
end if;
end Get_Line;
----------------------
-- Report_Truncated --
----------------------
procedure Report_Truncated is
begin
Write_Str ("warning: mapping file """);
Write_Str (File_Name);
Write_Line (""" is truncated");
end Report_Truncated;
-- start of procedure Initialize
begin
Name_Len := File_Name'Length;
Name_Buffer (1 .. Name_Len) := File_Name;
Read_Source_File (Name_Enter, 0, Hi, Src, Config);
if Src = null then
Write_Str ("warning: could not read mapping file """);
Write_Str (File_Name);
Write_Line ("""");
else
BS := To_Big_String_Ptr (Src);
SP := BS (1 .. Natural (Hi))'Unrestricted_Access;
loop
-- Get the unit name
Get_Line;
-- Exit if end of file has been reached
exit when Deb > Fin;
pragma Assert (Fin >= Deb + 2);
pragma Assert (SP (Fin - 1) = '%');
pragma Assert (SP (Fin) = 's' or else SP (Fin) = 'b');
Name_Len := Fin - Deb + 1;
Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin);
Uname := Name_Find;
-- Get the file name
Get_Line;
-- If end of line has been reached, file is truncated
if Deb > Fin then
Report_Truncated;
Empty_Tables;
return;
end if;
Name_Len := Fin - Deb + 1;
Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin);
Fname := Name_Find;
-- Get the path name
Get_Line;
-- If end of line has been reached, file is truncated
if Deb > Fin then
Report_Truncated;
Empty_Tables;
return;
end if;
Name_Len := Fin - Deb + 1;
Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin);
Pname := Name_Find;
-- Check for duplicate entries
if Unit_Hash_Table.Get (Uname) /= No_Entry then
Write_Str ("warning: duplicate entry """);
Write_Str (Get_Name_String (Uname));
Write_Str (""" in mapping file """);
Write_Str (File_Name);
Write_Line ("""");
Empty_Tables;
return;
end if;
if File_Hash_Table.Get (Fname) /= No_Entry then
Write_Str ("warning: duplicate entry """);
Write_Str (Get_Name_String (Fname));
Write_Str (""" in mapping file """);
Write_Str (File_Name);
Write_Line ("""");
Empty_Tables;
return;
end if;
-- Add the mappings for this unit name
Add (Uname, Fname, Pname);
end loop;
end if;
end Initialize;
------------------
-- Path_Name_Of --
------------------
function Path_Name_Of (File : File_Name_Type) return File_Name_Type is
Index : Int := No_Entry;
begin
Index := File_Hash_Table.Get (File);
if Index = No_Entry then
return No_File;
else
return Path_Mapping.Table (Index);
end if;
end Path_Name_Of;
end Fmap;

55
gcc/ada/fmap.ads Normal file
View File

@ -0,0 +1,55 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- F M A P --
-- --
-- S p e c --
-- --
-- $Revision$
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package keeps two mappings: from unit names to file names,
-- and from file names to path names.
with Types; use Types;
package Fmap is
procedure Initialize (File_Name : String);
-- Initialize the mappings from the mapping file File_Name.
-- If the mapping file is incorrect (non existent file, truncated file,
-- duplicate entries), output a warning and do not initialize the mappings.
function Path_Name_Of (File : File_Name_Type) return File_Name_Type;
-- Return the path name mapped to the file name File.
-- Return No_File if File is not mapped.
function File_Name_Of (Unit : Unit_Name_Type) return File_Name_Type;
-- Return the file name mapped to the unit name Unit.
-- Return No_File if Unit is not mapped.
procedure Add
(Unit_Name : Unit_Name_Type;
File_Name : File_Name_Type;
Path_Name : File_Name_Type);
-- Add mapping of Unit_Name to File_Name and of File_Name to Path_Name
end Fmap;

44
gcc/ada/fname-uf.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- $Revision: 1.1 $
-- $Revision$
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- --
@ -28,6 +28,7 @@
with Alloc;
with Debug; use Debug;
with Fmap;
with Krunch;
with Namet; use Namet;
with Opt; use Opt;
@ -137,6 +138,9 @@ package body Fname.UF is
N : Int;
Pname : File_Name_Type := No_File;
Fname : File_Name_Type := No_File;
begin
-- Null or error name means that some previous error occurred
-- This is an unrecoverable error, so signal it.
@ -145,6 +149,19 @@ package body Fname.UF is
raise Unrecoverable_Error;
end if;
-- Look into the mapping from unit names to file names
Fname := Fmap.File_Name_Of (Uname);
-- If the unit name is already mapped, return the corresponding
-- file name.
if Fname /= No_File then
return Fname;
end if;
-- If there is a specific SFN pragma, return the corresponding file name
N := SFN_HTable.Get (Uname);
if N /= No_Entry then
@ -367,14 +384,25 @@ package body Fname.UF is
-- Check if file exists and if so, return the entry
elsif Find_File (Fnam, Source) /= No_File then
return Fnam;
-- This entry does not match after all, because this is
-- the first search loop, and the file does not exist.
else
Fnam := No_File;
Pname := Find_File (Fnam, Source);
-- Check if file exists and if so, return the entry
if Pname /= No_File then
-- Add to mapping, so that we don't do another
-- path search in Find_File for this file name
Fmap.Add (Get_File_Name.Uname, Fnam, Pname);
return Fnam;
-- This entry does not match after all, because this is
-- the first search loop, and the file does not exist.
else
Fnam := No_File;
end if;
end if;
end if;

8
gcc/ada/frontend.adb
View File

@ -33,6 +33,7 @@ with Debug; use Debug;
with Elists;
with Exp_Ch11;
with Exp_Dbug;
with Fmap;
with Fname.UF;
with Hostparm; use Hostparm;
with Inline; use Inline;
@ -184,6 +185,13 @@ begin
end if;
-- If there was a -gnatem switch, initialize the mappings of unit names to
-- file names and of file names to path names from the mapping file.
if Mapping_File_Name /= null then
Fmap.Initialize (Mapping_File_Name.all);
end if;
-- We have now processed the command line switches, and the gnat.adc
-- file, so this is the point at which we want to capture the values
-- of the configuration switches (see Opt for further details).

17
gcc/ada/layout.adb
View File

@ -524,13 +524,12 @@ package body Layout is
end if;
return
Convert_To (Standard_Unsigned,
Assoc_Add (Loc,
Left_Opnd =>
Assoc_Subtract (Loc,
Left_Opnd => Hi_Op,
Right_Opnd => Lo_Op),
Right_Opnd => Make_Integer_Literal (Loc, 1)));
Assoc_Add (Loc,
Left_Opnd =>
Assoc_Subtract (Loc,
Left_Opnd => Hi_Op,
Right_Opnd => Lo_Op),
Right_Opnd => Make_Integer_Literal (Loc, 1));
end Compute_Length;
----------------------
@ -749,6 +748,8 @@ package body Layout is
Set_Parent (Len, E);
Determine_Range (Len, OK, LLo, LHi);
Len := Convert_To (Standard_Unsigned, Len);
-- If we cannot verify that range cannot be super-flat,
-- we need a max with zero, since length must be non-neg.
@ -1059,6 +1060,8 @@ package body Layout is
Set_Parent (Len, E);
Determine_Range (Len, OK, LLo, LHi);
Len := Convert_To (Standard_Unsigned, Len);
-- If range definitely flat or superflat, result size is zero
if OK and then LHi <= 0 then

35
gcc/ada/make.adb
View File

@ -2508,6 +2508,10 @@ package body Make is
-- be rebuild (if we rebuild mains), even in the case when it is not
-- really necessary, because it is too hard to decide.
Mapping_File_Name : Temp_File_Name;
-- The name of the temporary mapping file that is copmmunicated
-- to the compiler through a -gnatem switch, when using project files.
begin
Do_Compile_Step := True;
Do_Bind_Step := True;
@ -2854,7 +2858,7 @@ package body Make is
-- in procedure Compile_Sources.
The_Saved_Gcc_Switches :=
new Argument_List (1 .. Saved_Gcc_Switches.Last + 1);
new Argument_List (1 .. Saved_Gcc_Switches.Last + 2);
for J in 1 .. Saved_Gcc_Switches.Last loop
The_Saved_Gcc_Switches (J) := Saved_Gcc_Switches.Table (J);
@ -2863,9 +2867,19 @@ package body Make is
-- We never use gnat.adc when a project file is used
The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last) :=
The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last - 1) :=
No_gnat_adc;
-- Create a temporary mapping file and add the switch -gnatem
-- with its name to the compiler.
Prj.Env.Create_Mapping_File (Name => Mapping_File_Name);
The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last) :=
new String'("-gnatem" & Mapping_File_Name);
-- Check if there are any relative search paths in the switches.
-- Fail if there is one.
for J in 1 .. Gcc_Switches.Last loop
Test_If_Relative_Path (Gcc_Switches.Table (J));
end loop;
@ -3184,7 +3198,7 @@ package body Make is
and then not No_Main_Subprogram
then
if Osint.Number_Of_Files = 1 then
return;
exit Multiple_Main_Loop;
else
goto Next_Main;
@ -3231,7 +3245,7 @@ package body Make is
end if;
if Osint.Number_Of_Files = 1 then
return;
exit Multiple_Main_Loop;
else
goto Next_Main;
@ -3477,6 +3491,19 @@ package body Make is
end if;
end loop Multiple_Main_Loop;
-- Delete the temporary mapping file that was created if we are
-- using project files.
if Main_Project /= No_Project then
declare
Success : Boolean;
begin
Delete_File (Name => Mapping_File_Name, Success => Success);
end;
end if;
Exit_Program (E_Success);
exception

1
gcc/ada/misc.c
View File

@ -45,6 +45,7 @@
#include "expr.h"
#include "ggc.h"
#include "flags.h"
#include "insn-codes.h"
#include "insn-flags.h"
#include "insn-config.h"
#include "optabs.h"

5
gcc/ada/opt.ads
View File

@ -470,6 +470,11 @@ package Opt is
-- When True we are allowed to look in the primary directory to locate
-- other source or library files.
Mapping_File_Name : String_Ptr := null;
-- GNAT
-- File name of mapping between unit names, file names and path names.
-- (given by switch -gnatem)
Maximum_Errors : Int := 9999;
-- GNAT, GNATBIND
-- Maximum number of errors before compilation is terminated

13
gcc/ada/osint.adb
View File

@ -26,6 +26,7 @@
-- --
------------------------------------------------------------------------------
with Fmap;
with Hostparm;
with Namet; use Namet;
with Opt; use Opt;
@ -1001,6 +1002,18 @@ package body Osint is
-- Otherwise do standard search for source file
else
-- Check the mapping of this file name
File := Fmap.Path_Name_Of (N);
-- If the file name is mapped to a path name, return the
-- corresponding path name
if File /= No_File then
return File;
end if;
-- First place to look is in the primary directory (i.e. the same
-- directory as the source) unless this has been disabled with -I-

89
gcc/ada/prj-env.adb
View File

@ -788,6 +788,95 @@ package body Prj.Env is
end Create_Config_Pragmas_File;
-------------------------
-- Create_Mapping_File --
-------------------------
procedure Create_Mapping_File (Name : in out Temp_File_Name) is
File : File_Descriptor := Invalid_FD;
The_Unit_Data : Unit_Data;
Data : File_Name_Data;
procedure Put (S : String);
-- Put a line in the mapping file
procedure Put_Data (Spec : Boolean);
-- Put the mapping of the spec or body contained in Data in the file
-- (3 lines).
procedure Put (S : String) is
Last : Natural;
begin
Last := Write (File, S'Address, S'Length);
if Last /= S'Length then
Osint.Fail ("Disk full");
end if;
end Put;
procedure Put_Data (Spec : Boolean) is
begin
Put (Get_Name_String (The_Unit_Data.Name));
if Spec then
Put ("%s");
else
Put ("%b");
end if;
Put (S => (1 => ASCII.LF));
Put (Get_Name_String (Data.Name));
Put (S => (1 => ASCII.LF));
Put (Get_Name_String (Data.Path));
Put (S => (1 => ASCII.LF));
end Put_Data;
begin
GNAT.OS_Lib.Create_Temp_File (File, Name => Name);
if File = Invalid_FD then
Osint.Fail
("unable to create temporary mapping file");
elsif Opt.Verbose_Mode then
Write_Str ("Creating temp mapping file """);
Write_Str (Name);
Write_Line ("""");
end if;
-- For all units in table Units
for Unit in 1 .. Units.Last loop
The_Unit_Data := Units.Table (Unit);
-- If the unit has a valid name
if The_Unit_Data.Name /= No_Name then
Data := The_Unit_Data.File_Names (Specification);
-- If there is a spec, put it mapping in the file
if Data.Name /= No_Name then
Put_Data (Spec => True);
end if;
Data := The_Unit_Data.File_Names (Body_Part);
-- If there is a body (or subunit) put its mapping in the file
if Data.Name /= No_Name then
Put_Data (Spec => False);
end if;
end if;
end loop;
GNAT.OS_Lib.Close (File);
end Create_Mapping_File;
------------------------------------
-- File_Name_Of_Library_Unit_Body --
------------------------------------

7
gcc/ada/prj-env.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- $Revision: 1.10 $
-- $Revision$
-- --
-- Copyright (C) 2001 Free Software Foundation, Inc. --
-- --
@ -39,6 +39,11 @@ package Prj.Env is
procedure Print_Sources;
-- Output the list of sources, after Project files have been scanned
procedure Create_Mapping_File (Name : in out Temp_File_Name);
-- Create a temporary mapping file.
-- For each unit, put the mapping of its spec and or body to its
-- file name and path name in this file.
procedure Create_Config_Pragmas_File
(For_Project : Project_Id;
Main_Project : Project_Id);

6
gcc/ada/prj-tree.ads
View File

@ -299,7 +299,8 @@ package Prj.Tree is
function First_Choice_Of
(Node : Project_Node_Id)
return Project_Node_Id;
-- Only valid for N_Case_Item nodes
-- Return the first choice in a N_Case_Item, or Empty_Node if
-- this is when others.
function Next_Case_Item
(Node : Project_Node_Id)
@ -708,7 +709,8 @@ package Prj.Tree is
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: not used
-- -- Field1: first choice (literal string)
-- -- Field1: first choice (literal string), or Empty_Node
-- -- for when others
-- -- Field2: first declarative item
-- -- Field3: next case item
-- -- Value: not used

3
gcc/ada/rident.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- $Revision: 1.12 $
-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
@ -73,6 +73,7 @@ package Rident is
No_Reentrancy, -- (RM H.4(23))
No_Relative_Delay, -- GNAT
No_Requeue, -- GNAT
No_Secondary_Stack, -- GNAT
No_Select_Statements, -- GNAT (Ravenscar)
No_Standard_Storage_Pools, -- GNAT
No_Streams, -- GNAT

13
gcc/ada/rtsfind.adb
View File

@ -582,6 +582,8 @@ package body Rtsfind is
Pkg_Ent : Entity_Id;
Ename : Name_Id;
Ravenscar : constant Boolean := Restricted_Profile;
procedure Check_RPC;
-- Reject programs that make use of distribution features not supported
-- on the current target. On such targets (VMS, Vxworks, others?) we
@ -712,13 +714,17 @@ package body Rtsfind is
-- Start of processing for RTE
begin
-- Check violation of no run time mode
-- Check violation of no run time and ravenscar mode
if No_Run_Time
and then not OK_To_Use_In_No_Run_Time_Mode (U_Id)
then
Disallow_In_No_Run_Time_Mode (Current_Error_Node);
return Empty;
if not Ravenscar
or else not OK_To_Use_In_Ravenscar_Mode (U_Id)
then
Disallow_In_No_Run_Time_Mode (Current_Error_Node);
return Empty;
end if;
end if;
-- Doing a rtsfind in system.ads is special, as we cannot do this
@ -843,6 +849,7 @@ package body Rtsfind is
and then not
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Current_Error_Node)))
and then not Ravenscar
then
Disallow_In_No_Run_Time_Mode (Current_Error_Node);
end if;

19
gcc/ada/rtsfind.ads
View File

@ -378,6 +378,7 @@ package Rtsfind is
OK_To_Use_In_No_Run_Time_Mode : array (RTU_Id) of Boolean :=
(Ada_Tags => True,
Ada_Exceptions => True,
Interfaces => True,
System => True,
System_Fat_Flt => True,
@ -387,12 +388,28 @@ package Rtsfind is
System_Machine_Code => True,
System_Storage_Elements => True,
System_Unsigned_Types => True,
System_Secondary_Stack => True,
others => False);
-- This array defines the set of packages that can legitimately be
-- accessed by Rtsfind in No_Run_Time mode. Any attempt to load
-- any other package in this mode will result in a message noting
-- use of a feature not supported in high integrity mode.
OK_To_Use_In_Ravenscar_Mode : array (RTU_Id) of Boolean :=
(System_Interrupts => True,
System_Tasking => True,
System_Tasking_Protected_Objects => True,
System_Tasking_Restricted_Stages => True,
System_Tasking_Protected_Objects_Single_Entry => True,
System_Task_Info => True,
System_Parameters => True,
Ada_Real_Time => True,
Ada_Real_Time_Delays => True,
others => False);
-- This array defines the set of packages that can legitimately be
-- accessed by Rtsfind in Ravenscar mode, in addition to the
-- No_Run_Time units which are also allowed.
--------------------------
-- Runtime Entity Table --
--------------------------
@ -1032,7 +1049,6 @@ package Rtsfind is
RE_Shared_Var_WOpen, -- System.Shared_Storage
RE_Abort_Undefer_Direct, -- System.Standard_Library
RE_Exception_Data, -- System.Standard_Library
RE_Exception_Data_Ptr, -- System.Standard_Library
RE_Integer_Address, -- System.Storage_Elements
@ -1953,7 +1969,6 @@ package Rtsfind is
RE_Shared_Var_WOpen => System_Shared_Storage,
RE_Abort_Undefer_Direct => System_Standard_Library,
RE_Exception_Data => System_Standard_Library,
RE_Exception_Data_Ptr => System_Standard_Library,
RE_Integer_Address => System_Storage_Elements,

26
gcc/ada/sem_ch10.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- $Revision: 1.2 $
-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
@ -1486,15 +1486,16 @@ package body Sem_Ch10 is
E_Name := Defining_Entity (U);
-- Note: in the following test, Unit_Kind is the original Nkind, but
-- in the case of an instantiation, the call to Semantics above will
-- have replaced the unit by its instantiated version.
-- in the case of an instantiation, semantic analysis above will
-- have replaced the unit by its instantiated version. If the instance
-- body has been generated, the instance now denotes the body entity.
-- For visibility purposes we need the entity of its spec.
elsif Unit_Kind = N_Package_Instantiation
elsif (Unit_Kind = N_Package_Instantiation
or else Nkind (Original_Node (Unit (Library_Unit (N)))) =
N_Package_Instantiation)
and then Nkind (U) = N_Package_Body
then
-- Instantiation node is replaced with body of instance.
-- Unit name is defining unit name in corresponding spec.
E_Name := Corresponding_Spec (U);
elsif Unit_Kind = N_Package_Instantiation
@ -2712,17 +2713,6 @@ package body Sem_Ch10 is
P : constant Entity_Id := Scope (Uname);
begin
-- If the unit is a package instantiation, its body may have been
-- generated for an inner instance, and the instance now denotes the
-- body entity. For visibility purposes we need the instance in the
-- specification.
if Ekind (Uname) = E_Package_Body
and then Is_Generic_Instance (Uname)
then
Uname := Spec_Entity (Uname);
end if;
-- We do not apply the restrictions to an internal unit unless
-- we are compiling the internal unit as a main unit. This check
-- is also skipped for dummy units (for missing packages).

22
gcc/ada/sem_res.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $
-- $Revision$
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- --
@ -5033,6 +5033,25 @@ package body Sem_Res is
It1 : Interp;
Found : Boolean;
function Init_Component return Boolean;
-- Check whether this is the initialization of a component within an
-- init_proc (by assignment or call to another init_proc). If true,
-- there is no need for a discriminant check.
--------------------
-- Init_Component --
--------------------
function Init_Component return Boolean is
begin
return Inside_Init_Proc
and then Nkind (Prefix (N)) = N_Identifier
and then Chars (Prefix (N)) = Name_uInit
and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative;
end Init_Component;
-- Start of processing for Resolve_Selected_Component
begin
if Is_Overloaded (P) then
@ -5128,6 +5147,7 @@ package body Sem_Res is
and then Present (Discriminant_Checking_Func
(Original_Record_Component (Entity (S))))
and then not Discriminant_Checks_Suppressed (T)
and then not Init_Component
then
Set_Do_Discriminant_Check (N);
end if;

18
gcc/ada/sem_warn.adb
View File

@ -643,6 +643,15 @@ package body Sem_Warn is
if not In_Extended_Main_Source_Unit (Cnode) then
return;
-- In No_Run_Time_Mode, we remove the bodies of non-
-- inlined subprograms, which may lead to spurious
-- warnings, clearly undesirable.
elsif No_Run_Time
and then Is_Predefined_File_Name (Unit_File_Name (Unit))
then
return;
end if;
-- Loop through context items in this unit
@ -674,15 +683,6 @@ package body Sem_Warn is
if Unit = Spec_Unit then
Set_Unreferenced_In_Spec (Item);
-- In No_Run_Time_Mode, we remove the bodies of non-
-- inlined subprograms, which may lead to spurious
-- warnings, clearly undesirable.
elsif No_Run_Time
and then Is_Predefined_File_Name (Unit_File_Name (Unit))
then
null;
-- Otherwise simple unreferenced message
else

15
gcc/ada/switch.adb
View File

@ -606,6 +606,8 @@ package body Switch is
case Switch_Chars (Ptr) is
-- Configuration pragmas
when 'c' =>
Ptr := Ptr + 1;
if Ptr > Max then
@ -617,6 +619,19 @@ package body Switch is
return;
-- Mapping file
when 'm' =>
Ptr := Ptr + 1;
if Ptr > Max then
Osint.Fail ("Invalid switch: ", "em");
end if;
Mapping_File_Name :=
new String'(Switch_Chars (Ptr .. Max));
return;
when others =>
Osint.Fail ("Invalid switch: ",
(1 => 'e', 2 => Switch_Chars (Ptr)));

13
gcc/ada/trans.c
View File

@ -585,9 +585,9 @@ tree_transform (gnat_node)
else
{
if (! Is_Machine_Number (gnat_node))
ur_realval =
Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
ur_realval);
ur_realval
= Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
ur_realval, Round_Even);
gnu_result
= UI_To_gnu (Numerator (ur_realval), gnu_result_type);
@ -1858,6 +1858,13 @@ tree_transform (gnat_node)
gnu_rhs = maybe_unconstrained_array (gnu_rhs);
}
/* If the result type is a private type, its full view may be a
numeric subtype. The representation we need is that of its base
type, given that it is the result of an arithmetic operation. */
else if (Is_Private_Type (Etype (gnat_node)))
gnu_type = gnu_result_type
= get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
/* If this is a shift whose count is not guaranteed to be correct,
we need to adjust the shift count. */
if (IN (Nkind (gnat_node), N_Op_Shift)

7
gcc/ada/urealp.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* $Revision: 1.1 $
* $Revision$
* *
* Copyright (C) 1992-2001 Free Software Foundation, Inc. *
* *
@ -46,5 +46,8 @@ extern Boolean UR_Is_Negative PARAMS ((Ureal));
#define UR_Is_Zero urealp__ur_is_zero
extern Boolean UR_Is_Zero PARAMS ((Ureal));
enum Rounding_Mode {Floor = 0, Ceiling = 1, Round = 2, Round_Even = 3};
#define Machine eval_fat__machine
extern Ureal Machine PARAMS ((Entity_Id, Ureal));
extern Ureal Machine PARAMS ((Entity_Id, Ureal,
enum Rounding_Mode));

5
gcc/ada/usage.adb
View File

@ -155,6 +155,11 @@ begin
Write_Switch_Char ("ec?");
Write_Line ("Specify configuration pragmas file, e.g. -gnatec/x/f.adc");
-- Line for -gnatem switch
Write_Switch_Char ("em?");
Write_Line ("Specify mapping file, e.g. -gnatemmapping");
-- Line for -gnatE switch
Write_Switch_Char ("E");