Skip to content

R
riscv-gcc-1
Commit 6510f4c9 by Geert Bosch
Options

sem_res.adb (Resolve_Selected_Component): do not generate a discriminant check… 

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
parent c6d96f20
Showing with 992 additions and 161 deletions
gcc/ada/ChangeLog
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> 2001-12-17 Joel Brobecker <brobecke@gnat.com>
* gnat_rm.texi: Fix minor typos. Found while reading the section * gnat_rm.texi: Fix minor typos. Found while reading the section
......
gcc/ada/Makefile.in
...@@ -296,7 +296,7 @@ GNAT_ADA_OBJS = \ ...@@ -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_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_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 \ 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 \ g-speche.o s-crc32.o get_targ.o gnatvsn.o \
hlo.o hostparm.o impunit.o \ hlo.o hostparm.o impunit.o \
interfac.o itypes.o inline.o krunch.o lib.o \ interfac.o itypes.o inline.o krunch.o lib.o \
...@@ -326,7 +326,7 @@ GNATBIND_OBJS = \ ...@@ -326,7 +326,7 @@ GNATBIND_OBJS = \
alloc.o bcheck.o binde.o \ alloc.o bcheck.o binde.o \
binderr.o bindgen.o bindusg.o \ binderr.o bindgen.o bindusg.o \
butil.o casing.o csets.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 \ 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 \ 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 \ 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 \ ...@@ -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-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 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 \ 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 \ output.o sdefault.o switch.o stylesw.o validsw.o table.o tree_io.o types.o \
$(GNATCMD_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) $(GNATCMD_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
...@@ -394,7 +394,7 @@ GNATLINK_RTL_OBJS = \ ...@@ -394,7 +394,7 @@ GNATLINK_RTL_OBJS = \
s-memory.o s-traceb.o s-wchcnv.o s-wchcon.o s-wchjis.o s-memory.o s-traceb.o s-wchcnv.o s-wchcon.o s-wchjis.o
GNATLINK_OBJS = gnatlink.o link.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 \ opt.o osint.o output.o sdefault.o stylesw.o validsw.o \
switch.o table.o tree_io.o types.o widechar.o \ switch.o table.o tree_io.o types.o widechar.o \
$(GNATLINK_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) $(GNATLINK_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
...@@ -483,6 +483,7 @@ GNATLS_OBJS = \ ...@@ -483,6 +483,7 @@ GNATLS_OBJS = \
einfo.o \ einfo.o \
elists.o \ elists.o \
errout.o \ errout.o \
fmap.o \
fname.o \ fname.o \
gnatls.o \ gnatls.o \
gnatvsn.o \ gnatvsn.o \
...@@ -553,7 +554,7 @@ GNATMAKE_RTL_OBJS = adaint.o argv.o raise.o exit.o a-comlin.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 \ 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 \ 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 \ 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 \ mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \
namet.o nlists.o opt.o osint.o output.o \ namet.o nlists.o opt.o osint.o output.o \
...@@ -706,7 +707,7 @@ GNATXREF_RTL_OBJS = \ ...@@ -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 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 \ 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 \ sdefault.o stylesw.o validsw.o tree_io.o opt.o table.o osint.o \
switch.o widechar.o namet.o \ switch.o widechar.o namet.o \
$(GNATXREF_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) $(GNATXREF_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS)
...@@ -729,7 +730,7 @@ GNATFIND_RTL_OBJS = \ ...@@ -729,7 +730,7 @@ GNATFIND_RTL_OBJS = \
s-valuns.o s-valuti.o s-wchcnv.o s-wchcon.o s-wchjis.o 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 \ 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 \ osint.o output.o sdefault.o stylesw.o validsw.o switch.o table.o \
tree_io.o types.o widechar.o \ tree_io.o types.o widechar.o \
$(GNATFIND_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) $(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 \ ...@@ -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 \ 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 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-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 \ 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 \ 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 \ ...@@ -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 \ 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 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 \ osint.o : ada.ads a-except.ads a-uncdea.ads alloc.ads debug.ads fmap.ads \
g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads namet.ads opt.ads \ gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads namet.ads \
osint.ads osint.adb output.ads sdefault.ads system.ads s-assert.ads \ opt.ads osint.ads osint.adb output.ads sdefault.ads system.ads \
s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ s-assert.ads s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads \
s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \
unchconv.ads unchdeal.ads types.ads unchconv.ads unchdeal.ads
output.o : gnat.ads g-os_lib.ads output.ads output.adb system.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 s-exctab.ads s-stalib.ads types.ads unchconv.ads unchdeal.ads
......
gcc/ada/a-except.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- $Revision: 1.1 $ -- $Revision$
-- -- -- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- -- -- --
...@@ -365,6 +365,34 @@ package body Ada.Exceptions is ...@@ -365,6 +365,34 @@ package body Ada.Exceptions is
-- Basic_Exc_Tback Or Tback_Decorator -- Basic_Exc_Tback Or Tback_Decorator
-- if no decorator set otherwise -- 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 -- -- Import Run-Time C Routines --
-------------------------------- --------------------------------
...@@ -953,29 +981,10 @@ package body Ada.Exceptions is ...@@ -953,29 +981,10 @@ package body Ada.Exceptions is
or else (Hrec.Id = Others_Id or else (Hrec.Id = Others_Id
and not Excep.Id.Not_Handled_By_Others) and not Excep.Id.Not_Handled_By_Others)
then then
-- Notify the debugger that we have found a handler -- Perform the necessary notification tasks.
-- and are about to propagate an exception.
Notify_Handled_Exception
Notify_Exception (Hrec.Handler, Hrec.Id = Others_Id, True);
(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;
-- If we already encountered a finalization handler, then -- If we already encountered a finalization handler, then
-- reset the context to that handler, and enter it. -- reset the context to that handler, and enter it.
...@@ -1002,15 +1011,10 @@ package body Ada.Exceptions is ...@@ -1002,15 +1011,10 @@ package body Ada.Exceptions is
Pop_Frame (Mstate, Info); Pop_Frame (Mstate, Info);
end loop Main_Loop; end loop Main_Loop;
-- Fall through if no "real" exception handler found. First thing -- Fall through if no "real" exception handler found. First thing is to
-- is to call the dummy Unhandled_Exception routine with the stack -- perform the necessary notification tasks with the stack intact.
-- intact, so that the debugger can get control.
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. -- If there were finalization handlers, then enter the top one.
-- Just because there is no handler does not mean we don't have -- Just because there is no handler does not mean we don't have
...@@ -1066,30 +1070,14 @@ package body Ada.Exceptions is ...@@ -1066,30 +1070,14 @@ package body Ada.Exceptions is
Call_Chain (Excep); Call_Chain (Excep);
end if; end if;
if not Excep.Exception_Raised then -- Perform the necessary notification tasks if this is not a
-- This is not a reraise. -- 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
Excep.Exception_Raised := True; Excep.Exception_Raised := True;
Notify_Handled_Exception (Null_Loc, False, False);
-- 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;
end if; end if;
builtin_longjmp (Jumpbuf_Ptr, 1); builtin_longjmp (Jumpbuf_Ptr, 1);
...@@ -1112,8 +1100,7 @@ package body Ada.Exceptions is ...@@ -1112,8 +1100,7 @@ package body Ada.Exceptions is
Call_Chain (Get_Current_Excep.all); Call_Chain (Get_Current_Excep.all);
end if; end if;
Unhandled_Exception; Notify_Unhandled_Exception (E);
Notify_Exception (E, Null_Loc, False);
Unhandled_Exception_Terminate; Unhandled_Exception_Terminate;
end if; end if;
end Raise_Current_Excep; end Raise_Current_Excep;
...@@ -1179,9 +1166,10 @@ package body Ada.Exceptions is ...@@ -1179,9 +1166,10 @@ package body Ada.Exceptions is
-- the signal handler that passed control here has already set the -- the signal handler that passed control here has already set the
-- machine state directly. -- machine state directly.
-- --
-- ??? Updates related to the implementation of automatic backtraces -- We also do not compute the backtrace for the occurrence since going
-- have not been done here. Some action will be required when dealing -- through the signal handler is far from trivial and it is not a
-- the remaining problems in ZCX mode (incomplete backtraces so far). -- 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 -- If the jump buffer pointer is non-null, it means that a jump
-- buffer was allocated (obviously that happens only in the case -- buffer was allocated (obviously that happens only in the case
...@@ -1204,7 +1192,7 @@ package body Ada.Exceptions is ...@@ -1204,7 +1192,7 @@ package body Ada.Exceptions is
-- have no finalizations to do other than at the outer level. -- have no finalizations to do other than at the outer level.
else else
Unhandled_Exception; Notify_Unhandled_Exception (E);
Unhandled_Exception_Terminate; Unhandled_Exception_Terminate;
end if; end if;
end Raise_From_Signal_Handler; end Raise_From_Signal_Handler;
...@@ -1833,6 +1821,58 @@ package body Ada.Exceptions is ...@@ -1833,6 +1821,58 @@ package body Ada.Exceptions is
null; null;
end Notify_Exception; 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 -- -- Unhandled_Exception_Terminate --
----------------------------------- -----------------------------------
......
gcc/ada/bindgen.adb
...@@ -286,6 +286,7 @@ package body Bindgen is ...@@ -286,6 +286,7 @@ package body Bindgen is
--------------------- ---------------------
procedure Gen_Adainit_Ada is procedure Gen_Adainit_Ada is
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
begin begin
WBI (" procedure " & Ada_Init_Name.all & " is"); WBI (" procedure " & Ada_Init_Name.all & " is");
...@@ -347,7 +348,32 @@ package body Bindgen is ...@@ -347,7 +348,32 @@ package body Bindgen is
-- the routine call, rather than define the globals in the binder -- the routine call, rather than define the globals in the binder
-- file to deal with cross-library calls in some systems. -- 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 ("");
WBI (" procedure Set_Globals"); WBI (" procedure Set_Globals");
WBI (" (Main_Priority : Integer;"); WBI (" (Main_Priority : Integer;");
...@@ -383,7 +409,7 @@ package body Bindgen is ...@@ -383,7 +409,7 @@ package body Bindgen is
WBI (" Set_Globals"); WBI (" Set_Globals");
Set_String (" (Main_Priority => "); Set_String (" (Main_Priority => ");
Set_Int (ALIs.Table (ALIs.First).Main_Priority); Set_Int (Main_Priority);
Set_Char (','); Set_Char (',');
Write_Statement_Buffer; Write_Statement_Buffer;
...@@ -449,14 +475,6 @@ package body Bindgen is ...@@ -449,14 +475,6 @@ package body Bindgen is
WBI (" if Handler_Installed = 0 then"); WBI (" if Handler_Installed = 0 then");
WBI (" Install_Handler;"); WBI (" Install_Handler;");
WBI (" end if;"); 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; end if;
Gen_Elab_Calls_Ada; Gen_Elab_Calls_Ada;
...@@ -469,6 +487,7 @@ package body Bindgen is ...@@ -469,6 +487,7 @@ package body Bindgen is
-------------------- --------------------
procedure Gen_Adainit_C is procedure Gen_Adainit_C is
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
begin begin
WBI ("void " & Ada_Init_Name.all & " ()"); WBI ("void " & Ada_Init_Name.all & " ()");
WBI ("{"); WBI ("{");
...@@ -493,9 +512,19 @@ package body Bindgen is ...@@ -493,9 +512,19 @@ package body Bindgen is
Write_Statement_Buffer; 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; Gen_Exception_Table_C;
...@@ -510,7 +539,7 @@ package body Bindgen is ...@@ -510,7 +539,7 @@ package body Bindgen is
WBI (" __gnat_set_globals ("); WBI (" __gnat_set_globals (");
Set_String (" "); Set_String (" ");
Set_Int (ALIs.Table (ALIs.First).Main_Priority); Set_Int (Main_Priority);
Set_Char (','); Set_Char (',');
Tab_To (15); Tab_To (15);
Set_String ("/* Main_Priority */"); Set_String ("/* Main_Priority */");
...@@ -584,12 +613,6 @@ package body Bindgen is ...@@ -584,12 +613,6 @@ package body Bindgen is
WBI (" {"); WBI (" {");
WBI (" __gnat_install_handler ();"); WBI (" __gnat_install_handler ();");
WBI (" }"); 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; end if;
WBI (""); WBI ("");
......
gcc/ada/cstand.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- $Revision: 1.2 $ -- $Revision$
-- -- -- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- -- -- --
...@@ -1003,14 +1003,27 @@ package body CStand is ...@@ -1003,14 +1003,27 @@ package body CStand is
-- Create type declaration for Duration, using a 64-bit size. -- Create type declaration for Duration, using a 64-bit size.
-- Delta is 1 nanosecond. -- 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 Build_Duration : declare
Dlo : constant Uint := Intval (Type_Low_Bound (Standard_Integer_64)); Dlo : Uint;
Dhi : constant Uint := Intval (Type_High_Bound (Standard_Integer_64)); Dhi : Uint;
Delta_Val : Ureal;
Delta_Val : constant Ureal := UR_From_Components (Uint_1, Uint_9, 10); Use_32_Bits : constant Boolean :=
No_Run_Time and then System_Word_Size = 32;
begin 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 := Decl :=
Make_Full_Type_Declaration (Stloc, Make_Full_Type_Declaration (Stloc,
Defining_Identifier => Standard_Duration, Defining_Identifier => Standard_Duration,
...@@ -1024,9 +1037,15 @@ package body CStand is ...@@ -1024,9 +1037,15 @@ package body CStand is
High_Bound => Make_Real_Literal (Stloc, High_Bound => Make_Real_Literal (Stloc,
Realval => Dhi * Delta_Val)))); Realval => Dhi * Delta_Val))));
Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type); Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type);
Set_Etype (Standard_Duration, Standard_Duration); Set_Etype (Standard_Duration, Standard_Duration);
Init_Size (Standard_Duration, 64);
if Use_32_Bits then
Init_Size (Standard_Duration, 32);
else
Init_Size (Standard_Duration, 64);
end if;
Set_Prim_Alignment (Standard_Duration); Set_Prim_Alignment (Standard_Duration);
Set_Delta_Value (Standard_Duration, Delta_Val); Set_Delta_Value (Standard_Duration, Delta_Val);
Set_Small_Value (Standard_Duration, Delta_Val); Set_Small_Value (Standard_Duration, Delta_Val);
......
gcc/ada/fmap.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/fname-uf.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- $Revision: 1.1 $ -- $Revision$
-- -- -- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- -- -- --
...@@ -28,6 +28,7 @@ ...@@ -28,6 +28,7 @@
with Alloc; with Alloc;
with Debug; use Debug; with Debug; use Debug;
with Fmap;
with Krunch; with Krunch;
with Namet; use Namet; with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
...@@ -137,6 +138,9 @@ package body Fname.UF is ...@@ -137,6 +138,9 @@ package body Fname.UF is
N : Int; N : Int;
Pname : File_Name_Type := No_File;
Fname : File_Name_Type := No_File;
begin begin
-- Null or error name means that some previous error occurred -- Null or error name means that some previous error occurred
-- This is an unrecoverable error, so signal it. -- This is an unrecoverable error, so signal it.
...@@ -145,6 +149,19 @@ package body Fname.UF is ...@@ -145,6 +149,19 @@ package body Fname.UF is
raise Unrecoverable_Error; raise Unrecoverable_Error;
end if; 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); N := SFN_HTable.Get (Uname);
if N /= No_Entry then if N /= No_Entry then
...@@ -367,14 +384,25 @@ package body Fname.UF is ...@@ -367,14 +384,25 @@ package body Fname.UF is
-- Check if file exists and if so, return the entry -- Check if file exists and if so, return the entry
elsif Find_File (Fnam, Source) /= No_File then else
return Fnam; Pname := Find_File (Fnam, Source);
-- Check if file exists and if so, return the entry
-- This entry does not match after all, because this is if Pname /= No_File then
-- the first search loop, and the file does not exist.
else -- Add to mapping, so that we don't do another
Fnam := No_File; -- 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;
end if; end if;
......
gcc/ada/frontend.adb
...@@ -33,6 +33,7 @@ with Debug; use Debug; ...@@ -33,6 +33,7 @@ with Debug; use Debug;
with Elists; with Elists;
with Exp_Ch11; with Exp_Ch11;
with Exp_Dbug; with Exp_Dbug;
with Fmap;
with Fname.UF; with Fname.UF;
with Hostparm; use Hostparm; with Hostparm; use Hostparm;
with Inline; use Inline; with Inline; use Inline;
...@@ -184,6 +185,13 @@ begin ...@@ -184,6 +185,13 @@ begin
end if; 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 -- 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 -- file, so this is the point at which we want to capture the values
-- of the configuration switches (see Opt for further details). -- of the configuration switches (see Opt for further details).
......
gcc/ada/layout.adb
...@@ -524,13 +524,12 @@ package body Layout is ...@@ -524,13 +524,12 @@ package body Layout is
end if; end if;
return return
Convert_To (Standard_Unsigned, Assoc_Add (Loc,
Assoc_Add (Loc, Left_Opnd =>
Left_Opnd => Assoc_Subtract (Loc,
Assoc_Subtract (Loc, Left_Opnd => Hi_Op,
Left_Opnd => Hi_Op, Right_Opnd => Lo_Op),
Right_Opnd => Lo_Op), Right_Opnd => Make_Integer_Literal (Loc, 1));
Right_Opnd => Make_Integer_Literal (Loc, 1)));
end Compute_Length; end Compute_Length;
---------------------- ----------------------
...@@ -749,6 +748,8 @@ package body Layout is ...@@ -749,6 +748,8 @@ package body Layout is
Set_Parent (Len, E); Set_Parent (Len, E);
Determine_Range (Len, OK, LLo, LHi); Determine_Range (Len, OK, LLo, LHi);
Len := Convert_To (Standard_Unsigned, Len);
-- If we cannot verify that range cannot be super-flat, -- If we cannot verify that range cannot be super-flat,
-- we need a max with zero, since length must be non-neg. -- we need a max with zero, since length must be non-neg.
...@@ -1059,6 +1060,8 @@ package body Layout is ...@@ -1059,6 +1060,8 @@ package body Layout is
Set_Parent (Len, E); Set_Parent (Len, E);
Determine_Range (Len, OK, LLo, LHi); Determine_Range (Len, OK, LLo, LHi);
Len := Convert_To (Standard_Unsigned, Len);
-- If range definitely flat or superflat, result size is zero -- If range definitely flat or superflat, result size is zero
if OK and then LHi <= 0 then if OK and then LHi <= 0 then
......
gcc/ada/make.adb
...@@ -2508,6 +2508,10 @@ package body Make is ...@@ -2508,6 +2508,10 @@ package body Make is
-- be rebuild (if we rebuild mains), even in the case when it is not -- be rebuild (if we rebuild mains), even in the case when it is not
-- really necessary, because it is too hard to decide. -- 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 begin
Do_Compile_Step := True; Do_Compile_Step := True;
Do_Bind_Step := True; Do_Bind_Step := True;
...@@ -2854,7 +2858,7 @@ package body Make is ...@@ -2854,7 +2858,7 @@ package body Make is
-- in procedure Compile_Sources. -- in procedure Compile_Sources.
The_Saved_Gcc_Switches := 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 for J in 1 .. Saved_Gcc_Switches.Last loop
The_Saved_Gcc_Switches (J) := Saved_Gcc_Switches.Table (J); The_Saved_Gcc_Switches (J) := Saved_Gcc_Switches.Table (J);
...@@ -2863,9 +2867,19 @@ package body Make is ...@@ -2863,9 +2867,19 @@ package body Make is
-- We never use gnat.adc when a project file is used -- 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; 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 for J in 1 .. Gcc_Switches.Last loop
Test_If_Relative_Path (Gcc_Switches.Table (J)); Test_If_Relative_Path (Gcc_Switches.Table (J));
end loop; end loop;
...@@ -3184,7 +3198,7 @@ package body Make is ...@@ -3184,7 +3198,7 @@ package body Make is
and then not No_Main_Subprogram and then not No_Main_Subprogram
then then
if Osint.Number_Of_Files = 1 then if Osint.Number_Of_Files = 1 then
return; exit Multiple_Main_Loop;
else else
goto Next_Main; goto Next_Main;
...@@ -3231,7 +3245,7 @@ package body Make is ...@@ -3231,7 +3245,7 @@ package body Make is
end if; end if;
if Osint.Number_Of_Files = 1 then if Osint.Number_Of_Files = 1 then
return; exit Multiple_Main_Loop;
else else
goto Next_Main; goto Next_Main;
...@@ -3477,6 +3491,19 @@ package body Make is ...@@ -3477,6 +3491,19 @@ package body Make is
end if; end if;
end loop Multiple_Main_Loop; 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); Exit_Program (E_Success);
exception exception
......
gcc/ada/misc.c
...@@ -45,6 +45,7 @@ ...@@ -45,6 +45,7 @@
#include "expr.h" #include "expr.h"
#include "ggc.h" #include "ggc.h"
#include "flags.h" #include "flags.h"
#include "insn-codes.h"
#include "insn-flags.h" #include "insn-flags.h"
#include "insn-config.h" #include "insn-config.h"
#include "optabs.h" #include "optabs.h"
......
gcc/ada/opt.ads
...@@ -470,6 +470,11 @@ package Opt is ...@@ -470,6 +470,11 @@ package Opt is
-- When True we are allowed to look in the primary directory to locate -- When True we are allowed to look in the primary directory to locate
-- other source or library files. -- 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; Maximum_Errors : Int := 9999;
-- GNAT, GNATBIND -- GNAT, GNATBIND
-- Maximum number of errors before compilation is terminated -- Maximum number of errors before compilation is terminated
......
gcc/ada/osint.adb
...@@ -26,6 +26,7 @@ ...@@ -26,6 +26,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Fmap;
with Hostparm; with Hostparm;
with Namet; use Namet; with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
...@@ -1001,6 +1002,18 @@ package body Osint is ...@@ -1001,6 +1002,18 @@ package body Osint is
-- Otherwise do standard search for source file -- Otherwise do standard search for source file
else 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 -- First place to look is in the primary directory (i.e. the same
-- directory as the source) unless this has been disabled with -I- -- directory as the source) unless this has been disabled with -I-
......
gcc/ada/prj-env.adb
...@@ -788,6 +788,95 @@ package body Prj.Env is ...@@ -788,6 +788,95 @@ package body Prj.Env is
end Create_Config_Pragmas_File; 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 -- -- File_Name_Of_Library_Unit_Body --
------------------------------------ ------------------------------------
......
gcc/ada/prj-env.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- $Revision: 1.10 $ -- $Revision$
-- -- -- --
-- Copyright (C) 2001 Free Software Foundation, Inc. -- -- Copyright (C) 2001 Free Software Foundation, Inc. --
-- -- -- --
...@@ -39,6 +39,11 @@ package Prj.Env is ...@@ -39,6 +39,11 @@ package Prj.Env is
procedure Print_Sources; procedure Print_Sources;
-- Output the list of sources, after Project files have been scanned -- 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 procedure Create_Config_Pragmas_File
(For_Project : Project_Id; (For_Project : Project_Id;
Main_Project : Project_Id); Main_Project : Project_Id);
......
gcc/ada/prj-tree.ads
...@@ -299,7 +299,8 @@ package Prj.Tree is ...@@ -299,7 +299,8 @@ package Prj.Tree is
function First_Choice_Of function First_Choice_Of
(Node : Project_Node_Id) (Node : Project_Node_Id)
return 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 function Next_Case_Item
(Node : Project_Node_Id) (Node : Project_Node_Id)
...@@ -708,7 +709,8 @@ package Prj.Tree is ...@@ -708,7 +709,8 @@ package Prj.Tree is
-- -- Name: not used -- -- Name: not used
-- -- Path_Name: not used -- -- Path_Name: not used
-- -- Expr_Kind: 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 -- -- Field2: first declarative item
-- -- Field3: next case item -- -- Field3: next case item
-- -- Value: not used -- -- Value: not used
......
gcc/ada/rident.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- $Revision: 1.12 $ -- $Revision$
-- -- -- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- -- -- --
...@@ -73,6 +73,7 @@ package Rident is ...@@ -73,6 +73,7 @@ package Rident is
No_Reentrancy, -- (RM H.4(23)) No_Reentrancy, -- (RM H.4(23))
No_Relative_Delay, -- GNAT No_Relative_Delay, -- GNAT
No_Requeue, -- GNAT No_Requeue, -- GNAT
No_Secondary_Stack, -- GNAT
No_Select_Statements, -- GNAT (Ravenscar) No_Select_Statements, -- GNAT (Ravenscar)
No_Standard_Storage_Pools, -- GNAT No_Standard_Storage_Pools, -- GNAT
No_Streams, -- GNAT No_Streams, -- GNAT
......
gcc/ada/rtsfind.adb
...@@ -582,6 +582,8 @@ package body Rtsfind is ...@@ -582,6 +582,8 @@ package body Rtsfind is
Pkg_Ent : Entity_Id; Pkg_Ent : Entity_Id;
Ename : Name_Id; Ename : Name_Id;
Ravenscar : constant Boolean := Restricted_Profile;
procedure Check_RPC; procedure Check_RPC;
-- Reject programs that make use of distribution features not supported -- Reject programs that make use of distribution features not supported
-- on the current target. On such targets (VMS, Vxworks, others?) we -- on the current target. On such targets (VMS, Vxworks, others?) we
...@@ -712,13 +714,17 @@ package body Rtsfind is ...@@ -712,13 +714,17 @@ package body Rtsfind is
-- Start of processing for RTE -- Start of processing for RTE
begin begin
-- Check violation of no run time mode -- Check violation of no run time and ravenscar mode
if No_Run_Time if No_Run_Time
and then not OK_To_Use_In_No_Run_Time_Mode (U_Id) and then not OK_To_Use_In_No_Run_Time_Mode (U_Id)
then then
Disallow_In_No_Run_Time_Mode (Current_Error_Node); if not Ravenscar
return Empty; 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; end if;
-- Doing a rtsfind in system.ads is special, as we cannot do this -- Doing a rtsfind in system.ads is special, as we cannot do this
...@@ -843,6 +849,7 @@ package body Rtsfind is ...@@ -843,6 +849,7 @@ package body Rtsfind is
and then not and then not
Is_Predefined_File_Name Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Current_Error_Node))) (Unit_File_Name (Get_Source_Unit (Current_Error_Node)))
and then not Ravenscar
then then
Disallow_In_No_Run_Time_Mode (Current_Error_Node); Disallow_In_No_Run_Time_Mode (Current_Error_Node);
end if; end if;
......
gcc/ada/rtsfind.ads
...@@ -378,6 +378,7 @@ package Rtsfind is ...@@ -378,6 +378,7 @@ package Rtsfind is
OK_To_Use_In_No_Run_Time_Mode : array (RTU_Id) of Boolean := OK_To_Use_In_No_Run_Time_Mode : array (RTU_Id) of Boolean :=
(Ada_Tags => True, (Ada_Tags => True,
Ada_Exceptions => True,
Interfaces => True, Interfaces => True,
System => True, System => True,
System_Fat_Flt => True, System_Fat_Flt => True,
...@@ -387,12 +388,28 @@ package Rtsfind is ...@@ -387,12 +388,28 @@ package Rtsfind is
System_Machine_Code => True, System_Machine_Code => True,
System_Storage_Elements => True, System_Storage_Elements => True,
System_Unsigned_Types => True, System_Unsigned_Types => True,
System_Secondary_Stack => True,
others => False); others => False);
-- This array defines the set of packages that can legitimately be -- This array defines the set of packages that can legitimately be
-- accessed by Rtsfind in No_Run_Time mode. Any attempt to load -- accessed by Rtsfind in No_Run_Time mode. Any attempt to load
-- any other package in this mode will result in a message noting -- any other package in this mode will result in a message noting
-- use of a feature not supported in high integrity mode. -- 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 -- -- Runtime Entity Table --
-------------------------- --------------------------
...@@ -1032,7 +1049,6 @@ package Rtsfind is ...@@ -1032,7 +1049,6 @@ package Rtsfind is
RE_Shared_Var_WOpen, -- System.Shared_Storage RE_Shared_Var_WOpen, -- System.Shared_Storage
RE_Abort_Undefer_Direct, -- System.Standard_Library RE_Abort_Undefer_Direct, -- System.Standard_Library
RE_Exception_Data, -- System.Standard_Library
RE_Exception_Data_Ptr, -- System.Standard_Library RE_Exception_Data_Ptr, -- System.Standard_Library
RE_Integer_Address, -- System.Storage_Elements RE_Integer_Address, -- System.Storage_Elements
...@@ -1953,7 +1969,6 @@ package Rtsfind is ...@@ -1953,7 +1969,6 @@ package Rtsfind is
RE_Shared_Var_WOpen => System_Shared_Storage, RE_Shared_Var_WOpen => System_Shared_Storage,
RE_Abort_Undefer_Direct => System_Standard_Library, RE_Abort_Undefer_Direct => System_Standard_Library,
RE_Exception_Data => System_Standard_Library,
RE_Exception_Data_Ptr => System_Standard_Library, RE_Exception_Data_Ptr => System_Standard_Library,
RE_Integer_Address => System_Storage_Elements, RE_Integer_Address => System_Storage_Elements,
......
gcc/ada/sem_ch10.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- $Revision: 1.2 $ -- $Revision$
-- -- -- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- -- -- --
...@@ -1486,15 +1486,16 @@ package body Sem_Ch10 is ...@@ -1486,15 +1486,16 @@ package body Sem_Ch10 is
E_Name := Defining_Entity (U); E_Name := Defining_Entity (U);
-- Note: in the following test, Unit_Kind is the original Nkind, but -- Note: in the following test, Unit_Kind is the original Nkind, but
-- in the case of an instantiation, the call to Semantics above will -- in the case of an instantiation, semantic analysis above will
-- have replaced the unit by its instantiated version. -- have replaced the unit by its instantiated version. If the instance
-- body has been generated, the instance now denotes the body entity.
elsif Unit_Kind = N_Package_Instantiation -- For visibility purposes we need the entity of its spec.
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 and then Nkind (U) = N_Package_Body
then then
-- Instantiation node is replaced with body of instance.
-- Unit name is defining unit name in corresponding spec.
E_Name := Corresponding_Spec (U); E_Name := Corresponding_Spec (U);
elsif Unit_Kind = N_Package_Instantiation elsif Unit_Kind = N_Package_Instantiation
...@@ -2712,17 +2713,6 @@ package body Sem_Ch10 is ...@@ -2712,17 +2713,6 @@ package body Sem_Ch10 is
P : constant Entity_Id := Scope (Uname); P : constant Entity_Id := Scope (Uname);
begin 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 do not apply the restrictions to an internal unit unless
-- we are compiling the internal unit as a main unit. This check -- we are compiling the internal unit as a main unit. This check
-- is also skipped for dummy units (for missing packages). -- is also skipped for dummy units (for missing packages).
......
gcc/ada/sem_res.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- $Revision: 1.4 $ -- $Revision$
-- -- -- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- -- -- --
...@@ -5033,6 +5033,25 @@ package body Sem_Res is ...@@ -5033,6 +5033,25 @@ package body Sem_Res is
It1 : Interp; It1 : Interp;
Found : Boolean; 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 begin
if Is_Overloaded (P) then if Is_Overloaded (P) then
...@@ -5128,6 +5147,7 @@ package body Sem_Res is ...@@ -5128,6 +5147,7 @@ package body Sem_Res is
and then Present (Discriminant_Checking_Func and then Present (Discriminant_Checking_Func
(Original_Record_Component (Entity (S)))) (Original_Record_Component (Entity (S))))
and then not Discriminant_Checks_Suppressed (T) and then not Discriminant_Checks_Suppressed (T)
and then not Init_Component
then then
Set_Do_Discriminant_Check (N); Set_Do_Discriminant_Check (N);
end if; end if;
......
gcc/ada/sem_warn.adb
...@@ -643,6 +643,15 @@ package body Sem_Warn is ...@@ -643,6 +643,15 @@ package body Sem_Warn is
if not In_Extended_Main_Source_Unit (Cnode) then if not In_Extended_Main_Source_Unit (Cnode) then
return; 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; end if;
-- Loop through context items in this unit -- Loop through context items in this unit
...@@ -674,15 +683,6 @@ package body Sem_Warn is ...@@ -674,15 +683,6 @@ package body Sem_Warn is
if Unit = Spec_Unit then if Unit = Spec_Unit then
Set_Unreferenced_In_Spec (Item); 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 -- Otherwise simple unreferenced message
else else
......
gcc/ada/switch.adb
...@@ -606,6 +606,8 @@ package body Switch is ...@@ -606,6 +606,8 @@ package body Switch is
case Switch_Chars (Ptr) is case Switch_Chars (Ptr) is
-- Configuration pragmas
when 'c' => when 'c' =>
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Ptr > Max then if Ptr > Max then
...@@ -617,6 +619,19 @@ package body Switch is ...@@ -617,6 +619,19 @@ package body Switch is
return; 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 => when others =>
Osint.Fail ("Invalid switch: ", Osint.Fail ("Invalid switch: ",
(1 => 'e', 2 => Switch_Chars (Ptr))); (1 => 'e', 2 => Switch_Chars (Ptr)));
......
gcc/ada/trans.c
...@@ -585,9 +585,9 @@ tree_transform (gnat_node) ...@@ -585,9 +585,9 @@ tree_transform (gnat_node)
else else
{ {
if (! Is_Machine_Number (gnat_node)) if (! Is_Machine_Number (gnat_node))
ur_realval = ur_realval
Machine (Base_Type (Underlying_Type (Etype (gnat_node))), = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
ur_realval); ur_realval, Round_Even);
gnu_result gnu_result
= UI_To_gnu (Numerator (ur_realval), gnu_result_type); = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
...@@ -1858,6 +1858,13 @@ tree_transform (gnat_node) ...@@ -1858,6 +1858,13 @@ tree_transform (gnat_node)
gnu_rhs = maybe_unconstrained_array (gnu_rhs); 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, /* If this is a shift whose count is not guaranteed to be correct,
we need to adjust the shift count. */ we need to adjust the shift count. */
if (IN (Nkind (gnat_node), N_Op_Shift) if (IN (Nkind (gnat_node), N_Op_Shift)
......
gcc/ada/urealp.h
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * C Header File *
* * * *
* $Revision: 1.1 $ * $Revision$
* * * *
* Copyright (C) 1992-2001 Free Software Foundation, Inc. * * Copyright (C) 1992-2001 Free Software Foundation, Inc. *
* * * *
...@@ -46,5 +46,8 @@ extern Boolean UR_Is_Negative PARAMS ((Ureal)); ...@@ -46,5 +46,8 @@ extern Boolean UR_Is_Negative PARAMS ((Ureal));
#define UR_Is_Zero urealp__ur_is_zero #define UR_Is_Zero urealp__ur_is_zero
extern Boolean UR_Is_Zero PARAMS ((Ureal)); extern Boolean UR_Is_Zero PARAMS ((Ureal));
enum Rounding_Mode {Floor = 0, Ceiling = 1, Round = 2, Round_Even = 3};
#define Machine eval_fat__machine #define Machine eval_fat__machine
extern Ureal Machine PARAMS ((Entity_Id, Ureal)); extern Ureal Machine PARAMS ((Entity_Id, Ureal,
enum Rounding_Mode));
gcc/ada/usage.adb
...@@ -155,6 +155,11 @@ begin ...@@ -155,6 +155,11 @@ begin
Write_Switch_Char ("ec?"); Write_Switch_Char ("ec?");
Write_Line ("Specify configuration pragmas file, e.g. -gnatec/x/f.adc"); 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 -- Line for -gnatE switch
Write_Switch_Char ("E"); Write_Switch_Char ("E");
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment