+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
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 \
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 \
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)
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)
einfo.o \
elists.o \
errout.o \
+ fmap.o \
fname.o \
gnatls.o \
gnatvsn.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 \
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)
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)
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 \
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
-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- 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 --
--------------------------------
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.
-
- 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;
+ -- Perform the necessary notification tasks.
+
+ 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.
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.
-
- Unhandled_Exception;
-
- -- Also make the appropriate Notify_Exception call for the debugger.
+ -- Fall through if no "real" exception handler found. First thing is to
+ -- perform the necessary notification tasks with the stack intact.
- 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
Call_Chain (Excep);
end if;
- if not Excep.Exception_Raised then
- -- This is not a reraise.
+ -- 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
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);
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;
-- 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
-- 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;
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 --
-----------------------------------
---------------------
procedure Gen_Adainit_Ada is
+ Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
begin
WBI (" procedure " & Ada_Init_Name.all & " 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;");
WBI (" Set_Globals");
Set_String (" (Main_Priority => ");
- Set_Int (ALIs.Table (ALIs.First).Main_Priority);
+ Set_Int (Main_Priority);
Set_Char (',');
Write_Statement_Buffer;
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;
--------------------
procedure Gen_Adainit_C is
+ Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
begin
WBI ("void " & Ada_Init_Name.all & " ()");
WBI ("{");
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;
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 */");
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 ("");
-- --
-- B o d y --
-- --
--- $Revision: 1.2 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- 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,
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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- --
with Alloc;
with Debug; use Debug;
+with Fmap;
with Krunch;
with Namet; use Namet;
with Opt; use Opt;
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.
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
-- Check if file exists and if so, return the entry
- elsif Find_File (Fnam, Source) /= No_File then
- return Fnam;
+ else
+ 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
- -- the first search loop, and the file does not exist.
+ if Pname /= No_File then
- else
- Fnam := No_File;
+ -- 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;
with Elists;
with Exp_Ch11;
with Exp_Dbug;
+with Fmap;
with Fname.UF;
with Hostparm; use Hostparm;
with Inline; use Inline;
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).
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;
----------------------
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.
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
-- 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;
-- 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);
-- 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;
and then not No_Main_Subprogram
then
if Osint.Number_Of_Files = 1 then
- return;
+ exit Multiple_Main_Loop;
else
goto Next_Main;
end if;
if Osint.Number_Of_Files = 1 then
- return;
+ exit Multiple_Main_Loop;
else
goto Next_Main;
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
#include "expr.h"
#include "ggc.h"
#include "flags.h"
+#include "insn-codes.h"
#include "insn-flags.h"
#include "insn-config.h"
#include "optabs.h"
-- 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
-- --
------------------------------------------------------------------------------
+with Fmap;
with Hostparm;
with Namet; use Namet;
with Opt; use Opt;
-- 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-
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 --
------------------------------------
-- --
-- S p e c --
-- --
--- $Revision: 1.10 $
+-- $Revision$
-- --
-- Copyright (C) 2001 Free Software Foundation, Inc. --
-- --
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);
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)
-- -- 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
-- --
-- S p e c --
-- --
--- $Revision: 1.12 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
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
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
-- 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
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;
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,
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 --
--------------------------
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
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,
-- --
-- B o d y --
-- --
--- $Revision: 1.2 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
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.
-
- elsif Unit_Kind = N_Package_Instantiation
+ -- 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
+ 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
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).
-- --
-- B o d y --
-- --
--- $Revision: 1.4 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- --
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
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;
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
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
case Switch_Chars (Ptr) is
+ -- Configuration pragmas
+
when 'c' =>
Ptr := Ptr + 1;
if Ptr > Max then
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)));
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);
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)
* *
* C Header File *
* *
- * $Revision: 1.1 $
+ * $Revision$
* *
* Copyright (C) 1992-2001 Free Software Foundation, Inc. *
* *
#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));
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");
projects / thirdparty / gcc.git / commitdiff
