diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 114 | ||||
| -rw-r--r-- | gcc/ada/Makefile.in | 30 | ||||
| -rw-r--r-- | gcc/ada/a-except.adb | 160 | ||||
| -rw-r--r-- | gcc/ada/bindgen.adb | 61 | ||||
| -rw-r--r-- | gcc/ada/cstand.adb | 35 | ||||
| -rw-r--r-- | gcc/ada/fmap.adb | 332 | ||||
| -rw-r--r-- | gcc/ada/fmap.ads | 55 | ||||
| -rw-r--r-- | gcc/ada/fname-uf.adb | 42 | ||||
| -rw-r--r-- | gcc/ada/frontend.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/layout.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 35 | ||||
| -rw-r--r-- | gcc/ada/misc.c | 1 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/osint.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/prj-env.adb | 89 | ||||
| -rw-r--r-- | gcc/ada/prj-env.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/prj-tree.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/rident.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_warn.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/switch.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/trans.c | 13 | ||||
| -rw-r--r-- | gcc/ada/urealp.h | 7 | ||||
| -rw-r--r-- | gcc/ada/usage.adb | 5 |
27 files changed, 992 insertions, 161 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 78e8980..abffb95 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,117 @@ +2001-12-17 Ed Schonberg <schonber@gnat.com> + + * sem_res.adb (Resolve_Selected_Component): do not generate a + discriminant check if the selected component is a component of + the argument of an initialization procedure. + + * trans.c (tree_transform, case of arithmetic operators): If result + type is private, the gnu_type is the base type of the full view, + given that the full view itself may be a subtype. + +2001-12-17 Robert Dewar <dewar@gnat.com> + + * sem_res.adb: Minor reformatting + + * trans.c (tree_transform, case N_Real_Literal): Add missing third + parameter in call to Machine (unknown horrible effects from this + omission). + + * urealp.h: Add definition of Round_Even for call to Machine + Add third parameter for Machine + +2001-12-17 Ed Schonberg <schonber@gnat.com> + + * sem_warn.adb (Check_One_Unit): Suppress warnings completely on + predefined units in No_Run_Time mode. + +2001-12-17 Richard Kenner <kenner@gnat.com> + + * misc.c (insn-codes.h): Now include. + +2001-12-17 Olivier Hainque <hainque@gnat.com> + + * a-except.adb: Preparation work for future integration of the GCC 3 + exception handling mechanism + (Notify_Handled_Exception, Notify_Unhandled_Exception): New routines + to factorize previous code sequences and make them externally callable, + e.g. for the Ada personality routine when the GCC 3 mechanism is used. + (Propagate_Exception, Raise_Current_Excep, Raise_From_Signal_Handler): + Use the new notification routines. + +2001-12-17 Emmanuel Briot <briot@gnat.com> + + * prj-tree.ads (First_Choice_Of): Document the when others case + +2001-12-17 Arnaud Charlet <charlet@gnat.com> + + * bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in + HI-E mode, in order to support Ravenscar profile properly. + + * cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E + mode on 32 bits targets. + +2001-12-17 Vincent Celier <celier@gnat.com> + + * fmap.adb: Initial version. + + * fmap.ads: Initial version. + + * fname-uf.adb (Get_File_Name): Use mapping if unit name mapped. + If search is successfully done, add to mapping. + + * frontend.adb: Initialize the mapping if a -gnatem switch was used. + + * make.adb: + (Gnatmake): Add new local variable Mapping_File_Name. + Create mapping file when using project file(s). + Delete mapping file before exiting. + + * opt.ads (Mapping_File_Name): New variable + + * osint.adb (Find_File): Use path name found in mapping, if any. + + * prj-env.adb (Create_Mapping_File): New procedure + + * prj-env.ads (Create_Mapping_File): New procedure. + + * switch.adb (Scan_Front_End_Switches): Add processing for -gnatem + (Mapping_File) + + * usage.adb: Add entry for new switch -gnatem. + + * Makefile.in: Add dependencies for fmap.o. + +2001-12-17 Ed Schonberg <schonber@gnat.com> + + * sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit + is a package instantiation rewritten as a package body. + (Install_Withed_Unit): Undo previous change, now redundant. + +2001-12-17 Gary Dismukes <dismukes@gnat.com> + + * layout.adb: + (Compute_Length): Move conversion to Unsigned to callers. + (Get_Max_Size): Convert Len expression to Unsigned after calls to + Compute_Length and Determine_Range. + (Layout_Array_Type): Convert Len expression to Unsigned after calls to + Compute_Length and Determine_Range. + Above changes fix problem with length computation for supernull arrays + where Max (Len, 0) wasn't getting applied due to the Unsigned + conversion used by Compute_Length. + +2001-12-17 Arnaud Charlet <charlet@gnat.com> + + * rtsfind.ads: + (OK_To_Use_In_No_Run_Time_Mode): Allow Ada.Exceptions and + System.Secondary_Stack. + (OK_To_Use_In_Ravenscar_Mode): New table needed to implement Ravenscar + in HI-E mode. + Remove unused entity RE_Exception_Data. + + * rtsfind.adb (RTE): Allow Ravenscar Profile in HI mode. + + * rident.ads (No_Secondary_Stack): New restriction. + 2001-12-17 Joel Brobecker <brobecke@gnat.com> * gnat_rm.texi: Fix minor typos. Found while reading the section diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 66b7b5f..0bd940b 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -296,7 +296,7 @@ GNAT_ADA_OBJS = \ exp_code.o exp_dbug.o exp_disp.o exp_dist.o exp_fixd.o exp_aggr.o exp_imgv.o \ exp_intr.o exp_pakd.o exp_prag.o exp_smem.o \ exp_strm.o exp_tss.o exp_util.o exp_vfpt.o expander.o fname.o fname-uf.o \ - freeze.o frontend.o gnat.o g-hesora.o g-htable.o g-os_lib.o \ + fmap.o freeze.o frontend.o gnat.o g-hesora.o g-htable.o g-os_lib.o \ g-speche.o s-crc32.o get_targ.o gnatvsn.o \ hlo.o hostparm.o impunit.o \ interfac.o itypes.o inline.o krunch.o lib.o \ @@ -326,7 +326,7 @@ GNATBIND_OBJS = \ alloc.o bcheck.o binde.o \ binderr.o bindgen.o bindusg.o \ butil.o casing.o csets.o \ - debug.o fname.o gnat.o g-hesora.o g-htable.o \ + debug.o fmap.o fname.o gnat.o g-hesora.o g-htable.o \ g-os_lib.o gnatbind.o gnatvsn.o hostparm.o \ krunch.o namet.o opt.o osint.o output.o rident.o s-crc32.o s-assert.o \ s-parame.o s-sopco3.o s-sopco4.o s-sopco5.o s-stache.o s-stalib.o \ @@ -364,7 +364,7 @@ GNATCMD_RTL_OBJS = adaint.o argv.o raise.o exit.o final.o init.o \ s-stache.o s-sopco3.o s-sopco4.o s-sopco5.o \ s-strops.o s-soflin.o s-wchcon.o s-wchcnv.o s-wchjis.o s-unstyp.o -GNATCMD_OBJS = alloc.o debug.o fname.o gnatcmd.o gnatvsn.o hostparm.o \ +GNATCMD_OBJS = alloc.o debug.o fmap.o fname.o gnatcmd.o gnatvsn.o hostparm.o \ krunch.o namet.o opt.o osint.o casing.o csets.o widechar.o \ output.o sdefault.o switch.o stylesw.o validsw.o table.o tree_io.o types.o \ $(GNATCMD_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) @@ -394,7 +394,7 @@ GNATLINK_RTL_OBJS = \ s-memory.o s-traceb.o s-wchcnv.o s-wchcon.o s-wchjis.o GNATLINK_OBJS = gnatlink.o link.o \ - alloc.o debug.o gnatvsn.o hostparm.o namet.o \ + alloc.o debug.o fmap.o gnatvsn.o hostparm.o namet.o \ opt.o osint.o output.o sdefault.o stylesw.o validsw.o \ switch.o table.o tree_io.o types.o widechar.o \ $(GNATLINK_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) @@ -483,6 +483,7 @@ GNATLS_OBJS = \ einfo.o \ elists.o \ errout.o \ + fmap.o \ fname.o \ gnatls.o \ gnatvsn.o \ @@ -553,7 +554,7 @@ GNATMAKE_RTL_OBJS = adaint.o argv.o raise.o exit.o a-comlin.o \ GNATMAKE_OBJS = ali.o ali-util.o \ alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o einfo.o elists.o \ - errout.o fname.o fname-uf.o fname-sf.o \ + errout.o fmap.o fname.o fname-uf.o fname-sf.o \ gnatmake.o gnatvsn.o hostparm.o krunch.o lib.o make.o makeusg.o \ mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \ namet.o nlists.o opt.o osint.o output.o \ @@ -706,7 +707,7 @@ GNATXREF_RTL_OBJS = \ s-valuti.o s-valuns.o s-valint.o s-wchcon.o s-wchjis.o s-wchcnv.o GNATXREF_OBJS = gnatxref.o xr_tabls.o xref_lib.o \ - alloc.o debug.o gnatvsn.o hostparm.o types.o output.o \ + alloc.o debug.o fmap.o gnatvsn.o hostparm.o types.o output.o \ sdefault.o stylesw.o validsw.o tree_io.o opt.o table.o osint.o \ switch.o widechar.o namet.o \ $(GNATXREF_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) @@ -729,7 +730,7 @@ GNATFIND_RTL_OBJS = \ s-valuns.o s-valuti.o s-wchcnv.o s-wchcon.o s-wchjis.o GNATFIND_OBJS = gnatfind.o xr_tabls.o xref_lib.o \ - alloc.o debug.o gnatvsn.o hostparm.o namet.o opt.o \ + alloc.o debug.o fmap.o gnatvsn.o hostparm.o namet.o opt.o \ osint.o output.o sdefault.o stylesw.o validsw.o switch.o table.o \ tree_io.o types.o widechar.o \ $(GNATFIND_RTL_OBJS) $(EXTRA_GNATTOOLS_OBJS) @@ -3129,6 +3130,9 @@ fname.o : ada.ads a-except.ads alloc.ads debug.ads fname.ads fname.adb \ system.ads s-assert.ads s-exctab.ads s-stalib.ads s-wchcon.ads \ table.ads table.adb tree_io.ads types.ads unchconv.ads unchdeal.ads +fmap.o : alloc.ads debug.ads fmap.ads fmap.adb hostparm.ads namet.ads opt.ads \ + osint.ads output.ads table.ads table.adb tree_io.ads types.ads + fname-sf.o : alloc.ads casing.ads fname.ads fname-sf.ads fname-sf.adb \ fname-uf.ads gnat.ads g-os_lib.ads namet.ads osint.ads sfn_scan.ads \ system.ads s-exctab.ads s-stalib.ads s-stoele.ads table.ads types.ads \ @@ -3522,12 +3526,12 @@ opt.o : ada.ads a-except.ads gnat.ads g-os_lib.ads gnatvsn.ads \ hostparm.ads opt.ads opt.adb system.ads s-exctab.ads s-stalib.ads \ s-wchcon.ads tree_io.ads types.ads unchconv.ads unchdeal.ads -osint.o : ada.ads a-except.ads a-uncdea.ads alloc.ads debug.ads gnat.ads \ - g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads namet.ads opt.ads \ - osint.ads osint.adb output.ads sdefault.ads system.ads s-assert.ads \ - s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads s-stalib.ads \ - s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads types.ads \ - unchconv.ads unchdeal.ads +osint.o : ada.ads a-except.ads a-uncdea.ads alloc.ads debug.ads fmap.ads \ + gnat.ads g-htable.ads g-htable.adb g-os_lib.ads hostparm.ads namet.ads \ + opt.ads osint.ads osint.adb output.ads sdefault.ads system.ads \ + s-assert.ads s-exctab.ads s-secsta.ads s-soflin.ads s-stache.ads \ + s-stalib.ads s-stoele.ads s-wchcon.ads table.ads table.adb tree_io.ads \ + types.ads unchconv.ads unchdeal.ads output.o : gnat.ads g-os_lib.ads output.ads output.adb system.ads \ s-exctab.ads s-stalib.ads types.ads unchconv.ads unchdeal.ads diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index de21237..cc21e03 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -365,6 +365,34 @@ package body Ada.Exceptions is -- Basic_Exc_Tback Or Tback_Decorator -- if no decorator set otherwise + ---------------------------------------------- + -- Run-Time Exception Notification Routines -- + ---------------------------------------------- + + -- The notification routines described above are low level "handles" for + -- the debugger but what needs to be done at the notification points + -- always involves more than just calling one of these routines. The + -- routines below provide a common run-time interface for this purpose, + -- with variations depending on the handled/not handled status of the + -- occurrence. They are exported to be usable by the Ada exception + -- handling personality routine when the GCC 3 mechanism is used. + + procedure Notify_Handled_Exception + (Handler : Code_Loc; + Is_Others : Boolean; + Low_Notify : Boolean); + pragma Export (C, Notify_Handled_Exception, + "__gnat_notify_handled_exception"); + -- Routine to call when a handled occurrence is about to be propagated. + -- Low_Notify might be set to false to skip the low level debugger + -- notification, which is useful when the information it requires is + -- not available, like in the SJLJ case. + + procedure Notify_Unhandled_Exception (Id : Exception_Id); + pragma Export (C, Notify_Unhandled_Exception, + "__gnat_notify_unhandled_exception"); + -- Routine to call when an unhandled occurrence is about to be propagated. + -------------------------------- -- Import Run-Time C Routines -- -------------------------------- @@ -953,29 +981,10 @@ package body Ada.Exceptions is or else (Hrec.Id = Others_Id and not Excep.Id.Not_Handled_By_Others) then - -- Notify the debugger that we have found a handler - -- and are about to propagate an exception. - - 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. @@ -1002,15 +1011,10 @@ package body Ada.Exceptions is Pop_Frame (Mstate, Info); end loop Main_Loop; - -- Fall through if no "real" exception handler found. First thing - -- is to call the dummy Unhandled_Exception routine with the stack - -- intact, so that the debugger can get control. - - 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 @@ -1066,30 +1070,14 @@ package body Ada.Exceptions is 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); @@ -1112,8 +1100,7 @@ package body Ada.Exceptions is Call_Chain (Get_Current_Excep.all); end if; - Unhandled_Exception; - Notify_Exception (E, Null_Loc, False); + Notify_Unhandled_Exception (E); Unhandled_Exception_Terminate; end if; end Raise_Current_Excep; @@ -1179,9 +1166,10 @@ package body Ada.Exceptions is -- the signal handler that passed control here has already set the -- machine state directly. -- - -- ??? Updates related to the implementation of automatic backtraces - -- have not been done here. Some action will be required when dealing - -- the remaining problems in ZCX mode (incomplete backtraces so far). + -- We also do not compute the backtrace for the occurrence since going + -- through the signal handler is far from trivial and it is not a + -- problem to fail providing a backtrace in the "raised from signal + -- handler" case. -- If the jump buffer pointer is non-null, it means that a jump -- buffer was allocated (obviously that happens only in the case @@ -1204,7 +1192,7 @@ package body Ada.Exceptions is -- have no finalizations to do other than at the outer level. else - Unhandled_Exception; + Notify_Unhandled_Exception (E); Unhandled_Exception_Terminate; end if; end Raise_From_Signal_Handler; @@ -1833,6 +1821,58 @@ package body Ada.Exceptions is null; end Notify_Exception; + ------------------------------ + -- Notify_Handled_Exception -- + ------------------------------ + + procedure Notify_Handled_Exception + (Handler : Code_Loc; + Is_Others : Boolean; + Low_Notify : Boolean) + is + Excep : constant EOA := Get_Current_Excep.all; + + begin + -- Notify the debugger that we have found a handler and are about to + -- propagate an exception, but only if specifically told to do so. + + if Low_Notify then + Notify_Exception (Excep.Id, Handler, Is_Others); + end if; + + -- Output some exception information if necessary, as specified by + -- GNAT.Exception_Traces. Take care not to output information about + -- internal exceptions. + -- + -- ??? In the ZCX case, the traceback entries we have at this point + -- only include the ones we stored while walking up the stack *up to + -- the handler*. All the frames above the subprogram in which the + -- handler is found are missing. + + if Exception_Trace = Every_Raise + and then not Excep.Id.Not_Handled_By_Others + then + To_Stderr (Nline); + To_Stderr ("Exception raised"); + To_Stderr (Nline); + To_Stderr (Tailored_Exception_Information (Excep.all)); + end if; + + end Notify_Handled_Exception; + + ------------------------------ + -- Notify_Handled_Exception -- + ------------------------------ + + procedure Notify_Unhandled_Exception (Id : Exception_Id) is + begin + -- Simply perform the two necessary low level notification calls. + + Unhandled_Exception; + Notify_Exception (Id, Null_Loc, False); + + end Notify_Unhandled_Exception; + ----------------------------------- -- Unhandled_Exception_Terminate -- ----------------------------------- diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index a45e792..b1f19af 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -286,6 +286,7 @@ package body Bindgen is --------------------- procedure Gen_Adainit_Ada is + Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; begin WBI (" procedure " & Ada_Init_Name.all & " is"); @@ -347,7 +348,32 @@ package body Bindgen is -- the routine call, rather than define the globals in the binder -- file to deal with cross-library calls in some systems. - if not No_Run_Time_Specified then + if No_Run_Time_Specified then + -- Case of pragma No_Run_Time present. The only global variable + -- that might be needed (by the Ravenscar profile) is + -- the environment task's priority. Also no exception tables are + -- needed. + + if Main_Priority /= No_Main_Priority then + WBI (" Main_Priority : Integer;"); + WBI (" pragma Import (C, Main_Priority," & + " ""__gl_main_priority"");"); + WBI (""); + end if; + + WBI (" begin"); + + if Main_Priority /= No_Main_Priority then + Set_String (" Main_Priority := "); + Set_Int (Main_Priority); + Set_Char (';'); + Write_Statement_Buffer; + + else + WBI (" null;"); + end if; + + else WBI (""); WBI (" procedure Set_Globals"); WBI (" (Main_Priority : Integer;"); @@ -383,7 +409,7 @@ package body Bindgen is WBI (" Set_Globals"); Set_String (" (Main_Priority => "); - Set_Int (ALIs.Table (ALIs.First).Main_Priority); + Set_Int (Main_Priority); Set_Char (','); Write_Statement_Buffer; @@ -449,14 +475,6 @@ package body Bindgen is WBI (" if Handler_Installed = 0 then"); WBI (" Install_Handler;"); WBI (" end if;"); - - -- Case of pragma No_Run_Time present. Globals are not needed since - -- there are no runtime routines to make use of them, and no routine - -- to store them in any case! Also no exception tables are needed. - - else - WBI (" begin"); - WBI (" null;"); end if; Gen_Elab_Calls_Ada; @@ -469,6 +487,7 @@ package body Bindgen is -------------------- procedure Gen_Adainit_C is + Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; begin WBI ("void " & Ada_Init_Name.all & " ()"); WBI ("{"); @@ -493,9 +512,19 @@ package body Bindgen is Write_Statement_Buffer; - -- Code for normal case (no pragma No_Run_Time in use) + if No_Run_Time_Specified then + -- Case where No_Run_Time pragma is present. + -- Set __gl_main_priority if needed for the Ravenscar profile. - if not No_Run_Time_Specified then + if Main_Priority /= No_Main_Priority then + Set_String (" extern int __gl_main_priority = "); + Set_Int (Main_Priority); + Set_Char (';'); + Write_Statement_Buffer; + end if; + + else + -- Code for normal case (no pragma No_Run_Time in use) Gen_Exception_Table_C; @@ -510,7 +539,7 @@ package body Bindgen is WBI (" __gnat_set_globals ("); Set_String (" "); - Set_Int (ALIs.Table (ALIs.First).Main_Priority); + Set_Int (Main_Priority); Set_Char (','); Tab_To (15); Set_String ("/* Main_Priority */"); @@ -584,12 +613,6 @@ package body Bindgen is WBI (" {"); WBI (" __gnat_install_handler ();"); WBI (" }"); - - -- Case where No_Run_Time pragma is present (no globals required) - -- Nothing more needs to be done in this case. - - else - null; end if; WBI (""); diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index fc29af09..1527ce1 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -1003,14 +1003,27 @@ package body CStand is -- Create type declaration for Duration, using a 64-bit size. -- Delta is 1 nanosecond. + -- Except on 32 bits machine in No_Run_Time mode, in which case Duration + -- is a 32 bits value whose delta is 10E-4 seconds. Build_Duration : declare - Dlo : constant Uint := Intval (Type_Low_Bound (Standard_Integer_64)); - Dhi : constant Uint := Intval (Type_High_Bound (Standard_Integer_64)); - - Delta_Val : constant Ureal := UR_From_Components (Uint_1, Uint_9, 10); + Dlo : Uint; + Dhi : Uint; + Delta_Val : Ureal; + Use_32_Bits : constant Boolean := + No_Run_Time and then System_Word_Size = 32; begin + if Use_32_Bits then + Dlo := Intval (Type_Low_Bound (Standard_Integer_32)); + Dhi := Intval (Type_High_Bound (Standard_Integer_32)); + Delta_Val := UR_From_Components (Uint_1, Uint_4, 10); + else + Dlo := Intval (Type_Low_Bound (Standard_Integer_64)); + Dhi := Intval (Type_High_Bound (Standard_Integer_64)); + Delta_Val := UR_From_Components (Uint_1, Uint_9, 10); + end if; + Decl := Make_Full_Type_Declaration (Stloc, Defining_Identifier => Standard_Duration, @@ -1024,9 +1037,15 @@ package body CStand is High_Bound => Make_Real_Literal (Stloc, Realval => Dhi * Delta_Val)))); - Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type); - Set_Etype (Standard_Duration, Standard_Duration); - Init_Size (Standard_Duration, 64); + Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type); + Set_Etype (Standard_Duration, Standard_Duration); + + if Use_32_Bits then + Init_Size (Standard_Duration, 32); + else + Init_Size (Standard_Duration, 64); + end if; + Set_Prim_Alignment (Standard_Duration); Set_Delta_Value (Standard_Duration, Delta_Val); Set_Small_Value (Standard_Duration, Delta_Val); diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb new file mode 100644 index 0000000..89b3fd8 --- /dev/null +++ b/gcc/ada/fmap.adb @@ -0,0 +1,332 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F M A P -- +-- -- +-- B o d y -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.HTable; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with Table; + +with Unchecked_Conversion; + +package body Fmap is + + subtype Big_String is String (Positive); + type Big_String_Ptr is access all Big_String; + + function To_Big_String_Ptr is new Unchecked_Conversion + (Source_Buffer_Ptr, Big_String_Ptr); + + package File_Mapping is new Table.Table ( + Table_Component_Type => File_Name_Type, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 1_000, + Table_Increment => 1_000, + Table_Name => "Fmap.File_Mapping"); + -- Mapping table to map unit names to file names. + + package Path_Mapping is new Table.Table ( + Table_Component_Type => File_Name_Type, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 1_000, + Table_Increment => 1_000, + Table_Name => "Fmap.Path_Mapping"); + -- Mapping table to map file names to path names + + type Header_Num is range 0 .. 1_000; + + function Hash (F : Unit_Name_Type) return Header_Num; + + No_Entry : constant Int := -1; + -- Signals no entry in following table + + package Unit_Hash_Table is new GNAT.HTable.Simple_HTable ( + Header_Num => Header_Num, + Element => Int, + No_Element => No_Entry, + Key => Unit_Name_Type, + Hash => Hash, + Equal => "="); + -- Hash table to map unit names to file names. Used in conjunction with + -- table File_Mapping above. + + package File_Hash_Table is new GNAT.HTable.Simple_HTable ( + Header_Num => Header_Num, + Element => Int, + No_Element => No_Entry, + Key => File_Name_Type, + Hash => Hash, + Equal => "="); + -- Hash table to map file names to path names. Used in conjunction with + -- table Path_Mapping above. + + --------- + -- Add -- + --------- + + procedure Add + (Unit_Name : Unit_Name_Type; + File_Name : File_Name_Type; + Path_Name : File_Name_Type) is + begin + File_Mapping.Increment_Last; + Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last); + File_Mapping.Table (File_Mapping.Last) := File_Name; + Path_Mapping.Increment_Last; + File_Hash_Table.Set (File_Name, Path_Mapping.Last); + Path_Mapping.Table (Path_Mapping.Last) := Path_Name; + end Add; + + ------------------ + -- File_Name_Of -- + ------------------ + + function File_Name_Of (Unit : Unit_Name_Type) return File_Name_Type is + The_Index : constant Int := Unit_Hash_Table.Get (Unit); + begin + if The_Index = No_Entry then + return No_File; + + else + return File_Mapping.Table (The_Index); + end if; + + end File_Name_Of; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Unit_Name_Type) return Header_Num is + begin + return Header_Num (Int (F) rem Header_Num'Range_Length); + end Hash; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (File_Name : String) is + Src : Source_Buffer_Ptr; + Hi : Source_Ptr; + BS : Big_String_Ptr; + SP : String_Ptr; + + Deb : Positive := 1; + Fin : Natural := 0; + + Uname : Unit_Name_Type; + Fname : Name_Id; + Pname : Name_Id; + + procedure Empty_Tables; + -- Remove all entries in case of incorrect mapping file + + procedure Get_Line; + -- Get a line from the mapping file + + procedure Report_Truncated; + -- Report a warning when the mapping file is truncated + -- (number of lines is not a multiple of 3). + + ------------------ + -- Empty_Tables -- + ------------------ + + procedure Empty_Tables is + begin + Unit_Hash_Table.Reset; + File_Hash_Table.Reset; + Path_Mapping.Set_Last (0); + File_Mapping.Set_Last (0); + end Empty_Tables; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line is + use ASCII; + begin + Deb := Fin + 1; + + -- If not at the end of file, skip the end of line + while Deb < SP'Last + and then (SP (Deb) = CR + or else SP (Deb) = LF + or else SP (Deb) = EOF) + loop + Deb := Deb + 1; + end loop; + + -- If not at the end of line, find the end of this new line + + if Deb < SP'Last and then SP (Deb) /= EOF then + Fin := Deb; + + while Fin < SP'Last + and then SP (Fin + 1) /= CR + and then SP (Fin + 1) /= LF + and then SP (Fin + 1) /= EOF + loop + Fin := Fin + 1; + end loop; + + end if; + end Get_Line; + + ---------------------- + -- Report_Truncated -- + ---------------------- + + procedure Report_Truncated is + begin + Write_Str ("warning: mapping file """); + Write_Str (File_Name); + Write_Line (""" is truncated"); + end Report_Truncated; + + -- start of procedure Initialize + + begin + Name_Len := File_Name'Length; + Name_Buffer (1 .. Name_Len) := File_Name; + Read_Source_File (Name_Enter, 0, Hi, Src, Config); + + if Src = null then + Write_Str ("warning: could not read mapping file """); + Write_Str (File_Name); + Write_Line (""""); + + else + BS := To_Big_String_Ptr (Src); + SP := BS (1 .. Natural (Hi))'Unrestricted_Access; + + loop + + -- Get the unit name + + Get_Line; + + -- Exit if end of file has been reached + + exit when Deb > Fin; + + pragma Assert (Fin >= Deb + 2); + pragma Assert (SP (Fin - 1) = '%'); + pragma Assert (SP (Fin) = 's' or else SP (Fin) = 'b'); + + Name_Len := Fin - Deb + 1; + Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin); + Uname := Name_Find; + + -- Get the file name + + Get_Line; + + -- If end of line has been reached, file is truncated + + if Deb > Fin then + Report_Truncated; + Empty_Tables; + return; + end if; + + Name_Len := Fin - Deb + 1; + Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin); + Fname := Name_Find; + + -- Get the path name + + Get_Line; + + -- If end of line has been reached, file is truncated + + if Deb > Fin then + Report_Truncated; + Empty_Tables; + return; + end if; + + Name_Len := Fin - Deb + 1; + Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin); + Pname := Name_Find; + + -- Check for duplicate entries + + if Unit_Hash_Table.Get (Uname) /= No_Entry then + Write_Str ("warning: duplicate entry """); + Write_Str (Get_Name_String (Uname)); + Write_Str (""" in mapping file """); + Write_Str (File_Name); + Write_Line (""""); + Empty_Tables; + return; + end if; + + if File_Hash_Table.Get (Fname) /= No_Entry then + Write_Str ("warning: duplicate entry """); + Write_Str (Get_Name_String (Fname)); + Write_Str (""" in mapping file """); + Write_Str (File_Name); + Write_Line (""""); + Empty_Tables; + return; + end if; + + -- Add the mappings for this unit name + + Add (Uname, Fname, Pname); + + end loop; + + end if; + + end Initialize; + + ------------------ + -- Path_Name_Of -- + ------------------ + + function Path_Name_Of (File : File_Name_Type) return File_Name_Type is + Index : Int := No_Entry; + begin + Index := File_Hash_Table.Get (File); + + if Index = No_Entry then + return No_File; + + else + return Path_Mapping.Table (Index); + end if; + + end Path_Name_Of; + +end Fmap; diff --git a/gcc/ada/fmap.ads b/gcc/ada/fmap.ads new file mode 100644 index 0000000..ac9c0e5 --- /dev/null +++ b/gcc/ada/fmap.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F M A P -- +-- -- +-- S p e c -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package keeps two mappings: from unit names to file names, +-- and from file names to path names. + +with Types; use Types; + +package Fmap is + + procedure Initialize (File_Name : String); + -- Initialize the mappings from the mapping file File_Name. + -- If the mapping file is incorrect (non existent file, truncated file, + -- duplicate entries), output a warning and do not initialize the mappings. + + function Path_Name_Of (File : File_Name_Type) return File_Name_Type; + -- Return the path name mapped to the file name File. + -- Return No_File if File is not mapped. + + function File_Name_Of (Unit : Unit_Name_Type) return File_Name_Type; + -- Return the file name mapped to the unit name Unit. + -- Return No_File if Unit is not mapped. + + procedure Add + (Unit_Name : Unit_Name_Type; + File_Name : File_Name_Type; + Path_Name : File_Name_Type); + -- Add mapping of Unit_Name to File_Name and of File_Name to Path_Name + +end Fmap; diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index 37fe82c..3572d1a 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.1 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -28,6 +28,7 @@ with Alloc; with Debug; use Debug; +with Fmap; with Krunch; with Namet; use Namet; with Opt; use Opt; @@ -137,6 +138,9 @@ package body Fname.UF is N : Int; + Pname : File_Name_Type := No_File; + Fname : File_Name_Type := No_File; + begin -- Null or error name means that some previous error occurred -- This is an unrecoverable error, so signal it. @@ -145,6 +149,19 @@ package body Fname.UF is raise Unrecoverable_Error; end if; + -- Look into the mapping from unit names to file names + + Fname := Fmap.File_Name_Of (Uname); + + -- If the unit name is already mapped, return the corresponding + -- file name. + + if Fname /= No_File then + return Fname; + end if; + + -- If there is a specific SFN pragma, return the corresponding file name + N := SFN_HTable.Get (Uname); if N /= No_Entry then @@ -367,14 +384,25 @@ package body Fname.UF is -- Check if file exists and if so, return the entry - elsif Find_File (Fnam, Source) /= No_File then - return Fnam; + 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; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index bbfdaee..a42626a0 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -33,6 +33,7 @@ with Debug; use Debug; with Elists; with Exp_Ch11; with Exp_Dbug; +with Fmap; with Fname.UF; with Hostparm; use Hostparm; with Inline; use Inline; @@ -184,6 +185,13 @@ begin end if; + -- If there was a -gnatem switch, initialize the mappings of unit names to + -- file names and of file names to path names from the mapping file. + + if Mapping_File_Name /= null then + Fmap.Initialize (Mapping_File_Name.all); + end if; + -- We have now processed the command line switches, and the gnat.adc -- file, so this is the point at which we want to capture the values -- of the configuration switches (see Opt for further details). diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 311a6e4..2cf97cb 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -524,13 +524,12 @@ package body Layout is end if; return - Convert_To (Standard_Unsigned, - Assoc_Add (Loc, - Left_Opnd => - Assoc_Subtract (Loc, - Left_Opnd => Hi_Op, - Right_Opnd => Lo_Op), - Right_Opnd => Make_Integer_Literal (Loc, 1))); + Assoc_Add (Loc, + Left_Opnd => + Assoc_Subtract (Loc, + Left_Opnd => Hi_Op, + Right_Opnd => Lo_Op), + Right_Opnd => Make_Integer_Literal (Loc, 1)); end Compute_Length; ---------------------- @@ -749,6 +748,8 @@ package body Layout is Set_Parent (Len, E); Determine_Range (Len, OK, LLo, LHi); + Len := Convert_To (Standard_Unsigned, Len); + -- If we cannot verify that range cannot be super-flat, -- we need a max with zero, since length must be non-neg. @@ -1059,6 +1060,8 @@ package body Layout is Set_Parent (Len, E); Determine_Range (Len, OK, LLo, LHi); + Len := Convert_To (Standard_Unsigned, Len); + -- If range definitely flat or superflat, result size is zero if OK and then LHi <= 0 then diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index a18c81e..7e0fd58 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -2508,6 +2508,10 @@ package body Make is -- be rebuild (if we rebuild mains), even in the case when it is not -- really necessary, because it is too hard to decide. + Mapping_File_Name : Temp_File_Name; + -- The name of the temporary mapping file that is copmmunicated + -- to the compiler through a -gnatem switch, when using project files. + begin Do_Compile_Step := True; Do_Bind_Step := True; @@ -2854,7 +2858,7 @@ package body Make is -- in procedure Compile_Sources. The_Saved_Gcc_Switches := - new Argument_List (1 .. Saved_Gcc_Switches.Last + 1); + new Argument_List (1 .. Saved_Gcc_Switches.Last + 2); for J in 1 .. Saved_Gcc_Switches.Last loop The_Saved_Gcc_Switches (J) := Saved_Gcc_Switches.Table (J); @@ -2863,9 +2867,19 @@ package body Make is -- We never use gnat.adc when a project file is used - The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last) := + The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last - 1) := No_gnat_adc; + -- Create a temporary mapping file and add the switch -gnatem + -- with its name to the compiler. + + Prj.Env.Create_Mapping_File (Name => Mapping_File_Name); + The_Saved_Gcc_Switches (The_Saved_Gcc_Switches'Last) := + new String'("-gnatem" & Mapping_File_Name); + + -- Check if there are any relative search paths in the switches. + -- Fail if there is one. + for J in 1 .. Gcc_Switches.Last loop Test_If_Relative_Path (Gcc_Switches.Table (J)); end loop; @@ -3184,7 +3198,7 @@ package body Make is and then not No_Main_Subprogram then if Osint.Number_Of_Files = 1 then - return; + exit Multiple_Main_Loop; else goto Next_Main; @@ -3231,7 +3245,7 @@ package body Make is end if; if Osint.Number_Of_Files = 1 then - return; + exit Multiple_Main_Loop; else goto Next_Main; @@ -3477,6 +3491,19 @@ package body Make is end if; end loop Multiple_Main_Loop; + -- Delete the temporary mapping file that was created if we are + -- using project files. + + if Main_Project /= No_Project then + declare + Success : Boolean; + + begin + Delete_File (Name => Mapping_File_Name, Success => Success); + end; + + end if; + Exit_Program (E_Success); exception diff --git a/gcc/ada/misc.c b/gcc/ada/misc.c index 9a01430..d422f60 100644 --- a/gcc/ada/misc.c +++ b/gcc/ada/misc.c @@ -45,6 +45,7 @@ #include "expr.h" #include "ggc.h" #include "flags.h" +#include "insn-codes.h" #include "insn-flags.h" #include "insn-config.h" #include "optabs.h" diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 9ed3579..5dcc8c7 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -470,6 +470,11 @@ package Opt is -- When True we are allowed to look in the primary directory to locate -- other source or library files. + Mapping_File_Name : String_Ptr := null; + -- GNAT + -- File name of mapping between unit names, file names and path names. + -- (given by switch -gnatem) + Maximum_Errors : Int := 9999; -- GNAT, GNATBIND -- Maximum number of errors before compilation is terminated diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index ba527b4..1856f16 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -26,6 +26,7 @@ -- -- ------------------------------------------------------------------------------ +with Fmap; with Hostparm; with Namet; use Namet; with Opt; use Opt; @@ -1001,6 +1002,18 @@ package body Osint is -- Otherwise do standard search for source file else + + -- Check the mapping of this file name + + File := Fmap.Path_Name_Of (N); + + -- If the file name is mapped to a path name, return the + -- corresponding path name + + if File /= No_File then + return File; + end if; + -- First place to look is in the primary directory (i.e. the same -- directory as the source) unless this has been disabled with -I- diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 65f282b..e52165d 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -788,6 +788,95 @@ package body Prj.Env is end Create_Config_Pragmas_File; + ------------------------- + -- Create_Mapping_File -- + ------------------------- + + procedure Create_Mapping_File (Name : in out Temp_File_Name) is + File : File_Descriptor := Invalid_FD; + The_Unit_Data : Unit_Data; + Data : File_Name_Data; + + procedure Put (S : String); + -- Put a line in the mapping file + + procedure Put_Data (Spec : Boolean); + -- Put the mapping of the spec or body contained in Data in the file + -- (3 lines). + + procedure Put (S : String) is + Last : Natural; + + begin + Last := Write (File, S'Address, S'Length); + + if Last /= S'Length then + Osint.Fail ("Disk full"); + end if; + + end Put; + + procedure Put_Data (Spec : Boolean) is + begin + Put (Get_Name_String (The_Unit_Data.Name)); + + if Spec then + Put ("%s"); + else + Put ("%b"); + end if; + + Put (S => (1 => ASCII.LF)); + Put (Get_Name_String (Data.Name)); + Put (S => (1 => ASCII.LF)); + Put (Get_Name_String (Data.Path)); + Put (S => (1 => ASCII.LF)); + end Put_Data; + + begin + GNAT.OS_Lib.Create_Temp_File (File, Name => Name); + + if File = Invalid_FD then + Osint.Fail + ("unable to create temporary mapping file"); + + elsif Opt.Verbose_Mode then + Write_Str ("Creating temp mapping file """); + Write_Str (Name); + Write_Line (""""); + end if; + + -- For all units in table Units + + for Unit in 1 .. Units.Last loop + The_Unit_Data := Units.Table (Unit); + + -- If the unit has a valid name + + if The_Unit_Data.Name /= No_Name then + Data := The_Unit_Data.File_Names (Specification); + + -- If there is a spec, put it mapping in the file + + if Data.Name /= No_Name then + Put_Data (Spec => True); + end if; + + Data := The_Unit_Data.File_Names (Body_Part); + + -- If there is a body (or subunit) put its mapping in the file + + if Data.Name /= No_Name then + Put_Data (Spec => False); + end if; + + end if; + end loop; + + GNAT.OS_Lib.Close (File); + + end Create_Mapping_File; + ------------------------------------ -- File_Name_Of_Library_Unit_Body -- ------------------------------------ diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index 272c559..f418dc3 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.10 $ +-- $Revision$ -- -- -- Copyright (C) 2001 Free Software Foundation, Inc. -- -- -- @@ -39,6 +39,11 @@ package Prj.Env is procedure Print_Sources; -- Output the list of sources, after Project files have been scanned + procedure Create_Mapping_File (Name : in out Temp_File_Name); + -- Create a temporary mapping file. + -- For each unit, put the mapping of its spec and or body to its + -- file name and path name in this file. + procedure Create_Config_Pragmas_File (For_Project : Project_Id; Main_Project : Project_Id); diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index 6cc7c6b..c5526b8 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -299,7 +299,8 @@ package Prj.Tree is function First_Choice_Of (Node : Project_Node_Id) return Project_Node_Id; - -- Only valid for N_Case_Item nodes + -- Return the first choice in a N_Case_Item, or Empty_Node if + -- this is when others. function Next_Case_Item (Node : Project_Node_Id) @@ -708,7 +709,8 @@ package Prj.Tree is -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: not used - -- -- Field1: first choice (literal string) + -- -- Field1: first choice (literal string), or Empty_Node + -- -- for when others -- -- Field2: first declarative item -- -- Field3: next case item -- -- Value: not used diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads index 3eb6540..2a9f875 100644 --- a/gcc/ada/rident.ads +++ b/gcc/ada/rident.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- $Revision: 1.12 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -73,6 +73,7 @@ package Rident is No_Reentrancy, -- (RM H.4(23)) No_Relative_Delay, -- GNAT No_Requeue, -- GNAT + No_Secondary_Stack, -- GNAT No_Select_Statements, -- GNAT (Ravenscar) No_Standard_Storage_Pools, -- GNAT No_Streams, -- GNAT diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 08b6e5e..2723e4f 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -582,6 +582,8 @@ package body Rtsfind is Pkg_Ent : Entity_Id; Ename : Name_Id; + Ravenscar : constant Boolean := Restricted_Profile; + procedure Check_RPC; -- Reject programs that make use of distribution features not supported -- on the current target. On such targets (VMS, Vxworks, others?) we @@ -712,13 +714,17 @@ package body Rtsfind is -- Start of processing for RTE begin - -- Check violation of no run time mode + -- Check violation of no run time and ravenscar mode if No_Run_Time and then not OK_To_Use_In_No_Run_Time_Mode (U_Id) then - Disallow_In_No_Run_Time_Mode (Current_Error_Node); - return Empty; + if not Ravenscar + or else not OK_To_Use_In_Ravenscar_Mode (U_Id) + then + Disallow_In_No_Run_Time_Mode (Current_Error_Node); + return Empty; + end if; end if; -- Doing a rtsfind in system.ads is special, as we cannot do this @@ -843,6 +849,7 @@ package body Rtsfind is and then not Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Current_Error_Node))) + and then not Ravenscar then Disallow_In_No_Run_Time_Mode (Current_Error_Node); end if; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 6b30cf1..fe6c31b 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -378,6 +378,7 @@ package Rtsfind is OK_To_Use_In_No_Run_Time_Mode : array (RTU_Id) of Boolean := (Ada_Tags => True, + Ada_Exceptions => True, Interfaces => True, System => True, System_Fat_Flt => True, @@ -387,12 +388,28 @@ package Rtsfind is System_Machine_Code => True, System_Storage_Elements => True, System_Unsigned_Types => True, + System_Secondary_Stack => True, others => False); -- This array defines the set of packages that can legitimately be -- accessed by Rtsfind in No_Run_Time mode. Any attempt to load -- any other package in this mode will result in a message noting -- use of a feature not supported in high integrity mode. + OK_To_Use_In_Ravenscar_Mode : array (RTU_Id) of Boolean := + (System_Interrupts => True, + System_Tasking => True, + System_Tasking_Protected_Objects => True, + System_Tasking_Restricted_Stages => True, + System_Tasking_Protected_Objects_Single_Entry => True, + System_Task_Info => True, + System_Parameters => True, + Ada_Real_Time => True, + Ada_Real_Time_Delays => True, + others => False); + -- This array defines the set of packages that can legitimately be + -- accessed by Rtsfind in Ravenscar mode, in addition to the + -- No_Run_Time units which are also allowed. + -------------------------- -- Runtime Entity Table -- -------------------------- @@ -1032,7 +1049,6 @@ package Rtsfind is RE_Shared_Var_WOpen, -- System.Shared_Storage RE_Abort_Undefer_Direct, -- System.Standard_Library - RE_Exception_Data, -- System.Standard_Library RE_Exception_Data_Ptr, -- System.Standard_Library RE_Integer_Address, -- System.Storage_Elements @@ -1953,7 +1969,6 @@ package Rtsfind is RE_Shared_Var_WOpen => System_Shared_Storage, RE_Abort_Undefer_Direct => System_Standard_Library, - RE_Exception_Data => System_Standard_Library, RE_Exception_Data_Ptr => System_Standard_Library, RE_Integer_Address => System_Storage_Elements, diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 1ef523c..a85d8a1 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.2 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- -- -- @@ -1486,15 +1486,16 @@ package body Sem_Ch10 is E_Name := Defining_Entity (U); -- Note: in the following test, Unit_Kind is the original Nkind, but - -- in the case of an instantiation, the call to Semantics above will - -- have replaced the unit by its instantiated version. - - 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 @@ -2712,17 +2713,6 @@ package body Sem_Ch10 is P : constant Entity_Id := Scope (Uname); begin - -- If the unit is a package instantiation, its body may have been - -- generated for an inner instance, and the instance now denotes the - -- body entity. For visibility purposes we need the instance in the - -- specification. - - if Ekind (Uname) = E_Package_Body - and then Is_Generic_Instance (Uname) - then - Uname := Spec_Entity (Uname); - end if; - -- We do not apply the restrictions to an internal unit unless -- we are compiling the internal unit as a main unit. This check -- is also skipped for dummy units (for missing packages). diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e48319f..09b5585 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.4 $ +-- $Revision$ -- -- -- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- -- -- @@ -5033,6 +5033,25 @@ package body Sem_Res is It1 : Interp; Found : Boolean; + function Init_Component return Boolean; + -- Check whether this is the initialization of a component within an + -- init_proc (by assignment or call to another init_proc). If true, + -- there is no need for a discriminant check. + + -------------------- + -- Init_Component -- + -------------------- + + function Init_Component return Boolean is + begin + return Inside_Init_Proc + and then Nkind (Prefix (N)) = N_Identifier + and then Chars (Prefix (N)) = Name_uInit + and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative; + end Init_Component; + + -- Start of processing for Resolve_Selected_Component + begin if Is_Overloaded (P) then @@ -5128,6 +5147,7 @@ package body Sem_Res is and then Present (Discriminant_Checking_Func (Original_Record_Component (Entity (S)))) and then not Discriminant_Checks_Suppressed (T) + and then not Init_Component then Set_Do_Discriminant_Check (N); end if; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index f6f5020..c6107e4 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -643,6 +643,15 @@ package body Sem_Warn is if not In_Extended_Main_Source_Unit (Cnode) then return; + + -- In No_Run_Time_Mode, we remove the bodies of non- + -- inlined subprograms, which may lead to spurious + -- warnings, clearly undesirable. + + elsif No_Run_Time + and then Is_Predefined_File_Name (Unit_File_Name (Unit)) + then + return; end if; -- Loop through context items in this unit @@ -674,15 +683,6 @@ package body Sem_Warn is if Unit = Spec_Unit then Set_Unreferenced_In_Spec (Item); - -- In No_Run_Time_Mode, we remove the bodies of non- - -- inlined subprograms, which may lead to spurious - -- warnings, clearly undesirable. - - elsif No_Run_Time - and then Is_Predefined_File_Name (Unit_File_Name (Unit)) - then - null; - -- Otherwise simple unreferenced message else diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb index 5749e0f..36ada8c 100644 --- a/gcc/ada/switch.adb +++ b/gcc/ada/switch.adb @@ -606,6 +606,8 @@ package body Switch is case Switch_Chars (Ptr) is + -- Configuration pragmas + when 'c' => Ptr := Ptr + 1; if Ptr > Max then @@ -617,6 +619,19 @@ package body Switch is return; + -- Mapping file + + when 'm' => + Ptr := Ptr + 1; + if Ptr > Max then + Osint.Fail ("Invalid switch: ", "em"); + end if; + + Mapping_File_Name := + new String'(Switch_Chars (Ptr .. Max)); + + return; + when others => Osint.Fail ("Invalid switch: ", (1 => 'e', 2 => Switch_Chars (Ptr))); diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index 1d6bf98..9864efa 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -585,9 +585,9 @@ tree_transform (gnat_node) else { if (! Is_Machine_Number (gnat_node)) - ur_realval = - Machine (Base_Type (Underlying_Type (Etype (gnat_node))), - ur_realval); + ur_realval + = Machine (Base_Type (Underlying_Type (Etype (gnat_node))), + ur_realval, Round_Even); gnu_result = UI_To_gnu (Numerator (ur_realval), gnu_result_type); @@ -1858,6 +1858,13 @@ tree_transform (gnat_node) gnu_rhs = maybe_unconstrained_array (gnu_rhs); } + /* If the result type is a private type, its full view may be a + numeric subtype. The representation we need is that of its base + type, given that it is the result of an arithmetic operation. */ + else if (Is_Private_Type (Etype (gnat_node))) + gnu_type = gnu_result_type + = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node)))); + /* If this is a shift whose count is not guaranteed to be correct, we need to adjust the shift count. */ if (IN (Nkind (gnat_node), N_Op_Shift) diff --git a/gcc/ada/urealp.h b/gcc/ada/urealp.h index 24afb55..3d0efad 100644 --- a/gcc/ada/urealp.h +++ b/gcc/ada/urealp.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * $Revision: 1.1 $ + * $Revision$ * * * Copyright (C) 1992-2001 Free Software Foundation, Inc. * * * @@ -46,5 +46,8 @@ extern Boolean UR_Is_Negative PARAMS ((Ureal)); #define UR_Is_Zero urealp__ur_is_zero extern Boolean UR_Is_Zero PARAMS ((Ureal)); +enum Rounding_Mode {Floor = 0, Ceiling = 1, Round = 2, Round_Even = 3}; + #define Machine eval_fat__machine -extern Ureal Machine PARAMS ((Entity_Id, Ureal)); +extern Ureal Machine PARAMS ((Entity_Id, Ureal, + enum Rounding_Mode)); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 7d64c14..4393df1 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -155,6 +155,11 @@ begin Write_Switch_Char ("ec?"); Write_Line ("Specify configuration pragmas file, e.g. -gnatec/x/f.adc"); + -- Line for -gnatem switch + + Write_Switch_Char ("em?"); + Write_Line ("Specify mapping file, e.g. -gnatemmapping"); + -- Line for -gnatE switch Write_Switch_Char ("E"); |