diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-06-11 10:47:39 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-06-11 10:47:39 +0000 |
| commit | a2877a77c08f7fb1c23523d10f44c1ff6093160f (patch) | |
| tree | 087a2a5de5d1db66fdac9e584721922ca4c2cc21 | |
| parent | b7fcd2878c707568e2ae50c742116231dc63c3ea (diff) | |
| download | gcc-a2877a77c08f7fb1c23523d10f44c1ff6093160f.tar.gz | |
2004-06-11 Vincent Celier <celier@gnat.com>
* mlib-tgt-vms-alpha.adb (Build_Dynamic_Library): Issue switch -R to
gnatsym, when symbol policy is Restricted.
* mlib-tgt-vms-ia64.adb (Build_Dynamic_Library): Issue switch -R to
gnatsym, when symbol policy is Restricted.
* symbols-vms-alpha.adb (Initialize): When symbol policy is Restricted,
read the symbol file.
(Finalize): Fail in symbol policy Restricted if a symbol in the original
symbol file is not in the object files. Do not create a new symbol file
when symbol policy is Restricted.
* gnatbind.adb (Gnatbind): Initialize Snames, because Snames is used
in Scng.
* gnatsym.adb (Parse_Vmd_Line): Process new switch -R for symbol policy
Restricted.
(Usage): Line for new switch -R
* make.adb (Initialize): When the platform is not VMS, add the
directory where gnatmake is invoked in the front of the path, if
gnatmake is invoked with directory information. Change the Scan_Args
while loop to a for loop.
(Recursive_Compute_Depth): Remove parameter Visited. Improve efficiency:
if Depth is equal or greater than the proposed depth, there is nothing
to do.
(Initialize): Call Recursive_Compute_Depth with initial Depth equal to 1
instead of 0.
* prj.ads: Add new symbol policy Restricted.
* prj-dect.adb (Parse_Case_Construction): Call End_Case_Construction
with the new parameters Check_All_Labels and Case_Location.
* prj-nmsc.adb (Ada_Check): Process new symbol policy Restricted
(Library_Symbol_File needs to be defined).
* prj-strt.adb (End_Case_Construction): New parameters Check_All_Labels
and Case_Location If Check_All_Labels is True, check that all values of
the string type are used, and output warning(s) if they are not.
* prj-strt.ads (End_Case_Construction): New parameters Check_All_Labels
and Case_Location.
* gnat_ugn.texi: Reorder subclauses in menus "Switches for gcc"
* gnat_ugn.texi: Update documentation about the library directory in
Library Projects.
* makegpr.adb (Display_Command): In verbose mode, also display the
value of the CPATH env var, when the compiler is gcc.
(Initialize): Change the Scan_Args while loop to a for loop
(Compile_Individual_Sources): Change directory to object directory
before compilations.
* symbols.ads: New symbol policy Restricted.
2004-06-11 Olivier Hainque <hainque@act-europe.fr>
* a-except.adb (Raise_After_Setup family): Remove. The responsibility
is now taken care of internally in the Exception_Propagation package
and does not require clients assistance any more.
* a-exexpr.adb (Is_Setup_And_Not_Propagated,
Set_Setup_And_Not_Propagated, and Clear_Setup_And_Not_Propagated): New
functions. Helpers to maintain a predicate required in the handling of
occurrence transfer between tasks.
This is now handled internally and does not require clients assistance
for the setup/propagate separation anymore.
(Setup_Exception, Propagate_Exception): Simplify the Private_Data
allocation strategy, handle the Setup_And_Not_Propagated predicate and
document.
* s-taenca.adb (Check_Exception): Use raise_with_msg instead of
raise_after_setup, now that everything is handled internally within the
setup/propagation engine.
2004-06-11 Hristian Kirtchev <kirtchev@gnat.com>
* exp_ch6.adb (Expand_Inlined_Call): Add function Formal_Is_Used_Once.
Add additional conditions for the case of an actual being a simple
name or literal. Improve inlining by preventing the generation
of temporaries with a short lifetime (one use).
2004-06-11 Hristian Kirtchev <kirtchev@gnat.com>
PR ada/15587
* einfo.ads: Minor comment updates for Has_Completion and
E_Constant list of flags.
* sem_ch3.adb (Analyze_Object_Declaration): Full constant declarations
and constant redeclarations now set the Has_Completion flag of their
defining identifiers.
* sem_ch7.adb (Analyze_Package_Spec): Add procedure
Inspect_Deferred_Constant_Completion.
Used to detect private deferred constants that have not been completed
either by a constant redeclaration or pragma Import. Emits error message
"constant declaration requires initialization expression".
* sem_prag.adb (Process_Import_Or_Interface): An Import pragma now
completes a deferred constant.
2004-06-11 Geert Bosch <bosch@gnat.com>
* eval_fat.adb (Decompose_Int): Fix rounding of negative numbers.
* s-fatgen.adb (Gradual_Scaling): Correct off-by-one error in
calculating exponent for scaling denormal numbers.
(Leading_Part): Properly raise Constraint_Error for zero or negative
Adjustment.
(Remainder): Properly raise Constraint_Error for zero divisor.
2004-06-11 Thomas Quinot <quinot@act-europe.fr>
* sem_util.adb: Minor reformatting.
* exp_ch2.adb (Expand_Entry_Parameter): Generate an explicit
dereference when accessing the entry parameter record.
(Check_Array_Type): Always check for possible implicit dereference.
(maybe_implicit_dereference): Rename to check_no_implicit_derefence.
Abort if a pointer is still present (denoting that an implicit
dereference was left in the tree by the front-end).
* sem_attr.adb (Expand_Entry_Parameter): Generate an explicit
dereference when accessing the entry parameter record.
(Check_Array_Type): Always check for possible implicit dereference.
(maybe_implicit_dereference): Rename to check_no_implicit_derefence.
Abort if a pointer is still present (denoting that an implicit
dereference was left in the tree by the front-end).
2004-06-11 Emmanuel Briot <briot@act-europe.fr>
* g-debpoo.adb (Deallocate, Dereference): Add prefix "error:" to error
message, like the compiler itself does. Easier to parse the output.
* g-debpoo.ads: (Allocate, Deallocate, Dereference): Add comments.
* gnat_ugn.texi (gnatxref, gnatfind): Clarify that source names should
be base names, and not includes directories.
2004-06-11 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.generic ($(EXEC)): Depend on $(OBJECTS), not $(OBJ_FILES),
so that dependencies are properly taken into account by make.
2004-06-11 Arnaud Charlet <charlet@act-europe.fr>
PR ada/15622
* s-unstyp.ads, s-maccod.ads, sem_ch8.adb, s-auxdec.ads,
exp_intr.adb, s-auxdec-vms_64.ads: Fix typo: instrinsic -> intrinsic
2004-06-11 Jerome Guitton <guitton@act-europe.fr>
* Makefile.in (install-gnatlib): install target-specific run-time files.
* Make-lang.in: Remove obsolete targets.
2004-06-11 Ed Schonberg <schonberg@gnat.com>
* par-ch12.adb (P_Generic): Add scope before analyzing subprogram
specification, to catch misuses of program unit names.
* sem_res.adb (Resolve_Type_Conversion): Do not emit warnings on
superfluous conversions in an instance.
2004-06-11 Ed Schonberg <schonberg@gnat.com>
PR ada/15403
* sem_ch12.adb (Save_References): If operator node has been folded to
enumeration literal, associated_node must be discarded.
2004-06-11 Jose Ruiz <ruiz@act-europe.fr>
* s-stchop-vxworks.adb: Add required pragma Convention to
Task_Descriptor because it is updated by a C function.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@82973 138bc75d-0d04-0410-961f-82ee72b054a4
43 files changed, 842 insertions, 296 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 665ba73cd33..8e5893db74c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,184 @@ +2004-06-11 Vincent Celier <celier@gnat.com> + + * mlib-tgt-vms-alpha.adb (Build_Dynamic_Library): Issue switch -R to + gnatsym, when symbol policy is Restricted. + + * mlib-tgt-vms-ia64.adb (Build_Dynamic_Library): Issue switch -R to + gnatsym, when symbol policy is Restricted. + + * symbols-vms-alpha.adb (Initialize): When symbol policy is Restricted, + read the symbol file. + (Finalize): Fail in symbol policy Restricted if a symbol in the original + symbol file is not in the object files. Do not create a new symbol file + when symbol policy is Restricted. + + * gnatbind.adb (Gnatbind): Initialize Snames, because Snames is used + in Scng. + + * gnatsym.adb (Parse_Vmd_Line): Process new switch -R for symbol policy + Restricted. + (Usage): Line for new switch -R + + * make.adb (Initialize): When the platform is not VMS, add the + directory where gnatmake is invoked in the front of the path, if + gnatmake is invoked with directory information. Change the Scan_Args + while loop to a for loop. + (Recursive_Compute_Depth): Remove parameter Visited. Improve efficiency: + if Depth is equal or greater than the proposed depth, there is nothing + to do. + (Initialize): Call Recursive_Compute_Depth with initial Depth equal to 1 + instead of 0. + + * prj.ads: Add new symbol policy Restricted. + + * prj-dect.adb (Parse_Case_Construction): Call End_Case_Construction + with the new parameters Check_All_Labels and Case_Location. + + * prj-nmsc.adb (Ada_Check): Process new symbol policy Restricted + (Library_Symbol_File needs to be defined). + + * prj-strt.adb (End_Case_Construction): New parameters Check_All_Labels + and Case_Location If Check_All_Labels is True, check that all values of + the string type are used, and output warning(s) if they are not. + + * prj-strt.ads (End_Case_Construction): New parameters Check_All_Labels + and Case_Location. + + * gnat_ugn.texi: Reorder subclauses in menus "Switches for gcc" + + * gnat_ugn.texi: Update documentation about the library directory in + Library Projects. + + * makegpr.adb (Display_Command): In verbose mode, also display the + value of the CPATH env var, when the compiler is gcc. + (Initialize): Change the Scan_Args while loop to a for loop + (Compile_Individual_Sources): Change directory to object directory + before compilations. + + * symbols.ads: New symbol policy Restricted. + +2004-06-11 Olivier Hainque <hainque@act-europe.fr> + + * a-except.adb (Raise_After_Setup family): Remove. The responsibility + is now taken care of internally in the Exception_Propagation package + and does not require clients assistance any more. + + * a-exexpr.adb (Is_Setup_And_Not_Propagated, + Set_Setup_And_Not_Propagated, and Clear_Setup_And_Not_Propagated): New + functions. Helpers to maintain a predicate required in the handling of + occurrence transfer between tasks. + This is now handled internally and does not require clients assistance + for the setup/propagate separation anymore. + (Setup_Exception, Propagate_Exception): Simplify the Private_Data + allocation strategy, handle the Setup_And_Not_Propagated predicate and + document. + + * s-taenca.adb (Check_Exception): Use raise_with_msg instead of + raise_after_setup, now that everything is handled internally within the + setup/propagation engine. + +2004-06-11 Hristian Kirtchev <kirtchev@gnat.com> + + * exp_ch6.adb (Expand_Inlined_Call): Add function Formal_Is_Used_Once. + Add additional conditions for the case of an actual being a simple + name or literal. Improve inlining by preventing the generation + of temporaries with a short lifetime (one use). + +2004-06-11 Hristian Kirtchev <kirtchev@gnat.com> + + PR ada/15587 + + * einfo.ads: Minor comment updates for Has_Completion and + E_Constant list of flags. + + * sem_ch3.adb (Analyze_Object_Declaration): Full constant declarations + and constant redeclarations now set the Has_Completion flag of their + defining identifiers. + + * sem_ch7.adb (Analyze_Package_Spec): Add procedure + Inspect_Deferred_Constant_Completion. + Used to detect private deferred constants that have not been completed + either by a constant redeclaration or pragma Import. Emits error message + "constant declaration requires initialization expression". + + * sem_prag.adb (Process_Import_Or_Interface): An Import pragma now + completes a deferred constant. + +2004-06-11 Geert Bosch <bosch@gnat.com> + + * eval_fat.adb (Decompose_Int): Fix rounding of negative numbers. + + * s-fatgen.adb (Gradual_Scaling): Correct off-by-one error in + calculating exponent for scaling denormal numbers. + (Leading_Part): Properly raise Constraint_Error for zero or negative + Adjustment. + (Remainder): Properly raise Constraint_Error for zero divisor. + +2004-06-11 Thomas Quinot <quinot@act-europe.fr> + + * sem_util.adb: Minor reformatting. + + * exp_ch2.adb (Expand_Entry_Parameter): Generate an explicit + dereference when accessing the entry parameter record. + (Check_Array_Type): Always check for possible implicit dereference. + (maybe_implicit_dereference): Rename to check_no_implicit_derefence. + Abort if a pointer is still present (denoting that an implicit + dereference was left in the tree by the front-end). + + * sem_attr.adb (Expand_Entry_Parameter): Generate an explicit + dereference when accessing the entry parameter record. + (Check_Array_Type): Always check for possible implicit dereference. + (maybe_implicit_dereference): Rename to check_no_implicit_derefence. + Abort if a pointer is still present (denoting that an implicit + dereference was left in the tree by the front-end). + +2004-06-11 Emmanuel Briot <briot@act-europe.fr> + + * g-debpoo.adb (Deallocate, Dereference): Add prefix "error:" to error + message, like the compiler itself does. Easier to parse the output. + + * g-debpoo.ads: (Allocate, Deallocate, Dereference): Add comments. + + * gnat_ugn.texi (gnatxref, gnatfind): Clarify that source names should + be base names, and not includes directories. + +2004-06-11 Arnaud Charlet <charlet@act-europe.fr> + + * Makefile.generic ($(EXEC)): Depend on $(OBJECTS), not $(OBJ_FILES), + so that dependencies are properly taken into account by make. + +2004-06-11 Arnaud Charlet <charlet@act-europe.fr> + + PR ada/15622 + * s-unstyp.ads, s-maccod.ads, sem_ch8.adb, s-auxdec.ads, + exp_intr.adb, s-auxdec-vms_64.ads: Fix typo: instrinsic -> intrinsic + +2004-06-11 Jerome Guitton <guitton@act-europe.fr> + + * Makefile.in (install-gnatlib): install target-specific run-time files. + + * Make-lang.in: Remove obsolete targets. + +2004-06-11 Ed Schonberg <schonberg@gnat.com> + + * par-ch12.adb (P_Generic): Add scope before analyzing subprogram + specification, to catch misuses of program unit names. + + * sem_res.adb (Resolve_Type_Conversion): Do not emit warnings on + superfluous conversions in an instance. + +2004-06-11 Ed Schonberg <schonberg@gnat.com> + + PR ada/15403 + + * sem_ch12.adb (Save_References): If operator node has been folded to + enumeration literal, associated_node must be discarded. + +2004-06-11 Jose Ruiz <ruiz@act-europe.fr> + + * s-stchop-vxworks.adb: Add required pragma Convention to + Task_Descriptor because it is updated by a C function. + 2004-06-08 Arnaud Charlet <charlet@act-europe.fr> PR ada/15568 diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index 1342a542da2..05ea6eaac10 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -279,12 +279,6 @@ gnatbind$(exeext): ada/b_gnatb.o $(CONFIG_H) $(GNATBIND_OBJS) $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ ada/b_gnatb.o $(GNATBIND_OBJS) \ $(LIBS) $(SYSLIBS) -install-rts-zfp: force - $(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=zfp - -install-rts-ravenscar: force - $(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=ravenscar - # use cross-gcc gnat-cross: force make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" \ diff --git a/gcc/ada/Makefile.generic b/gcc/ada/Makefile.generic index a678d241650..7ecd218461b 100644 --- a/gcc/ada/Makefile.generic +++ b/gcc/ada/Makefile.generic @@ -344,7 +344,7 @@ link: else link: $(EXEC_DIR)/$(EXEC) archive-objects -$(EXEC_DIR)/$(EXEC): $(OBJ_FILES) +$(EXEC_DIR)/$(EXEC): $(OBJECTS) @$(display) $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS) $(FLDFLAGS) @$(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS) $(FLDFLAGS) endif diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 89fe096cdbc..97544297887 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -1622,6 +1622,9 @@ install-gnatlib: ../stamp-gnatlib $(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \ $(RANLIB) $(DESTDIR)$(ADA_RTL_OBJ_DIR)/$$file; \ done + -$(foreach file, $(EXTRA_ADALIB_FILES), \ + $(INSTALL_DATA_DATE) rts/$(file) $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \ + ) true # Install the shared libraries, if any, using $(INSTALL) instead # of $(INSTALL_DATA). The latter may force a mode inappropriate # for shared libraries on some targets, e.g. on HP-UX where the x diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index c07790ab4fe..477caa87558 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -331,20 +331,6 @@ package body Ada.Exceptions is -- exception occurrence referenced by the Current_Excep in the TSD. -- Abort is deferred before the raise call. - procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean); - pragma No_Return (Raise_With_Msg); - -- Similar to above, with an extra parameter to indicate wether - -- Setup_Exception has been called already. - - procedure Raise_After_Setup (E : Exception_Id); - pragma No_Return (Raise_After_Setup); - pragma Export (C, Raise_After_Setup, "__gnat_raise_after_setup"); - -- Wrapper to Raise_With_Msg and Setup set to True. - -- - -- This is called by System.Tasking.Entry_Calls.Check_Exception when an - -- exception has occured during an entry call. The exception to propagate - -- has been setup and initialized via Transfer_Occurrence in this case. - procedure Raise_With_Location_And_Msg (E : Exception_Id; F : Big_String_Ptr; @@ -993,13 +979,11 @@ package body Ada.Exceptions is -- Raise_With_Msg -- -------------------- - procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean) is + procedure Raise_With_Msg (E : Exception_Id) is Excep : constant EOA := Get_Current_Excep.all; begin - if not Setup then - Exception_Propagation.Setup_Exception (Excep, Excep); - end if; + Exception_Propagation.Setup_Exception (Excep, Excep); Excep.Exception_Raised := False; Excep.Id := E; @@ -1010,20 +994,6 @@ package body Ada.Exceptions is Raise_Current_Excep (E); end Raise_With_Msg; - procedure Raise_With_Msg (E : Exception_Id) is - begin - Raise_With_Msg (E, Setup => False); - end Raise_With_Msg; - - ----------------------- - -- Raise_After_Setup -- - ----------------------- - - procedure Raise_After_Setup (E : Exception_Id) is - begin - Raise_With_Msg (E, Setup => True); - end Raise_After_Setup; - -------------------------------------- -- Calls to Run-Time Check Routines -- -------------------------------------- diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb index b42b3fc7fd7..0d0eb094759 100644 --- a/gcc/ada/a-exexpr.adb +++ b/gcc/ada/a-exexpr.adb @@ -36,6 +36,8 @@ with Interfaces; with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; +with System.Storage_Elements; use System.Storage_Elements; + pragma Warnings (Off); -- Since several constructs give warnings in 3.14a1, including unreferenced -- variables and pragma Unreferenced itself. @@ -170,22 +172,6 @@ package body Exception_Propagation is procedure Free is new Unchecked_Deallocation (Exception_Occurrence, EOA); - function Remove - (Top : EOA; - Excep : GNAT_GCC_Exception_Access) return Boolean; - -- Remove Excep from the stack starting at Top. - -- Return True if Excep was found and removed, false otherwise. - - -- Hooks called when entering/leaving an exception handler for a given - -- occurrence, aimed at handling the stack of active occurrences. The - -- calls are generated by gigi in tree_transform/N_Exception_Handler. - - procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access); - pragma Export (C, Begin_Handler, "__gnat_begin_handler"); - - procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access); - pragma Export (C, End_Handler, "__gnat_end_handler"); - function CleanupUnwind_Handler (UW_Version : Integer; UW_Phases : Unwind_Action; @@ -211,6 +197,41 @@ package body Exception_Propagation is UW_Argument : System.Address); pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); + -------------------------------------------- + -- Occurrence stack management facilities -- + -------------------------------------------- + + function Remove + (Top : EOA; + Excep : GNAT_GCC_Exception_Access) return Boolean; + -- Remove Excep from the stack starting at Top. + -- Return True if Excep was found and removed, false otherwise. + + -- Hooks called when entering/leaving an exception handler for a given + -- occurrence, aimed at handling the stack of active occurrences. The + -- calls are generated by gigi in tree_transform/N_Exception_Handler. + + procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access); + pragma Export (C, Begin_Handler, "__gnat_begin_handler"); + + procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access); + pragma Export (C, End_Handler, "__gnat_end_handler"); + + -- To handle the case of a task "transferring" an exception occurrence to + -- another task, for instance via Exceptional_Complete_Rendezvous, we need + -- to be able to identify occurrences which have been Setup and not yet + -- Propagated. We hijack one of the common header fields for that purpose, + -- setting it to a special key value during the setup process, clearing it + -- at the very beginning of the propagation phase, and expecting it never + -- to be reset to the special value later on. + + Setup_Key : constant := 16#DEAD_BEEF#; + + function Is_Setup_And_Not_Propagated (E : EOA) return Boolean; + + procedure Set_Setup_And_Not_Propagated (E : EOA); + procedure Clear_Setup_And_Not_Propagated (E : EOA); + ------------------------------------------------------------ -- Accessors to basic components of a GNAT exception data -- ------------------------------------------------------------ @@ -316,11 +337,48 @@ package body Exception_Propagation is return URC_NO_REASON; end CleanupUnwind_Handler; + --------------------------------- + -- Is_Setup_And_Not_Propagated -- + --------------------------------- + + function Is_Setup_And_Not_Propagated (E : EOA) return Boolean is + GCC_E : GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (E.Private_Data); + begin + return GCC_E /= null and then GCC_E.Header.Private1 = Setup_Key; + end Is_Setup_And_Not_Propagated; + + ------------------------------------ + -- Clear_Setup_And_Not_Propagated -- + ------------------------------------ + + procedure Clear_Setup_And_Not_Propagated (E : EOA) is + GCC_E : GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (E.Private_Data); + begin + pragma Assert (GCC_E /= null); + GCC_E.Header.Private1 := 0; + end Clear_Setup_And_Not_Propagated; + + ---------------------------------- + -- Set_Setup_And_Not_Propagated -- + ---------------------------------- + + procedure Set_Setup_And_Not_Propagated (E : EOA) is + GCC_E : GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (E.Private_Data); + begin + pragma Assert (GCC_E /= null); + GCC_E.Header.Private1 := Setup_Key; + end Set_Setup_And_Not_Propagated; + --------------------- -- Setup_Exception -- --------------------- - -- Push the current exception occurrence on the stack before overriding it. + -- In this implementation of the exception propagation scheme, this + -- subprogram should be understood as: Setup the exception occurrence + -- stack headed at Current for a forthcoming raise of Excep. procedure Setup_Exception (Excep : EOA; @@ -331,38 +389,62 @@ package body Exception_Propagation is Next : EOA; GCC_Exception : GNAT_GCC_Exception_Access; - -- Note that we make no use of the Reraised indication at this point. - - -- The information is still passed around just in case of future needs, - -- since we've already switched between using/not-using it a number of - -- times. - begin - -- If the current exception is not live, the stack is empty and there - -- is nothing to do. Note that the stack always appears empty for - -- mechanisms that do not require one. For the mechanism we implement - -- in this unit, the initial Private_Data allocation for an occurrence - -- is issued by Propagate_Exception. - if Top.Private_Data = System.Null_Address then + -- The exception Excep is soon to be propagated, and the storage used + -- for that will be the occurrence statically allocated for the current + -- thread. This storage might currently be used for a still active + -- occurrence, so we need to push it on the thread's occurrence stack + -- (headed at that static occurrence) before it gets clobbered. + + -- What we do here is to trigger this push when need be, and allocate a + -- Private_Data block for the forthcoming Propagation. + + -- Some tasking rendez-vous attempts lead to an occurrence transfer + -- from the server to the client (see Exceptional_Complete_Rendezvous). + -- In those cases Setup is called twice for the very same occurrence + -- before it gets propagated: once from the server, because this is + -- where the occurrence contents is elaborated and known, and then + -- once from the client when it detects the case and actually raises + -- the exception in its own context. + + -- The Is_Setup_And_Not_Propagated predicate tells us when we are in + -- the second call to Setup for a Transferred occurrence, and there is + -- nothing to be done here in this situation. This predicate cannot be + -- True if we are dealing with a Reraise, and we may even be called + -- with a raw uninitialized Excep occurrence in this case so we should + -- not check anyway. Observe the front-end expansion for a "raise;" to + -- see that happening. We get a local occurrence and a direct call to + -- Save_Occurrence without the intermediate init-proc call. + + if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then return; end if; - -- Shift the contents of the Top of the stack in a freshly allocated - -- entry, which leaves the room in the fixed Top entry available for the - -- occurrence about to be propagated. + -- Allocate what will be the Private_Data block for the exception + -- to be propagated. - Next := new Exception_Occurrence; - Save_Occurrence_And_Private (Next.all, Top.all); + GCC_Exception := new GNAT_GCC_Exception; - -- Allocate Private_Data for the occurrence about to be propagated - -- and link everything together. + -- If the Top of the occurrence stack is not currently used for an + -- active exception (the stack is empty) we just need to setup the + -- Private_Data pointer. - GCC_Exception := new GNAT_GCC_Exception; - GCC_Exception.Next_Exception := Next; + -- Otherwise, we also need to shift the contents of the Top of the + -- stack in a freshly allocated entry and link everything together. + + if Top.Private_Data /= System.Null_Address then + Next := new Exception_Occurrence; + Save_Occurrence_And_Private (Next.all, Top.all); + + GCC_Exception.Next_Exception := Next; + Top.Private_Data := GCC_Exception.all'Address; + end if; Top.Private_Data := GCC_Exception.all'Address; + Set_Setup_And_Not_Propagated (Top); + end Setup_Exception; ------------------- @@ -403,16 +485,16 @@ package body Exception_Propagation is GCC_Exception : GNAT_GCC_Exception_Access; begin - if Excep.Private_Data = System.Null_Address then - GCC_Exception := new GNAT_GCC_Exception; - Excep.Private_Data := GCC_Exception.all'Address; - else - GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data); - end if; + pragma Assert (Excep.Private_Data /= System.Null_Address); - -- Fill in the useful flags for the personality routine called for each + -- Retrieve the Private_Data for this occurrence and set the useful + -- flags for the personality routine, which will be called for each -- frame via Unwind_RaiseException below. + GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data); + + Clear_Setup_And_Not_Propagated (Excep); + GCC_Exception.Id := Excep.Id; GCC_Exception.N_Cleanups_To_Trigger := 0; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 57f97329602..7327be8b246 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1250,8 +1250,8 @@ package Einfo is -- Has_Completion (Flag26) -- Present in all entities that require a completion (functions, -- procedures, private types, limited private types, incomplete types, --- and packages that require a body). Set if the completion has been --- encountered and analyzed. +-- constants and packages that require a body). The flag is set if the +-- completion has been encountered and analyzed. -- Has_Completion_In_Body (Flag71) -- Present in "Taft amendment types" that is to say incomplete types @@ -4142,6 +4142,7 @@ package Einfo is -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) -- Has_Biased_Representation (Flag139) + -- Has_Completion (Flag26) (constants only) -- Has_Size_Clause (Flag29) -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb index 2d439930301..00a131dd623 100644 --- a/gcc/ada/eval_fat.adb +++ b/gcc/ada/eval_fat.adb @@ -382,14 +382,10 @@ package body Eval_Fat is Calculate_Fraction_And_Exponent : begin Uintp_Mark := Mark; - -- Put back sign before applying the rounding. - - if UR_Is_Negative (X) then - Fraction := -Fraction; - end if; - -- Determine correct rounding based on the remainder - -- which is in N and the divisor D. + -- which is in N and the divisor D. The rounding is + -- performed on the absolute value of X, so Ceiling + -- and Floor need to check for the sign of X explicitly. case Mode is when Round_Even => @@ -416,11 +412,14 @@ package body Eval_Fat is end if; when Ceiling => - if N > Uint_0 then + if N > Uint_0 and then not UR_Is_Negative (X) then Fraction := Fraction + 1; end if; - when Floor => null; + when Floor => + if N > Uint_0 and then UR_Is_Negative (X) then + Fraction := Fraction + 1; + end if; end case; -- The result must be normalized to [1.0/Radix, 1.0), @@ -431,6 +430,12 @@ package body Eval_Fat is Exponent := Exponent + 1; end if; + -- Put back sign after applying the rounding. + + if UR_Is_Negative (X) then + Fraction := -Fraction; + end if; + Release_And_Save (Uintp_Mark, Fraction, Exponent); end Calculate_Fraction_And_Exponent; end Decompose_Int; diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 7192cb9a333..966670d68c2 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -519,8 +519,9 @@ package body Exp_Ch2 is P_Comp_Ref := Make_Selected_Component (Loc, Prefix => - Unchecked_Convert_To (Parm_Type, - New_Reference_To (Addr_Ent, Loc)), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Parm_Type, + New_Reference_To (Addr_Ent, Loc))), Selector_Name => New_Reference_To (Entry_Component (Ent_Formal), Loc)); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 67d18dde16a..edb31846708 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2278,6 +2278,9 @@ package body Exp_Ch6 is -- If procedure body has no local variables, inline body without -- creating block, otherwise rewrite call with block. + function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; + -- Determine whether a formal parameter is used only once in Orig_Bod + --------------------- -- Make_Exit_Label -- --------------------- @@ -2512,6 +2515,62 @@ package body Exp_Ch6 is end if; end Rewrite_Procedure_Call; + ------------------------- + -- Formal_Is_Used_Once -- + ------------------------ + + function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is + Use_Counter : Int := 0; + + function Count_Uses (N : Node_Id) return Traverse_Result; + -- Traverse the tree and count the uses of the formal parameter. + -- In this case, for optimization purposes, we do not need to + -- continue the traversal once more than one use is encountered. + + function Count_Uses (N : Node_Id) return Traverse_Result is + begin + + -- The original node is an identifier + + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + + -- The original node's entity points to the one in the + -- copied body. + + and then Nkind (Entity (N)) = N_Identifier + and then Present (Entity (Entity (N))) + + -- The entity of the copied node is the formal parameter + + and then Entity (Entity (N)) = Formal + then + Use_Counter := Use_Counter + 1; + + if Use_Counter > 1 then + + -- Denote more than one use and abandon the traversal + + Use_Counter := 2; + return Abandon; + + end if; + end if; + + return OK; + end Count_Uses; + + procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses); + + -- Start of processing for Formal_Is_Used_Once + + begin + + Count_Formal_Uses (Orig_Bod); + return Use_Counter = 1; + + end Formal_Is_Used_Once; + -- Start of processing for Expand_Inlined_Call begin @@ -2608,6 +2667,13 @@ package body Exp_Ch6 is (not Is_Scalar_Type (Etype (A)) or else Ekind (Entity (A)) = E_Enumeration_Literal)) + -- When the actual is an identifier and the corresponding formal + -- is used only once in the original body, the formal can be + -- substituted directly with the actual parameter. + + or else (Nkind (A) = N_Identifier + and then Formal_Is_Used_Once (F)) + or else Nkind (A) = N_Real_Literal or else Nkind (A) = N_Integer_Literal or else Nkind (A) = N_Character_Literal diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 9fe40522970..f7014d25f93 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -72,7 +72,7 @@ package body Exp_Intr is procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind); -- Expand an intrinsic shift operation, N and E are from the call to - -- Expand_Instrinsic_Call (call node and subprogram spec entity) and + -- Expand_Intrinsic_Call (call node and subprogram spec entity) and -- K is the kind for the shift node procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 4d93310db2f..340c2f65158 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -1095,7 +1095,7 @@ package body GNAT.Debug_Pools is if Pool.Raise_Exceptions then raise Freeing_Not_Allocated_Storage; else - Put ("Freeing not allocated storage, at "); + Put ("error: Freeing not allocated storage, at "); Put_Line (Pool.Stack_Trace_Depth, null, Deallocate_Label'Address, Code_Address_For_Deallocate_End); @@ -1106,7 +1106,7 @@ package body GNAT.Debug_Pools is if Pool.Raise_Exceptions then raise Freeing_Deallocated_Storage; else - Put ("Freeing already deallocated storage, at "); + Put ("error: Freeing already deallocated storage, at "); Put_Line (Pool.Stack_Trace_Depth, null, Deallocate_Label'Address, Code_Address_For_Deallocate_End); @@ -1225,7 +1225,7 @@ package body GNAT.Debug_Pools is if Pool.Raise_Exceptions then raise Accessing_Not_Allocated_Storage; else - Put ("Accessing not allocated storage, at "); + Put ("error: Accessing not allocated storage, at "); Put_Line (Pool.Stack_Trace_Depth, null, Dereference_Label'Address, Code_Address_For_Dereference_End); @@ -1238,7 +1238,7 @@ package body GNAT.Debug_Pools is if Pool.Raise_Exceptions then raise Accessing_Deallocated_Storage; else - Put ("Accessing deallocated storage, at "); + Put ("error: Accessing deallocated storage, at "); Put_Line (Pool.Stack_Trace_Depth, null, Dereference_Label'Address, diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads index 3cfe1bc270a..6207f93878d 100644 --- a/gcc/ada/g-debpoo.ads +++ b/gcc/ada/g-debpoo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -249,20 +249,35 @@ private Storage_Address : out Address; Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count); + -- Allocate a new chunk of memory, and set it up so that the debug pool + -- can check accesses to its data, and report incorrect access later on. + -- The parameters have the same semantics as defined in the ARM95. procedure Deallocate (Pool : in out Debug_Pool; Storage_Address : Address; Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count); + -- Mark a block of memory as invalid. It might not be physically removed + -- immediately, depending on the setup of the debug pool, so that checks + -- are still possible. + -- The parameters have the same semantics as defined in the ARM95. function Storage_Size (Pool : Debug_Pool) return SSC; + -- Return the maximal size of data that can be allocated through Pool. + -- Since Pool uses the malloc() system call, all the memory is accessible + -- through the pool procedure Dereference (Pool : in out Debug_Pool; Storage_Address : System.Address; Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count); + -- Check whether a derefence statement is valid, ie whether the pointer + -- was allocated through Pool. As documented above, errors will be + -- reported either by a special error message or an exception, depending + -- on the setup of the storage pool. + -- The parameters have the same semantics as defined in the ARM95. type Byte_Count is mod System.Max_Binary_Modulus; -- Type used for maintaining byte counts, needs to be large enough diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 82f64a92396..809973c7d08 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -280,10 +280,10 @@ Switches for gcc * Output and Error Message Control:: * Warning Message Control:: * Debugging and Assertion Control:: -* Run-Time Checks:: -* Stack Overflow Checking:: * Validity Checking:: * Style Checking:: +* Run-Time Checks:: +* Stack Overflow Checking:: * Using gcc for Syntax Checking:: * Using gcc for Semantic Checking:: * Compiling Ada 83 Programs:: @@ -3631,10 +3631,10 @@ describe the switches in more detail in functionally grouped sections. * Output and Error Message Control:: * Warning Message Control:: * Debugging and Assertion Control:: -* Run-Time Checks:: -* Stack Overflow Checking:: * Validity Checking:: * Style Checking:: +* Run-Time Checks:: +* Stack Overflow Checking:: * Using gcc for Syntax Checking:: * Using gcc for Semantic Checking:: * Compiling Ada 83 Programs:: @@ -12435,6 +12435,8 @@ The @code{Library_Dir} attribute has a string value that designates the path (absolute or relative) of the directory where the library will reside. It must designate an existing directory, and this directory must be different from the project's object directory. It also needs to be writable. +The directory should only be used for one library; the reason is that all +files contained in this directory may be deleted by the Project Manager. If both @code{Library_Name} and @code{Library_Dir} are specified and are legal, then the project file defines a library project. The optional @@ -13758,6 +13760,10 @@ specifying @file{source*.adb} is the same as giving every file in the current directory whose name starts with @file{source} and whose extension is @file{adb}. +You shouldn't specify any directory name, just base names. @command{gnatxref} +and @command{gnatfind} will be able to locate these files by themselves using +the source path. If you specify directories, no result is produced. + @end table @noindent diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 3dc76ef0932..6d5595e7264 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -43,6 +43,7 @@ with Osint; use Osint; with Osint.B; use Osint.B; with Output; use Output; with Rident; use Rident; +with Snames; with Switch; use Switch; with Switch.B; use Switch.B; with Targparm; use Targparm; @@ -444,6 +445,7 @@ begin Csets.Initialize; Namet.Initialize; + Snames.Initialize; -- Acquire target parameters diff --git a/gcc/ada/gnatsym.adb b/gcc/ada/gnatsym.adb index 6b1dd4d3499..f639f43fd14 100644 --- a/gcc/ada/gnatsym.adb +++ b/gcc/ada/gnatsym.adb @@ -124,7 +124,7 @@ procedure Gnatsym is procedure Parse_Cmd_Line is begin loop - case GNAT.Command_Line.Getopt ("c C q r: s: v V:") is + case GNAT.Command_Line.Getopt ("c C q r: R s: v V:") is when ASCII.NUL => exit; @@ -141,6 +141,9 @@ procedure Gnatsym is Reference_Symbol_File_Name := new String'(GNAT.Command_Line.Parameter); + when 'R' => + Symbol_Policy := Restricted; + when 's' => Symbol_File_Name := new String'(GNAT.Command_Line.Parameter); @@ -183,10 +186,11 @@ procedure Gnatsym is begin Write_Line ("gnatsym [options] object_file {object_file}"); Write_Eol; - Write_Line (" -c Compliant policy"); - Write_Line (" -C Controlled policy"); + Write_Line (" -c Compliant symbol policy"); + Write_Line (" -C Controlled symbol policy"); Write_Line (" -q Quiet mode"); Write_Line (" -r<ref> Reference symbol file name"); + Write_Line (" -R Restricted symbol policy"); Write_Line (" -s<sym> Symbol file name"); Write_Line (" -v Verbose mode"); Write_Line (" -V<ver> Version"); diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index a4b2a41ff9f..3de414cce22 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -502,12 +502,8 @@ package body Make is procedure Debug_Msg (S : String; N : Name_Id); -- If Debug.Debug_Flag_W is set outputs string S followed by name N. - type Project_Array is array (Positive range <>) of Project_Id; - No_Projects : constant Project_Array := (1 .. 0 => No_Project); - procedure Recursive_Compute_Depth (Project : Project_Id; - Visited : Project_Array; Depth : Natural); -- Compute depth of Project and of the projects it depends on @@ -5554,8 +5550,6 @@ package body Make is ---------------- procedure Initialize is - Next_Arg : Positive; - begin -- Override default initialization of Check_Object_Consistency -- since this is normally False for GNATBIND, but is True for @@ -5585,10 +5579,37 @@ package body Make is Mains.Delete; - Next_Arg := 1; - Scan_Args : while Next_Arg <= Argument_Count loop + -- Add the directory where gnatmake is invoked in the front of the + -- path, if gnatmake is invoked with directory information. + -- Only do this if the platform is not VMS, where the notion of path + -- does not really exist. + + if not OpenVMS then + declare + Command : constant String := Command_Name; + begin + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname (Command (Command'First .. Index)); + PATH : constant String := + Absolute_Dir & Path_Separator & Getenv ("PATH").all; + + begin + Setenv ("PATH", PATH); + end; + + exit; + end if; + end loop; + end; + end if; + + -- Scan the switches and arguments + + Scan_Args : for Next_Arg in 1 .. Argument_Count loop Scan_Make_Arg (Argument (Next_Arg), And_Save => True); - Next_Arg := Next_Arg + 1; end loop Scan_Args; if Usage_Requested then @@ -5688,8 +5709,13 @@ package body Make is -- Compute depth of each project + for Proj in 1 .. Projects.Last loop + Projects.Table (Proj).Seen := False; + Projects.Table (Proj).Depth := 0; + end loop; + Recursive_Compute_Depth - (Main_Project, Visited => No_Projects, Depth => 0); + (Main_Project, Depth => 1); else @@ -6189,26 +6215,28 @@ package body Make is procedure Recursive_Compute_Depth (Project : Project_Id; - Visited : Project_Array; Depth : Natural) is List : Project_List; Proj : Project_Id; - OK : Boolean; - New_Visited : constant Project_Array := Visited & Project; begin - -- Nothing to do if there is no project + -- Nothing to do if there is no project or if the project has already + -- been seen or if the depth is large enough. - if Project = No_Project then + if Project = No_Project + or else Projects.Table (Project).Seen + or else Projects.Table (Project).Depth >= Depth + then return; end if; - -- If current depth of project is lower than Depth, adjust it + Projects.Table (Project).Depth := Depth; - if Projects.Table (Project).Depth < Depth then - Projects.Table (Project).Depth := Depth; - end if; + -- Mark the project as Seen to avoid endless loop caused by limited + -- withs. + + Projects.Table (Project).Seen := True; List := Projects.Table (Project).Imported_Projects; @@ -6217,34 +6245,20 @@ package body Make is while List /= Empty_Project_List loop Proj := Project_Lists.Table (List).Project; List := Project_Lists.Table (List).Next; - - OK := True; - - -- To avoid endless loops due to cycles with limited widts, - -- do not revisit a project that is already in the chain of imports - -- that brought us here. - - for J in Visited'Range loop - if Visited (J) = Proj then - OK := False; - exit; - end if; - end loop; - - if OK then - Recursive_Compute_Depth - (Project => Proj, - Visited => New_Visited, - Depth => Depth + 1); - end if; + Recursive_Compute_Depth + (Project => Proj, + Depth => Depth + 1); end loop; -- Visit a project being extended, if any Recursive_Compute_Depth (Project => Projects.Table (Project).Extends, - Visited => New_Visited, - Depth => Depth + 1); + Depth => Depth + 1); + + -- Reset the Seen flag, as we leave this project + + Projects.Table (Project).Seen := False; end Recursive_Compute_Depth; ----------------------- diff --git a/gcc/ada/makegpr.adb b/gcc/ada/makegpr.adb index 5204206d481..691a6de930d 100644 --- a/gcc/ada/makegpr.adb +++ b/gcc/ada/makegpr.adb @@ -392,7 +392,10 @@ package body Makegpr is First_Source : Other_Source_Id); -- ??? needs comment - procedure Display_Command (Name : String; Path : String_Access); + procedure Display_Command + (Name : String; + Path : String_Access; + CPATH : String_Access := null); -- Display the command for a spawned process, if in Verbose_Mode or -- not in Quiet_Output. @@ -1625,6 +1628,7 @@ package body Makegpr is is Source : Other_Source := Other_Sources.Table (Source_Id); Success : Boolean; + CPATH : String_Access := null; begin -- If the compiler is not know yet, get its path name @@ -1808,11 +1812,18 @@ package body Makegpr is Add_Search_Directories (Data, Source.Language); + -- Set CPATH, if compiler is GCC + + if Compiler_Is_Gcc (Source.Language) then + CPATH := Current_Include_Paths (Source.Language); + end if; + -- And invoke the compiler Display_Command - (Compiler_Names (Source.Language).all, - Compiler_Paths (Source.Language)); + (Name => Compiler_Names (Source.Language).all, + Path => Compiler_Paths (Source.Language), + CPATH => CPATH); Spawn (Compiler_Paths (Source.Language).all, @@ -1881,6 +1892,10 @@ package body Makegpr is Get_Imported_Directories (Main_Project, Data); Projects.Table (Main_Project) := Data; + -- Compilation will occur in the object directory + + Change_Dir (Get_Name_String (Data.Object_Directory)); + if not Data.Sources_Present then if Ada_Is_A_Language then Mains.Reset; @@ -2238,7 +2253,11 @@ package body Makegpr is -- Display_Command -- --------------------- - procedure Display_Command (Name : String; Path : String_Access) is + procedure Display_Command + (Name : String; + Path : String_Access; + CPATH : String_Access := null) + is begin -- Only display the command in Verbose Mode (-v) or when -- not in Quiet Output (no -q). @@ -2247,6 +2266,11 @@ package body Makegpr is -- In Verbose Mode output the full path of the spawned process if Verbose_Mode then + if CPATH /= null then + Write_Str ("CPATH = "); + Write_Line (CPATH.all); + end if; + Write_Str (Path.all); else @@ -2584,8 +2608,6 @@ package body Makegpr is ---------------- procedure Initialize is - Next_Arg : Positive; - begin -- Do some necessary package initializations @@ -2605,13 +2627,10 @@ package body Makegpr is Add_Str_To_Name_Buffer ("compiler_command"); Name_Compiler_Command := Name_Find; - Next_Arg := 1; - -- Get the command line arguments - Scan_Args : while Next_Arg <= Argument_Count loop + Scan_Args : for Next_Arg in 1 .. Argument_Count loop Scan_Arg (Argument (Next_Arg)); - Next_Arg := Next_Arg + 1; end loop Scan_Args; -- Fail if command line ended with "-P" diff --git a/gcc/ada/mlib-tgt-vms-alpha.adb b/gcc/ada/mlib-tgt-vms-alpha.adb index 8637014a9c9..b3b71722fb6 100644 --- a/gcc/ada/mlib-tgt-vms-alpha.adb +++ b/gcc/ada/mlib-tgt-vms-alpha.adb @@ -438,6 +438,10 @@ package body MLib.Tgt is when Controlled => Last_Argument := Last_Argument + 1; Arguments (Last_Argument) := new String'("-C"); + + when Restricted => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-R"); end case; -- Add each relevant object file diff --git a/gcc/ada/mlib-tgt-vms-ia64.adb b/gcc/ada/mlib-tgt-vms-ia64.adb index 7d868d0b327..5ce66cce12e 100644 --- a/gcc/ada/mlib-tgt-vms-ia64.adb +++ b/gcc/ada/mlib-tgt-vms-ia64.adb @@ -471,6 +471,10 @@ package body MLib.Tgt is when Controlled => Last_Argument := Last_Argument + 1; Arguments (Last_Argument) := new String'("-C"); + + when Restricted => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-R"); end case; -- Add each relevant object file diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 2880fe43678..4dd2b1e01cd 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -200,7 +200,15 @@ package body Ch12 is Set_Specification (Gen_Decl, P_Package (Pf_Spcn)); else Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc); + Set_Specification (Gen_Decl, P_Subprogram_Specification); + + if Nkind (Defining_Unit_Name (Specification (Gen_Decl))) + = N_Defining_Program_Unit_Name + and then Scope.Last > 0 + then + Error_Msg_SP ("child unit allowed only at library level"); + end if; TF_Semicolon; end if; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 0db8d9150bd..35cb8c0c135 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -26,6 +26,7 @@ with Err_Vars; use Err_Vars; with Namet; use Namet; +with Opt; use Opt; with Prj.Err; use Prj.Err; with Prj.Strt; use Prj.Strt; with Prj.Tree; use Prj.Tree; @@ -535,7 +536,10 @@ package body Prj.Dect is First_Declarative_Item : Project_Node_Id := Empty_Node; - First_Choice : Project_Node_Id := Empty_Node; + First_Choice : Project_Node_Id := Empty_Node; + + When_Others : Boolean := False; + -- Set to True when there is a "when others =>" clause begin Case_Construction := @@ -612,6 +616,7 @@ package body Prj.Dect is Scan; if Token = Tok_Others then + When_Others := True; -- Scan past "others" @@ -661,7 +666,9 @@ package body Prj.Dect is end if; end loop When_Loop; - End_Case_Construction; + End_Case_Construction + (Check_All_Labels => not When_Others and not Quiet_Output, + Case_Location => Location_Of (Case_Construction)); Expect (Tok_End, "`END CASE`"); Remove_Next_End_Node; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index c710a2bd0af..c87b7e3f722 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -1209,7 +1209,44 @@ package body Prj.Nmsc is end; end if; - if not Lib_Symbol_File.Default then + if not Lib_Symbol_Policy.Default then + declare + Value : constant String := + To_Lower + (Get_Name_String (Lib_Symbol_Policy.Value)); + + begin + if Value = "autonomous" or else Value = "default" then + Data.Symbol_Data.Symbol_Policy := Autonomous; + + elsif Value = "compliant" then + Data.Symbol_Data.Symbol_Policy := Compliant; + + elsif Value = "controlled" then + Data.Symbol_Data.Symbol_Policy := Controlled; + + elsif Value = "restricted" then + Data.Symbol_Data.Symbol_Policy := Restricted; + + else + Error_Msg + (Project, + "illegal value for Library_Symbol_Policy", + Lib_Symbol_Policy.Location); + end if; + end; + end if; + + if Lib_Symbol_File.Default then + if Data.Symbol_Data.Symbol_Policy = Restricted then + Error_Msg + (Project, + "Library_Symbol_File needs to be defined when " & + "symbol policy is Restricted", + Lib_Symbol_Policy.Location); + end if; + + else Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value; Get_Name_String (Lib_Symbol_File.Value); @@ -1245,33 +1282,10 @@ package body Prj.Nmsc is end if; end if; - if not Lib_Symbol_Policy.Default then - declare - Value : constant String := - To_Lower - (Get_Name_String (Lib_Symbol_Policy.Value)); - - begin - if Value = "autonomous" or else Value = "default" then - Data.Symbol_Data.Symbol_Policy := Autonomous; - - elsif Value = "compliant" then - Data.Symbol_Data.Symbol_Policy := Compliant; - - elsif Value = "controlled" then - Data.Symbol_Data.Symbol_Policy := Controlled; - - else - Error_Msg - (Project, - "illegal value for Library_Symbol_Policy", - Lib_Symbol_Policy.Location); - end if; - end; - end if; - if Lib_Ref_Symbol_File.Default then - if Data.Symbol_Data.Symbol_Policy /= Autonomous then + if Data.Symbol_Data.Symbol_Policy = Compliant + or else Data.Symbol_Data.Symbol_Policy = Controlled + then Error_Msg (Project, "a reference symbol file need to be defined", diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index cc1bd83db80..dabd2a1730d 100644 --- a/gcc/ada/prj-strt.adb +++ b/gcc/ada/prj-strt.adb @@ -260,8 +260,48 @@ package body Prj.Strt is -- End_Case_Construction -- --------------------------- - procedure End_Case_Construction is + procedure End_Case_Construction + (Check_All_Labels : Boolean; + Case_Location : Source_Ptr) + is + Non_Used : Natural := 0; + First_Non_Used : Choice_Node_Id := First_Choice_Node_Id; begin + -- First, if Check_All_Labels is True, check if all values + -- of the string type have been used. + + if Check_All_Labels then + for Choice in Choice_First .. Choices.Last loop + if not Choices.Table (Choice).Already_Used then + Non_Used := Non_Used + 1; + + if Non_Used = 1 then + First_Non_Used := Choice; + end if; + end if; + end loop; + + -- If only one is not used, report a single warning for this value + if Non_Used = 1 then + Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String; + Error_Msg ("?value { is not used as label", Case_Location); + + -- If several are not used, report a warning for each one of them + + elsif Non_Used > 1 then + Error_Msg + ("?the following values are not used as labels:", + Case_Location); + + for Choice in First_Non_Used .. Choices.Last loop + if not Choices.Table (Choice).Already_Used then + Error_Msg_Name_1 := Choices.Table (Choice).The_String; + Error_Msg ("\?{", Case_Location); + end if; + end loop; + end if; + end if; + -- If this is the only case construction, empty the tables if Choice_Lasts.Last = 1 then diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads index 633b022e8f5..612a3984d27 100644 --- a/gcc/ada/prj-strt.ads +++ b/gcc/ada/prj-strt.ads @@ -53,11 +53,16 @@ private package Prj.Strt is -- into a table to be checked against the case labels of the -- case construction. - procedure End_Case_Construction; + procedure End_Case_Construction + (Check_All_Labels : Boolean; + Case_Location : Source_Ptr); -- This procedure is called at the end of a case construction -- to remove the case labels and to restore the previous state. -- In particular, in the case of nested case constructions, -- the case labels of the enclosing case construction are restored. + -- When When_Others is False and we are not in quiet output, a warning + -- is emitted for each value of the case variable string type that has + -- not been specified. procedure Parse_Choice_List (First_Choice : out Project_Node_Id); diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 9d82b5ff841..0edac399d6b 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -172,8 +172,8 @@ package Prj is type Lib_Kind is (Static, Dynamic, Relocatable); - type Policy is (Autonomous, Compliant, Controlled); - -- See explaination about this type in package Symbol + type Policy is (Autonomous, Compliant, Controlled, Restricted); + -- See explaination about this type in package Symbols type Symbol_Record is record Symbol_File : Name_Id := No_Name; diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads index daf4b4682f2..111be333b94 100644 --- a/gcc/ada/s-auxdec-vms_64.ads +++ b/gcc/ada/s-auxdec-vms_64.ads @@ -463,7 +463,7 @@ private -- convention C so that the critical parameters are passed by reference. -- Without this, the parameters are passed by copy, creating load/store -- race conditions. We also inline them, since this seems more in the - -- spirit of the original (hardware instrinsic) routines. + -- spirit of the original (hardware intrinsic) routines. pragma Convention (C, Clear_Interlocked); pragma Inline_Always (Clear_Interlocked); diff --git a/gcc/ada/s-auxdec.ads b/gcc/ada/s-auxdec.ads index 2d34ff111c9..c3e16f502ca 100644 --- a/gcc/ada/s-auxdec.ads +++ b/gcc/ada/s-auxdec.ads @@ -459,7 +459,7 @@ private -- convention C so that the critical parameters are passed by reference. -- Without this, the parameters are passed by copy, creating load/store -- race conditions. We also inline them, since this seems more in the - -- spirit of the original (hardware instrinsic) routines. + -- spirit of the original (hardware intrinsic) routines. pragma Convention (C, Clear_Interlocked); pragma Inline_Always (Clear_Interlocked); diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb index c0f53b15657..50b5e63548c 100644 --- a/gcc/ada/s-fatgen.adb +++ b/gcc/ada/s-fatgen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -302,12 +302,12 @@ package body System.Fat_Gen is Ex : UI := Adjustment; begin - if Adjustment < T'Machine_Emin then + if Adjustment < T'Machine_Emin - 1 then Y := 2.0 ** T'Machine_Emin; Y1 := Y; Ex := Ex - T'Machine_Emin; - while Ex <= 0 loop + while Ex < 0 loop Y := T'Machine (Y / 2.0); if Y = 0.0 then @@ -337,6 +337,9 @@ package body System.Fat_Gen is if Radix_Digits >= T'Machine_Mantissa then return X; + elsif Radix_Digits <= 0 then + raise Constraint_Error; + else L := Exponent (X) - Radix_Digits; Y := Truncation (Scaling (X, -L)); @@ -433,6 +436,10 @@ package body System.Fat_Gen is P_Even : Boolean; begin + if Y = 0.0 then + raise Constraint_Error; + end if; + if X > 0.0 then Sign_X := 1.0; Arg := X; diff --git a/gcc/ada/s-maccod.ads b/gcc/ada/s-maccod.ads index b08c3bb17b2..0c970d65824 100644 --- a/gcc/ada/s-maccod.ads +++ b/gcc/ada/s-maccod.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This package provides machine code support, both for instrinsic machine +-- This package provides machine code support, both for intrinsic machine -- operations, and also for machine code statements. See GNAT documentation -- for full details. diff --git a/gcc/ada/s-stchop-vxworks.adb b/gcc/ada/s-stchop-vxworks.adb index 3c3c84e8980..a5cb67a927b 100644 --- a/gcc/ada/s-stchop-vxworks.adb +++ b/gcc/ada/s-stchop-vxworks.adb @@ -122,6 +122,7 @@ package body System.Stack_Checking.Operations is Td_ErrorStatus : Interfaces.C.int; -- most recent task error status Td_Delay : Interfaces.C.int; -- delay/timeout ticks end record; + pragma Convention (C, Task_Descriptor); -- This VxWorks procedure fills in a specified task descriptor -- for a specified task. diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb index 97705c1f834..d63a9454b96 100644 --- a/gcc/ada/s-taenca.adb +++ b/gcc/ada/s-taenca.adb @@ -154,7 +154,7 @@ package body System.Tasking.Entry_Calls is use type Ada.Exceptions.Exception_Id; procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); - pragma Import (C, Internal_Raise, "__gnat_raise_after_setup"); + pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); E : constant Ada.Exceptions.Exception_Id := Entry_Call.Exception_To_Raise; diff --git a/gcc/ada/s-unstyp.ads b/gcc/ada/s-unstyp.ads index 5edeeb83412..7617c9ac466 100644 --- a/gcc/ada/s-unstyp.ads +++ b/gcc/ada/s-unstyp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -88,7 +88,7 @@ pragma Pure (Unsigned_Types); -- Types used for packed array conversions subtype Bytes_F is Packed_Bytes4 (1 .. Float'Size / 8); - -- Type used in implementation of Is_Negative instrinsic (see Exp_Intr) + -- Type used in implementation of Is_Negative intrinsic (see Exp_Intr) function Shift_Left (Value : Short_Short_Unsigned; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 25285378550..18c6177724f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -671,12 +671,8 @@ package body Sem_Attr is -- object, and that the expression, if present, is static -- and within the range of the dimensions of the type. - if Is_Array_Type (P_Type) then - Index := First_Index (P_Base_Type); - - else pragma Assert (Is_Access_Type (P_Type)); - Index := First_Index (Base_Type (Designated_Type (P_Type))); - end if; + pragma Assert (Is_Array_Type (P_Type)); + Index := First_Index (P_Base_Type); if No (E1) then @@ -722,6 +718,7 @@ package body Sem_Attr is -- Normal case of array type or subtype Check_Either_E0_Or_E1; + Check_Dereference; if Is_Array_Type (P_Type) then if not Is_Constrained (P_Type) @@ -740,26 +737,18 @@ package body Sem_Attr is D := Number_Dimensions (P_Type); - elsif Is_Access_Type (P_Type) - and then Is_Array_Type (Designated_Type (P_Type)) - then - if Is_Entity_Name (P) and then Is_Type (Entity (P)) then - Error_Attr ("prefix of % attribute cannot be access type", P); - end if; - - D := Number_Dimensions (Designated_Type (P_Type)); - - -- If there is an implicit dereference, then we must freeze - -- the designated type of the access type, since the type of - -- the referenced array is this type (see AI95-00106). - - Freeze_Before (N, Designated_Type (P_Type)); - else if Is_Private_Type (P_Type) then Error_Attr ("prefix for % attribute may not be private type", P); + elsif Is_Access_Type (P_Type) + and then Is_Array_Type (Designated_Type (P_Type)) + and then Is_Entity_Name (P) + and then Is_Type (Entity (P)) + then + Error_Attr ("prefix of % attribute cannot be access type", P); + elsif Attr_Id = Attribute_First or else Attr_Id = Attribute_Last @@ -874,6 +863,13 @@ package body Sem_Attr is Resolve (P); if Is_Access_Type (P_Type) then + + -- If there is an implicit dereference, then we must freeze + -- the designated type of the access type, since the type of + -- the referenced array is this type (see AI95-00106). + + Freeze_Before (N, Designated_Type (P_Type)); + Rewrite (P, Make_Explicit_Dereference (Sloc (P), Prefix => Relocate_Node (P))); @@ -1861,6 +1857,7 @@ package body Sem_Attr is -- If the prefix is a selected component whose prefix is of an -- access type, then introduce an explicit dereference. + -- ??? Could we reuse Check_Dereference here? if Nkind (Pref) = N_Selected_Component and then Is_Access_Type (Ptyp) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 8a531409b71..6f1083acda8 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -9531,7 +9531,6 @@ package body Sem_Ch12 is -- inlining. Rewrite (N, New_Copy (N2)); - Set_Associated_Node (N, N2); Set_Analyzed (N, False); end if; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b81cac9052d..ea0991faa29 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1696,6 +1696,13 @@ package body Sem_Ch3 is Set_Is_True_Constant (Id, True); + -- If we are analyzing a constant declaration, set its completion + -- flag after analyzing the expression. + + if Constant_Present (N) then + Set_Has_Completion (Id); + end if; + if not Assignment_OK (N) then Check_Initialization (T, E); end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index e6973652360..d0a5b63e377 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -691,6 +691,12 @@ package body Sem_Ch7 is -- Child and Unit are entities of compilation units. True if Child -- is a public child of Parent as defined in 10.1.1 + procedure Inspect_Deferred_Constant_Completion; + -- Examines the deferred constants in the private part of the + -- package specification. Emits the error "constant declaration + -- requires initialization expression " if not completed by an + -- import pragma. + --------------------- -- Clear_Constants -- --------------------- @@ -793,6 +799,42 @@ package body Sem_Ch7 is end if; end Is_Public_Child; + -------------------------------------------- + -- Inspect_Deferred_Constant_Completion -- + -------------------------------------------- + + procedure Inspect_Deferred_Constant_Completion is + Decl : Node_Id; + begin + + Decl := First (Priv_Decls); + while Present (Decl) loop + + -- Deferred constant signature + + if Nkind (Decl) = N_Object_Declaration + and then Constant_Present (Decl) + and then No (Expression (Decl)) + + -- No need to check internally generated constants + + and then Comes_From_Source (Decl) + + -- The constant is not completed. A full object declaration + -- or a pragma Import complete a deferred constant. + + and then not Has_Completion (Defining_Identifier (Decl)) + then + Error_Msg_N + ("constant declaration requires initialization expression", + Defining_Identifier (Decl)); + + end if; + + Decl := Next (Decl); + end loop; + end Inspect_Deferred_Constant_Completion; + -- Start of processing for Analyze_Package_Specification begin @@ -887,6 +929,11 @@ package body Sem_Ch7 is Analyze_Declarations (Priv_Decls); + -- Check the private declarations for incomplete deferred + -- constants. + + Inspect_Deferred_Constant_Completion; + -- The first private entity is the immediate follower of the last -- visible entity, if there was one. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 1b0d7b17511..78aceb63e20 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1436,7 +1436,7 @@ package body Sem_Ch8 is Set_Alias (New_S, Old_S); end if; - -- Note that we do not set Is_Instrinsic_Subprogram if we have + -- Note that we do not set Is_Intrinsic_Subprogram if we have -- a renaming as body, since the entity in this case is not an -- intrinsic (it calls an intrinsic, but we have a real body -- for this call, and it is in this body that the required diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c5ee33c867f..8501a71c72c 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2705,6 +2705,12 @@ package body Sem_Prag is Set_Is_Public (Def_Id); Process_Interface_Name (Def_Id, Arg3, Arg4); + -- pragma Import completes deferred constants + + if Ekind (Def_Id) = E_Constant then + Set_Has_Completion (Def_Id); + end if; + -- It is not possible to import a constant of an unconstrained -- array type (e.g. string) because there is no simple way to -- write a meaningful subtype for it. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 0dcea1dfa9a..53574d60673 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6355,6 +6355,7 @@ package body Sem_Res is if Warn_On_Redundant_Constructs and then Comes_From_Source (Orig_N) and then Nkind (Orig_N) = N_Type_Conversion + and then not In_Instance then Orig_N := Original_Node (Expression (Orig_N)); Orig_T := Target_Type; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 22c5f885dd7..d7e5f3b3ee8 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -42,7 +42,7 @@ with Nmake; use Nmake; with Output; use Output; with Opt; use Opt; with Restrict; use Restrict; -with Rtsfind; use Rtsfind; +with Rtsfind; use Rtsfind; with Scans; use Scans; with Scn; use Scn; with Sem; use Sem; diff --git a/gcc/ada/symbols-vms-alpha.adb b/gcc/ada/symbols-vms-alpha.adb index c623e42b383..0f0c6240f26 100644 --- a/gcc/ada/symbols-vms-alpha.adb +++ b/gcc/ada/symbols-vms-alpha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2004 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- -- @@ -229,25 +229,52 @@ package body Symbols is Success := True; - -- If policy is not autonomous, attempt to read the reference file + -- If policy is Compliant or Controlled, attempt to read the reference + -- file. If policy is Restricted, attempt to read the symbol file. if Sym_Policy /= Autonomous then - begin - Open (File, In_File, Reference); + case Sym_Policy is + when Autonomous => + null; - exception - when Ada.Text_IO.Name_Error => - return; + when Compliant | Controlled => + begin + Open (File, In_File, Reference); - when X : others => - if not Quiet then - Put_Line ("could not open """ & Reference & """"); - Put_Line (Exception_Message (X)); - end if; + exception + when Ada.Text_IO.Name_Error => + Success := False; + return; - Success := False; - return; - end; + when X : others => + if not Quiet then + Put_Line ("could not open """ & Reference & """"); + Put_Line (Exception_Message (X)); + end if; + + Success := False; + return; + end; + + when Restricted => + begin + Open (File, In_File, Symbol_File); + + exception + when Ada.Text_IO.Name_Error => + Success := False; + return; + + when X : others => + if not Quiet then + Put_Line ("could not open """ & Symbol_File & """"); + Put_Line (Exception_Message (X)); + end if; + + Success := False; + return; + end; + end case; -- Read line by line @@ -637,7 +664,7 @@ package body Symbols is """ is no longer present in the object files"); end if; - if Sym_Policy = Controlled then + if Sym_Policy = Controlled or else Sym_Policy = Restricted then Success := False; return; @@ -656,78 +683,83 @@ package body Symbols is end if; end loop; - -- Append additional symbols, if any, to the Original_Symbols table + if Sym_Policy /= Restricted then - for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop - S_Data := Complete_Symbols.Table (Index); + -- Append additional symbols, if any, to the Original_Symbols + -- table. - if S_Data.Present then + for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop + S_Data := Complete_Symbols.Table (Index); - if Sym_Policy = Controlled then - Put_Line ("symbol """ & S_Data.Name.all & - """ is not in the reference symbol file"); - Success := False; - return; + if S_Data.Present then - elsif Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; + if Sym_Policy = Controlled then + Put_Line ("symbol """ & S_Data.Name.all & + """ is not in the reference symbol file"); + Success := False; + return; + + elsif Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + + Symbol_Table.Increment_Last (Original_Symbols); + Original_Symbols.Table + (Symbol_Table.Last (Original_Symbols)) := S_Data; + Complete_Symbols.Table (Index).Present := False; end if; + end loop; - Symbol_Table.Increment_Last (Original_Symbols); - Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) := - S_Data; - Complete_Symbols.Table (Index).Present := False; - end if; - end loop; + -- Create the symbol file - -- Create the symbol file + Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all); - Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all); + Put (File, Case_Sensitive); + Put_Line (File, "yes"); - Put (File, Case_Sensitive); - Put_Line (File, "yes"); + -- Put a line in the symbol file for each symbol in the symbol + -- table. - -- Put a line in the symbol file for each symbol in the symbol table + for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop + if Original_Symbols.Table (Index).Present then + Put (File, Symbol_Vector); + Put (File, Original_Symbols.Table (Index).Name.all); - for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop - if Original_Symbols.Table (Index).Present then - Put (File, Symbol_Vector); - Put (File, Original_Symbols.Table (Index).Name.all); + if Original_Symbols.Table (Index).Kind = Data then + Put_Line (File, Equal_Data); - if Original_Symbols.Table (Index).Kind = Data then - Put_Line (File, Equal_Data); + else + Put_Line (File, Equal_Procedure); + end if; - else - Put_Line (File, Equal_Procedure); + Free (Original_Symbols.Table (Index).Name); end if; + end loop; - Free (Original_Symbols.Table (Index).Name); - end if; - end loop; - - Put (File, Case_Sensitive); - Put_Line (File, "NO"); + Put (File, Case_Sensitive); + Put_Line (File, "NO"); - -- Put the version IDs + -- Put the version IDs - Put (File, Gsmatch); - Put (File, Image (Major_ID)); - Put (File, ','); - Put_Line (File, Image (Minor_ID)); + Put (File, Gsmatch); + Put (File, Image (Major_ID)); + Put (File, ','); + Put_Line (File, Image (Minor_ID)); - -- And we are done + -- And we are done - Close (File); + Close (File); - -- Reset both tables + -- Reset both tables - Symbol_Table.Set_Last (Original_Symbols, 0); - Symbol_Table.Set_Last (Complete_Symbols, 0); + Symbol_Table.Set_Last (Original_Symbols, 0); + Symbol_Table.Set_Last (Complete_Symbols, 0); - -- Clear the symbol file name + -- Clear the symbol file name - Free (Symbol_File_Name); + Free (Symbol_File_Name); + end if; Success := True; end if; diff --git a/gcc/ada/symbols.ads b/gcc/ada/symbols.ads index 73fa2c8863c..81a87d00b6a 100644 --- a/gcc/ada/symbols.ads +++ b/gcc/ada/symbols.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2004 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- -- @@ -44,9 +44,13 @@ package Symbols is -- all symbols are already found in the reference file or with an -- incremented minor ID, if not. - Controlled); + Controlled, -- Fail if symbols are not the same as those in the reference file + Restricted); + -- Restrict the symbols to those in the symbol file. Fail if some + -- symbols in the symbol file are not exported from the object files. + type Symbol_Kind is (Data, Proc); -- To distinguish between the different kinds of symbols |