From aa720a546a2945095bfa7a8cfb2b0f1a4021763a Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 5 May 2004 12:09:56 +0200 Subject: [PATCH] [multiple changes] 2004-05-05 Emmanuel Briot * g-os_lib.ads (Invalid_Time): New constant * adaint.h, adaint.c (__gnat_file_time_name, __gnat_file_time_fd): Now return OS_Time instead of time_t to match what is imported by Ada. Now return -1 if the file doesn't exist, instead of a random value 2004-05-05 Robert Dewar * usage.adb: Add line for -gnatR?s switch * sem_ch13.adb, exp_ch2.adb: Minor reformatting * g-regpat.ads, g-regpat.adb: Add documentation on handling of Size and for Match (Data_First, Data_last) * lib-writ.adb (Write_With_Lines): Ensure that correct index number is written when we are dealing with multi-unit files. 2004-05-05 Jerome Guitton * Makefile.in: Remove unused targets and variables. 2004-05-05 Vincent Celier * switch-m.adb: New gnatmake switch -eI * vms_data.ads: Add VMS equivalents of new gnatclean swith -innn and of new gnatmake switch -eInnn. * makegpr.adb: Take into account new parameters Index and Src_Index in Prj.Util. * clean.adb: Implement support for multi-unit sources, including new switch -i. * gnatcmd.adb (GNATCmd): Call Prj.Util.Value_Of with new parameter Src_Index. * make.ads, make.adb (Insert_Q): New parameter Index, defaulted to 0 (Extract_From_Q): New out parameter Index (Mark, Is_Marked): Subprograms moved to Makeutl (Switches_Of): New parameter Source_Index (Add_Switch): New parameter Index (Check): New parameter Source_Index (Collect_Arguments): New parameter Source_Index (Collect_Arguments_And_Compile): New parameter Source_Index (Compile): New parameter Source_Index Put subprograms in alphabetical order Add support for multi-source sources, including in project files. * makeutl.ads, makeutl.adb (Unit_Index_Of): New function (Mark, Is_Marked, Delete_All_Marks): New subprograms, moved from Make. * makeusg.adb: New gnatmake switch -eInnn * mlib-prj.adb (Build_Library): Add new parameter Src_Index to call to Prj.Util.Value_Of. * opt.ads (Main_Index): New variable, defaulted to 0. * osint.ads, osinte.adb (Add_File): New parameter Index (Current_Source_Index): New function * prj.adb: Take into account new components Index and Src_Index * prj.ads (String_Element): New component Index (Variable_Value): New component Index (Array_Element): New component Src_Index * prj-attr.adb: Indicate that optional index may be specified for attributes Main, Executable, Spec, Body and some of Switches. * prj-attr.ads (Attribute_Kind): New values for optional indexes (Attribute_Record): New component Optional_Index * prj-com.ads (File_Name_Data): New component Index * prj-dect.adb (Parse_Attribute_Declaration): Process optional index * prj-env.adb (Put): Output optional index * prj-makr.adb: Put indexes for multi-unit sources in SFN pragmas and attributes Spec and Body. * prj-nmsc.adb: Process optional indexes * prj-pp.adb: Ouput "at" for optional indexes * prj-proc.adb: Take into account optional indexes * prj-strt.ads, prj-strt.adb (Terms): New Boolean parameter Optional_Index. For string literal, process optional index when Optional_Index is True. (Parse_Expresion): New Boolean parameter Optional_Index * prj-tree.ads, prj-tree.adb (Source_Index_Of): New function (Set_Source_Index_Of): New procedure * prj-util.adb (Executable_Of, Value_Of): Take into account optional index. * prj-util.ads (Executable_Of): New parameter Index (Value_Of (Name_Id, Array_Element_Id) returning Variable_Value): New parameter Src_Index, defaulted to 0. 2004-05-05 Ed Schonberg PR ada/15257 * sem_ch3.adb (Access_Definition): If this is an access parameter whose designated type is imported through a limited_with clause, do not add the enclosing subprogram to the list of private dependents of the type. 2004-05-05 Ed Schonberg PR ada/15258 * sem_ch6.adb (Base_Types_Match): True if one type is imported through a limited_with clause, and the other is its non-limited view. 2004-05-05 Thomas Quinot * cstand.adb (Create_Standard): Initialize Stand.Boolean_Literals. * exp_attr.adb, exp_ch5.adb, exp_ch9.adb, exp_disp.adb, exp_fixd.adb, sem_attr.adb, sem_dist.adb, sem_util.adb: Use Stand.Boolean_Literals to produce references to entities Standard_False and Standard_True from compile-time computed boolean values. * stand.ads (Boolean_Literals): New variable, provides the entity values for False and True, for use by the expander. 2004-05-05 Doug Rupp * 5vinmaop.adb, 5[vx]system.ads: Add Short_Address subtype 5vinmaop.adb: Unchecked convert Short_Address vice Address * adaint.c, raise.c: Caste CRTL function return value to avoid gcc error on 32/64 bit IVMS. * Makefile.in [VMS]: Use iar archiver if host = Alpha/VMS and target = IA64/VMS. * init.c[VMS]: Only call Alpha specific __gnat_error_prehandler IN_RTS. * 5qsystem.ads (Address): Declare as Long_Integer (Short_Address): Declare as 32 bit subtype of Address Declare abstract address operations to avoid gratuitous ambiguities. 2004-05-05 Jose Ruiz * gnat_rm.texi: Use the new restriction Simple_Barriers (AI-249) instead of the old Boolean_Entry_Barriers. Ditto for No_Task_Attributes_Package instead of No_Task_Attributes. 2004-05-05 GNAT Script * Make-lang.in: Makefile automatically updated From-SVN: r81519 --- gcc/ada/5qsystem.ads | 18 +- gcc/ada/5vinmaop.adb | 2 +- gcc/ada/5vsystem.ads | 3 +- gcc/ada/5xsystem.ads | 3 +- gcc/ada/ChangeLog | 162 ++++++++++ gcc/ada/Make-lang.in | 25 +- gcc/ada/Makefile.in | 261 +--------------- gcc/ada/adaint.c | 35 ++- gcc/ada/adaint.h | 7 +- gcc/ada/clean.adb | 399 +++++++++++++++---------- gcc/ada/cstand.adb | 5 + gcc/ada/exp_attr.adb | 26 +- gcc/ada/exp_ch2.adb | 9 +- gcc/ada/exp_ch5.adb | 10 +- gcc/ada/exp_ch9.adb | 13 +- gcc/ada/exp_disp.adb | 26 +- gcc/ada/exp_fixd.adb | 14 +- gcc/ada/g-os_lib.ads | 7 + gcc/ada/g-regpat.adb | 22 +- gcc/ada/g-regpat.ads | 208 ++++++++----- gcc/ada/gnat_rm.texi | 34 +-- gcc/ada/gnatcmd.adb | 5 +- gcc/ada/init.c | 7 + gcc/ada/lib-writ.adb | 9 +- gcc/ada/make.adb | 686 +++++++++++++++++++++++-------------------- gcc/ada/make.ads | 7 +- gcc/ada/makegpr.adb | 233 +++++++++------ gcc/ada/makeusg.adb | 5 + gcc/ada/makeutl.adb | 120 ++++++++ gcc/ada/makeutl.ads | 22 ++ gcc/ada/mlib-prj.adb | 4 +- gcc/ada/opt.ads | 5 + gcc/ada/osint.adb | 16 +- gcc/ada/osint.ads | 12 +- gcc/ada/prj-attr.adb | 58 ++-- gcc/ada/prj-attr.ads | 15 +- gcc/ada/prj-com.ads | 1 + gcc/ada/prj-dect.adb | 50 +++- gcc/ada/prj-env.adb | 24 +- gcc/ada/prj-makr.adb | 211 +++++++------ gcc/ada/prj-nmsc.adb | 436 +++++++++++++++------------ gcc/ada/prj-pp.adb | 13 +- gcc/ada/prj-proc.adb | 24 +- gcc/ada/prj-strt.adb | 52 +++- gcc/ada/prj-strt.ads | 5 +- gcc/ada/prj-tree.adb | 41 ++- gcc/ada/prj-tree.ads | 13 + gcc/ada/prj-util.adb | 23 +- gcc/ada/prj-util.ads | 7 +- gcc/ada/prj.adb | 14 +- gcc/ada/prj.ads | 3 + gcc/ada/raise.c | 2 +- gcc/ada/sem_attr.adb | 43 +-- gcc/ada/sem_ch13.adb | 4 + gcc/ada/sem_ch3.adb | 9 +- gcc/ada/sem_ch6.adb | 13 + gcc/ada/sem_dist.adb | 17 +- gcc/ada/sem_util.adb | 7 +- gcc/ada/stand.ads | 5 +- gcc/ada/switch-m.adb | 6 + gcc/ada/usage.adb | 6 +- gcc/ada/vms_data.ads | 21 +- 62 files changed, 2105 insertions(+), 1438 deletions(-) diff --git a/gcc/ada/5qsystem.ads b/gcc/ada/5qsystem.ads index 4d17cdacde5..cfbba6d5c53 100644 --- a/gcc/ada/5qsystem.ads +++ b/gcc/ada/5qsystem.ads @@ -62,7 +62,10 @@ pragma Pure (System); -- Storage-related Declarations - type Address is private; + type Address is new Long_Integer; + subtype Short_Address is Address + range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; + for Short_Address'Object_Size use 32; Null_Address : constant Address; Storage_Unit : constant := 8; @@ -83,6 +86,18 @@ pragma Pure (System); pragma Import (Intrinsic, ">="); pragma Import (Intrinsic, "="); + -- Abstract declarations for arithmetic operations on type address. + -- These declarations are needed when Address is non-private. They + -- avoid excessive visibility of arithmetic operations on address + -- which are typically available elsewhere (e.g. Storage_Elements) + -- and which would cause excessive ambiguities in application code. + + function "+" (Left, Right : Address) return Address is abstract; + function "-" (Left, Right : Address) return Address is abstract; + function "/" (Left, Right : Address) return Address is abstract; + function "*" (Left, Right : Address) return Address is abstract; + function "mod" (Left, Right : Address) return Address is abstract; + -- Other System-Dependent Declarations type Bit_Order is (High_Order_First, Low_Order_First); @@ -101,7 +116,6 @@ pragma Pure (System); private - type Address is mod Memory_Size; Null_Address : constant Address := 0; -------------------------------------- diff --git a/gcc/ada/5vinmaop.adb b/gcc/ada/5vinmaop.adb index 3d770f2bed9..42207a1ce10 100644 --- a/gcc/ada/5vinmaop.adb +++ b/gcc/ada/5vinmaop.adb @@ -114,7 +114,7 @@ package body System.Interrupt_Management.Operations is -------------------- function To_unsigned_long is new - Unchecked_Conversion (System.Address, unsigned_long); + Unchecked_Conversion (System.Short_Address, unsigned_long); function Interrupt_Wait (Mask : access Interrupt_Mask) return Interrupt_ID diff --git a/gcc/ada/5vsystem.ads b/gcc/ada/5vsystem.ads index 3a66df33bfe..9bf3b5f2698 100644 --- a/gcc/ada/5vsystem.ads +++ b/gcc/ada/5vsystem.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS DEC Threads Version) -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -63,6 +63,7 @@ pragma Pure (System); -- Storage-related Declarations type Address is private; + subtype Short_Address is Address; Null_Address : constant Address; Storage_Unit : constant := 8; diff --git a/gcc/ada/5xsystem.ads b/gcc/ada/5xsystem.ads index c7fa20898df..a716fa1a708 100644 --- a/gcc/ada/5xsystem.ads +++ b/gcc/ada/5xsystem.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS GCC_ZCX DEC Threads Version) -- -- -- --- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2004 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -63,6 +63,7 @@ pragma Pure (System); -- Storage-related Declarations type Address is private; + subtype Short_Address is Address; Null_Address : constant Address; Storage_Unit : constant := 8; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d2b4da737e2..19d4b15b1f7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,165 @@ +2004-05-05 Emmanuel Briot + + * g-os_lib.ads (Invalid_Time): New constant + + * adaint.h, adaint.c (__gnat_file_time_name, __gnat_file_time_fd): Now + return OS_Time instead of time_t to match what is imported by Ada. + Now return -1 if the file doesn't exist, instead of a random value + +2004-05-05 Robert Dewar + + * usage.adb: Add line for -gnatR?s switch + + * sem_ch13.adb, exp_ch2.adb: Minor reformatting + + * g-regpat.ads, g-regpat.adb: Add documentation on handling of Size + and for Match (Data_First, Data_last) + + * lib-writ.adb (Write_With_Lines): Ensure that correct index number is + written when we are dealing with multi-unit files. + +2004-05-05 Jerome Guitton + + * Makefile.in: Remove unused targets and variables. + +2004-05-05 Vincent Celier + + * switch-m.adb: New gnatmake switch -eI + + * vms_data.ads: Add VMS equivalents of new gnatclean swith -innn and + of new gnatmake switch -eInnn. + + * makegpr.adb: Take into account new parameters Index and Src_Index in + Prj.Util. + + * clean.adb: Implement support for multi-unit sources, including new + switch -i. + + * gnatcmd.adb (GNATCmd): Call Prj.Util.Value_Of with new parameter + Src_Index. + + * make.ads, make.adb (Insert_Q): New parameter Index, defaulted to 0 + (Extract_From_Q): New out parameter Index + (Mark, Is_Marked): Subprograms moved to Makeutl + (Switches_Of): New parameter Source_Index + (Add_Switch): New parameter Index + (Check): New parameter Source_Index + (Collect_Arguments): New parameter Source_Index + (Collect_Arguments_And_Compile): New parameter Source_Index + (Compile): New parameter Source_Index + Put subprograms in alphabetical order + Add support for multi-source sources, including in project files. + + * makeutl.ads, makeutl.adb (Unit_Index_Of): New function + (Mark, Is_Marked, Delete_All_Marks): New subprograms, moved from + Make. + + * makeusg.adb: New gnatmake switch -eInnn + + * mlib-prj.adb (Build_Library): Add new parameter Src_Index to call to + Prj.Util.Value_Of. + + * opt.ads (Main_Index): New variable, defaulted to 0. + + * osint.ads, osinte.adb (Add_File): New parameter Index + (Current_Source_Index): New function + + * prj.adb: Take into account new components Index and Src_Index + + * prj.ads (String_Element): New component Index + (Variable_Value): New component Index + (Array_Element): New component Src_Index + + * prj-attr.adb: Indicate that optional index may be specified for + attributes Main, Executable, Spec, Body and some of Switches. + + * prj-attr.ads (Attribute_Kind): New values for optional indexes + (Attribute_Record): New component Optional_Index + + * prj-com.ads (File_Name_Data): New component Index + + * prj-dect.adb (Parse_Attribute_Declaration): Process optional index + + * prj-env.adb (Put): Output optional index + + * prj-makr.adb: Put indexes for multi-unit sources in SFN pragmas and + attributes Spec and Body. + + * prj-nmsc.adb: Process optional indexes + + * prj-pp.adb: Ouput "at" for optional indexes + + * prj-proc.adb: Take into account optional indexes + + * prj-strt.ads, prj-strt.adb (Terms): New Boolean parameter + Optional_Index. For string literal, + process optional index when Optional_Index is True. + (Parse_Expresion): New Boolean parameter Optional_Index + + * prj-tree.ads, prj-tree.adb (Source_Index_Of): New function + (Set_Source_Index_Of): New procedure + + * prj-util.adb (Executable_Of, Value_Of): Take into account optional + index. + + * prj-util.ads (Executable_Of): New parameter Index + (Value_Of (Name_Id, Array_Element_Id) returning Variable_Value): + New parameter Src_Index, defaulted to 0. + +2004-05-05 Ed Schonberg + + PR ada/15257 + * sem_ch3.adb (Access_Definition): If this is an access parameter + whose designated type is imported through a limited_with clause, do + not add the enclosing subprogram to the list of private dependents of + the type. + +2004-05-05 Ed Schonberg + + PR ada/15258 + * sem_ch6.adb (Base_Types_Match): True if one type is imported through + a limited_with clause, and the other is its non-limited view. + +2004-05-05 Thomas Quinot + + * cstand.adb (Create_Standard): Initialize Stand.Boolean_Literals. + + * exp_attr.adb, exp_ch5.adb, exp_ch9.adb, exp_disp.adb, + exp_fixd.adb, sem_attr.adb, sem_dist.adb, sem_util.adb: Use + Stand.Boolean_Literals to produce references to entities + Standard_False and Standard_True from compile-time computed boolean + values. + + * stand.ads (Boolean_Literals): New variable, provides the entity + values for False and True, for use by the expander. + +2004-05-05 Doug Rupp + + * 5vinmaop.adb, 5[vx]system.ads: Add Short_Address subtype + 5vinmaop.adb: Unchecked convert Short_Address vice Address + + * adaint.c, raise.c: Caste CRTL function return value + to avoid gcc error on 32/64 bit IVMS. + + * Makefile.in [VMS]: Use iar archiver if host = Alpha/VMS and + target = IA64/VMS. + + * init.c[VMS]: Only call Alpha specific __gnat_error_prehandler IN_RTS. + + * 5qsystem.ads (Address): Declare as Long_Integer + (Short_Address): Declare as 32 bit subtype of Address + Declare abstract address operations to avoid gratuitous ambiguities. + +2004-05-05 Jose Ruiz + + * gnat_rm.texi: Use the new restriction Simple_Barriers (AI-249) + instead of the old Boolean_Entry_Barriers. + Ditto for No_Task_Attributes_Package instead of No_Task_Attributes. + +2004-05-05 GNAT Script + + * Make-lang.in: Makefile automatically updated + 2004-05-03 Arnaud Charlet * 50system.ads, 59system.ads, s-thread.ads: Removed, no longer used. diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index 751bc039586..5cf5d62d425 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -2953,10 +2953,10 @@ ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/urealp.adb + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \ ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ @@ -3457,14 +3457,15 @@ ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \ ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ ada/eval_fat.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \ - ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \ - ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ - ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_cat.ads ada/sem_ch8.ads ada/sem_eval.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_cat.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \ ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 41b5f5baee2..f35622436fe 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -549,40 +549,6 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb - EXTRA_HIE_NONE_TARGET_PAIRS= \ - system.ads<50system.ads - - EXTRA_RAVEN_SOURCES=i-vxwork.ads s-vxwork.ads - EXTRA_RAVEN_OBJS=i-vxwork.o s-vxwork.o - EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o - EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o - HIE_RAVEN_TARGET_PAIRS=\ - $(HIE_NONE_TARGET_PAIRS) \ - a-reatim.ads<1areatim.ads \ - a-reatim.adb<1areatim.adb \ - a-retide.adb<1aretide.adb \ - a-interr.adb<1ainterr.adb \ - s-interr.ads<1sinterr.ads \ - s-interr.adb<1sinterr.adb \ - s-taskin.ads<1staskin.ads \ - s-taskin.adb<1staskin.adb \ - s-taspri.ads<1staspri.ads \ - s-tarest.adb<1starest.adb \ - s-tposen.ads<1stposen.ads \ - s-tposen.adb<1stposen.adb \ - s-osinte.adb<1sosinte.adb \ - s-taprop.ads<1staprop.ads \ - s-taprop.adb<1staprop.adb \ - s-taprob.ads<1staprob.ads \ - s-taprob.adb<1staprob.adb \ - a-sytaco.ads<1asytaco.ads \ - a-sytaco.adb<1asytaco.adb \ - a-intnam.ads<4zintnam.ads \ - s-osinte.ads<5zosinte.ads \ - s-parame.ads<5zparame.ads \ - s-vxwork.ads<5pvxwork.ads \ - a-taside.adb<1ataside.adb \ - ifeq ($(strip $(filter-out yes,$(TRACE))),) LIBGNAT_TARGET_PAIRS += \ s-traces.adb<7straces.adb \ @@ -593,22 +559,6 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) endif endif -ifeq ($(strip $(filter-out powerpc% unknown elf,$(targ))),) - EXTRA_HIE_NONE_TARGET_PAIRS= \ - system.ads<59system.ads - - LIBGNAT_TARGET_PAIRS = \ - $(HIE_NONE_TARGET_PAIRS) -endif - -ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),) - EXTRA_HIE_NONE_TARGET_PAIRS= \ - system.ads<5rsystem.ads - - LIBGNAT_TARGET_PAIRS = \ - $(HIE_NONE_TARGET_PAIRS) -endif - ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),) LIBGNAT_TARGET_PAIRS = \ a-sytaco.ads<4zsytaco.ads \ @@ -1182,6 +1132,10 @@ ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(host))), soext = .exe hyphen = _ +ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),) +AR = iar +endif + .SUFFIXES: .sym .o.sym: @@ -1394,131 +1348,6 @@ include $(fsrcdir)/Makefile.rtl GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \ g-trasym.o memtrack.o -# Files which are suitable in no run time/hi integrity mode - -COMPILABLE_HIE_SOURCES= \ - system.ads \ - ada.ads \ - gnat.ads \ - g-souinf.ads \ - interfac.ads \ - i-c.ads \ - s-stoele.ads \ - s-stoele.adb \ - s-maccod.ads \ - s-unstyp.ads \ - s-fatflt.ads \ - s-fatlfl.ads \ - s-fatllf.ads \ - s-fatsfl.ads \ - s-secsta.ads \ - s-secsta.adb \ - a-tags.ads \ - a-tags.adb \ - a-except.ads \ - a-except.adb $(EXTRA_HIE_SOURCES) - -NON_COMPILABLE_HIE_SOURCES= \ - a-unccon.ads \ - a-uncdea.ads \ - s-fatgen.adb \ - s-fatgen.ads \ - unchconv.ads \ - s-atacco.ads \ - s-atacco.adb \ - unchdeal.ads - - -HIE_SOURCES = $(NON_COMPILABLE_HIE_SOURCES) $(COMPILABLE_HIE_SOURCES) - -# Object to generate for the HI run time - -HIE_OBJS = \ - system.o \ - ada.o \ - a-except.o \ - gnat.o \ - g-souinf.o \ - interfac.o \ - i-c.o \ - s-stoele.o \ - s-maccod.o \ - s-unstyp.o \ - s-fatflt.o \ - s-fatlfl.o \ - s-fatllf.o \ - s-fatsfl.o \ - s-secsta.o \ - a-tags.o $(EXTRA_HIE_OBJS) - -# Files which are needed in ravenscar mode - -COMPILABLE_RAVEN_SOURCES = \ -$(COMPILABLE_HIE_SOURCES) \ - s-parame.ads \ - s-parame.adb \ - s-purexc.ads \ - s-osinte.ads \ - s-osinte.adb \ - s-tasinf.ads \ - s-tasinf.adb \ - s-taspri.ads \ - s-taprop.ads \ - s-taprop.adb \ - s-taskin.ads \ - s-taskin.adb \ - s-interr.ads \ - s-interr.adb \ - a-interr.ads \ - a-interr.adb \ - a-intnam.ads \ - a-reatim.ads \ - a-reatim.adb \ - a-retide.ads \ - a-retide.adb \ - s-taprob.ads \ - s-taprob.adb \ - s-tposen.ads \ - s-tposen.adb \ - s-tasres.ads \ - s-tarest.ads \ - s-tarest.adb \ - a-sytaco.ads \ - a-sytaco.adb \ - a-taside.ads \ - a-taside.adb $(EXTRA_RAVEN_SOURCES) - -NON_COMPILABLE_RAVEN_SOURCES= $(NON_COMPILABLE_HIE_SOURCES) - -RAVEN_SOURCES = $(NON_COMPILABLE_RAVEN_SOURCES) $(COMPILABLE_RAVEN_SOURCES) - -# Objects to generate for the ravenscar run time - -RAVEN_LIBGNARL_OBJS = \ - s-parame.o \ - s-purexc.o \ - s-osinte.o \ - s-tasinf.o \ - s-taspri.o \ - s-taprop.o \ - s-taskin.o \ - s-interr.o \ - a-interr.o \ - a-intnam.o \ - a-reatim.o \ - a-retide.o \ - s-osinte.o \ - s-taprob.o \ - s-tposen.o \ - s-tasres.o \ - s-tarest.o \ - a-sytaco.o \ - a-taside.o $(EXTRA_RAVEN_OBJS) - -RAVEN_OBJS = \ - $(HIE_OBJS) \ - $(RAVEN_LIBGNARL_OBJS) - # Default run time files ADA_INCLUDE_SRCS =\ @@ -1878,88 +1707,6 @@ gnatlib: ../stamp-gnatlib1 ../stamp-gnatlib2 $(CHMOD) a-wx rts/*.ali touch ../stamp-gnatlib -HIE_NONE_TARGET_PAIRS=\ - a-except.ads<1aexcept.ads \ - a-except.adb<1aexcept.adb \ - a-tags.ads<1atags.ads \ - a-tags.adb<1atags.adb \ - s-secsta.ads<1ssecsta.ads \ - s-secsta.adb<1ssecsta.adb \ - i-c.ads<1ic.ads $(EXTRA_HIE_NONE_TARGET_PAIRS) - -# This target needs RTS_NAME, RTS_SRCS, RTS_TARGET_PAIRS to be set properly -# it creates a rts with the proper structure and the right target -# dependant srcs -prepare-rts: - $(RMDIR) rts-$(RTS_NAME) - $(MKDIR) rts-$(RTS_NAME) - $(CHMOD) u+w rts-$(RTS_NAME) - $(MKDIR) rts-$(RTS_NAME)/adalib - $(MKDIR) rts-$(RTS_NAME)/adainclude - $(CHMOD) u+w rts-$(RTS_NAME)/* -# Generate the project file - $(ECHO) "project $(RTS_NAME) is" > rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) " for Source_Dirs use (\"adainclude\");" \ - >> rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) " for Object_Dir use \"adalib\";" \ - >> rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) " for Source_List_File use " \ - >>rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) " \"rts-$(RTS_NAME)_source_list.txt\";" \ - >>rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) " package Builder is" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) " for Default_Switches (\"Ada\") use (\"-a\");" \ - >>rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) " end Builder;" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) " package Compiler is" >> rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) " for Default_Switches (\"Ada\") use (\"-nostdinc\");" \ - >>rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) " end Compiler;" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr - $(ECHO) "end $(RTS_NAME);" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr - - $(foreach f, $(COMPILABLE_SOURCES), \ - $(ECHO) $(f) >> \ - rts-$(RTS_NAME)/rts-$(RTS_NAME)_source_list.txt ;) true -# Copy target independent sources - $(foreach f,$(RTS_SRCS), \ - $(CP) $(fsrcpfx)$(f) rts-$(RTS_NAME)/adainclude/ ;) true -# Remove files to be replaced by target dependent sources - $(RM) $(foreach PAIR,$(RTS_TARGET_PAIRS), \ - rts-$(RTS_NAME)/adainclude/$(word 1,$(subst <, ,$(PAIR)))) -# Copy new target dependent sources - $(foreach PAIR,$(RTS_TARGET_PAIRS), \ - $(CP) $(fsrcpfx)$(word 2,$(subst <, ,$(PAIR))) \ - rts-$(RTS_NAME)/adainclude/$(word 1,$(subst <, ,$(PAIR)));) - -install-rts: force - $(CP) -r rts-$(RTS_NAME) $(DESTDIR)$(libsubdir)/ - -rts-zfp: force - $(MAKE) $(FLAGS_TO_PASS) prepare-rts \ - RTS_NAME=zfp RTS_SRCS="$(HIE_SOURCES)" \ - RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \ - COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)" - $(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../" - cd rts-zfp/adalib/ ; $(AR) r libgnat.a *.o - $(RM) rts-zfp/adalib/*.o - $(CHMOD) a-wx rts-zfp/adalib/*.ali - $(CHMOD) a-wx rts-zfp/adalib/libgnat.a - -rts-ravenscar: force - $(MAKE) $(FLAGS_TO_PASS) prepare-rts \ - RTS_NAME=ravenscar RTS_SRCS="$(RAVEN_SOURCES)" \ - RTS_TARGET_PAIRS="$(HIE_RAVEN_TARGET_PAIRS)" \ - COMPILABLE_SOURCES="$(COMPILABLE_RAVEN_SOURCES)" - $(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \ - --GCC="../../../xgcc -B../../../" - cd rts-ravenscar/adalib ; \ - $(foreach FILE,$(RAVEN_LIBGNARL_OBJS), $(AR) r libgnarl.a $(FILE);) \ - $(foreach FILE,$(HIE_OBJS), $(AR) r libgnat.a $(FILE);) - $(RM) rts-ravenscar/adalib/*.o - $(CHMOD) a-wx rts-ravenscar/adalib/*.ali - $(CHMOD) a-wx rts-ravenscar/adalib/libgnat.a - $(CHMOD) a-wx rts-ravenscar/adalib/libgnarl.a - # Warning: this target assumes that LIBRARY_VERSION has been set correctly. gnatlib-shared-default: $(MAKE) $(FLAGS_TO_PASS) \ diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 9ff14f2d847..7b8813ab6ee 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -862,7 +862,7 @@ win32_filetime (HANDLE h) /* Return a GNAT time stamp given a file name. */ -time_t +OS_Time __gnat_file_time_name (char *name) { @@ -870,7 +870,7 @@ __gnat_file_time_name (char *name) int fd = open (name, O_RDONLY | O_BINARY); time_t ret = __gnat_file_time_fd (fd); close (fd); - return ret; + return (OS_Time)ret; #elif defined (_WIN32) time_t ret = 0; @@ -882,22 +882,25 @@ __gnat_file_time_name (char *name) ret = win32_filetime (h); CloseHandle (h); } - return ret; + return (OS_Time) ret; #else struct stat statbuf; - (void) __gnat_stat (name, &statbuf); + if (__gnat_stat (name, &statbuf) != 0) { + return (OS_Time)-1; + } else { #ifdef VMS - /* VMS has file versioning. */ - return statbuf.st_ctime; + /* VMS has file versioning. */ + return (OS_Time)statbuf.st_ctime; #else - return statbuf.st_mtime; + return (OS_Time)statbuf.st_mtime; #endif + } #endif } /* Return a GNAT time stamp given a file descriptor. */ -time_t +OS_Time __gnat_file_time_fd (int fd) { /* The following workaround code is due to the fact that under EMX and @@ -965,24 +968,26 @@ __gnat_file_time_fd (int fd) tot_secs += file_hour * 3600; tot_secs += file_min * 60; tot_secs += file_tsec * 2; - return tot_secs; + return (OS_Time) tot_secs; #elif defined (_WIN32) HANDLE h = (HANDLE) _get_osfhandle (fd); time_t ret = win32_filetime (h); - return ret; + return (OS_Time) ret; #else struct stat statbuf; - (void) fstat (fd, &statbuf); - + if (fstat (fd, &statbuf) != 0) { + return (OS_Time) -1; + } else { #ifdef VMS - /* VMS has file versioning. */ - return statbuf.st_ctime; + /* VMS has file versioning. */ + return (OS_Time) statbuf.st_ctime; #else - return statbuf.st_mtime; + return (OS_Time) statbuf.st_mtime; #endif + } #endif } diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index b52191c356d..c45a5332309 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -70,8 +70,11 @@ extern long __gnat_named_file_length (char *); extern void __gnat_tmp_name (char *); extern char *__gnat_readdir (DIR *, char *); extern int __gnat_readdir_is_thread_safe (void); -extern time_t __gnat_file_time_name (char *); -extern time_t __gnat_file_time_fd (int); + +extern OS_Time __gnat_file_time_name (char *); +extern OS_Time __gnat_file_time_fd (int); +/* return -1 in case of error */ + extern void __gnat_set_file_time_name (char *, time_t); extern void __gnat_get_env_value_ptr (char *, int *, char **); diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 7759bbb82e2..53f82d0d416 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -24,10 +24,13 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Command_Line; use Ada.Command_Line; + with ALI; use ALI; with Csets; with Gnatvsn; with Hostparm; +with Makeutl; use Makeutl; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; @@ -43,12 +46,10 @@ with System; with Table; with Types; use Types; -with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.IO; use GNAT.IO; with GNAT.OS_Lib; use GNAT.OS_Lib; - package body Clean is Initialized : Boolean := False; @@ -136,15 +137,13 @@ package body Clean is procedure Init_Q; -- Must be called to initialize the Q - procedure Insert_Q - (Source_File : File_Name_Type); - -- If Source_File is not marked, inserts it at the end of Q and mark it + procedure Insert_Q (Lib_File : File_Name_Type); + -- If Lib_File is not marked, inserts it at the end of Q and mark it function Empty_Q return Boolean; -- Returns True if Q is empty. - procedure Extract_From_Q - (Source_File : out File_Name_Type); + procedure Extract_From_Q (Lib_File : out File_Name_Type); -- Extracts the first element from the Q. Q_Front : Natural; @@ -367,14 +366,14 @@ package body Clean is Main_Source_File : File_Name_Type; -- Current main source - Source_File : File_Name_Type; - -- Current source file + Main_Lib_File : File_Name_Type; + -- ALI file of the current main Lib_File : File_Name_Type; - -- Current library file + -- Current ALI file Full_Lib_File : File_Name_Type; - -- Full name of the current library file + -- Full name of the current ALI file Text : Text_Buffer_Ptr; The_ALI : ALI_Id; @@ -393,12 +392,13 @@ package body Clean is for N_File in 1 .. Osint.Number_Of_Files loop Main_Source_File := Next_Main_Source; - Insert_Q (Main_Source_File); + Main_Lib_File := Osint.Lib_File_Name + (Main_Source_File, Current_File_Index); + Insert_Q (Main_Lib_File); while not Empty_Q loop Sources.Set_Last (0); - Extract_From_Q (Source_File); - Lib_File := Osint.Lib_File_Name (Source_File); + Extract_From_Q (Lib_File); Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File); -- If we have an existing ALI file that is not read-only, @@ -428,7 +428,7 @@ package body Clean is for K in ALI.Units.Table (J).First_With .. ALI.Units.Table (J).Last_With loop - Insert_Q (Withs.Table (K).Sfile); + Insert_Q (Withs.Table (K).Afile); end loop; end loop; @@ -499,7 +499,7 @@ package body Clean is if not Compile_Only then declare - Source : constant Name_Id := Strip_Suffix (Main_Source_File); + Source : constant Name_Id := Strip_Suffix (Main_Lib_File); Executable : constant String := Get_Name_String (Executable_Name (Source)); begin @@ -529,7 +529,10 @@ package body Clean is Data : constant Project_Data := Projects.Table (Project); U_Data : Prj.Com.Unit_Data; File_Name1 : Name_Id; + Index1 : Int; File_Name2 : Name_Id; + Index2 : Int; + Lib_File : File_Name_Type; use Prj.Com; @@ -583,14 +586,18 @@ package body Clean is (U_Data.File_Names (Specification).Project, Project) then File_Name1 := U_Data.File_Names (Body_Part).Name; + Index1 := U_Data.File_Names (Body_Part).Index; File_Name2 := U_Data.File_Names (Specification).Name; + Index2 := U_Data.File_Names (Specification).Index; -- If there is no body file name, then there may be only a -- spec. if File_Name1 = No_Name then File_Name1 := File_Name2; + Index1 := Index2; File_Name2 := No_Name; + Index2 := 0; end if; end if; @@ -598,11 +605,13 @@ package body Clean is -- object directory. if File_Name1 /= No_Name then + Lib_File := Osint.Lib_File_Name (File_Name1, Index1); + declare - Asm : constant String := Assembly_File_Name (File_Name1); - ALI : constant String := ALI_File_Name (File_Name1); - Obj : constant String := Object_File_Name (File_Name1); - Adt : constant String := Tree_File_Name (File_Name1); + Asm : constant String := Assembly_File_Name (Lib_File); + ALI : constant String := ALI_File_Name (Lib_File); + Obj : constant String := Object_File_Name (Lib_File); + Adt : constant String := Tree_File_Name (Lib_File); Deb : constant String := Debug_File_Name (File_Name1); Rep : constant String := Repinfo_File_Name (File_Name1); Del : Boolean := True; @@ -776,7 +785,11 @@ package body Clean is Main_Source_File := Next_Main_Source; if not Compile_Only then - Executable := Executable_Of (Main_Project, Main_Source_File); + Executable := + Executable_Of + (Main_Project, + Main_Source_File, + Current_File_Index); if Is_Regular_File (Get_Name_String (Executable)) then Delete (Exec_Dir, Get_Name_String (Executable)); @@ -938,12 +951,12 @@ package body Clean is -- Extract_From_Q -- -------------------- - procedure Extract_From_Q (Source_File : out File_Name_Type) is - File : constant File_Name_Type := Q.Table (Q_Front); + procedure Extract_From_Q (Lib_File : out File_Name_Type) is + Lib : constant File_Name_Type := Q.Table (Q_Front); begin - Q_Front := Q_Front + 1; - Source_File := File; + Q_Front := Q_Front + 1; + Lib_File := Lib; end Extract_From_Q; --------------- @@ -1019,12 +1032,14 @@ package body Clean is if Main_Project /= No_Project and then Osint.Number_Of_Files = 0 then declare Value : String_List_Id := Projects.Table (Main_Project).Mains; - + Main : String_Element; begin while Value /= Prj.Nil_String loop - Get_Name_String (String_Elements.Table (Value).Value); - Osint.Add_File (Name_Buffer (1 .. Name_Len)); - Value := String_Elements.Table (Value).Next; + Main := String_Elements.Table (Value); + Osint.Add_File + (File_Name => Get_Name_String (Main.Value), + Index => Main.Index); + Value := Main.Next; end loop; end; end if; @@ -1152,19 +1167,17 @@ package body Clean is -- Insert_Q -- -------------- - procedure Insert_Q (Source_File : File_Name_Type) is + procedure Insert_Q (Lib_File : File_Name_Type) is begin -- Do not insert an empty name or an already marked source - if Source_File /= No_Name - and then Get_Name_Table_Byte (Source_File) = 0 - then - Q.Table (Q.Last) := Source_File; + if Lib_File /= No_Name and then not Is_Marked (Lib_File) then + Q.Table (Q.Last) := Lib_File; Q.Increment_Last; -- Mark the source that has been just added to the Q - Set_Name_Table_Byte (Source_File, 1); + Mark (Lib_File); end if; end Insert_Q; @@ -1196,165 +1209,236 @@ package body Clean is -------------------- procedure Parse_Cmd_Line is + Source_Index : Int := 0; + Index : Positive := 1; + Last : constant Natural := Argument_Count; begin - loop - case - GNAT.Command_Line.Getopt - ("aO: c D: F h I: I- n P: q r v vP0 vP1 vP2 X:") - is - when ASCII.NUL => - exit; + while Index <= Last loop + declare + Arg : constant String := Argument (Index); - when 'a' => - Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); + procedure Bad_Argument; + -- Signal bad argument - when 'c' => - Compile_Only := True; + ------------------ + -- Bad_Argument -- + ------------------ - when 'D' => - declare - Dir : constant String := GNAT.Command_Line.Parameter; + procedure Bad_Argument is + begin + Fail ("invalid argument """, Arg, """"); + end Bad_Argument; - begin - if Object_Directory_Path /= null then - Fail ("duplicate -D switch"); + begin + if Arg'Length /= 0 then + if Arg (1) = '-' then + if Arg'Length = 1 then + Bad_Argument; + end if; - elsif Project_File_Name /= null then - Fail ("-P and -D cannot be used simultaneously"); + case Arg (2) is + when 'a' => + if Arg'Length < 4 or else Arg (3) /= 'O' then + Bad_Argument; + end if; - elsif not Is_Directory (Dir) then - Fail (Dir, " is not a directory"); + Add_Lib_Search_Dir (Arg (3 .. Arg'Last)); - else - Add_Lib_Search_Dir (Dir); - end if; - end; + when 'c' => + Compile_Only := True; - when 'F' => - Full_Path_Name_For_Brief_Errors := True; + when 'D' => + if Object_Directory_Path /= null then + Fail ("duplicate -D switch"); - when 'h' => - Usage; + elsif Project_File_Name /= null then + Fail ("-P and -D cannot be used simultaneously"); + end if; - when 'I' => - if Full_Switch = "I-" then - Opt.Look_In_Primary_Dir := False; + if Arg'Length > 2 then + declare + Dir : constant String := Arg (3 .. Arg'Last); + begin + if not Is_Directory (Dir) then + Fail (Dir, " is not a directory"); + else + Add_Lib_Search_Dir (Dir); + end if; + end; - else - Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); - end if; + else + if Index = Last then + Fail ("no directory specified after -D"); + end if; - when 'n' => - Do_Nothing := True; + Index := Index + 1; - when 'P' => - if Project_File_Name /= null then - Fail ("multiple -P switches"); + declare + Dir : constant String := Argument (Index); + begin + if not Is_Directory (Dir) then + Fail (Dir, " is not a directory"); + else + Add_Lib_Search_Dir (Dir); + end if; + end; + end if; - elsif Object_Directory_Path /= null then - Fail ("-D and -P cannot be used simultaneously"); + when 'F' => + Full_Path_Name_For_Brief_Errors := True; - else - declare - Prj : constant String := GNAT.Command_Line.Parameter; - begin - if Prj'Length > 1 and then Prj (Prj'First) = '=' then - Project_File_Name := - new String'(Prj (Prj'First + 1 .. Prj'Last)); + when 'h' => + Usage; - else - Project_File_Name := new String'(Prj); - end if; - end; - end if; + when 'i' => + if Arg'Length = 2 then + Bad_Argument; + end if; - when 'q' => - Quiet_Output := True; + Source_Index := 0; - when 'r' => - All_Projects := True; + for J in 3 .. Arg'Last loop + if Arg (J) not in '0' .. '9' then + Bad_Argument; + end if; - when 'v' => - if Full_Switch = "v" then - Verbose_Mode := True; + Source_Index := + (20 * Source_Index) + + (Character'Pos (Arg (J)) - Character'Pos ('0')); + end loop; - elsif Full_Switch = "vP0" then - Prj.Com.Current_Verbosity := Prj.Default; + when 'I' => + if Arg = "-I-" then + Opt.Look_In_Primary_Dir := False; - elsif Full_Switch = "vP1" then - Prj.Com.Current_Verbosity := Prj.Medium; + else + if Arg'Length = 2 then + Bad_Argument; + end if; - else - Prj.Com.Current_Verbosity := Prj.High; - end if; + Add_Lib_Search_Dir (Arg (3 .. Arg'Last)); + end if; - when 'X' => - declare - Ext_Asgn : constant String := GNAT.Command_Line.Parameter; - Start : Positive := Ext_Asgn'First; - Stop : Natural := Ext_Asgn'Last; - Equal_Pos : Natural; - OK : Boolean := True; + when 'n' => + Do_Nothing := True; - begin - if Ext_Asgn (Start) = '"' then - if Ext_Asgn (Stop) = '"' then - Start := Start + 1; - Stop := Stop - 1; + when 'P' => + if Project_File_Name /= null then + Fail ("multiple -P switches"); - else - OK := False; - end if; - end if; + elsif Object_Directory_Path /= null then + Fail ("-D and -P cannot be used simultaneously"); - Equal_Pos := Start; + end if; - while Equal_Pos <= Stop and then - Ext_Asgn (Equal_Pos) /= '=' - loop - Equal_Pos := Equal_Pos + 1; - end loop; + if Arg'Length > 2 then + declare + Prj : constant String := Arg (3 .. Arg'Last); + begin + if Prj'Length > 1 and then + Prj (Prj'First) = '=' + then + Project_File_Name := + new String' + (Prj (Prj'First + 1 .. Prj'Last)); + else + Project_File_Name := new String'(Prj); + end if; + end; - if Equal_Pos = Start or else Equal_Pos > Stop then - OK := False; - end if; + else + if Index = Last then + Fail ("no project specified after -P"); + end if; - if OK then - Prj.Ext.Add - (External_Name => Ext_Asgn (Start .. Equal_Pos - 1), - Value => Ext_Asgn (Equal_Pos + 1 .. Stop)); + Index := Index + 1; + Project_File_Name := new String'(Argument (Index)); + end if; - else - Fail ("illegal external assignment '", Ext_Asgn, "'"); - end if; - end; + when 'q' => + Quiet_Output := True; - when others => - Fail ("INTERNAL ERROR, please report"); - end case; - end loop; + when 'r' => + All_Projects := True; - -- Get the file names + when 'v' => + if Arg = "-v" then + Verbose_Mode := True; - loop - declare - S : constant String := GNAT.Command_Line.Get_Argument; + elsif Arg = "-vP0" then + Prj.Com.Current_Verbosity := Prj.Default; - begin - exit when S'Length = 0; + elsif Arg = "-vP1" then + Prj.Com.Current_Verbosity := Prj.Medium; - Add_File (S); - end; - end loop; + elsif Arg = "-vP2" then + Prj.Com.Current_Verbosity := Prj.High; - exception - when GNAT.Command_Line.Invalid_Switch => - Usage; - Fail ("invalid switch : "& GNAT.Command_Line.Full_Switch); + else + Bad_Argument; + end if; - when GNAT.Command_Line.Invalid_Parameter => - Usage; - Fail ("parameter missing for : " & GNAT.Command_Line.Full_Switch); + when 'X' => + if Arg'Length = 2 then + Bad_Argument; + end if; + + declare + Ext_Asgn : constant String := Arg (3 .. Arg'Last); + Start : Positive := Ext_Asgn'First; + Stop : Natural := Ext_Asgn'Last; + Equal_Pos : Natural; + OK : Boolean := True; + + begin + if Ext_Asgn (Start) = '"' then + if Ext_Asgn (Stop) = '"' then + Start := Start + 1; + Stop := Stop - 1; + + else + OK := False; + end if; + end if; + + Equal_Pos := Start; + + while Equal_Pos <= Stop + and then Ext_Asgn (Equal_Pos) /= '=' + loop + Equal_Pos := Equal_Pos + 1; + end loop; + + if Equal_Pos = Start or else Equal_Pos > Stop then + OK := False; + end if; + + if OK then + Prj.Ext.Add + (External_Name => + Ext_Asgn (Start .. Equal_Pos - 1), + Value => + Ext_Asgn (Equal_Pos + 1 .. Stop)); + + else + Fail + ("illegal external assignment '", + Ext_Asgn, "'"); + end if; + end; + + when others => + Bad_Argument; + end case; + + else + Add_File (Arg, Source_Index); + end if; + end if; + end; + + Index := Index + 1; + end loop; end Parse_Cmd_Line; ----------------------- @@ -1398,7 +1482,7 @@ package body Clean is if not Usage_Displayed then Usage_Displayed := True; Display_Copyright; - Put_Line ("Usage: gnatclean [switches] names"); + Put_Line ("Usage: gnatclean [switches] {[-innn] name}"); New_Line; Put_Line (" names is one or more file names from which " & @@ -1411,6 +1495,7 @@ package body Clean is Put_Line (" -F Full project path name " & "in brief error messages"); Put_Line (" -h Display this message"); + Put_Line (" -innn Index of unit in source for following names"); Put_Line (" -n Nothing to do: only list files to delete"); Put_Line (" -Pproj Use GNAT Project File proj"); Put_Line (" -q Be quiet/terse"); diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 7c133248c07..b7d1c90eb5c 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -402,6 +402,11 @@ package body CStand is Set_Etype (R_Node, Standard_Boolean); Set_Parent (R_Node, Standard_Boolean); + -- Record entity identifiers for boolean literals in the + -- Boolean_Literals array, for easy reference during expansion. + + Boolean_Literals := (False => Standard_False, True => Standard_True); + -- Create type definition nodes for predefined integer types Build_Signed_Integer_Type diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 040377e2f6d..edf358ef1b2 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1182,13 +1182,8 @@ package body Exp_Attr is Res := Is_Constrained (Etype (Ent)); end if; - if Res then - Rewrite (N, - New_Reference_To (Standard_True, Loc)); - else - Rewrite (N, - New_Reference_To (Standard_False, Loc)); - end if; + Rewrite (N, + New_Reference_To (Boolean_Literals (Res), Loc)); end; -- Prefix is not an entity name. These are also cases where @@ -1196,16 +1191,13 @@ package body Exp_Attr is -- and type of the prefix. else - if not Is_Variable (Pref) - or else Nkind (Pref) = N_Explicit_Dereference - or else Is_Constrained (Etype (Pref)) - then - Rewrite (N, - New_Reference_To (Standard_True, Loc)); - else - Rewrite (N, - New_Reference_To (Standard_False, Loc)); - end if; + Rewrite (N, + New_Reference_To ( + Boolean_Literals ( + not Is_Variable (Pref) + or else Nkind (Pref) = N_Explicit_Dereference + or else Is_Constrained (Etype (Pref))), + Loc)); end if; Analyze_And_Resolve (N, Standard_Boolean); diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 57881093916..7192cb9a333 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -218,12 +218,13 @@ package body Exp_Ch2 is and then Nkind (Parent (N)) /= N_Pragma_Argument_Association - -- Same for Asm_Input and Asm_Output attribute references. + -- Same for Asm_Input and Asm_Output attribute references and then not (Nkind (Parent (N)) = N_Attribute_Reference - and then (Attribute_Name (Parent (N)) = Name_Asm_Input - or else Attribute_Name (Parent (N)) = Name_Asm_Output)) - + and then + (Attribute_Name (Parent (N)) = Name_Asm_Input + or else + Attribute_Name (Parent (N)) = Name_Asm_Output)) then -- Case of Current_Value is a compile time known value diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 08ec7d507b5..4a08a28477b 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -702,13 +702,9 @@ package body Exp_Ch5 is Duplicate_Subexpr (Right_Lo, Name_Req => True), Duplicate_Subexpr (Right_Hi, Name_Req => True)); - if Forwards_OK (N) then - Append_To (Actuals, - New_Occurrence_Of (Standard_False, Loc)); - else - Append_To (Actuals, - New_Occurrence_Of (Standard_True, Loc)); - end if; + Append_To (Actuals, + New_Occurrence_Of ( + Boolean_Literals (not Forwards_OK (N)), Loc)); Rewrite (N, Make_Procedure_Call_Statement (Loc, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index d0eb4394697..d8c43df42ad 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -5735,19 +5735,16 @@ package body Exp_Ch9 is RTS_Call : Entity_Id; begin - if Abort_Present (N) then - Abortable := New_Occurrence_Of (Standard_True, Loc); - else - Abortable := New_Occurrence_Of (Standard_False, Loc); - end if; + Abortable := + New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc); - -- Set up the target object. + -- Set up the target object Extract_Entry (N, Concval, Ename, Index); Conctyp := Etype (Concval); New_Param := Concurrent_Ref (Concval); - -- The target entry index and abortable flag are the same for all cases. + -- The target entry index and abortable flag are the same for all cases Params := New_List ( Entry_Index_Expression (Loc, Entity (Ename), Index, Conctyp), @@ -5804,7 +5801,7 @@ package body Exp_Ch9 is end if; end loop; - -- Create the GNARLI call. + -- Create the GNARLI call Rcall := Make_Procedure_Call_Statement (Loc, Name => diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 0d203b6d289..fb8f6be31e0 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.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- -- @@ -876,24 +876,22 @@ package body Exp_Disp is Node2 => Position))); end; - -- Generate: Set_Remotely_Callable (DT_Ptr, status); - -- where status is described in E.4 (18) + -- Generate: Set_Remotely_Callable (DT_Ptr, Status); + -- where Status is described in E.4 (18) declare Status : Entity_Id; begin - if Is_Pure (Typ) - or else Is_Shared_Passive (Typ) - or else - ((Is_Remote_Types (Typ) or else Is_Remote_Call_Interface (Typ)) - and then Original_View_In_Visible_Part (Typ)) - or else not Comes_From_Source (Typ) - then - Status := Standard_True; - else - Status := Standard_False; - end if; + Status := + Boolean_Literals + (Is_Pure (Typ) + or else Is_Shared_Passive (Typ) + or else + ((Is_Remote_Types (Typ) + or else Is_Remote_Call_Interface (Typ)) + and then Original_View_In_Visible_Part (Typ)) + or else not Comes_From_Source (Typ)); Append_To (Elab_Code, Make_DT_Access_Action (Typ, diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 41158104beb..75357a2f3ab 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 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- -- @@ -561,11 +561,7 @@ package body Exp_Fixd is -- call the runtime routine to compute the quotient and remainder else - if Rounded_Result_Set (N) then - Rnd := Standard_True; - else - Rnd := Standard_False; - end if; + Rnd := Boolean_Literals (Rounded_Result_Set (N)); Code := New_List ( Make_Object_Declaration (Loc, @@ -947,11 +943,7 @@ package body Exp_Fixd is -- call the runtime routine to compute the quotient and remainder else - if Rounded_Result_Set (N) then - Rnd := Standard_True; - else - Rnd := Standard_False; - end if; + Rnd := Boolean_Literals (Rounded_Result_Set (N)); Code := New_List ( Make_Object_Declaration (Loc, diff --git a/gcc/ada/g-os_lib.ads b/gcc/ada/g-os_lib.ads index 6cd6b82f787..a8968c25c6c 100644 --- a/gcc/ada/g-os_lib.ads +++ b/gcc/ada/g-os_lib.ads @@ -103,6 +103,7 @@ pragma Elaborate_Body (OS_Lib); -- file (of course in Unix systems, this *is* in GMT form). type OS_Time is private; + Invalid_Time : constant OS_Time; subtype Year_Type is Integer range 1900 .. 2099; subtype Month_Type is Integer range 1 .. 12; @@ -368,9 +369,11 @@ pragma Elaborate_Body (OS_Lib); function File_Time_Stamp (Name : String) return OS_Time; -- Given the name of a file or directory, Name, obtains and returns the -- time stamp. This function can be used for an unopened file. + -- Returns Invalid_Time is Name doesn't correspond to an existing file. function File_Time_Stamp (FD : File_Descriptor) return OS_Time; -- Get time stamp of file from file descriptor FD + -- Returns Invalid_Time is FD doesn't correspond to an existing file. function Normalize_Pathname (Name : String; @@ -542,6 +545,7 @@ pragma Elaborate_Body (OS_Lib); Success : out Boolean); function File_Time_Stamp (Name : C_File_Name) return OS_Time; + -- Returns Invalid_Time is Name doesn't correspond to an existing file. function Is_Regular_File (Name : C_File_Name) return Boolean; @@ -735,6 +739,9 @@ private -- but this was not properly supported till GNAT 3.15a, so that would -- cause bootstrap path problems. To be changed later ??? + Invalid_Time : constant OS_Time := -1; + -- This value should match the return valud by __gnat_file_time_* + pragma Inline ("<"); pragma Inline (">"); pragma Inline ("<="); diff --git a/gcc/ada/g-regpat.adb b/gcc/ada/g-regpat.adb index 8857edccbfc..76fd6abd46d 100644 --- a/gcc/ada/g-regpat.adb +++ b/gcc/ada/g-regpat.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1996-2003 Ada Core Technologies, Inc. -- +-- Copyright (C) 1996-2004 Ada Core Technologies, 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- -- @@ -3406,9 +3406,9 @@ package body GNAT.Regpat is (Expression : String; Data : String; Matches : out Match_Array; - Size : Program_Size := 0; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) is PM : Pattern_Matcher (Size); Finalize_Size : Program_Size; @@ -3426,12 +3426,12 @@ package body GNAT.Regpat is -- Match -- ----------- - function Match + function Match (Expression : String; Data : String; - Size : Program_Size := 0; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Natural + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Natural is PM : Pattern_Matcher (Size); Final_Size : Program_Size; -- unused @@ -3452,9 +3452,9 @@ package body GNAT.Regpat is function Match (Expression : String; Data : String; - Size : Program_Size := 0; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Boolean + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Boolean is Matches : Match_Array (0 .. 0); PM : Pattern_Matcher (Size); diff --git a/gcc/ada/g-regpat.ads b/gcc/ada/g-regpat.ads index 57bc076717a..82bab7f5bda 100644 --- a/gcc/ada/g-regpat.ads +++ b/gcc/ada/g-regpat.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1996-2003 Ada Core Technologies, Inc. -- +-- Copyright (C) 1996-2004 Ada Core Technologies, 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- -- @@ -300,19 +300,32 @@ pragma Preelaborate (Regpat); -- This is limited by the size of a Character, as found in the -- byte-compiled version of regular expressions. - Max_Program_Size : constant := 2**15 - 1; - -- Maximum size that can be allocated for a program - Max_Curly_Repeat : constant := 32767; -- Maximum number of repetition for the curly operator. -- The digits in the {n}, {n,} and {n,m } operators can not be higher -- than this constant, since they have to fit on two characters in the -- byte-compiled version of regular expressions. + Max_Program_Size : constant := 2**15 - 1; + -- Maximum size that can be allocated for a program + type Program_Size is range 0 .. Max_Program_Size; for Program_Size'Size use 16; -- Number of bytes allocated for the byte-compiled version of a regular - -- expression. + -- expression. The size required depends on the complexity of the regular + -- expression in a complex manner that is undocumented (other than in the + -- body of the Compile procedure). Normally the size is automatically set + -- and the programmer need not be concerned about it. There are two + -- exceptions to this. First in the calls to Match, it is possible to + -- specify a non-zero size that is known to be large enough. This can + -- slightly increase the efficiency by avoiding a copy. Second, in the + -- case of calling compile, it is possible using the procedural form + -- of Compile to use a single Pattern_Matcher variable for several + -- different expressions by setting its size sufficiently large. + + Auto_Size : constant := 0; + -- Used in calls to Match to indicate that the Size should be set to + -- a value appropriate to the expression being used automatically. type Regexp_Flags is mod 256; for Regexp_Flags'Size use 8; @@ -368,9 +381,14 @@ pragma Preelaborate (Regpat); -- matching a null string at position 1, which uses (1, 0) -- and no match at all. - ------------------------------ - -- Pattern_Matcher Creation -- - ------------------------------ + --------------------------------- + -- Pattern_Matcher Compilation -- + --------------------------------- + + -- The subprograms here are used to precompile regular expressions + -- for use in subsequent Match calls. Precompilation improves + -- efficiency if the same regular expression is to be used in + -- more than one Match call. type Pattern_Matcher (Size : Program_Size) is private; -- Type used to represent a regular expression compiled into byte code @@ -381,14 +399,18 @@ pragma Preelaborate (Regpat); function Compile (Expression : String; Flags : Regexp_Flags := No_Flags) return Pattern_Matcher; - -- Compile a regular expression into internal code. - -- Raises Expression_Error if Expression is not a legal regular expression. - -- The appropriate size is calculated automatically, but this means that - -- the regular expression has to be compiled twice (the first time to - -- calculate the size, the second time to actually generate the byte code). + -- Compile a regular expression into internal code -- - -- Flags is the default value to use to set properties for Expression (case - -- sensitivity,...). + -- Raises Expression_Error if Expression is not a legal regular expression + -- + -- The appropriate size is calculated automatically to correspond to the + -- provided expression. This is the normal default method of compilation. + -- Note that it is generally not possible to assign the result of two + -- different calls to this Compile function to the same Pattern_Matcher + -- variable, since the sizes will differ. + -- + -- Flags is the default value to use to set properties for Expression + -- (e.g. case sensitivity,...). procedure Compile (Matcher : out Pattern_Matcher; @@ -396,11 +418,28 @@ pragma Preelaborate (Regpat); Final_Code_Size : out Program_Size; Flags : Regexp_Flags := No_Flags); -- Compile a regular expression into into internal code - -- This procedure is significantly faster than the function - -- Compile, as there is a known maximum size for the matcher. - -- This function raises Storage_Error if Matcher is too small - -- to hold the resulting code, or Expression_Error is Expression - -- is not a legal regular expression. + + -- This procedure is significantly faster than the Compile function + -- since it avoids the extra step of precomputing the required size. + -- + -- However, it requires the user to provide a Pattern_Matcher variable + -- whose size is preset to a large enough value. One advantage of this + -- approach, in addition to the improved efficiency, is that the same + -- Pattern_Matcher variable can be used to hold the compiled code for + -- several different regular expressions by setting a size that is + -- large enough to accomodate all possibilities. + -- + -- In this version of the procedure call, the actual required code + -- size is returned. Also if Matcher.Size is zero on entry, then the + -- resulting code is not stored. A call with Matcher.Size set to Auto_Size + -- can thus be used to determine the space required for compiling the + -- given regular expression. + -- + -- This function raises Storage_Error if Matcher is too small to hold + -- the resulting code (i.e. Matcher.Size has too small a value). + -- + -- Expression_Error is raised if the string Expression does not contain + -- a valid regular expression. -- -- Flags is the default value to use to set properties for Expression (case -- sensitivity,...). @@ -410,7 +449,7 @@ pragma Preelaborate (Regpat); Expression : String; Flags : Regexp_Flags := No_Flags); -- Same procedure as above, expect it does not return the final - -- program size. + -- program size, and Matcher.Size cannot be Auto_Size. function Paren_Count (Regexp : Pattern_Matcher) return Match_Count; pragma Inline (Paren_Count); @@ -442,83 +481,96 @@ pragma Preelaborate (Regpat); -- Matching -- -------------- - procedure Match - (Expression : String; - Data : String; - Matches : out Match_Array; - Size : Program_Size := 0; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last); - -- Match Expression against Data (Data_First .. Data_Last) and store - -- result in Matches. - -- - -- Data_First defaults to Data'First if unspecified (that is the - -- dummy value of -1 is interpreted to mean Data'First). - -- - -- Data_Last defaults to Data'Last if unspecified (that is the - -- dummy value of Positive'Last is interpreted to mean Data'Last) - -- - -- It is important that Data contains the whole string (or file) you - -- want to matched against, even if you start in the middle, since - -- otherwise regular expressions starting with "^" or ending with "$" will - -- be improperly processed. + -- The Match subprograms are given a regular expression in string + -- form, and perform the corresponding match. The following parameters + -- are present in all forms of the Match call. + + -- Expression contains the regular expression to be matched as a string + + -- Data contains the string to be matched + + -- Data_First is the lower bound for the match, i.e. Data (Data_First) + -- will be the first character to be examined. If Data_First is set to + -- the special value of -1 (the default), then the first character to + -- be examined is Data (Data_First). However, the regular expression + -- character ^ (start of string) still refers to the first character + -- of the full string (Data (Data'First)), which is why there is a + -- separate mechanism for specifying Data_First. + + -- Data_Last is the upper bound for the match, i.e. Data (Data_Last) + -- will be the last character to be examined. If Data_Last is set to + -- the special value of Positive'Last (the default), then the last + -- character to be examined is Data (Data_Last). However, the regular + -- expression character $ (end of string) still refers to the last + -- character of the full string (Data (Data'Last)), which is why there + -- is a separate mechanism for specifying Data_Last. + + -- Note: the use of Data_First and Data_Last is not equivalent to + -- simply passing a slice as Expression because of the handling of + -- regular expression characters ^ and $. + + -- Size is the size allocated for the compiled byte code. Normally + -- this is defaulted to Auto_Size which means that the appropriate + -- size is allocated automatically. It is possible to specify an + -- explicit size, which must be sufficiently large. This slightly + -- increases the efficiency by avoiding the extra step of computing + -- the appropriate size. + + -- The following exceptions can be raised in calls to Match -- - -- Function raises Storage_Error if Size is too small for Expression, - -- or Expression_Error if Expression is not a legal regular expression. - -- If Size is 0, then the appropriate size is automatically calculated - -- by this package, but this is slightly slower. + -- Storage_Error is raised if a non-zero value is given for Size + -- and it is too small to hold the compiled byte code. -- + -- Expression_Error is raised if the given expression is not a legal + -- regular expression. + + + procedure Match + (Expression : String; + Data : String; + Matches : out Match_Array; + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last); + -- This version returns the result of the match stored in Match_Array. -- At most Matches'Length parenthesis are returned. - function Match + function Match (Expression : String; Data : String; - Size : Program_Size := 0; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Natural; - -- Return the position where Data matches, or (Data'First - 1) if - -- there is no match. - -- - -- Function raises Storage_Error if Size is too small for Expression - -- or Expression_Error if Expression is not a legal regular expression - -- - -- If Size is 0, then the appropriate size is automatically calculated - -- by this package, but this is slightly slower. - -- See description of Data_First and Data_Last above. + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Natural; + -- This version returns the position where Data matches, or if there is + -- no match, then the value Data'First - 1. function Match (Expression : String; Data : String; - Size : Program_Size := 0; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Boolean; - -- Return True if Data matches Expression. Match raises Storage_Error - -- if Size is too small for Expression, or Expression_Error if Expression - -- is not a legal regular expression. - -- - -- If Size is 0, then the appropriate size is automatically calculated - -- by this package, but this is slightly slower. - -- - -- See description of Data_First and Data_Last above. + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Boolean; + -- This version returns True if the match succeeds, False otherwise ------------------------------------------------ - -- Matching a pre-compiled regular expression -- + -- Matching a Pre-Compiled Regular Expression -- ------------------------------------------------ -- The following functions are significantly faster if you need to reuse -- the same regular expression multiple times, since you only have to - -- compile it once. + -- compile it once. For these functions you must first compile the + -- expression with a call to Compile as previously described. + + -- The parameters Data, Data_First and Data_Last are as described + -- in the previous section. function Match (Self : Pattern_Matcher; Data : String; Data_First : Integer := -1; Data_Last : Positive := Positive'Last) return Natural; - -- Match Data using the given pattern matcher. - -- Return the position where Data matches, or (Data'First - 1) if there is - -- no match. - -- - -- See description of Data_First and Data_Last above. + -- Match Data using the given pattern matcher. Returns the position + -- where Data matches, or (Data'First - 1) if there is no match. function Match (Self : Pattern_Matcher; @@ -526,8 +578,6 @@ pragma Preelaborate (Regpat); Data_First : Integer := -1; Data_Last : Positive := Positive'Last) return Boolean; -- Return True if Data matches using the given pattern matcher. - -- - -- See description of Data_First and Data_Last above. pragma Inline (Match); -- All except the last one below @@ -542,8 +592,6 @@ pragma Preelaborate (Regpat); -- The expression matches if Matches (0) /= No_Match. -- -- At most Matches'Length parenthesis are returned. - -- - -- See description of Data_First and Data_Last above. ----------- -- Debug -- diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index fad86e184bc..ec766614392 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -2970,14 +2970,13 @@ There are no semantic dependencies on the package Ada.Calendar. @item No_Relative_Delay There are no delay_relative_statements. -@item No_Task_Attributes -There are no semantic dependencies on the Ada.Task_Attributes package and -there are no references to the attributes Callable and Terminated [RM 9.9]. +@item No_Task_Attributes_Package +There are no semantic dependencies on the Ada.Task_Attributes package. -@item Boolean_Entry_Barriers -Entry barrier condition expressions shall be boolean -objects which are declared in the protected type -which contains the entry. +@item Simple_Barriers +Entry barrier condition expressions shall be either static +boolean expressions or boolean objects which are declared in +the protected type which contains the entry. @item Max_Asynchronous_Select_Nesting = 0 [RM D.7] Specifies the maximum dynamic nesting level of asynchronous_selects. @@ -3023,7 +3022,7 @@ and whose most recent description is available at The above set is a superset of the restrictions provided by pragma @code{Restricted_Run_Time}, it includes five additional restrictions -(@code{Boolean_Entry_Barriers}, @code{No_Select_Statements}, +(@code{Simple_Barriers}, @code{No_Select_Statements}, @code{No_Calendar}, @code{No_Relative_Delay} and @code{No_Task_Termination}). This means that pragma @code{Ravenscar}, like the pragma @code{Restricted_Run_Time}, @@ -3054,7 +3053,7 @@ A configuration pragma that establishes the following set of restrictions: @item No_Protected_Type_Allocators @item No_Local_Protected_Objects @item No_Requeue_Statements -@item No_Task_Attributes +@item No_Task_Attributes_Package @item Max_Asynchronous_Select_Nesting = 0 @item Max_Task_Entries = 0 @item Max_Protected_Entries = 1 @@ -6847,13 +6846,14 @@ then all compilation units in the partition must obey the restriction. @table @code -@item Boolean_Entry_Barriers -@findex Boolean_Entry_Barriers +@item Simple_Barriers +@findex Simple_Barriers This restriction ensures at compile time that barriers in entry declarations -for protected types are restricted to references to simple boolean variables -defined in the private part of the protected type. No other form of entry -barriers is permitted. This is one of the restrictions of the Ravenscar -profile for limited tasking (see also pragma @code{Ravenscar}). +for protected types are restricted to either static boolean expressions or +references to simple boolean variables defined in the private part of the +protected type. No other form of entry barriers is permitted. This is one +of the restrictions of the Ravenscar profile for limited tasking (see also +pragma @code{Ravenscar}). @item Max_Entry_Queue_Depth => Expr @findex Max_Entry_Queue_Depth @@ -6990,8 +6990,8 @@ user-defined storage pool. This restriction ensures at compile time that there are no implicit or explicit dependencies on the package @code{Ada.Streams}. -@item No_Task_Attributes -@findex No_Task_Attributes +@item No_Task_Attributes_Package +@findex No_Task_Attributes_Package This restriction ensures at compile time that there are no implicit or explicit dependencies on the package @code{Ada.Task_Attributes}. diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 3ef0e327b5b..1747d25d307 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -839,8 +839,9 @@ begin (Name => Name_Default_Switches, In_Arrays => Element.Decl.Arrays); The_Switches := Prj.Util.Value_Of - (Index => Name_Ada, - In_Array => Default_Switches_Array); + (Index => Name_Ada, + Src_Index => 0, + In_Array => Default_Switches_Array); end if; end if; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index fd25d0d7b0d..e43821eab67 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1281,11 +1281,14 @@ __gnat_initialize (void) #elif defined (VMS) +#ifdef IN_RTS + /* The prehandler actually gets control first on a condition. It swaps the stack pointer and calls the handler (__gnat_error_handler). */ extern long __gnat_error_prehandler (void); extern char *__gnat_error_prehandler_stack; /* Alternate signal stack */ +#endif /* Conditions that don't have an Ada exception counterpart must raise Non_Ada_Error. Since this is defined in s-auxdec, it should only be @@ -1474,6 +1477,7 @@ void __gnat_install_handler (void) { long prvhnd; +#ifdef IN_RTS char *c; c = (char *) xmalloc (2049); @@ -1482,6 +1486,9 @@ __gnat_install_handler (void) /* __gnat_error_prehandler is an assembly function. */ SYS$SETEXV (1, __gnat_error_prehandler, 3, &prvhnd); +#else + SYS$SETEXV (1, __gnat_error_handler, 3, &prvhnd); +#endif __gnat_handler_installed = 1; } diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index bc6bfe54bf9..1259bc890b7 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -600,6 +600,7 @@ package body Lib.Writ is Pname : constant Unit_Name_Type := Get_Parent_Spec_Name (Unit_Name (Main_Unit)); Body_Fname : File_Name_Type; + Body_Index : Nat; begin -- Loop to build the with table. A with on the main unit itself @@ -657,12 +658,18 @@ package body Lib.Writ is (Get_Body_Name (Uname), Subunit => False, May_Fail => True); + Body_Index := + Get_Unit_Index + (Get_Body_Name (Uname)); + if Body_Fname = No_File then Body_Fname := Get_File_Name (Uname, Subunit => False); + Body_Index := Get_Unit_Index (Uname); end if; else Body_Fname := Get_File_Name (Uname, Subunit => False); + Body_Index := Get_Unit_Index (Uname); end if; -- A package is considered to have a body if it requires @@ -675,7 +682,7 @@ package body Lib.Writ is Write_Info_Name (Body_Fname); Write_Info_Tab (49); Write_Info_Name - (Lib_File_Name (Body_Fname, Munit_Index (Unum))); + (Lib_File_Name (Body_Fname, Body_Index)); else Write_Info_Name (Fname); Write_Info_Tab (49); diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index d3f2da3edaa..ee0926c5464 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -124,16 +124,18 @@ package body Make is procedure Insert_Q (Source_File : File_Name_Type; - Source_Unit : Unit_Name_Type := No_Name); - -- Inserts Source_File at the end of Q. Provide Source_Unit when - -- possible for external use (gnatdist). + Source_Unit : Unit_Name_Type := No_Name; + Index : Int := 0); + -- Inserts Source_File at the end of Q. Provide Source_Unit when possible + -- for external use (gnatdist). Provide index for multi-unit sources. function Empty_Q return Boolean; -- Returns True if Q is empty. procedure Extract_From_Q - (Source_File : out File_Name_Type; - Source_Unit : out Unit_Name_Type); + (Source_File : out File_Name_Type; + Source_Unit : out Unit_Name_Type; + Source_Index : out Int); -- Extracts the first element from the Q. procedure Insert_Project_Sources @@ -164,12 +166,14 @@ package body Make is -- Used to detect multiple --RTS= switches type Q_Record is record - File : File_Name_Type; - Unit : Unit_Name_Type; + File : File_Name_Type; + Unit : Unit_Name_Type; + Index : Int; end record; -- File is the name of the file to compile. Unit is for gnatdist -- use in order to easily get the unit name of a file to compile - -- when its name is krunched or declared in gnat.adc. + -- when its name is krunched or declared in gnat.adc. Index, when not 0, + -- is the index of the unit in a multi-unit source. package Q is new Table.Table ( Table_Component_Type => Q_Record, @@ -459,20 +463,6 @@ package body Make is -- pragmas file to be specified for For_Project, -- otherwise return an empty argument list. - ---------------------- - -- Marking Routines -- - ---------------------- - - Marking_Label : Byte := 1; - -- Value to mark the source files - - procedure Mark (Source_File : File_Name_Type); - -- Mark Source_File. Marking is used to signal that Source_File has - -- already been inserted in the Q. - - function Is_Marked (Source_File : File_Name_Type) return Boolean; - -- Returns True if Source_File was previously marked. - ------------------- -- Misc Routines -- ------------------- @@ -574,6 +564,7 @@ package body Make is function Switches_Of (Source_File : Name_Id; Source_File_Name : String; + Source_Index : Int; Naming : Naming_Data; In_Package : Package_Id; Allow_ALI : Boolean) return Variable_Value; @@ -656,6 +647,7 @@ package body Make is procedure Add_Switches (The_Package : Package_Id; File_Name : String; + Index : Int; Program : Make_Program_Type); procedure Add_Switch (S : String_Access; @@ -676,13 +668,14 @@ package body Make is -- added at the beginning of the command line. procedure Check - (Source_File : File_Name_Type; - The_Args : Argument_List; - Lib_File : File_Name_Type; - Read_Only : Boolean; - ALI : out ALI_Id; - O_File : out File_Name_Type; - O_Stamp : out Time_Stamp_Type); + (Source_File : File_Name_Type; + Source_Index : Int; + The_Args : Argument_List; + Lib_File : File_Name_Type; + Read_Only : Boolean; + ALI : out ALI_Id; + O_File : out File_Name_Type; + O_Stamp : out Time_Stamp_Type); -- Determines whether the library file Lib_File is up-to-date or not. The -- full name (with path information) of the object file corresponding to -- Lib_File is returned in O_File. Its time stamp is saved in O_Stamp. @@ -703,8 +696,9 @@ package body Make is -- Otherwise O_File is No_File. procedure Collect_Arguments - (Source_File : File_Name_Type; - Args : Argument_List); + (Source_File : File_Name_Type; + Source_Index : Int; + Args : Argument_List); -- Collect all arguments for a source to be compiled, including those -- that come from a project file. @@ -942,6 +936,7 @@ package body Make is procedure Add_Switches (The_Package : Package_Id; File_Name : String; + Index : Int; Program : Make_Program_Type) is Switches : Variable_Value; @@ -956,6 +951,7 @@ package body Make is Switches_Of (Source_File => Name_Find, Source_File_Name => File_Name, + Source_Index => Index, Naming => Projects.Table (Main_Project).Naming, In_Package => The_Package, Allow_ALI => @@ -1104,13 +1100,14 @@ package body Make is ----------- procedure Check - (Source_File : File_Name_Type; - The_Args : Argument_List; - Lib_File : File_Name_Type; - Read_Only : Boolean; - ALI : out ALI_Id; - O_File : out File_Name_Type; - O_Stamp : out Time_Stamp_Type) + (Source_File : File_Name_Type; + Source_Index : Int; + The_Args : Argument_List; + Lib_File : File_Name_Type; + Read_Only : Boolean; + ALI : out ALI_Id; + O_File : out File_Name_Type; + O_Stamp : out Time_Stamp_Type) is function First_New_Spec (A : ALI_Id) return File_Name_Type; -- Looks in the with table entries of A and returns the spec file name @@ -1342,7 +1339,7 @@ package body Make is -- First, collect all the switches - Collect_Arguments (Source_File, The_Args); + Collect_Arguments (Source_File, Source_Index, The_Args); Prev_Switch := Dummy_Switch; @@ -1705,8 +1702,9 @@ package body Make is ----------------------- procedure Collect_Arguments - (Source_File : File_Name_Type; - Args : Argument_List) + (Source_File : File_Name_Type; + Source_Index : Int; + Args : Argument_List) is begin Arguments_Collected := True; @@ -1787,6 +1785,7 @@ package body Make is Switches := Switches_Of (Source_File => Source_File, Source_File_Name => Source_File_Name, + Source_Index => Source_Index, Naming => Data.Naming, In_Package => Compiler_Package, Allow_ALI => False); @@ -1885,6 +1884,7 @@ package body Make is Most_Recent_Obj_Stamp : out Time_Stamp_Type; Main_Unit : out Boolean; Compilation_Failures : out Natural; + Main_Index : Int := 0; Check_Readonly_Files : Boolean := False; Do_Not_Execute : Boolean := False; Force_Compilations : Boolean := False; @@ -1893,15 +1893,6 @@ package body Make is Initialize_ALI_Data : Boolean := True; Max_Process : Positive := 1) is - function Compile - (S : Name_Id; - L : Name_Id; - Args : Argument_List) return Process_Id; - -- Compiles S using Args. If S is a GNAT predefined source - -- "-gnatpg" is added to Args. Non blocking call. L corresponds to the - -- expected library file name. Process_Id of the process spawned to - -- execute the compile. - No_Mapping_File : constant Natural := 0; type Compilation_Data is record @@ -1990,9 +1981,23 @@ package body Make is -- resp. No_File, No_File and No_Name if there were no compilations -- to wait for. - procedure Collect_Arguments_And_Compile (Source_File : File_Name_Type); + function Bad_Compilation_Count return Natural; + -- Returns the number of compilation failures. + + procedure Collect_Arguments_And_Compile + (Source_File : File_Name_Type; Source_Index : Int); -- Collect arguments from project file (if any) and compile + function Compile + (S : Name_Id; + L : Name_Id; + Source_Index : Int; + Args : Argument_List) return Process_Id; + -- Compiles S using Args. If S is a GNAT predefined source + -- "-gnatpg" is added to Args. Non blocking call. L corresponds to the + -- expected library file name. Process_Id of the process spawned to + -- execute the compile. + package Good_ALI is new Table.Table ( Table_Component_Type => ALI_Id, Table_Index_Type => Natural, @@ -2002,12 +2007,13 @@ package body Make is Table_Name => "Make.Good_ALI"); -- Contains the set of valid ALI files that have not yet been scanned. - procedure Record_Good_ALI (A : ALI_Id); - -- Records in the previous set the Id of an ALI file. - function Good_ALI_Present return Boolean; -- Returns True if any ALI file was recorded in the previous set. + procedure Get_Mapping_File (Project : Project_Id); + -- Get a mapping file name. If there is one to be reused, reuse it. + -- Otherwise, create a new mapping file. + function Get_Next_Good_ALI return ALI_Id; -- Returns the next good ALI_Id record; @@ -2019,12 +2025,8 @@ package body Make is -- If Found is False then the compilation of File failed because we -- could not find it. Records also Unit when possible. - function Bad_Compilation_Count return Natural; - -- Returns the number of compilation failures. - - procedure Get_Mapping_File (Project : Project_Id); - -- Get a mapping file name. If there is one to be reused, reuse it. - -- Otherwise, create a new mapping file. + procedure Record_Good_ALI (A : ALI_Id); + -- Records in the previous set the Id of an ALI file. ----------------- -- Add_Process -- @@ -2146,14 +2148,16 @@ package body Make is -- Collect_Arguments_And_Compile -- ----------------------------------- - procedure Collect_Arguments_And_Compile (Source_File : File_Name_Type) is + procedure Collect_Arguments_And_Compile + (Source_File : File_Name_Type; Source_Index : Int) + is begin -- If arguments have not yet been collected (in Check), collect them -- now. if not Arguments_Collected then - Collect_Arguments (Source_File, Args); + Collect_Arguments (Source_File, Source_Index, Args); end if; -- If we use mapping file (-P or -C switches), then get one @@ -2201,7 +2205,7 @@ package body Make is Change_To_Object_Directory (Arguments_Project); - Pid := Compile (Arguments_Path_Name, Lib_File, + Pid := Compile (Arguments_Path_Name, Lib_File, Source_Index, Arguments (1 .. Last_Argument)); else @@ -2213,7 +2217,7 @@ package body Make is Change_To_Object_Directory (Arguments_Project); end if; - Pid := Compile (Full_Source_File, Lib_File, + Pid := Compile (Full_Source_File, Lib_File, Source_Index, Arguments (1 .. Last_Argument)); end if; end Collect_Arguments_And_Compile; @@ -2223,9 +2227,10 @@ package body Make is ------------- function Compile - (S : Name_Id; - L : Name_Id; - Args : Argument_List) return Process_Id + (S : Name_Id; + L : Name_Id; + Source_Index : Int; + Args : Argument_List) return Process_Id is Comp_Args : Argument_List (Args'First .. Args'Last + 8); Comp_Next : Integer := Args'First; @@ -2337,7 +2342,20 @@ package body Make is Comp_Args (Comp_Last) := Ada_Flag_2; end if; - if L /= Strip_Directory (L) or else Object_Directory_Path /= null then + if Source_Index /= 0 then + declare + Num : constant String := Source_Index'Img; + begin + Comp_Last := Comp_Last + 1; + Comp_Args (Comp_Last) := + new String'("-gnateI" & Num (Num'First + 1 .. Num'Last)); + end; + end if; + + if Source_Index /= 0 or else + L /= Strip_Directory (L) or else + Object_Directory_Path /= null + then -- Build -o argument. @@ -2501,9 +2519,9 @@ package body Make is -- Only insert in the Q if it is not already done, to avoid simultaneous -- compilations if -jnnn is used. - if not Is_Marked (Main_Source) then - Insert_Q (Main_Source); - Mark (Main_Source); + if not Is_Marked (Main_Source, Main_Index) then + Insert_Q (Main_Source, Index => Main_Index); + Mark (Main_Source, Main_Index); end if; First_Compiled_File := No_File; @@ -2537,157 +2555,156 @@ package body Make is -- up all the available processes. if not Empty_Q and then Outstanding_Compiles < Max_Process then - Extract_From_Q (Source_File, Source_Unit); - Full_Source_File := Osint.Full_Source_Name (Source_File); - Lib_File := Osint.Lib_File_Name (Source_File); - Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File); - - -- If this source has already been compiled, the executable is - -- obsolete. + declare + Source_Index : Int; + -- Index of the current unit in the current source file - if Is_In_Obsoleted (Source_File) then - Executable_Obsolete := True; - end if; + begin + Extract_From_Q (Source_File, Source_Unit, Source_Index); + Full_Source_File := Osint.Full_Source_Name (Source_File); + Lib_File := Osint.Lib_File_Name + (Source_File, Source_Index); + Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File); - -- If the library file is an Ada library skip it + -- If this source has already been compiled, the executable is + -- obsolete. - if Full_Lib_File /= No_File - and then In_Ada_Lib_Dir (Full_Lib_File) - then - Verbose_Msg (Lib_File, "is in an Ada library", Prefix => " "); + if Is_In_Obsoleted (Source_File) then + Executable_Obsolete := True; + end if; - -- If the library file is a read-only library skip it, but only - -- if, when using project files, this library file is in the - -- right object directory (a read-only ALI file in the object - -- directory of a project being extended should not be skipped). + -- If the library file is an Ada library skip it - elsif Full_Lib_File /= No_File - and then not Check_Readonly_Files - and then Is_Readonly_Library (Full_Lib_File) - and then Is_In_Object_Directory (Source_File, Full_Lib_File) - then - Verbose_Msg - (Lib_File, "is a read-only library", Prefix => " "); - - -- The source file that we are checking cannot be located + if Full_Lib_File /= No_File + and then In_Ada_Lib_Dir (Full_Lib_File) + then + Verbose_Msg + (Lib_File, "is in an Ada library", Prefix => " "); + + -- If the library file is a read-only library skip it, but + -- only if, when using project files, this library file is + -- in the right object directory (a read-only ALI file + -- in the object directory of a project being extended + -- should not be skipped). + + elsif Full_Lib_File /= No_File + and then not Check_Readonly_Files + and then Is_Readonly_Library (Full_Lib_File) + and then Is_In_Object_Directory (Source_File, Full_Lib_File) + then + Verbose_Msg + (Lib_File, "is a read-only library", Prefix => " "); - elsif Full_Source_File = No_File then - Record_Failure (Source_File, Source_Unit, False); + -- The source file that we are checking cannot be located - -- Source and library files can be located but are internal - -- files + elsif Full_Source_File = No_File then + Record_Failure (Source_File, Source_Unit, False); - elsif not Check_Readonly_Files - and then Full_Lib_File /= No_File - and then Is_Internal_File_Name (Source_File) - then + -- Source and library files can be located but are internal + -- files - if Force_Compilations then - Fail - ("not allowed to compile """ & - Get_Name_String (Source_File) & - """; use -a switch, or compile file with " & - """-gnatg"" switch"); - end if; + elsif not Check_Readonly_Files + and then Full_Lib_File /= No_File + and then Is_Internal_File_Name (Source_File) + then + if Force_Compilations then + Fail + ("not allowed to compile """ & + Get_Name_String (Source_File) & + """; use -a switch, or compile file with " & + """-gnatg"" switch"); + end if; - Verbose_Msg - (Lib_File, "is an internal library", Prefix => " "); + Verbose_Msg + (Lib_File, "is an internal library", Prefix => " "); - -- The source file that we are checking can be located + -- The source file that we are checking can be located - else - Arguments_Collected := False; + else + Arguments_Collected := False; - -- Don't waste any time if we have to recompile anyway + -- Don't waste any time if we have to recompile anyway - Obj_Stamp := Empty_Time_Stamp; - Need_To_Compile := Force_Compilations; + Obj_Stamp := Empty_Time_Stamp; + Need_To_Compile := Force_Compilations; - if not Force_Compilations then - Read_Only := - Full_Lib_File /= No_File - and then not Check_Readonly_Files - and then Is_Readonly_Library (Full_Lib_File); - Check (Source_File, Args, Lib_File, Read_Only, - ALI, Obj_File, Obj_Stamp); - Need_To_Compile := (ALI = No_ALI_Id); - end if; + if not Force_Compilations then + Read_Only := + Full_Lib_File /= No_File + and then not Check_Readonly_Files + and then Is_Readonly_Library (Full_Lib_File); + Check (Source_File, Source_Index, Args, Lib_File, + Read_Only, ALI, Obj_File, Obj_Stamp); + Need_To_Compile := (ALI = No_ALI_Id); + end if; - if not Need_To_Compile then + if not Need_To_Compile then - -- The ALI file is up-to-date. Record its Id. + -- The ALI file is up-to-date. Record its Id. - Record_Good_ALI (ALI); + Record_Good_ALI (ALI); - -- Record the time stamp of the most recent object file - -- as long as no (re)compilations are needed. + -- Record the time stamp of the most recent object file + -- as long as no (re)compilations are needed. - if First_Compiled_File = No_File - and then (Most_Recent_Obj_File = No_File - or else Obj_Stamp > Most_Recent_Obj_Stamp) - then - Most_Recent_Obj_File := Obj_File; - Most_Recent_Obj_Stamp := Obj_Stamp; - end if; + if First_Compiled_File = No_File + and then (Most_Recent_Obj_File = No_File + or else Obj_Stamp > Most_Recent_Obj_Stamp) + then + Most_Recent_Obj_File := Obj_File; + Most_Recent_Obj_Stamp := Obj_Stamp; + end if; - else - -- Is this the first file we have to compile? + else + -- Is this the first file we have to compile? - if First_Compiled_File = No_File then - First_Compiled_File := Full_Source_File; - Most_Recent_Obj_File := No_File; + if First_Compiled_File = No_File then + First_Compiled_File := Full_Source_File; + Most_Recent_Obj_File := No_File; - if Do_Not_Execute then - exit Make_Loop; + if Do_Not_Execute then + exit Make_Loop; + end if; end if; - end if; - if In_Place_Mode then + if In_Place_Mode then - -- If the library file was not found, then save the - -- library file near the source file. + -- If the library file was not found, then save the + -- library file near the source file. - if Full_Lib_File = No_File then - Get_Name_String (Full_Source_File); - - for J in reverse 1 .. Name_Len loop - if Name_Buffer (J) = '.' then - Name_Buffer (J + 1 .. J + 3) := "ali"; - Name_Len := J + 3; - exit; - end if; - end loop; + if Full_Lib_File = No_File then + Lib_File := Osint.Lib_File_Name + (Full_Source_File, Source_Index); - Lib_File := Name_Find; + -- If the library file was found, then save the + -- library file in the same place. - -- If the library file was found, then save the - -- library file in the same place. + else + Lib_File := Full_Lib_File; + end if; - else - Lib_File := Full_Lib_File; end if; - end if; - - -- Start the compilation and record it. We can do this - -- because there is at least one free process. + -- Start the compilation and record it. We can do this + -- because there is at least one free process. - Collect_Arguments_And_Compile (Source_File); + Collect_Arguments_And_Compile (Source_File, Source_Index); - -- Make sure we could successfully start the compilation + -- Make sure we could successfully start the compilation - if Pid = Invalid_Pid then - Record_Failure (Full_Source_File, Source_Unit); - else - Add_Process - (Pid, - Full_Source_File, - Lib_File, - Source_Unit, - Mfile); + if Pid = Invalid_Pid then + Record_Failure (Full_Source_File, Source_Unit); + else + Add_Process + (Pid, + Full_Source_File, + Lib_File, + Source_Unit, + Mfile); + end if; end if; end if; - end if; + end; end if; -- PHASE 2: Now check if we should wait for a compilation to @@ -2784,96 +2801,111 @@ package body Make is while Good_ALI_Present loop ALI := Get_Next_Good_ALI; - -- If we are processing the library file corresponding to the - -- main source file check if this source can be a main unit. + declare + Source_Index : Int := Unit_Index_Of (ALIs.Table (ALI).Afile); - if ALIs.Table (ALI).Sfile = Main_Source then - Main_Unit := ALIs.Table (ALI).Main_Program /= None; - end if; + begin + -- If we are processing the library file corresponding to the + -- main source file check if this source can be a main unit. - -- The following adds the standard library (s-stalib) to the - -- list of files to be handled by gnatmake: this file and any - -- files it depends on are always included in every bind, - -- even if they are not in the explicit dependency list. - -- Of course, it is not added if Suppress_Standard_Library - -- is True. + if ALIs.Table (ALI).Sfile = Main_Source and then + Source_Index = Main_Index + then + Main_Unit := ALIs.Table (ALI).Main_Program /= None; + end if; - -- However, to avoid annoying output about s-stalib.ali being - -- read only, when "-v" is used, we add the standard library - -- only when "-a" is used. + -- The following adds the standard library (s-stalib) to the + -- list of files to be handled by gnatmake: this file and any + -- files it depends on are always included in every bind, + -- even if they are not in the explicit dependency list. + -- Of course, it is not added if Suppress_Standard_Library + -- is True. - if Need_To_Check_Standard_Library then - Need_To_Check_Standard_Library := False; + -- However, to avoid annoying output about s-stalib.ali being + -- read only, when "-v" is used, we add the standard library + -- only when "-a" is used. - if not Targparm.Suppress_Standard_Library_On_Target then - declare - Sfile : Name_Id; - Add_It : Boolean := True; + if Need_To_Check_Standard_Library then + Need_To_Check_Standard_Library := False; - begin - Name_Len := Standard_Library_Package_Body_Name'Length; - Name_Buffer (1 .. Name_Len) := - Standard_Library_Package_Body_Name; - Sfile := Name_Enter; + if not Targparm.Suppress_Standard_Library_On_Target then + declare + Sfile : Name_Id; + Add_It : Boolean := True; - -- If we have a special runtime, we add the standard - -- library only if we can find it. + begin + Name_Len := Standard_Library_Package_Body_Name'Length; + Name_Buffer (1 .. Name_Len) := + Standard_Library_Package_Body_Name; + Sfile := Name_Enter; - if RTS_Switch then - Add_It := Find_File (Sfile, Osint.Source) /= No_File; - end if; + -- If we have a special runtime, we add the standard + -- library only if we can find it. - if Add_It then - if Is_Marked (Sfile) then - if Is_In_Obsoleted (Sfile) then - Executable_Obsolete := True; - end if; + if RTS_Switch then + Add_It := + Find_File (Sfile, Osint.Source) /= No_File; + end if; - else - Insert_Q (Sfile); - Mark (Sfile); + if Add_It then + if Is_Marked (Sfile) then + if Is_In_Obsoleted (Sfile) then + Executable_Obsolete := True; + end if; + + else + Insert_Q (Sfile, Index => 0); + Mark (Sfile, Index => 0); + end if; end if; - end if; - end; + end; + end if; end if; - end if; - -- Now insert in the Q the unmarked source files (i.e. those - -- which have never been inserted in the Q and hence never - -- considered). Only do that if Unique_Compile is False. + -- Now insert in the Q the unmarked source files (i.e. those + -- which have never been inserted in the Q and hence never + -- considered). Only do that if Unique_Compile is False. - if not Unique_Compile then - for J in - ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit - loop - for K in - Units.Table (J).First_With .. Units.Table (J).Last_With + if not Unique_Compile then + for J in + ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit loop - Sfile := Withs.Table (K).Sfile; - Add_Dependency (ALIs.Table (ALI).Sfile, Sfile); + for K in + Units.Table (J).First_With .. Units.Table (J).Last_With + loop + Sfile := Withs.Table (K).Sfile; + Add_Dependency (ALIs.Table (ALI).Sfile, Sfile); - if Is_In_Obsoleted (Sfile) then - Executable_Obsolete := True; - end if; + if Is_In_Obsoleted (Sfile) then + Executable_Obsolete := True; + end if; + + if Sfile = No_File then + Debug_Msg + ("Skipping generic:", Withs.Table (K).Uname); - if Sfile = No_File then - Debug_Msg ("Skipping generic:", Withs.Table (K).Uname); + else + Source_Index := + Unit_Index_Of (Withs.Table (K).Afile); - elsif Is_Marked (Sfile) then - Debug_Msg ("Skipping marked file:", Sfile); + if Is_Marked (Sfile, Source_Index) then + Debug_Msg ("Skipping marked file:", Sfile); - elsif not Check_Readonly_Files - and then Is_Internal_File_Name (Sfile) - then - Debug_Msg ("Skipping internal file:", Sfile); + elsif not Check_Readonly_Files + and then Is_Internal_File_Name (Sfile) + then + Debug_Msg ("Skipping internal file:", Sfile); - else - Insert_Q (Sfile, Withs.Table (K).Uname); - Mark (Sfile); - end if; + else + Insert_Q + (Sfile, Withs.Table (K).Uname, Source_Index); + Mark (Sfile, Source_Index); + end if; + end if; + end loop; end loop; - end loop; - end if; + end if; + end; end loop; if Display_Compilation_Progress then @@ -3266,35 +3298,34 @@ package body Make is -------------------- procedure Extract_From_Q - (Source_File : out File_Name_Type; - Source_Unit : out Unit_Name_Type) + (Source_File : out File_Name_Type; + Source_Unit : out Unit_Name_Type; + Source_Index : out Int) is - File : constant File_Name_Type := Q.Table (Q_Front).File; - Unit : constant Unit_Name_Type := Q.Table (Q_Front).Unit; + File : constant File_Name_Type := Q.Table (Q_Front).File; + Unit : constant Unit_Name_Type := Q.Table (Q_Front).Unit; + Index : constant Int := Q.Table (Q_Front).Index; begin if Debug.Debug_Flag_Q then Write_Str (" Q := Q - [ "); Write_Name (File); + + if Index /= 0 then + Write_Str (", "); + Write_Int (Index); + end if; + Write_Str (" ]"); Write_Eol; end if; Q_Front := Q_Front + 1; - Source_File := File; - Source_Unit := Unit; + Source_File := File; + Source_Unit := Unit; + Source_Index := Index; end Extract_From_Q; - ----------------- - -- Make_Failed -- - ----------------- - - procedure Make_Failed (S1 : String; S2 : String := ""; S3 : String := "") is - begin - Delete_All_Temp_Files; - Osint.Fail (S1, S2, S3); - end Make_Failed; - -------------- -- Gnatmake -- -------------- @@ -3326,7 +3357,12 @@ package body Make is -- The current working directory, used to modify some relative path -- switches on the command line when a project file is used. + Current_Main_Index : Int := 0; + -- If not zero, the index of the current main unit in its source file + There_Are_Stand_Alone_Libraries : Boolean := False; + -- Set to True when there are Stand-Alone Libraries, so that gnatbind + -- is invoked with the -F switch to force checking of elaboration flags. begin Gnatmake_Called := True; @@ -3407,6 +3443,9 @@ package body Make is end loop; end if; + elsif Main_Index /= 0 and then Osint.Number_Of_Files > 1 then + Make_Failed ("cannot specify several mains with a multi-unit index"); + elsif Main_Project /= No_Project then -- If the main project file is a library project file, main(s) @@ -3575,6 +3614,11 @@ package body Make is -- the sources of the project file as mains. else + if Main_Index /= 0 then + Make_Failed ("cannot specify a multi-unit index but no main " & + "on the command line"); + end if; + declare Value : String_List_Id := Projects.Table (Main_Project).Mains; @@ -3669,7 +3713,8 @@ package body Make is At_Least_One_Main := True; Osint.Add_File (Get_Name_String - (String_Elements.Table (Value).Value)); + (String_Elements.Table (Value).Value), + Index => String_Elements.Table (Value).Index); end if; Value := String_Elements.Table (Value).Next; @@ -3743,6 +3788,10 @@ package body Make is Main_Source_File := Next_Main_Source; + if Current_File_Index /= No_Index then + Main_Index := Current_File_Index; + end if; + Add_Switch ("-I-", Binder, And_Save => True); Add_Switch ("-I-", Compiler, And_Save => True); @@ -3935,6 +3984,7 @@ package body Make is Add_Switches (File_Name => Main_Unit_File_Name, + Index => Main_Index, The_Package => Builder_Package, Program => None); @@ -3949,6 +3999,7 @@ package body Make is Defaults : constant Variable_Value := Prj.Util.Value_Of (Name => Name_Ada, + Index => 0, Attribute_Or_Array_Name => Name_Default_Switches, In_Package => Builder_Package); @@ -3973,6 +4024,7 @@ package body Make is Add_Switches (File_Name => " ", + Index => 0, The_Package => Builder_Package, Program => None); @@ -4010,6 +4062,7 @@ package body Make is Add_Switches (File_Name => Main_Unit_File_Name, + Index => Main_Index, The_Package => Binder_Package, Program => Binder); end if; @@ -4025,6 +4078,7 @@ package body Make is Add_Switches (File_Name => Main_Unit_File_Name, + Index => Main_Index, The_Package => Linker_Package, Program => Linker); end if; @@ -4256,6 +4310,8 @@ package body Make is Bad_Compilation.Init; + Current_Main_Index := Main_Index; + -- Here is where the make process is started -- We do the same process for each main @@ -4312,7 +4368,7 @@ package body Make is -- "main.2.ada", when the body termination is ".2.ada". Executable := Prj.Util.Executable_Of - (Main_Project, Main_Source_File); + (Main_Project, Main_Source_File, Main_Index); end if; end if; @@ -4380,6 +4436,7 @@ package body Make is Most_Recent_Obj_File => Youngest_Obj_File, Most_Recent_Obj_Stamp => Youngest_Obj_Stamp, Main_Unit => Is_Main_Unit, + Main_Index => Current_Main_Index, Compilation_Failures => Compilation_Failures, Check_Readonly_Files => Check_Readonly_Files, Do_Not_Execute => Do_Not_Execute, @@ -4629,7 +4686,7 @@ package body Make is begin Src_File := Strip_Directory (Main_Source_File); - ALI_File := Lib_File_Name (Src_File); + ALI_File := Lib_File_Name (Src_File, Current_Main_Index); Main_ALI_File := Full_Lib_File_Name (ALI_File); -- When In_Place_Mode, the library file can be located in the @@ -5164,6 +5221,10 @@ package body Make is if N_File < Osint.Number_Of_Files then Main_Source_File := Next_Main_Source; + if Current_File_Index /= No_Index then + Main_Index := Current_File_Index; + end if; + if Main_Project /= No_Project then -- Find the file name of the main unit @@ -5249,6 +5310,7 @@ package body Make is Add_Switches (File_Name => Main_Unit_File_Name, + Index => Main_Index, The_Package => Binder_Package, Program => Binder); end if; @@ -5265,6 +5327,7 @@ package body Make is Add_Switches (File_Name => Main_Unit_File_Name, + Index => Main_Index, The_Package => Linker_Package, Program => Linker); end if; @@ -5317,17 +5380,10 @@ package body Make is end if; end if; - -- Increase the marking label to be sure to check sources - -- for all executables. + -- Remove all marks to be sure to check sources for all executables, + -- as the switches may be different and -s may be in use. - Marking_Label := Marking_Label + 1; - - -- Make sure it is not 0, which is the default value for - -- a file that has never been marked. - - if Marking_Label = 0 then - Marking_Label := 1; - end if; + Delete_All_Marks; end loop Multiple_Main_Loop; if Failed_Links.Last > 0 then @@ -5657,9 +5713,6 @@ package body Make is Project_Object_Directory := No_Project; - -- Set the marking label to a value that is not zero - - Marking_Label := 1; end Initialize; ---------------------------- @@ -5828,18 +5881,27 @@ package body Make is procedure Insert_Q (Source_File : File_Name_Type; - Source_Unit : Unit_Name_Type := No_Name) + Source_Unit : Unit_Name_Type := No_Name; + Index : Int := 0) is begin if Debug.Debug_Flag_Q then Write_Str (" Q := Q + [ "); Write_Name (Source_File); + + if Index /= 0 then + Write_Str (", "); + Write_Int (Index); + end if; + Write_Str (" ] "); Write_Eol; end if; - Q.Table (Q.Last).File := Source_File; - Q.Table (Q.Last).Unit := Source_Unit; + Q.Table (Q.Last) := + (File => Source_File, + Unit => Source_Unit, + Index => Index); Q.Increment_Last; end Insert_Q; @@ -5963,15 +6025,6 @@ package body Make is return True; end Is_In_Object_Directory; - --------------- - -- Is_Marked -- - --------------- - - function Is_Marked (Source_File : File_Name_Type) return Boolean is - begin - return Get_Name_Table_Byte (Source_File) = Marking_Label; - end Is_Marked; - ---------- -- Link -- ---------- @@ -6085,14 +6138,15 @@ package body Make is Set_Standard_Error; end List_Depend; - ---------- - -- Mark -- - ---------- + ----------------- + -- Make_Failed -- + ----------------- - procedure Mark (Source_File : File_Name_Type) is + procedure Make_Failed (S1 : String; S2 : String := ""; S3 : String := "") is begin - Set_Name_Table_Byte (Source_File, Marking_Label); - end Mark; + Delete_All_Temp_Files; + Osint.Fail (S1, S2, S3); + end Make_Failed; -------------------- -- Mark_Directory -- @@ -6755,6 +6809,7 @@ package body Make is -- or one character switches which are not in 'a' .. 'z' -- (except 'C', 'F', 'M' and 'B') are passed to the compiler, -- unless we are dealing with a debug switch (starts with 'd') + -- or an extended gnatmake switch (starts with 'e'). elsif Argv (2) /= 'd' and then Argv (2) /= 'e' @@ -6787,6 +6842,7 @@ package body Make is function Switches_Of (Source_File : Name_Id; Source_File_Name : String; + Source_Index : Int; Naming : Naming_Data; In_Package : Package_Id; Allow_ALI : Boolean) return Variable_Value @@ -6808,8 +6864,9 @@ package body Make is begin Switches := Prj.Util.Value_Of - (Index => Source_File, - In_Array => Switches_Array); + (Index => Source_File, + Src_Index => Source_Index, + In_Array => Switches_Array); if Switches = Nil_Variable_Value then declare @@ -6846,8 +6903,9 @@ package body Make is Name_Buffer (1 .. Name_Len) := Name (1 .. Last); Switches := Prj.Util.Value_Of - (Index => Name_Find, - In_Array => Switches_Array); + (Index => Name_Find, + Src_Index => 0, + In_Array => Switches_Array); if Switches = Nil_Variable_Value and then Allow_ALI @@ -6863,16 +6921,20 @@ package body Make is Name_Buffer (1 .. Name_Len) := Name (1 .. Name_Len); Switches := Prj.Util.Value_Of - (Index => Name_Find, - In_Array => Switches_Array); + (Index => Name_Find, + Src_Index => 0, + In_Array => Switches_Array); end if; end if; end; end if; if Switches = Nil_Variable_Value then - Switches := Prj.Util.Value_Of - (Index => Name_Ada, In_Array => Defaults); + Switches := + Prj.Util.Value_Of + (Index => Name_Ada, + Src_Index => 0, + In_Array => Defaults); end if; return Switches; diff --git a/gcc/ada/make.ads b/gcc/ada/make.ads index f07846336c7..9fcdf6d3842 100644 --- a/gcc/ada/make.ads +++ b/gcc/ada/make.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- -- @@ -112,6 +112,7 @@ package Make is Most_Recent_Obj_Stamp : out Time_Stamp_Type; Main_Unit : out Boolean; Compilation_Failures : out Natural; + Main_Index : Int := 0; Check_Readonly_Files : Boolean := False; Do_Not_Execute : Boolean := False; Force_Compilations : Boolean := False; @@ -148,6 +149,10 @@ package Make is -- Compilation_Failures is a count of compilation failures. This count -- is used to extract compilation failure reports with Extract_Failure. -- + -- Main_Index, when not zero, is the index of the main unit in source + -- file Main_Source which is a multi-unit source. + -- Zero indicates that Main_Source is a single unit source file. + -- -- Check_Readonly_Files set it to True to compile source files -- which library files are read-only. When compiling GNAT predefined -- files the "-gnatg" flag is used. diff --git a/gcc/ada/makegpr.adb b/gcc/ada/makegpr.adb index 08a1f4decaf..a881bc30d49 100644 --- a/gcc/ada/makegpr.adb +++ b/gcc/ada/makegpr.adb @@ -178,7 +178,6 @@ package body Makegpr is Options : array (Programming_Language) of Comp_Opts.Instance; -- Tables to store compiling options for the different compilers - package Linker_Options is new Table.Table (Table_Component_Type => String_Access, Table_Index_Type => Integer, @@ -354,9 +353,9 @@ package body Makegpr is -- or Linker (depending on Proc) of a specified project file. procedure Build_Archive (Project : Project_Id; Unconditionally : Boolean); - -- Build the archive for a specified project. - -- If Unconditionally is False, first check if the archive is up to date, - -- and build it only if it is not. + -- Build the archive for a specified project. If Unconditionally is + -- False, first check if the archive is up to date, and build it only + -- if it is not. procedure Check_Compilation_Needed (Source : Other_Source; @@ -369,7 +368,7 @@ package body Makegpr is procedure Compile (Source_Id : Other_Source_Id; - Data : in Project_Data; + Data : Project_Data; Local_Errors : in out Boolean); procedure Compile_Individual_Sources; @@ -378,9 +377,8 @@ package body Makegpr is procedure Compile_Link_With_Gnatmake (Mains_Specified : Boolean); -- Compile/Link with gnatmake when there are Ada sources in the main - -- project. - -- Arguments may already contain options to be used by gnatmake. - -- Used for both Ada mains and mains of other languages. + -- project. Arguments may already contain options to be used by + -- gnatmake. Used for both Ada mains and mains of other languages. -- When Compile_Only is True, do not use the linking options procedure Compile_Sources; @@ -390,7 +388,9 @@ package body Makegpr is -- Output the Copyright notice procedure Create_Archive_Dependency_File - (Name : String; First_Source : Other_Source_Id); + (Name : String; + First_Source : Other_Source_Id); + -- ??? needs comment procedure Display_Command (Name : String; Path : String_Access); -- Display the command for a spawned process, if in Verbose_Mode or @@ -431,6 +431,7 @@ package body Makegpr is -- Process one command line argument function Strip_CR_LF (Text : String) return String; + -- Needs comment ??? procedure Usage; -- Display the usage @@ -467,6 +468,7 @@ package body Makegpr is -- Nothing to do if the project has already been processed if not Data.Seen then + -- Mark the project as processed, to avoid processing it again Projects.Table (Project).Seen := True; @@ -496,6 +498,7 @@ package body Makegpr is if Data.Sources_Present then if Data.Library then + -- If it is a library project file, nothing to do if -- gnatmake will be invoked, because gnatmake will take -- care of it, even if the library is not an Ada library. @@ -633,16 +636,20 @@ package body Makegpr is -- Nothing to do if no argument is specified or if argument is empty if Arg /= null or else Arg'Length = 0 then + -- Reallocate arrays if necessary if Last_Argument = Arguments'Last then declare New_Arguments : constant Argument_List_Access := - new Argument_List - (1 .. Last_Argument + Initial_Argument_Count); + new Argument_List + (1 .. Last_Argument + + Initial_Argument_Count); + New_Arguments_Displayed : constant Booleans := - new Boolean_Array - (1 .. Last_Argument + Initial_Argument_Count); + new Boolean_Array + (1 .. Last_Argument + + Initial_Argument_Count); begin New_Arguments (Arguments'Range) := Arguments.all; @@ -672,6 +679,7 @@ package body Makegpr is procedure Add_Argument (Arg : String; Display : Boolean) is Argument : String_Access := null; + begin -- Nothing to do if argument is empty @@ -750,18 +758,21 @@ package body Makegpr is procedure Add_Option (Arg : String) is Option : constant String_Access := new String'(Arg); + begin case Current_Processor is when None => null; when Linker => + -- Add option to the linker table Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last) := Option; when Compiler => + -- Add option to the compiler option table, depending on the -- value of Current_Language. @@ -783,8 +794,9 @@ package body Makegpr is if Last_Source = Source_Indexes'Last then declare New_Indexes : constant Source_Indexes_Ref := - new Source_Index_Array - (1 .. Source_Indexes'Last + Initial_Source_Index_Count); + new Source_Index_Array + (1 .. Source_Indexes'Last + + Initial_Source_Index_Count); begin New_Indexes (Source_Indexes'Range) := Source_Indexes.all; Free (Source_Indexes); @@ -801,7 +813,8 @@ package body Makegpr is ---------------------------- procedure Add_Search_Directories - (Data : Project_Data; Language : Programming_Language) + (Data : Project_Data; + Language : Programming_Language) is begin -- If a GNU compiler is used, set the CPATH environment variable, @@ -858,6 +871,7 @@ package body Makegpr is end case; -- Get the Switches ("file name"), if they exist + Switches_Array := Prj.Util.Value_Of (Name => Name_Switches, In_Arrays => @@ -865,8 +879,9 @@ package body Makegpr is Switches := Prj.Util.Value_Of - (Index => File_Name, - In_Array => Switches_Array); + (Index => File_Name, + Src_Index => 0, + In_Array => Switches_Array); -- Otherwise, get the Default_Switches ("language"), if they exist @@ -875,8 +890,9 @@ package body Makegpr is (Name => Name_Default_Switches, In_Arrays => Packages.Table (Pkg).Decl.Arrays); Switches := Prj.Util.Value_Of - (Index => Lang_Name_Ids (Language), - In_Array => Defaults); + (Index => Lang_Name_Ids (Language), + Src_Index => 0, + In_Array => Defaults); end if; -- If there are switches, add them to Arguments @@ -923,6 +939,7 @@ package body Makegpr is Time_Stamp : Time_Stamp_Type; Saved_Last_Argument : Natural; + begin -- First, make sure that the archive builder (ar) is on the path @@ -961,6 +978,8 @@ package body Makegpr is Write_Line (" -> archive does not exist"); end if; + -- Archive does exist + else -- Check the archive dependency file @@ -1000,8 +1019,7 @@ package body Makegpr is Object_Name := Name_Find; Source_Id := No_Other_Source; - -- Check if this object file is for a source of this - -- project. + -- Check if this object file is for a source of this project for S in 1 .. Last_Source loop if (not Source_Indexes (S).Found) and then @@ -1088,6 +1106,7 @@ package body Makegpr is Close (File); if not Need_To_Rebuild then + -- Now, check if all object files of the project have been -- accounted for. If any of them is not in the dependency -- file, the archive needs to be rebuilt. @@ -1120,6 +1139,7 @@ package body Makegpr is -- Build the archive if necessary if Need_To_Rebuild then + -- If an archive is built, then linking will need to occur -- unconditionally. @@ -1131,10 +1151,12 @@ package body Makegpr is -- in the library directory. if Data.Library then + -- If there are sources in Ada, then gnatmake will build the -- library, so nothing to do. if not Data.Languages (Lang_Ada) then + -- Get all the object files of the project Source_Id := Data.First_Other_Source; @@ -1174,13 +1196,11 @@ package body Makegpr is end if; end if; - -- Create a fake empty archive, to be able to check its time stamp - -- later. + -- Create fake empty archive, so we can check its time stamp later declare Archive : Ada.Text_IO.File_Type; use Ada.Text_IO; - begin Create (Archive, Out_File, Archive_Name); Close (Archive); @@ -1239,6 +1259,7 @@ package body Makegpr is end loop; if Success then + -- If the archive was built, run the archive indexer (ranlib), -- if there is one. @@ -1251,6 +1272,7 @@ package body Makegpr is Spawn (Archive_Indexer_Path.all, Arguments (1 .. 1), Success); if not Success then + -- Running ranlib failed, delete the dependency file, -- if it exists. @@ -1309,7 +1331,9 @@ package body Makegpr is -- object file. Dep_File : Prj.Util.Text_File; - Start, Finish : Natural; + Start : Natural; + Finish : Natural; + begin -- Assume the worst, so that statement "return;" may be used if there -- is any problem. @@ -1378,8 +1402,7 @@ package body Makegpr is Open (Dep_File, Dep_Name); - -- If the dependency file cannot be open, we need to recompile the - -- source. + -- If dependency file cannot be open, we need to recompile the source if not Is_Valid (Dep_File) then if Verbose_Mode then @@ -1392,6 +1415,7 @@ package body Makegpr is declare End_Of_File_Reached : Boolean := False; + begin loop if End_Of_File (Dep_File) then @@ -1445,8 +1469,10 @@ package body Makegpr is declare Line : constant String := Name_Buffer (1 .. Name_Len); Last : constant Natural := Name_Len; + begin Name_Loop : loop + -- Find the beginning of the next source path name while Start < Last and then Line (Start) = ' ' loop @@ -1484,13 +1510,13 @@ package body Makegpr is declare Src_Name : constant String := - Normalize_Pathname - (Name => Line (Start .. Finish), - Case_Sensitive => False); + Normalize_Pathname + (Name => Line (Start .. Finish), + Case_Sensitive => False); Src_TS : Time_Stamp_Type; + begin - -- If it is the original source, - -- set Source_In_Dependencies. + -- If it is original source, set Source_In_Dependencies if Src_Name = Source_Path then Source_In_Dependencies := True; @@ -1599,6 +1625,7 @@ package body Makegpr is is Source : Other_Source := Other_Sources.Table (Source_Id); Success : Boolean; + begin -- If the compiler is not know yet, get its path name @@ -1668,6 +1695,7 @@ package body Makegpr is declare S : constant String := Strip_CR_LF (Expect_Out (FD)); + begin -- Each line of the output is put in the dependency -- file, including errors. If there are errors, the @@ -1679,8 +1707,8 @@ package body Makegpr is end; end loop; - -- If we are here, it means we had a timeout. - -- So, the dependency file may be incomplete: it is safer to + -- If we are here, it means we had a timeout, so the + -- dependency file may be incomplete. It is safer to -- delete it, otherwise the dependencies may be wrong. Close (FD, Status); @@ -1688,13 +1716,15 @@ package body Makegpr is Delete_File (Get_Name_String (Source.Dep_Name), Success); exception - when Process_Died => - -- This is the normal outcome. Just close the file. + when Process_Died => + + -- This is the normal outcome. Just close the file Close (FD, Status); Close (Dep_File); - when others => + when others => + -- Something wrong happened. It is safer to delete the -- dependency file, otherwise the dependencies may be wrong. @@ -1719,10 +1749,9 @@ package body Makegpr is Last_Argument := 0; - -- For GCC compilers, make sure the language is always - -- specified to the GCC driver, in case the extension is - -- not recognized by the GCC driver as a source of the - -- language. + -- For GCC compilers, make sure the language is always specified to + -- to the GCC driver, in case the extension is not recognized by the + -- GCC driver as a source of the language. if Compiler_Is_Gcc (Source.Language) then Add_Argument (Dash_x, Verbose_Mode); @@ -1731,13 +1760,14 @@ package body Makegpr is end if; -- Specify the source to be compiled + Add_Argument (Dash_c, True); Add_Argument (Get_Name_String (Source.Path_Name), True); - -- If it is a non static library project, compile with the PIC option - -- if there is one (when there is no PIC option, function - -- MLib.Tgt.PIC_Option returns an empty string, and Add_Argument with - -- an empty string has no effect). + -- If non static library project, compile with the PIC option if there + -- is one (when there is no PIC option, function MLib.Tgt.PIC_Option + -- returns an empty string, and Add_Argument with an empty string has + -- no effect). if Data.Library and then Data.Library_Kind /= Static then Add_Argument (PIC_Option, True); @@ -1790,6 +1820,7 @@ package body Makegpr is Success); if Success then + -- Compilation was successful, update the time stamp -- of the object file. @@ -1812,8 +1843,7 @@ package body Makegpr is " has not been modified"); else - -- Everything looks fine, update the Other_Sources - -- table. + -- Everything looks fine, update the Other_Sources table Other_Sources.Table (Source_Id) := Source; end if; @@ -1832,13 +1862,15 @@ package body Makegpr is -------------------------------- procedure Compile_Individual_Sources is - Data : Project_Data := Projects.Table (Main_Project); - Source_Id : Other_Source_Id; - Source : Other_Source; - Source_Name : Name_Id; + Data : Project_Data := Projects.Table (Main_Project); + Source_Id : Other_Source_Id; + Source : Other_Source; + Source_Name : Name_Id; Project_Name : String := Get_Name_String (Data.Name); Dummy : Boolean := False; + Ada_Is_A_Language : constant Boolean := Data.Languages (Lang_Ada); + begin Ada_Mains.Init; @@ -1914,6 +1946,7 @@ package body Makegpr is end if; if Ada_Mains.Last > 0 then + -- Invoke gnatmake for all sources that are not of a non Ada language Last_Argument := 0; @@ -1933,8 +1966,9 @@ package body Makegpr is -------------------------------- procedure Compile_Link_With_Gnatmake (Mains_Specified : Boolean) is - Data : constant Project_Data := Projects.Table (Main_Project); + Data : constant Project_Data := Projects.Table (Main_Project); Success : Boolean; + begin -- Array Arguments may already contain some arguments, so we don't -- set Last_Argument to 0. @@ -2074,9 +2108,8 @@ package body Makegpr is Source : Other_Source; Local_Errors : Boolean := False; - -- Set to True when there is a compilation error. - -- Used only when Keep_Going is True, to inhibit the building of the - -- archive. + -- Set to True when there is a compilation error. Used only when + -- Keep_Going is True, to inhibit the building of the archive. Need_To_Compile : Boolean; -- Set to True when a source needs to be compiled/recompiled. @@ -2092,6 +2125,7 @@ package body Makegpr is Data := Projects.Table (Project); if not Data.Virtual then + -- If the imported directory switches are unknown, compute them if not Data.Include_Data_Set then @@ -2100,8 +2134,7 @@ package body Makegpr is Projects.Table (Project) := Data; end if; - -- Nothing to do when there are no sources of language other than - -- Ada. + -- Nothing to do when no sources of language other than Ada if Data.Sources_Present then Need_To_Rebuild_Archive := Force_Compilations; @@ -2116,7 +2149,6 @@ package body Makegpr is while Source_Id /= No_Other_Source loop Source := Other_Sources.Table (Source_Id); - Need_To_Compile := Force_Compilations; -- Check if compilation is needed @@ -2128,11 +2160,11 @@ package body Makegpr is -- Proceed, if compilation is needed if Need_To_Compile then + -- If a source is compiled/recompiled, of course the -- archive will need to be built/rebuilt. Need_To_Rebuild_Archive := True; - Compile (Source_Id, Data, Local_Errors); end if; @@ -2175,11 +2207,12 @@ package body Makegpr is ------------------------------------ procedure Create_Archive_Dependency_File - (Name : String; First_Source : Other_Source_Id) + (Name : String; + First_Source : Other_Source_Id) is Source_Id : Other_Source_Id := First_Source; Source : Other_Source; - Dep_File : Ada.Text_IO.File_Type; + Dep_File : Ada.Text_IO.File_Type; use Ada.Text_IO; begin @@ -2246,14 +2279,18 @@ package body Makegpr is -- The id of the package IDE in the project file Compiler : constant Variable_Value := - Value_Of (Lang_Name_Ids (For_Language), Name_Compiler_Command, Ide); - -- The value of Compiler_Command ("language") in package IDE, if it is - -- defined. + Value_Of + (Name => Lang_Name_Ids (For_Language), + Index => 0, + Attribute_Or_Array_Name => Name_Compiler_Command, + In_Package => Ide); + -- The value of Compiler_Command ("language") in package IDE, if defined begin -- No need to do it again if the compiler is known for this language if Compiler_Names (For_Language) = null then + -- If compiler command is not defined for this language in package -- IDE, use the default compiler for this language. @@ -2266,8 +2303,7 @@ package body Makegpr is new String'(Get_Name_String (Compiler.Value)); end if; - -- Check if compiler is a GCC compiler: its name end with "gcc" or - -- "g++". + -- Check we have a GCC compiler (name ends with "gcc" or "g++") declare Comp_Name : constant String := Compiler_Names (For_Language).all; @@ -2277,7 +2313,6 @@ package body Makegpr is Last3 := Comp_Name (Comp_Name'Last - 2 .. Comp_Name'Last); Compiler_Is_Gcc (For_Language) := (Last3 = "gcc") or (Last3 = "g++"); - else Compiler_Is_Gcc (For_Language) := False; end if; @@ -2315,6 +2350,7 @@ package body Makegpr is Data : in out Project_Data) is Imported_Projects : Project_List := Data.Imported_Projects; + Path_Length : Natural := 0; Position : Natural := 0; @@ -2380,8 +2416,9 @@ package body Makegpr is ------------------------ procedure Recursive_Get_Dirs (Prj : Project_Id) is - Data : Project_Data; + Data : Project_Data; Imported : Project_List; + begin -- Nothing to do if project is undefined @@ -2391,6 +2428,7 @@ package body Makegpr is -- Nothing to do if project has already been processed if not Data.Seen then + -- Mark the project as processed, to avoid multiple processing -- of the same project. @@ -2427,8 +2465,7 @@ package body Makegpr is Last_Argument := 0; - -- Process this project individually, the project data are already - -- known. + -- Process this project individually, project data are already known Projects.Table (Project).Seen := True; @@ -2518,7 +2555,6 @@ package body Makegpr is end if; else - -- First compile sources and build archives, if necessary Compile_Sources; @@ -2676,6 +2712,7 @@ package body Makegpr is File : Ada.Text_IO.File_Type; use Ada.Text_IO; + begin Create (File, Out_File, Cpp_Linker); @@ -2693,11 +2730,8 @@ package body Makegpr is end if; end Choose_C_Plus_Plus_Link_Process; - - begin - -- If no mains were specified, get the mains from attribute Main, if - -- it exists. + -- If no mains specified, get mains from attribute Main, if it exists if not Mains_Specified then declare @@ -2844,6 +2878,7 @@ package body Makegpr is (Executable_Of (Project => Main_Project, Main => Other_Mains.Table (Main).File_Name, + Index => 0, Ada_Main => False)), True); end if; @@ -2959,24 +2994,30 @@ package body Makegpr is Executable_Name : constant String := Get_Name_String (Executable_Of - (Main_Project, Main_Id, Ada_Main => False)); + (Project => Main_Project, + Main => Main_Id, + Index => 0, + Ada_Main => False)); -- File name of the executable Executable_Path : constant String := - Get_Name_String (Data.Exec_Directory) & - Directory_Separator & Executable_Name; + Get_Name_String + (Data.Exec_Directory) & + Directory_Separator & + Executable_Name; -- Path name of the executable Exec_Time_Stamp : Time_Stamp_Type; - begin + begin -- Now, check if the executable is up to date. -- It is considered up to date if its time stamp is -- not earlier that the time stamp of any archive. -- Only do that if we don't know if we need to link. if not Need_To_Relink then - -- Get the time stamp of the excutable + + -- Get the time stamp of the executable Name_Len := 0; Add_Str_To_Name_Buffer (Executable_Path); @@ -3003,6 +3044,7 @@ package body Makegpr is declare Prj_Data : Project_Data; + begin for Prj in 1 .. Projects.Last loop Prj_Data := Projects.Table (Prj); @@ -3052,7 +3094,6 @@ package body Makegpr is end; end if; - -- If Need_To_Relink is False, we are done if Verbose_Mode and (not Need_To_Relink) then @@ -3076,7 +3117,10 @@ package body Makegpr is Directory_Separator & Get_Name_String (Executable_Of - (Main_Project, Main_Id, Ada_Main => False)), + (Project => Main_Project, + Main => Main_Id, + Index => 0, + Ada_Main => False)), True); -- Specify the object file of the main source @@ -3156,7 +3200,10 @@ package body Makegpr is Write_Str (Get_Name_String (Executable_Of - (Main_Project, Main_Id, Ada_Main => False))); + (Project => Main_Project, + Main => Main_Id, + Index => 0, + Ada_Main => False))); Write_Line (""" up to date"); end; @@ -3173,10 +3220,12 @@ package body Makegpr is ------------------ procedure Report_Error - (S1 : String; S2 : String := ""; S3 : String := "") + (S1 : String; + S2 : String := ""; + S3 : String := "") is begin - -- If keep_Going is True, output the error message, preceded by the + -- If Keep_Going is True, output the error message, preceded by the -- error header. if Keep_Going then @@ -3231,7 +3280,6 @@ package body Makegpr is if Project_File_Name_Expected then if Arg (1) = '-' then Osint.Fail ("project file name missing after -P"); - else Project_File_Name_Expected := False; Project_File_Name := new String'(Arg); @@ -3243,7 +3291,6 @@ package body Makegpr is elsif Output_File_Name_Expected then if Arg (1) = '-' then Osint.Fail ("output file name missing after -o"); - else Output_File_Name_Expected := False; Output_File_Name := new String'(Arg); @@ -3255,10 +3302,11 @@ package body Makegpr is elsif Arg'Length >= 6 and then Arg (Arg'First .. Arg'First + 1) = "-c" and then - Arg (Arg'Last - 3 .. Arg'Last) = "args" + Arg (Arg'Last - 3 .. Arg'Last) = "args" + then declare - OK : Boolean := False; + OK : Boolean := False; Args_String : constant String := Arg (Arg'First + 2 .. Arg'Last - 4); @@ -3287,9 +3335,8 @@ package body Makegpr is elsif Arg = "-gargs" then Current_Processor := None; - -- A special test is needed for the -o switch within a -largs - -- since that is another way to specify the name of the final - -- executable. + -- A special test is needed for the -o switch within a -largs since + -- that is another way to specify the name of the final executable. elsif Current_Processor = Linker and then Arg = "-o" then Osint.Fail diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb index 49b7a0df475..268f75492eb 100644 --- a/gcc/ada/makeusg.adb +++ b/gcc/ada/makeusg.adb @@ -88,6 +88,11 @@ begin Write_Str (" -D dir Specify dir as the object directory"); Write_Eol; + -- Line for -eI + + Write_Str (" -eI Index of unit in multi-unit source file"); + Write_Eol; + -- Line for -eL Write_Str (" -eL Follow symbolic links when processing " & diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index f5cd39338fd..eb92cd76daf 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -25,6 +25,7 @@ ------------------------------------------------------------------------------ with Namet; use Namet; +with Osint; use Osint; with Prj; use Prj; with Prj.Ext; with Prj.Util; @@ -32,8 +33,32 @@ with Snames; use Snames; with Table; with Types; use Types; +with System.HTable; + package body Makeutl is + type Mark_Key is record + File : File_Name_Type; + Index : Int; + end record; + -- Identify either a mono-unit source (when Index = 0) or a specific unit + -- in a multi-unit source. + + Max_Mask_Num : constant := 2048; + + subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1; + + function Hash (Key : Mark_Key) return Mark_Num; + + package Marks is new System.HTable.Simple_HTable + (Header_Num => Mark_Num, + Element => Boolean, + No_Element => False, + Key => Mark_Key, + Hash => Hash, + Equal => "="); + -- A hash table to keep tracks of the marked units. + type Linker_Options_Data is record Project : Project_Id; Options : String_List_Id; @@ -83,6 +108,24 @@ package body Makeutl is end if; end Add_Linker_Option; + ---------------------- + -- Delete_All_Marks -- + ---------------------- + + procedure Delete_All_Marks is + begin + Marks.Reset; + end Delete_All_Marks; + + ---------- + -- Hash -- + ---------- + + function Hash (Key : Mark_Key) return Mark_Num is + begin + return Union_Id (Key.File) mod Max_Mask_Num; + end Hash; + ---------------------------- -- Is_External_Assignment -- ---------------------------- @@ -124,6 +167,19 @@ package body Makeutl is end if; end Is_External_Assignment; + --------------- + -- Is_Marked -- + --------------- + + function Is_Marked + (Source_File : File_Name_Type; + Index : Int := 0) + return Boolean + is + begin + return Marks.Get (K => (File => Source_File, Index => Index)); + end Is_Marked; + ----------------------------- -- Linker_Options_Switches -- ----------------------------- @@ -166,6 +222,7 @@ package body Makeutl is Options := Prj.Util.Value_Of (Name => Name_Ada, + Index => 0, Attribute_Or_Array_Name => Name_Linker_Options, In_Package => Linker_Package); @@ -305,6 +362,15 @@ package body Makeutl is end Mains; + ---------- + -- Mark -- + ---------- + + procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is + begin + Marks.Set (K => (File => Source_File, Index => Index), E => True); + end Mark; + --------------------------- -- Test_If_Relative_Path -- --------------------------- @@ -384,4 +450,58 @@ package body Makeutl is end if; end Test_If_Relative_Path; + ------------------- + -- Unit_Index_Of -- + ------------------- + + function Unit_Index_Of (ALI_File : File_Name_Type) return Int is + Start : Natural; + Finish : Natural; + Result : Int := 0; + begin + Get_Name_String (ALI_File); + + -- First, find the last dot + + Finish := Name_Len; + + while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop + Finish := Finish - 1; + end loop; + + if Finish = 1 then + return 0; + end if; + + -- Now check that the dot is preceded by digits + + Start := Finish; + Finish := Finish - 1; + + while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop + Start := Start - 1; + end loop; + + -- If there is no difits, or if the digits are not preceded by + -- the character that precedes a unit index, this is not the ALI file + -- of a unit in a multi-unit source. + + if Start > Finish or else + Start = 1 or else + Name_Buffer (Start - 1) /= Multi_Unit_Index_Character + then + return 0; + end if; + + -- Build the index from the digit(s) + + while Start <= Finish loop + Result := (Result * 10) + Character'Pos (Name_Buffer (Start)) + - Character'Pos ('0'); + Start := Start + 1; + end loop; + + return Result; + end Unit_Index_Of; + end Makeutl; diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 3e82e0d010a..b5cfaf7be3d 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -27,6 +27,7 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; with Osint; with Prj; use Prj; +with Types; use Types; package Makeutl is @@ -34,6 +35,9 @@ package Makeutl is (S1 : String; S2 : String := ""; S3 : String := ""); Do_Fail : Fail_Proc := Osint.Fail'Access; + function Unit_Index_Of (ALI_File : File_Name_Type) return Int; + -- Find the index of a unit in a source file. Return zero if the file + -- is not a multi-unit source file. function Is_External_Assignment (Argv : String) return Boolean; -- Verify that an external assignment switch is syntactically correct. @@ -85,4 +89,22 @@ package Makeutl is -- For gnatbind switches, Including_L_Switch is False, because the -- argument of the -L switch is not a path. + ---------------------- + -- Marking Routines -- + ---------------------- + + procedure Mark (Source_File : File_Name_Type; Index : Int := 0); + -- Mark a unit, identified by its source file and, when Index is not 0, + -- the index of the unit in the source file. Marking is used to signal + -- that the unit has already been inserted in the Q. + + function Is_Marked + (Source_File : File_Name_Type; + Index : Int := 0) + return Boolean; + -- Returns True if the unit was previously marked. + + procedure Delete_All_Marks; + -- Remove all file/index couples marked + end Makeutl; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 70d8741f42e..b55d801388d 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -815,7 +815,9 @@ package body MLib.Prj is if Defaults /= No_Array_Element then Switches := Value_Of - (Index => Name_Ada, In_Array => Defaults); + (Index => Name_Ada, + Src_Index => 0, + In_Array => Defaults); if not Switches.Default then Switch := Switches.Values; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 9fea924caec..90babc28861 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -638,6 +638,11 @@ package Opt is -- Set to True when either Compile_Only, Bind_Only or Link_Only is -- set to True. + Main_Index : Int := 0; + -- GNATMAKE + -- This is set to non-zero by gnatmake switch -eInnn to indicate that + -- the main program is the nnn unit in a multi-unit source file. + Mapping_File_Name : String_Ptr := null; -- GNAT -- File name of mapping between unit names, file names and path names. diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 2dc5c321509..7ca5fca77e5 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -520,7 +520,7 @@ package body Osint is -- Add_File -- -------------- - procedure Add_File (File_Name : String) is + procedure Add_File (File_Name : String; Index : Int := No_Index) is begin Number_File_Names := Number_File_Names + 1; @@ -530,9 +530,12 @@ package body Osint is if Number_File_Names > File_Names'Last then File_Names := new File_Name_Array'(File_Names.all & File_Names.all); + File_Indexes := + new File_Index_Array'(File_Indexes.all & File_Indexes.all); end if; - File_Names (Number_File_Names) := new String'(File_Name); + File_Names (Number_File_Names) := new String'(File_Name); + File_Indexes (Number_File_Names) := Index; end Add_File; ------------------------ @@ -670,6 +673,15 @@ package body Osint is end if; end Create_File_And_Check; + ------------------------ + -- Current_File_Index -- + ------------------------ + + function Current_File_Index return Int is + begin + return File_Indexes (Current_File_Name_Index); + end Current_File_Index; + -------------------------------- -- Current_Library_File_Stamp -- -------------------------------- diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 44ad5bad4ed..f6e69c74814 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -92,7 +92,9 @@ package Osint is function Number_Of_Files return Int; -- gives the total number of filenames found on the command line. - procedure Add_File (File_Name : String); + No_Index : constant := -1; + + procedure Add_File (File_Name : String; Index : Int := No_Index); -- Called by the subprogram processing the command line for each -- file name found. @@ -379,6 +381,9 @@ package Osint is -- every single time the routines are called unless you have previously -- called Source_File_Data (Cache => True). See below. + function Current_File_Index return Int; + -- Return the index in its source file of the current main unit + function Matching_Full_Source_Name (N : File_Name_Type; T : Time_Stamp_Type) return File_Name_Type; @@ -573,6 +578,11 @@ private -- extensible, because when using project files, there may be -- more files than arguments on the command line. + type File_Index_Array is array (Int range <>) of Int; + type File_Index_Array_Ptr is access File_Index_Array; + File_Indexes : File_Index_Array_Ptr := + new File_Index_Array (1 .. Int (Argument_Count) + 2); + Current_File_Name_Index : Int := 0; -- The index in File_Names of the last file opened by Next_Main_Source -- or Next_Main_Lib_File. The value 0 indicates that no files have been diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 6e8cc6cccb0..a0588bcb4e1 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -39,7 +39,9 @@ package body Prj.Attr is -- The first letter is one of -- 'S' for Single - -- 'L' for list + -- 's' for Single with optional index + -- 'L' for List + -- 'l' for List of strings with optional indexes -- The second letter is one of -- 'V' for single variable @@ -47,6 +49,7 @@ package body Prj.Attr is -- 'a' for case insensitive associative array -- 'b' for associative array, case insensitive if file names are case -- insensitive + -- 'c' same as 'b', with optional index -- End is indicated by two consecutive '#'. @@ -72,7 +75,7 @@ package body Prj.Attr is "SVlibrary_symbol_file#" & "SVlibrary_symbol_policy#" & "SVlibrary_reference_symbol_file#" & - "LVmain#" & + "lVmain#" & "LVlanguages#" & "SVmain_language#" & @@ -86,10 +89,10 @@ package body Prj.Attr is "SVseparate_suffix#" & "SVcasing#" & "SVdot_replacement#" & - "SAspecification#" & - "SAspec#" & - "SAimplementation#" & - "SAbody#" & + "sAspecification#" & + "sAspec#" & + "sAimplementation#" & + "sAbody#" & "Laspecification_exceptions#" & "Laimplementation_exceptions#" & @@ -97,15 +100,15 @@ package body Prj.Attr is "Pcompiler#" & "Ladefault_switches#" & - "Lbswitches#" & + "Lcswitches#" & "SVlocal_configuration_pragmas#" & -- package Builder "Pbuilder#" & "Ladefault_switches#" & - "Lbswitches#" & - "Sbexecutable#" & + "Lcswitches#" & + "Scexecutable#" & "SVexecutable_suffix#" & "SVglobal_configuration_pragmas#" & @@ -118,13 +121,13 @@ package body Prj.Attr is "Pbinder#" & "Ladefault_switches#" & - "Lbswitches#" & + "Lcswitches#" & -- package Linker "Plinker#" & "Ladefault_switches#" & - "Lbswitches#" & + "Lcswitches#" & "LVlinker_options#" & -- package Cross_Reference @@ -184,6 +187,7 @@ package body Prj.Attr is Current_Attribute : Attribute_Node_Id := Empty_Attribute; Is_An_Attribute : Boolean := False; Kind_1 : Variable_Kind := Undefined; + Optional_Index : Boolean := False; Kind_2 : Attribute_Kind := Single; Package_Name : Name_Id := No_Name; Attribute_Name : Name_Id := No_Name; @@ -232,10 +236,20 @@ package body Prj.Attr is Start := Finish + 1; when 'S' => - Kind_1 := Single; + Kind_1 := Single; + Optional_Index := False; + + when 's' => + Kind_1 := Single; + Optional_Index := True; when 'L' => - Kind_1 := List; + Kind_1 := List; + Optional_Index := False; + + when 'l' => + Kind_1 := List; + Optional_Index := True; when others => raise Program_Error; @@ -263,6 +277,14 @@ package body Prj.Attr is Kind_2 := Case_Insensitive_Associative_Array; end if; + when 'c' => + if File_Names_Case_Sensitive then + Kind_2 := Optional_Index_Associative_Array; + else + Kind_2 := + Optional_Index_Case_Insensitive_Associative_Array; + end if; + when others => raise Program_Error; end case; @@ -279,6 +301,7 @@ package body Prj.Attr is To_Lower (Initialization_Data (Start .. Finish - 1)); Attribute_Name := Name_Find; Attributes.Increment_Last; + if Current_Attribute = Empty_Attribute then First_Attribute := Attributes.Last; @@ -306,10 +329,11 @@ package body Prj.Attr is Current_Attribute := Attributes.Last; Attributes.Table (Current_Attribute) := - (Name => Attribute_Name, - Kind_1 => Kind_1, - Kind_2 => Kind_2, - Next => Empty_Attribute); + (Name => Attribute_Name, + Kind_1 => Kind_1, + Optional_Index => Optional_Index, + Kind_2 => Kind_2, + Next => Empty_Attribute); Start := Finish + 1; end if; end loop; diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads index cf3c140b11f..9ca7ded47c1 100644 --- a/gcc/ada/prj-attr.ads +++ b/gcc/ada/prj-attr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -53,13 +53,16 @@ package Prj.Attr is type Attribute_Kind is (Single, Associative_Array, - Case_Insensitive_Associative_Array); + Optional_Index_Associative_Array, + Case_Insensitive_Associative_Array, + Optional_Index_Case_Insensitive_Associative_Array); type Attribute_Record is record - Name : Name_Id; - Kind_1 : Variable_Kind; - Kind_2 : Attribute_Kind; - Next : Attribute_Node_Id; + Name : Name_Id; + Kind_1 : Variable_Kind; + Optional_Index : Boolean; + Kind_2 : Attribute_Kind; + Next : Attribute_Node_Id; end record; package Attributes is diff --git a/gcc/ada/prj-com.ads b/gcc/ada/prj-com.ads index 123ff290f67..e4e73d92209 100644 --- a/gcc/ada/prj-com.ads +++ b/gcc/ada/prj-com.ads @@ -56,6 +56,7 @@ package Prj.Com is type File_Name_Data is record Name : Name_Id := No_Name; + Index : Int := 0; Display_Name : Name_Id := No_Name; Path : Name_Id := No_Name; Display_Path : Name_Id := No_Name; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index ac39eeda369..89233fa90eb 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc -- +-- Copyright (C) 2001-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- -- @@ -33,6 +33,7 @@ with Scans; use Scans; with Snames; with Types; use Types; with Prj.Attr; use Prj.Attr; +with Uintp; use Uintp; package body Prj.Dect is @@ -121,6 +122,7 @@ package body Prj.Dect is Current_Attribute : Attribute_Node_Id := First_Attribute; Full_Associative_Array : Boolean := False; Attribute_Name : Name_Id := No_Name; + Optional_Index : Boolean := False; begin Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration); @@ -194,8 +196,9 @@ package body Prj.Dect is -- Set, if appropriate the index case insensitivity flag - elsif Attributes.Table (Current_Attribute).Kind_2 = - Case_Insensitive_Associative_Array + elsif Attributes.Table (Current_Attribute).Kind_2 in + Case_Insensitive_Associative_Array .. + Optional_Index_Case_Insensitive_Associative_Array then Set_Case_Insensitive (Attribute, To => True); end if; @@ -245,6 +248,40 @@ package body Prj.Dect is if Token = Tok_String_Literal then Set_Associative_Array_Index_Of (Attribute, Token_Name); Scan; -- past the literal string index + + if Token = Tok_At then + case Attributes.Table (Current_Attribute).Kind_2 is + when Optional_Index_Associative_Array | + Optional_Index_Case_Insensitive_Associative_Array => + Scan; + Expect (Tok_Integer_Literal, "integer literal"); + + if Token = Tok_Integer_Literal then + declare + Index : constant Int := + UI_To_Int (Int_Literal_Value); + begin + if Index = 0 then + Error_Msg ("index cannot be zero", Token_Ptr); + + else + -- Set the index + Set_Source_Index_Of (Attribute, To => Index); + end if; + end; + + Scan; + end if; + + when others => + Error_Msg ("index not allowed here", Token_Ptr); + Scan; + + if Token = Tok_Integer_Literal then + Scan; + end if; + end case; + end if; end if; Expect (Tok_Right_Paren, "`)`"); @@ -271,6 +308,7 @@ package body Prj.Dect is if Current_Attribute /= Empty_Attribute then Set_Expression_Kind_Of (Attribute, To => Attributes.Table (Current_Attribute).Kind_1); + Optional_Index := Attributes.Table (Current_Attribute).Optional_Index; end if; Expect (Tok_Use, "USE"); @@ -439,7 +477,8 @@ package body Prj.Dect is Parse_Expression (Expression => Expression, Current_Project => Current_Project, - Current_Package => Current_Package); + Current_Package => Current_Package, + Optional_Index => Optional_Index); Set_Expression_Of (Attribute, To => Expression); -- If the expression is legal, but not of the right kind @@ -1225,7 +1264,8 @@ package body Prj.Dect is Parse_Expression (Expression => Expression, Current_Project => Current_Project, - Current_Package => Current_Package); + Current_Package => Current_Package, + Optional_Index => False); Set_Expression_Of (Variable, To => Expression); if Expression /= Empty_Node then diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index ba2b04f546e..b8e3fc7bf02 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -584,7 +584,8 @@ package body Prj.Env is procedure Put (Unit_Name : Name_Id; File_Name : Name_Id; - Unit_Kind : Spec_Or_Body); + Unit_Kind : Spec_Or_Body; + Index : Int); -- Put an SFN pragma in the temporary file procedure Put (File : File_Descriptor; S : String); @@ -742,7 +743,8 @@ package body Prj.Env is procedure Put (Unit_Name : Name_Id; File_Name : Name_Id; - Unit_Kind : Spec_Or_Body) + Unit_Kind : Spec_Or_Body; + Index : Int) is begin -- A temporary file needs to be open @@ -761,7 +763,14 @@ package body Prj.Env is end if; Put (File, Namet.Get_Name_String (File_Name)); - Put_Line (File, """);"); + Put (File, """"); + + if Index /= 0 then + Put (File, ", Index =>"); + Put (File, Index'Img); + end if; + + Put_Line (File, ");"); end Put; procedure Put (File : File_Descriptor; S : String) is @@ -788,7 +797,7 @@ package body Prj.Env is Last : Natural; begin - -- Add an ASCII.LF to the string. As this gnat.adc is supposed to + -- Add an ASCII.LF to the string. As this config file is supposed to -- be used only by the compiler, we don't care about the characters -- for the end of line. In fact we could have put a space, but -- it is more convenient to be able to read gnat.adc during @@ -831,13 +840,15 @@ package body Prj.Env is if Unit.File_Names (Specification).Needs_Pragma then Put (Unit.Name, Unit.File_Names (Specification).Name, - Specification); + Specification, + Unit.File_Names (Specification).Index); end if; if Unit.File_Names (Body_Part).Needs_Pragma then Put (Unit.Name, Unit.File_Names (Body_Part).Name, - Body_Part); + Body_Part, + Unit.File_Names (Body_Part).Index); end if; Current_Unit := Current_Unit + 1; @@ -1269,7 +1280,6 @@ package body Prj.Env is Write_Line (" OK"); end if; - if Full_Path then return Get_Name_String (Unit.File_Names (Specification).Path); diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index 6fdb3bba0e3..b6b66dd5195 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -136,9 +136,10 @@ package body Prj.Makr is Args : Argument_List (1 .. Preproc_Switches'Length + 6); type SFN_Pragma is record - Unit : Name_Id; - File : Name_Id; - Spec : Boolean; + Unit : Name_Id; + File : Name_Id; + Index : Int := 0; + Spec : Boolean; end record; package SFN_Pragmas is new Table.Table @@ -254,7 +255,7 @@ package body Prj.Makr is then Output.Write_Str (" Checking """); Output.Write_Str (Str (1 .. Last)); - Output.Write_Str (""": "); + Output.Write_Line (""": "); end if; -- If the file name matches one of the regular expressions, @@ -362,7 +363,7 @@ package body Prj.Makr is if End_Of_File (File) then if Opt.Verbose_Mode then if not Success then - Output.Write_Str ("(process died) "); + Output.Write_Str (" (process died) "); end if; end if; @@ -383,10 +384,11 @@ package body Prj.Makr is Name_Buffer (1 .. Name_Len) := Text_Line (6 .. J - 7); SFN_Prag := - (Unit => Name_Find, - File => File_Name_Id, - Spec => Text_Line (J - 5 .. J) = - "(spec)"); + (Unit => Name_Find, + File => File_Name_Id, + Index => 0, + Spec => Text_Line (J - 5 .. J) = + "(spec)"); SFN_Pragmas.Increment_Last; SFN_Pragmas.Table @@ -400,107 +402,116 @@ package body Prj.Makr is if Save_Last_Pragma_Index = SFN_Pragmas.Last then if Opt.Verbose_Mode then - Output.Write_Line ("not a unit"); - end if; - - elsif SFN_Pragmas.Last > - Save_Last_Pragma_Index + 1 - then - SFN_Pragmas.Set_Last (Save_Last_Pragma_Index); - - if Opt.Verbose_Mode then - Output.Write_Line - ("file contains multiple units"); + Output.Write_Line (" not a unit"); end if; else - SFN_Prag := SFN_Pragmas.Table - (SFN_Pragmas.Last); - - if Opt.Verbose_Mode then - if SFN_Prag.Spec then - Output.Write_Str ("spec of "); - - else - Output.Write_Str ("body of "); - end if; - - Output.Write_Line - (Get_Name_String (SFN_Prag.Unit)); + if SFN_Pragmas.Last > + Save_Last_Pragma_Index + 1 + then + for Index in Save_Last_Pragma_Index + 1 .. + SFN_Pragmas.Last + loop + SFN_Pragmas.Table (Index).Index := + Int (Index - Save_Last_Pragma_Index); + end loop; end if; - if Project_File then - - -- Add the corresponding attribute in the - -- Naming package of the naming project. - - declare - Decl_Item : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => - N_Declarative_Item); - - Attribute : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => - N_Attribute_Declaration); - - Expression : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Expression, - And_Expr_Kind => Single); - - Term : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Term, - And_Expr_Kind => Single); - - Value : constant Project_Node_Id := - Default_Project_Node - (Of_Kind => N_Literal_String, - And_Expr_Kind => Single); - - begin - Set_Next_Declarative_Item - (Decl_Item, - To => First_Declarative_Item_Of - (Naming_Package)); - Set_First_Declarative_Item_Of - (Naming_Package, To => Decl_Item); - Set_Current_Item_Node - (Decl_Item, To => Attribute); - - -- Is it a spec or a body? + for Index in Save_Last_Pragma_Index + 1 .. + SFN_Pragmas.Last + loop + SFN_Prag := SFN_Pragmas.Table (Index); + if Opt.Verbose_Mode then if SFN_Prag.Spec then - Set_Name_Of - (Attribute, To => Name_Spec); + Output.Write_Str (" spec of "); + else - Set_Name_Of - (Attribute, - To => Name_Body); + Output.Write_Str (" body of "); end if; - -- Get the name of the unit + Output.Write_Line + (Get_Name_String (SFN_Prag.Unit)); + end if; + + if Project_File then + + -- Add the corresponding attribute in the + -- Naming package of the naming project. + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Declarative_Item); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Attribute_Declaration); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); + + begin + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of + (Naming_Package)); + Set_First_Declarative_Item_Of + (Naming_Package, To => Decl_Item); + Set_Current_Item_Node + (Decl_Item, To => Attribute); + + -- Is it a spec or a body? + + if SFN_Prag.Spec then + Set_Name_Of + (Attribute, To => Name_Spec); + else + Set_Name_Of + (Attribute, + To => Name_Body); + end if; - Get_Name_String (SFN_Prag.Unit); - To_Lower (Name_Buffer (1 .. Name_Len)); - Set_Associative_Array_Index_Of - (Attribute, To => Name_Find); + -- Get the name of the unit - Set_Expression_Of - (Attribute, To => Expression); - Set_First_Term - (Expression, To => Term); - Set_Current_Term (Term, To => Value); + Get_Name_String (SFN_Prag.Unit); + To_Lower (Name_Buffer (1 .. Name_Len)); + Set_Associative_Array_Index_Of + (Attribute, To => Name_Find); - -- And set the name of the file + Set_Expression_Of + (Attribute, To => Expression); + Set_First_Term + (Expression, To => Term); + Set_Current_Term (Term, To => Value); - Set_String_Value_Of - (Value, To => File_Name_Id); - end; + -- And set the name of the file - -- Add source file name to source list file + Set_String_Value_Of + (Value, To => File_Name_Id); + Set_Source_Index_Of + (Value, To => SFN_Prag.Index); + end; + end if; + end loop; + + if Project_File then + -- Add source file name to source list + -- file. Last := Last + 1; Str (Last) := ASCII.LF; @@ -1273,7 +1284,15 @@ package body Prj.Makr is Write_A_String (Get_Name_String (SFN_Pragmas.Table (Index).File)); - Write_A_String (""");"); + + Write_A_String (""""); + + if SFN_Pragmas.Table (Index).Index /= 0 then + Write_A_String (", Index =>"); + Write_A_String (SFN_Pragmas.Table (Index).Index'Img); + end if; + + Write_A_String (");"); Write_Eol; end loop; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index f49af20afa6..f728d975d34 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -38,6 +38,7 @@ with Prj.Err; with Prj.Util; use Prj.Util; with Sinput.P; with Snames; use Snames; +with Table; use Table; with Types; use Types; with Ada.Characters.Handling; use Ada.Characters.Handling; @@ -97,27 +98,48 @@ package body Prj.Nmsc is -- several times, and to avoid cycles that may be introduced by symbolic -- links. + type Ada_Naming_Exception_Id is new Nat; + No_Ada_Naming_Exception : constant Ada_Naming_Exception_Id := 0; + type Unit_Info is record Kind : Spec_Or_Body; Unit : Name_Id; + Next : Ada_Naming_Exception_Id := No_Ada_Naming_Exception; end record; - No_Unit : constant Unit_Info := (Specification, No_Name); + -- No_Unit : constant Unit_Info := + -- (Specification, No_Name, No_Ada_Naming_Exception); + + package Ada_Naming_Exception_Table is new Table.Table + (Table_Component_Type => Unit_Info, + Table_Index_Type => Ada_Naming_Exception_Id, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 100, + Table_Name => "Prj.Nmsc.Ada_Naming_Exception_Table"); package Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, - Element => Unit_Info, - No_Element => No_Unit, + Element => Ada_Naming_Exception_Id, + No_Element => No_Ada_Naming_Exception, Key => Name_Id, Hash => Hash, Equal => "="); - -- A hash table to store naming exceptions for Ada + -- A hash table to store naming exceptions for Ada. For each file name + -- there is one or several unit in table Ada_Naming_Exception_Table. function Hash (Unit : Unit_Info) return Header_Num; + type Name_And_Index is record + Name : Name_Id := No_Name; + Index : Int := 0; + end record; + No_Name_And_Index : constant Name_And_Index := + (Name => No_Name, Index => 0); + package Reverse_Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, - Element => Name_Id, - No_Element => No_Name, + Element => Name_And_Index, + No_Element => No_Name_And_Index, Key => Unit_Info, Hash => Hash, Equal => "="); @@ -198,12 +220,15 @@ package body Prj.Nmsc is procedure Get_Unit (Canonical_File_Name : Name_Id; Naming : Naming_Data; + Exception_Id : out Ada_Naming_Exception_Id; Unit_Name : out Name_Id; Unit_Kind : out Spec_Or_Body; Needs_Pragma : out Boolean); -- Find out, from a file name, the unit name, the unit kind and if a -- specific SFN pragma is needed. If the file name corresponds to no - -- unit, then Unit_Name will be No_Name. + -- unit, then Unit_Name will be No_Name. If the file is a multi-unit source + -- or an exception to the naming scheme, then Exception_Id is set to + -- the unit or units that the source contains. function Is_Illegal_Suffix (Suffix : String; @@ -362,7 +387,7 @@ package body Prj.Nmsc is Write_Line (Get_Name_String (Name)); end if; - -- Register the source if it is an Ada compilation unit.. + -- Register the source if it is an Ada compilation unit. Record_Ada_Source (File_Name => Name, @@ -574,7 +599,6 @@ package body Prj.Nmsc is (Name_Locally_Removed_Files, Data.Decl.Attributes); - begin pragma Assert (Sources.Kind = List, @@ -896,6 +920,7 @@ package body Prj.Nmsc is String_Elements.Increment_Last; String_Elements.Table (String_Elements.Last) := (Value => ALI_Name_Id, + Index => 0, Display_Value => ALI_Name_Id, Location => String_Elements.Table (Interfaces).Location, @@ -2099,8 +2124,9 @@ package body Prj.Nmsc is declare Ada_Spec_Suffix : constant Variable_Value := Prj.Util.Value_Of - (Index => Name_Ada, - In_Array => Data.Naming.Spec_Suffix); + (Index => Name_Ada, + Src_Index => 0, + In_Array => Data.Naming.Spec_Suffix); begin if Ada_Spec_Suffix.Kind = Single @@ -2128,8 +2154,9 @@ package body Prj.Nmsc is declare Ada_Body_Suffix : constant Variable_Value := Prj.Util.Value_Of - (Index => Name_Ada, - In_Array => Data.Naming.Body_Suffix); + (Index => Name_Ada, + Src_Index => 0, + In_Array => Data.Naming.Body_Suffix); begin if Ada_Body_Suffix.Kind = Single @@ -2491,6 +2518,7 @@ package body Prj.Nmsc is procedure Free_Ada_Naming_Exceptions is begin + Ada_Naming_Exception_Table.Set_Last (0); Ada_Naming_Exceptions.Reset; Reverse_Ada_Naming_Exceptions.Reset; end Free_Ada_Naming_Exceptions; @@ -2591,57 +2619,42 @@ package body Prj.Nmsc is procedure Get_Unit (Canonical_File_Name : Name_Id; Naming : Naming_Data; + Exception_Id : out Ada_Naming_Exception_Id; Unit_Name : out Name_Id; Unit_Kind : out Spec_Or_Body; Needs_Pragma : out Boolean) is - function Check_Exception (Canonical : Name_Id) return Boolean; - pragma Inline (Check_Exception); - -- Check if Canonical is one of the exceptions in List. - -- Returns True if Get_Unit should exit - - --------------------- - -- Check_Exception -- - --------------------- + Info_Id : Ada_Naming_Exception_Id + := Ada_Naming_Exceptions.Get (Canonical_File_Name); + VMS_Name : Name_Id; - function Check_Exception (Canonical : Name_Id) return Boolean is - Info : Unit_Info := Ada_Naming_Exceptions.Get (Canonical); - VMS_Name : Name_Id; - - begin - if Info = No_Unit then - if Hostparm.OpenVMS then - VMS_Name := Canonical; - Get_Name_String (VMS_Name); - - if Name_Buffer (Name_Len) = '.' then - Name_Len := Name_Len - 1; - VMS_Name := Name_Find; - end if; - - Info := Ada_Naming_Exceptions.Get (VMS_Name); + begin + if Info_Id = No_Ada_Naming_Exception then + if Hostparm.OpenVMS then + VMS_Name := Canonical_File_Name; + Get_Name_String (VMS_Name); + + if Name_Buffer (Name_Len) = '.' then + Name_Len := Name_Len - 1; + VMS_Name := Name_Find; end if; - if Info = No_Unit then - return False; - end if; + Info_Id := Ada_Naming_Exceptions.Get (VMS_Name); end if; - Unit_Kind := Info.Kind; - Unit_Name := Info.Unit; - Needs_Pragma := True; - return True; - end Check_Exception; - - -- Start of processing for Get_Unit - - begin - Needs_Pragma := False; + end if; - if Check_Exception (Canonical_File_Name) then + if Info_Id /= No_Ada_Naming_Exception then + Exception_Id := Info_Id; + Unit_Name := No_Name; + Unit_Kind := Specification; + Needs_Pragma := True; return; end if; + Needs_Pragma := False; + Exception_Id := No_Ada_Naming_Exception; + Get_Name_String (Canonical_File_Name); declare @@ -3004,7 +3017,8 @@ package body Prj.Nmsc is Display_Value => Non_Canonical_Path, Location => No_Location, Flag => False, - Next => Nil_String); + Next => Nil_String, + Index => 0); -- Case of first source directory @@ -3380,7 +3394,8 @@ package body Prj.Nmsc is Display_Value => Data.Display_Directory, Location => No_Location, Flag => False, - Next => Nil_String); + Next => Nil_String, + Index => 0); if Current_Verbosity = High then Write_Line ("Single source directory:"); @@ -3747,10 +3762,11 @@ package body Prj.Nmsc is if Suffix2 = No_Array_Element then Array_Elements.Increment_Last; Array_Elements.Table (Array_Elements.Last) := - (Index => Element.Index, + (Index => Element.Index, + Src_Index => Element.Src_Index, Index_Case_Sensitive => False, - Value => Element.Value, - Next => Spec_Suffixs); + Value => Element.Value, + Next => Spec_Suffixs); Spec_Suffixs := Array_Elements.Last; end if; @@ -3823,6 +3839,7 @@ package body Prj.Nmsc is Array_Elements.Increment_Last; Array_Elements.Table (Array_Elements.Last) := (Index => Element.Index, + Src_Index => Element.Src_Index, Index_Case_Sensitive => False, Value => Element.Value, Next => Impl_Suffixs); @@ -4091,8 +4108,9 @@ package body Prj.Nmsc is declare Naming_Exceptions : constant Variable_Value := Value_Of - (Index => Lang_Name_Ids (Lang), - In_Array => Data.Naming.Implementation_Exceptions); + (Index => Lang_Name_Ids (Lang), + Src_Index => 0, + In_Array => Data.Naming.Implementation_Exceptions); Element_Id : String_List_Id; Element : String_Element; File_Id : Name_Id; @@ -4325,6 +4343,8 @@ package body Prj.Nmsc is Current : Array_Element_Id := List; Element : Array_Element; + Unit : Unit_Info; + begin -- Traverse the list @@ -4332,12 +4352,18 @@ package body Prj.Nmsc is Element := Array_Elements.Table (Current); if Element.Index /= No_Name then - Ada_Naming_Exceptions.Set - (Element.Value.Value, - (Kind => Kind, Unit => Element.Index)); + Unit := + (Kind => Kind, + Unit => Element.Index, + Next => No_Ada_Naming_Exception); Reverse_Ada_Naming_Exceptions.Set - ((Kind => Kind, Unit => Element.Index), - Element.Value.Value); + (Unit, (Element.Value.Value, Element.Value.Index)); + Unit.Next := Ada_Naming_Exceptions.Get (Element.Value.Value); + Ada_Naming_Exception_Table.Increment_Last; + Ada_Naming_Exception_Table.Table + (Ada_Naming_Exception_Table.Last) := Unit; + Ada_Naming_Exceptions.Set + (Element.Value.Value, Ada_Naming_Exception_Table.Last); end if; Current := Element.Next; @@ -4382,16 +4408,22 @@ package body Prj.Nmsc is is Canonical_File_Name : Name_Id; Canonical_Path_Name : Name_Id; + Exception_Id : Ada_Naming_Exception_Id; Unit_Name : Name_Id; Unit_Kind : Spec_Or_Body; + Unit_Index : Int := 0; + Info : Unit_Info; + Name_Index : Name_And_Index; Needs_Pragma : Boolean; The_Location : Source_Ptr := Location; Previous_Source : constant String_List_Id := Current_Source; - Except_Name : Name_Id := No_Name; + Except_Name : Name_And_Index := No_Name_And_Index; Unit_Prj : Unit_Project; + File_Name_Recorded : Boolean := False; + begin Get_Name_String (File_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); @@ -4415,11 +4447,14 @@ package body Prj.Nmsc is Get_Unit (Canonical_File_Name => Canonical_File_Name, Naming => Data.Naming, + Exception_Id => Exception_Id, Unit_Name => Unit_Name, Unit_Kind => Unit_Kind, Needs_Pragma => Needs_Pragma); - if Unit_Name = No_Name then + if Exception_Id = No_Ada_Naming_Exception and then + Unit_Name = No_Name + then if Current_Verbosity = High then Write_Str (" """); Write_Str (Get_Name_String (Canonical_File_Name)); @@ -4427,19 +4462,21 @@ package body Prj.Nmsc is end if; else + -- Check to see if the source has been hidden by an exception, -- but only if it is not an exception. if not Needs_Pragma then Except_Name := - Reverse_Ada_Naming_Exceptions.Get ((Unit_Kind, Unit_Name)); + Reverse_Ada_Naming_Exceptions.Get + ((Unit_Kind, Unit_Name, No_Ada_Naming_Exception)); - if Except_Name /= No_Name then + if Except_Name /= No_Name_And_Index then if Current_Verbosity = High then Write_Str (" """); Write_Str (Get_Name_String (Canonical_File_Name)); Write_Str (""" contains a unit that is found in """); - Write_Str (Get_Name_String (Except_Name)); + Write_Str (Get_Name_String (Except_Name.Name)); Write_Line (""" (ignored)."); end if; @@ -4451,145 +4488,173 @@ package body Prj.Nmsc is end if; end if; - -- Put the file name in the list of sources of the project + loop + if Exception_Id /= No_Ada_Naming_Exception then + Info := Ada_Naming_Exception_Table.Table (Exception_Id); + Exception_Id := Info.Next; + Info.Next := No_Ada_Naming_Exception; + Name_Index := Reverse_Ada_Naming_Exceptions.Get (Info); - String_Elements.Increment_Last; - String_Elements.Table (String_Elements.Last) := - (Value => Canonical_File_Name, - Display_Value => File_Name, - Location => No_Location, - Flag => False, - Next => Nil_String); + Unit_Name := Info.Unit; + Unit_Index := Name_Index.Index; + Unit_Kind := Info.Kind; + end if; + -- Put the file name in the list of sources of the project - if Current_Source = Nil_String then - Data.Sources := String_Elements.Last; + if not File_Name_Recorded then + String_Elements.Increment_Last; + String_Elements.Table (String_Elements.Last) := + (Value => Canonical_File_Name, + Display_Value => File_Name, + Location => No_Location, + Flag => False, + Next => Nil_String, + Index => Unit_Index); + end if; - else - String_Elements.Table (Current_Source).Next := - String_Elements.Last; - end if; + if Current_Source = Nil_String then + Data.Sources := String_Elements.Last; - Current_Source := String_Elements.Last; + else + String_Elements.Table (Current_Source).Next := + String_Elements.Last; + end if; - -- Put the unit in unit list + Current_Source := String_Elements.Last; - declare - The_Unit : Unit_Id := Units_Htable.Get (Unit_Name); - The_Unit_Data : Unit_Data; + -- Put the unit in unit list - begin - if Current_Verbosity = High then - Write_Str ("Putting "); - Write_Str (Get_Name_String (Unit_Name)); - Write_Line (" in the unit list."); - end if; + declare + The_Unit : Unit_Id := Units_Htable.Get (Unit_Name); + The_Unit_Data : Unit_Data; - -- The unit is already in the list, but may be it is - -- only the other unit kind (spec or body), or what is - -- in the unit list is a unit of a project we are extending. + begin + if Current_Verbosity = High then + Write_Str ("Putting "); + Write_Str (Get_Name_String (Unit_Name)); + Write_Line (" in the unit list."); + end if; - if The_Unit /= Prj.Com.No_Unit then - The_Unit_Data := Units.Table (The_Unit); + -- The unit is already in the list, but may be it is + -- only the other unit kind (spec or body), or what is + -- in the unit list is a unit of a project we are extending. - if The_Unit_Data.File_Names (Unit_Kind).Name = No_Name - or else Project_Extends - (Data.Extends, - The_Unit_Data.File_Names (Unit_Kind).Project) - then - if The_Unit_Data.File_Names (Unit_Kind).Path = Slash then - Remove_Forbidden_File_Name - (The_Unit_Data.File_Names (Unit_Kind).Name); - end if; + if The_Unit /= Prj.Com.No_Unit then + The_Unit_Data := Units.Table (The_Unit); - -- Record the file name in the hash table Files_Htable - - Unit_Prj := (Unit => The_Unit, Project => Project); - Files_Htable.Set (Canonical_File_Name, Unit_Prj); - - The_Unit_Data.File_Names (Unit_Kind) := - (Name => Canonical_File_Name, - Display_Name => File_Name, - Path => Canonical_Path_Name, - Display_Path => Path_Name, - Project => Project, - Needs_Pragma => Needs_Pragma); - Units.Table (The_Unit) := The_Unit_Data; - Source_Recorded := True; - - elsif The_Unit_Data.File_Names (Unit_Kind).Project = Project - and then (Data.Known_Order_Of_Source_Dirs or else - The_Unit_Data.File_Names (Unit_Kind).Path = - Canonical_Path_Name) - then - if Previous_Source = Nil_String then - Data.Sources := Nil_String; - else - String_Elements.Table (Previous_Source).Next := - Nil_String; - String_Elements.Decrement_Last; - end if; + if The_Unit_Data.File_Names (Unit_Kind).Name = No_Name + or else Project_Extends + (Data.Extends, + The_Unit_Data.File_Names (Unit_Kind).Project) + then + if The_Unit_Data.File_Names (Unit_Kind).Path = Slash then + Remove_Forbidden_File_Name + (The_Unit_Data.File_Names (Unit_Kind).Name); + end if; - Current_Source := Previous_Source; + -- Record the file name in the hash table Files_Htable + + Unit_Prj := (Unit => The_Unit, Project => Project); + Files_Htable.Set (Canonical_File_Name, Unit_Prj); + + The_Unit_Data.File_Names (Unit_Kind) := + (Name => Canonical_File_Name, + Index => Unit_Index, + Display_Name => File_Name, + Path => Canonical_Path_Name, + Display_Path => Path_Name, + Project => Project, + Needs_Pragma => Needs_Pragma); + Units.Table (The_Unit) := The_Unit_Data; + Source_Recorded := True; + + elsif The_Unit_Data.File_Names (Unit_Kind).Project = Project + and then (Data.Known_Order_Of_Source_Dirs or else + The_Unit_Data.File_Names (Unit_Kind).Path = + Canonical_Path_Name) + then + if Previous_Source = Nil_String then + Data.Sources := Nil_String; + else + String_Elements.Table (Previous_Source).Next := + Nil_String; + String_Elements.Decrement_Last; + end if; - else - -- It is an error to have two units with the same name - -- and the same kind (spec or body). + Current_Source := Previous_Source; - if The_Location = No_Location then - The_Location := Projects.Table (Project).Location; - end if; + else + -- It is an error to have two units with the same name + -- and the same kind (spec or body). - Err_Vars.Error_Msg_Name_1 := Unit_Name; - Error_Msg (Project, "duplicate source {", The_Location); + if The_Location = No_Location then + The_Location := Projects.Table (Project).Location; + end if; - Err_Vars.Error_Msg_Name_1 := - Projects.Table - (The_Unit_Data.File_Names (Unit_Kind).Project).Name; - Err_Vars.Error_Msg_Name_2 := - The_Unit_Data.File_Names (Unit_Kind).Path; - Error_Msg (Project, "\ project file {, {", The_Location); + Err_Vars.Error_Msg_Name_1 := Unit_Name; + Error_Msg (Project, "duplicate source {", The_Location); - Err_Vars.Error_Msg_Name_1 := Projects.Table (Project).Name; - Err_Vars.Error_Msg_Name_2 := Canonical_Path_Name; - Error_Msg (Project, "\ project file {, {", The_Location); + Err_Vars.Error_Msg_Name_1 := + Projects.Table + (The_Unit_Data.File_Names (Unit_Kind).Project).Name; + Err_Vars.Error_Msg_Name_2 := + The_Unit_Data.File_Names (Unit_Kind).Path; + Error_Msg + (Project, "\ project file {, {", The_Location); - end if; + Err_Vars.Error_Msg_Name_1 := + Projects.Table (Project).Name; + Err_Vars.Error_Msg_Name_2 := Canonical_Path_Name; + Error_Msg + (Project, "\ project file {, {", The_Location); - -- It is a new unit, create a new record + end if; - else - -- First, check if there is no other unit with this file name - -- in another project. If it is, report an error. + -- It is a new unit, create a new record - Unit_Prj := Files_Htable.Get (Canonical_File_Name); + else + -- First, check if there is no other unit with this file + -- name in another project. If it is, report an error. + -- Of course, we do that only for the first unit in the + -- source file. - if Unit_Prj /= No_Unit_Project then - Error_Msg_Name_1 := File_Name; - Error_Msg_Name_2 := Projects.Table (Unit_Prj.Project).Name; - Error_Msg - (Project, - "{ is already a source of project {", - Location); + Unit_Prj := Files_Htable.Get (Canonical_File_Name); - else - Units.Increment_Last; - The_Unit := Units.Last; - Units_Htable.Set (Unit_Name, The_Unit); - Unit_Prj := (Unit => The_Unit, Project => Project); - Files_Htable.Set (Canonical_File_Name, Unit_Prj); - The_Unit_Data.Name := Unit_Name; - The_Unit_Data.File_Names (Unit_Kind) := - (Name => Canonical_File_Name, - Display_Name => File_Name, - Path => Canonical_Path_Name, - Display_Path => Path_Name, - Project => Project, - Needs_Pragma => Needs_Pragma); - Units.Table (The_Unit) := The_Unit_Data; - Source_Recorded := True; + if not File_Name_Recorded and then + Unit_Prj /= No_Unit_Project + then + Error_Msg_Name_1 := File_Name; + Error_Msg_Name_2 := + Projects.Table (Unit_Prj.Project).Name; + Error_Msg + (Project, + "{ is already a source of project {", + Location); + + else + Units.Increment_Last; + The_Unit := Units.Last; + Units_Htable.Set (Unit_Name, The_Unit); + Unit_Prj := (Unit => The_Unit, Project => Project); + Files_Htable.Set (Canonical_File_Name, Unit_Prj); + The_Unit_Data.Name := Unit_Name; + The_Unit_Data.File_Names (Unit_Kind) := + (Name => Canonical_File_Name, + Index => Unit_Index, + Display_Name => File_Name, + Path => Canonical_Path_Name, + Display_Path => Path_Name, + Project => Project, + Needs_Pragma => Needs_Pragma); + Units.Table (The_Unit) := The_Unit_Data; + Source_Recorded := True; + end if; end if; - end if; - end; + end; + + exit when Exception_Id = No_Ada_Naming_Exception; + File_Name_Recorded := True; + end loop; end if; end Record_Ada_Source; @@ -4797,8 +4862,9 @@ package body Prj.Nmsc is is Suffix : constant Variable_Value := Value_Of - (Index => Lang_Name_Ids (Language), - In_Array => Naming.Body_Suffix); + (Index => Lang_Name_Ids (Language), + Src_Index => 0, + In_Array => Naming.Body_Suffix); begin -- If no suffix for this language is found in package Naming, use the -- default. diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index 965939db193..f9cceb5bc52 100644 --- a/gcc/ada/prj-pp.adb +++ b/gcc/ada/prj-pp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -454,6 +454,11 @@ package body Prj.PP is pragma Debug (Indicate_Tested (N_Literal_String)); Output_String (String_Value_Of (Node)); + if Source_Index_Of (Node) /= 0 then + Write_String (" at "); + Write_String (Source_Index_Of (Node)'Img); + end if; + when N_Attribute_Declaration => pragma Debug (Indicate_Tested (N_Attribute_Declaration)); Print (First_Comment_Before (Node), Indent); @@ -464,6 +469,12 @@ package body Prj.PP is if Associative_Array_Index_Of (Node) /= No_Name then Write_String (" ("); Output_String (Associative_Array_Index_Of (Node)); + + if Source_Index_Of (Node) /= 0 then + Write_String (" at "); + Write_String (Source_Index_Of (Node)'Img); + end if; + Write_String (")"); end if; diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 170da259f9e..439645e4bb7 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -182,7 +182,8 @@ package body Prj.Proc is Kind => Single, Location => No_Location, Default => True, - Value => Empty_String); + Value => Empty_String, + Index => 0); -- List attributes have a default value of nil list @@ -275,6 +276,7 @@ package body Prj.Proc is when Single => Add (Result.Value, String_Value_Of (The_Current_Term)); + Result.Index := Source_Index_Of (The_Current_Term); when List => @@ -295,6 +297,7 @@ package body Prj.Proc is Last := String_Elements.Last; String_Elements.Table (Last) := (Value => String_Value_Of (The_Current_Term), + Index => Source_Index_Of (The_Current_Term), Display_Value => No_Name, Location => Location_Of (The_Current_Term), Flag => False, @@ -342,7 +345,8 @@ package body Prj.Proc is Display_Value => No_Name, Location => Value.Location, Flag => False, - Next => Nil_String); + Next => Nil_String, + Index => Value.Index); loop -- Add the other element of the literal string list @@ -370,7 +374,8 @@ package body Prj.Proc is Display_Value => No_Name, Location => Value.Location, Flag => False, - Next => Nil_String); + Next => Nil_String, + Index => Value.Index); end loop; end if; @@ -560,7 +565,8 @@ package body Prj.Proc is Kind => Single, Location => No_Location, Default => True, - Value => Empty_String); + Value => Empty_String, + Index => 0); end if; end if; end; @@ -623,7 +629,8 @@ package body Prj.Proc is Display_Value => No_Name, Location => Location_Of (The_Current_Term), Flag => False, - Next => Nil_String); + Next => Nil_String, + Index => 0); when List => @@ -653,7 +660,8 @@ package body Prj.Proc is Location => Location_Of (The_Current_Term), Flag => False, - Next => Nil_String); + Next => Nil_String, + Index => 0); The_List := String_Elements.Table (The_List).Next; end loop; @@ -725,7 +733,8 @@ package body Prj.Proc is Display_Value => No_Name, Location => Location_Of (The_Current_Term), Flag => False, - Next => Nil_String); + Next => Nil_String, + Index => 0); end case; end; @@ -1582,6 +1591,7 @@ package body Prj.Proc is Array_Elements.Table (The_Array_Element) := (Index => Index_Name, + Src_Index => Source_Index_Of (Current_Item), Index_Case_Sensitive => not Case_Insensitive (Current_Item), Value => New_Value, diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index 1d1d1a8cb5d..8dade507915 100644 --- a/gcc/ada/prj-strt.adb +++ b/gcc/ada/prj-strt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -33,6 +33,7 @@ with Scans; use Scans; with Snames; with Table; with Types; use Types; +with Uintp; use Uintp; package body Prj.Strt is @@ -115,7 +116,8 @@ package body Prj.Strt is (Term : out Project_Node_Id; Expr_Kind : in out Variable_Kind; Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id); + Current_Package : Project_Node_Id; + Optional_Index : Boolean); -- Recursive procedure to parse one term or several terms concatenated -- using "&". @@ -454,7 +456,8 @@ package body Prj.Strt is procedure Parse_Expression (Expression : out Project_Node_Id; Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id) + Current_Package : Project_Node_Id; + Optional_Index : Boolean) is First_Term : Project_Node_Id := Empty_Node; Expression_Kind : Variable_Kind := Undefined; @@ -470,7 +473,8 @@ package body Prj.Strt is Terms (Term => First_Term, Expr_Kind => Expression_Kind, Current_Project => Current_Project, - Current_Package => Current_Package); + Current_Package => Current_Package, + Optional_Index => Optional_Index); -- Set the first term and the expression kind @@ -1077,7 +1081,8 @@ package body Prj.Strt is (Term : out Project_Node_Id; Expr_Kind : in out Variable_Kind; Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id) + Current_Package : Project_Node_Id; + Optional_Index : Boolean) is Next_Term : Project_Node_Id := Empty_Node; Term_Id : Project_Node_Id := Empty_Node; @@ -1143,7 +1148,8 @@ package body Prj.Strt is Current_Location := Token_Ptr; Parse_Expression (Expression => Next_Expression, Current_Project => Current_Project, - Current_Package => Current_Package); + Current_Package => Current_Package, + Optional_Index => Optional_Index); -- The expression kind is String list, report an error @@ -1199,6 +1205,37 @@ package body Prj.Strt is Scan; + if Token = Tok_At then + if not Optional_Index then + Error_Msg ("index not allowed here", Token_Ptr); + Scan; + + if Token = Tok_Integer_Literal then + Scan; + end if; + + else + Scan; + Expect (Tok_Integer_Literal, "integer literal"); + + if Token = Tok_Integer_Literal then + declare + Index : constant Int := UI_To_Int (Int_Literal_Value); + begin + if Index = 0 then + Error_Msg ("index cannot be zero", Token_Ptr); + + else + -- Set the index + Set_Source_Index_Of (Term_Id, To => Index); + end if; + end; + + Scan; + end if; + end if; + end if; + when Tok_Identifier => Current_Location := Token_Ptr; @@ -1292,7 +1329,8 @@ package body Prj.Strt is Terms (Term => Next_Term, Expr_Kind => Expr_Kind, Current_Project => Current_Project, - Current_Package => Current_Package); + Current_Package => Current_Package, + Optional_Index => Optional_Index); -- And link the next term to this term diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads index 69105690b51..633b022e8f5 100644 --- a/gcc/ada/prj-strt.ads +++ b/gcc/ada/prj-strt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -70,7 +70,8 @@ private package Prj.Strt is procedure Parse_Expression (Expression : out Project_Node_Id; Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id); + Current_Package : Project_Node_Id; + Optional_Index : Boolean); -- Parse a simple string expression or a string list expression. -- Current_Project is the node of the project file being parsed. -- Current_Package is the node of the package being parsed, diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index e8603c67bfb..993d1ecf451 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -111,6 +111,7 @@ package body Prj.Tree is Packages => Empty_Node, Pkg_Id => Empty_Package, Name => No_Name, + Src_Index => 0, Path_Name => No_Name, Value => No_Name, Field1 => Empty_Node, @@ -157,6 +158,7 @@ package body Prj.Tree is Packages => Empty_Node, Pkg_Id => Empty_Package, Name => No_Name, + Src_Index => 0, Path_Name => No_Name, Value => Comments.Table (J).Value, Field1 => Empty_Node, @@ -204,7 +206,6 @@ package body Prj.Tree is Comments.Set_Last (0); end Add_Comments; - -------------------------------- -- Associative_Array_Index_Of -- -------------------------------- @@ -310,6 +311,7 @@ package body Prj.Tree is Packages => Empty_Node, Pkg_Id => Empty_Package, Name => No_Name, + Src_Index => 0, Path_Name => No_Name, Value => No_Name, Field1 => Empty_Node, @@ -379,6 +381,7 @@ package body Prj.Tree is Packages => Empty_Node, Pkg_Id => Empty_Package, Name => No_Name, + Src_Index => 0, Path_Name => No_Name, Value => No_Name, Field1 => Empty_Node, @@ -411,6 +414,7 @@ package body Prj.Tree is Packages => Empty_Node, Pkg_Id => Empty_Package, Name => No_Name, + Src_Index => 0, Path_Name => No_Name, Value => No_Name, Field1 => Empty_Node, @@ -441,6 +445,7 @@ package body Prj.Tree is Packages => Empty_Node, Pkg_Id => Empty_Package, Name => No_Name, + Src_Index => 0, Path_Name => No_Name, Value => Comments.Table (J).Value, Field1 => Empty_Node, @@ -2323,6 +2328,24 @@ package body Prj.Tree is Project_Nodes.Table (Node).Field1 := To; end Set_Project_Of_Renamed_Package_Of; + ------------------------- + -- Set_Source_Index_Of -- + ------------------------- + + procedure Set_Source_Index_Of + (Node : Project_Node_Id; + To : Int) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Literal_String + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); + Project_Nodes.Table (Node).Src_Index := To; + end Set_Source_Index_Of; + ------------------------ -- Set_String_Type_Of -- ------------------------ @@ -2368,6 +2391,21 @@ package body Prj.Tree is Project_Nodes.Table (Node).Value := To; end Set_String_Value_Of; + --------------------- + -- Source_Index_Of -- + --------------------- + + function Source_Index_Of (Node : Project_Node_Id) return Int is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Literal_String + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); + return Project_Nodes.Table (Node).Src_Index; + end Source_Index_Of; + -------------------- -- String_Type_Of -- -------------------- @@ -2450,5 +2488,4 @@ package body Prj.Tree is return Unkept_Comments; end There_Are_Unkept_Comments; - end Prj.Tree; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index 7192fcee796..c376d3beee2 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -269,6 +269,10 @@ package Prj.Tree is pragma Inline (String_Value_Of); -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment + function Source_Index_Of (Node : Project_Node_Id) return Int; + pragma Inline (Source_Index_Of); + -- Only valid for N_Literal_String and N_Attribute_Declaration nodes + function First_With_Clause_Of (Node : Project_Node_Id) return Project_Node_Id; pragma Inline (First_With_Clause_Of); @@ -694,6 +698,11 @@ package Prj.Tree is To : Project_Node_Id); pragma Inline (Set_Package_Node_Of); + procedure Set_Source_Index_Of + (Node : Project_Node_Id; + To : Int); + pragma Inline (Set_Source_Index_Of); + procedure Set_String_Type_Of (Node : Project_Node_Id; To : Project_Node_Id); @@ -773,6 +782,10 @@ package Prj.Tree is Name : Name_Id := No_Name; -- See below for what Project_Node_Kind it is used + Src_Index : Int := 0; + -- Index of a unit in a multi-unit source. + -- Onli for some N_Attribute_Declaration and N_Literal_String. + Path_Name : Name_Id := No_Name; -- See below for what Project_Node_Kind it is used diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index 4081e117508..9de974760dd 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -76,6 +76,7 @@ package body Prj.Util is function Executable_Of (Project : Project_Id; Main : Name_Id; + Index : Int; Ada_Main : Boolean := True) return Name_Id is pragma Assert (Project /= No_Project); @@ -91,12 +92,14 @@ package body Prj.Util is Executable : Variable_Value := Prj.Util.Value_Of (Name => Main, + Index => Index, Attribute_Or_Array_Name => Name_Executable, In_Package => Builder_Package); Executable_Suffix : constant Variable_Value := Prj.Util.Value_Of (Name => Main, + Index => 0, Attribute_Or_Array_Name => Name_Executable_Suffix, In_Package => Builder_Package); @@ -158,6 +161,7 @@ package body Prj.Util is Executable := Prj.Util.Value_Of (Name => Name_Find, + Index => 0, Attribute_Or_Array_Name => Name_Executable, In_Package => Builder_Package); end if; @@ -395,8 +399,8 @@ package body Prj.Util is end Value_Of; function Value_Of - (Index : Name_Id; - In_Array : Array_Element_Id) return Name_Id + (Index : Name_Id; + In_Array : Array_Element_Id) return Name_Id is Current : Array_Element_Id := In_Array; Element : Array_Element; @@ -431,8 +435,9 @@ package body Prj.Util is end Value_Of; function Value_Of - (Index : Name_Id; - In_Array : Array_Element_Id) return Variable_Value + (Index : Name_Id; + Src_Index : Int := 0; + In_Array : Array_Element_Id) return Variable_Value is Current : Array_Element_Id := In_Array; Element : Array_Element; @@ -454,7 +459,9 @@ package body Prj.Util is while Current /= No_Array_Element loop Element := Array_Elements.Table (Current); - if Real_Index = Element.Index then + if Real_Index = Element.Index and then + Src_Index = Element.Src_Index + then return Element.Value; else Current := Element.Next; @@ -466,6 +473,7 @@ package body Prj.Util is function Value_Of (Name : Name_Id; + Index : Int := 0; Attribute_Or_Array_Name : Name_Id; In_Package : Package_Id) return Variable_Value is @@ -483,8 +491,9 @@ package body Prj.Util is In_Arrays => Packages.Table (In_Package).Decl.Arrays); The_Attribute := Value_Of - (Index => Name, - In_Array => The_Array); + (Index => Name, + Src_Index => Index, + In_Array => The_Array); -- If there is no array element, look for a variable diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads index c40b2949584..7373a640d59 100644 --- a/gcc/ada/prj-util.ads +++ b/gcc/ada/prj-util.ads @@ -35,6 +35,7 @@ package Prj.Util is function Executable_Of (Project : Project_Id; Main : Name_Id; + Index : Int; Ada_Main : Boolean := True) return Name_Id; -- Return the value of the attribute Builder'Executable for file Main in -- the project Project, if it exists. If there is no attribute Executable @@ -59,8 +60,9 @@ package Prj.Util is -- associative array. function Value_Of - (Index : Name_Id; - In_Array : Array_Element_Id) return Variable_Value; + (Index : Name_Id; + Src_Index : Int := 0; + In_Array : Array_Element_Id) return Variable_Value; -- Get a string array component (single String or String list). -- Returns Nil_Variable_Value if there is no component Index -- or if In_Array is null. @@ -72,6 +74,7 @@ package Prj.Util is function Value_Of (Name : Name_Id; + Index : Int := 0; Attribute_Or_Array_Name : Name_Id; In_Package : Package_Id) return Variable_Value; -- In a specific package, diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index b71b7db512f..55523435f4f 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -34,6 +34,7 @@ with Prj.Env; with Prj.Err; use Prj.Err; with Scans; use Scans; with Snames; use Snames; +with Uintp; use Uintp; with GNAT.OS_Lib; use GNAT.OS_Lib; @@ -240,6 +241,7 @@ package body Prj is begin if not Initialized then Initialized := True; + Uintp.Initialize; Name_Len := 0; The_Empty_String := Name_Find; Empty_Name := The_Empty_String; @@ -321,13 +323,15 @@ package body Prj is if not Found then Element := - (Index => Lang, + (Index => Lang, + Src_Index => 0, Index_Case_Sensitive => False, Value => (Project => No_Project, Kind => Single, Location => No_Location, Default => False, - Value => Default_Spec_Suffix), + Value => Default_Spec_Suffix, + Index => 0), Next => Std_Naming_Data.Spec_Suffix); Array_Elements.Increment_Last; Array_Elements.Table (Array_Elements.Last) := Element; @@ -357,13 +361,15 @@ package body Prj is if not Found then Element := - (Index => Lang, + (Index => Lang, + Src_Index => 0, Index_Case_Sensitive => False, Value => (Project => No_Project, Kind => Single, Location => No_Location, Default => False, - Value => Default_Body_Suffix), + Value => Default_Body_Suffix, + Index => 0), Next => Std_Naming_Data.Body_Suffix); Array_Elements.Increment_Last; Array_Elements.Table (Array_Elements.Last) := Element; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index ebbc8599d07..9d82b5ff841 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -197,6 +197,7 @@ package Prj is Nil_String : constant String_List_Id := 0; type String_Element is record Value : Name_Id := No_Name; + Index : Int := 0; Display_Value : Name_Id := No_Name; Location : Source_Ptr := No_Location; Flag : Boolean := False; @@ -233,6 +234,7 @@ package Prj is Values : String_List_Id := Nil_String; when Single => Value : Name_Id := No_Name; + Index : Int := 0; end case; end record; -- Values for variables and array elements. @@ -267,6 +269,7 @@ package Prj is No_Array_Element : constant Array_Element_Id := 0; type Array_Element is record Index : Name_Id; + Src_Index : Int := 0; Index_Case_Sensitive : Boolean := True; Value : Variable_Value; Next : Array_Element_Id := No_Array_Element; diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c index b0803ae8426..2d7c61a057d 100644 --- a/gcc/ada/raise.c +++ b/gcc/ada/raise.c @@ -152,7 +152,7 @@ db_accepted_codes (void) if (accepted_codes == -1) { - char * db_env = getenv ("EH_DEBUG"); + char * db_env = (char *) getenv ("EH_DEBUG"); accepted_codes = db_env ? (atoi (db_env) | DB_ERR) : 0; /* Arranged for ERR stuff to always be visible when the variable diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index efbd935641e..afe954e71ac 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4820,19 +4820,9 @@ package body Sem_Attr is -------------- when Attribute_Definite => - declare - Result : Node_Id; - - begin - if Is_Indefinite_Subtype (P_Entity) then - Result := New_Occurrence_Of (Standard_False, Loc); - else - Result := New_Occurrence_Of (Standard_True, Loc); - end if; - - Rewrite (N, Result); - Analyze_And_Resolve (N, Standard_Boolean); - end; + Rewrite (N, New_Occurrence_Of ( + Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); ------------ -- Denorm -- @@ -4961,19 +4951,9 @@ package body Sem_Attr is ----------------------- when Attribute_Has_Discriminants => - declare - Result : Node_Id; - - begin - if Has_Discriminants (P_Entity) then - Result := New_Occurrence_Of (Standard_True, Loc); - else - Result := New_Occurrence_Of (Standard_False, Loc); - end if; - - Rewrite (N, Result); - Analyze_And_Resolve (N, Standard_Boolean); - end; + Rewrite (N, New_Occurrence_Of ( + Boolean_Literals (Has_Discriminants (P_Entity)), Loc)); + Analyze_And_Resolve (N, Standard_Boolean); -------------- -- Identity -- @@ -5962,13 +5942,10 @@ package body Sem_Attr is Typ : constant Entity_Id := Underlying_Type (P_Type); begin - if Is_Array_Type (P_Type) - and then not Is_Constrained (Typ) - then - Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - else - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; + Rewrite (N, New_Occurrence_Of ( + Boolean_Literals ( + Is_Array_Type (P_Type) + and then not Is_Constrained (Typ)), Loc)); -- Analyze and resolve as boolean, note that this attribute is -- a static attribute in GNAT. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 1da9566e0dd..69e324b0a7f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1399,6 +1399,10 @@ package body Sem_Ch13 is -- Return true if the entity is a procedure with an -- appropriate profile for the write attribute. + ---------------------- + -- Has_Good_Profile -- + ---------------------- + function Has_Good_Profile (Subp : Entity_Id) return Boolean is F : Entity_Id; Ok : Boolean := False; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1b4f7e316a9..a800768af5b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -734,9 +734,12 @@ package body Sem_Ch3 is -- discriminant, in a private or a full type declaration. In -- the case of a subprogram, If the designated type is incomplete, -- the operation will be a primitive operation of the full type, to - -- be updated subsequently. + -- be updated subsequently. If the type is imported through a limited + -- with clause, it is not a primitive operation of the type (which + -- is declared elsewhere in some other scope). if Ekind (Desig_Type) = E_Incomplete_Type + and then not From_With_Type (Desig_Type) and then Is_Overloadable (Current_Scope) then Append_Elmt (Current_Scope, Private_Dependents (Desig_Type)); @@ -9988,7 +9991,7 @@ package body Sem_Ch3 is Defining_Identifier => T, Subtype_Indication => Relocate_Node (Obj_Def))); - -- This subtype may need freezing and it will not be done + -- This subtype may need freezing, and this will not be done -- automatically if the object declaration is not in a -- declarative part. Since this is an object declaration, the -- type cannot always be frozen here. Deferred constants do not @@ -10125,7 +10128,7 @@ package body Sem_Ch3 is elsif Can_Derive_From (Standard_Long_Long_Float) then Base_Typ := Standard_Long_Long_Float; - -- If we can't derive from any existing type, use long long float + -- If we can't derive from any existing type, use long_long_float -- and give appropriate message explaining the problem. else diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 340eae79e51..3d4f02eef6f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -88,6 +88,8 @@ package body Sem_Ch6 is -- subsequenty used for inline expansions at call sites. If subprogram can -- be inlined (depending on size and nature of local declarations) this -- function returns true. Otherwise subprogram body is treated normally. + -- If proper warnings are enabled and the subprogram contains a construct + -- that cannot be inlined, the offending construct is flagged accordingly. type Conformance_Type is (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant); @@ -2986,6 +2988,17 @@ package body Sem_Ch6 is or else not Is_Generic_Actual_Type (T2) or else Scope (T1) /= Scope (T2); + -- In some cases a type imported through a limited_with clause, + -- and its non-limited view are both visible, for example in an + -- anonymous access_to_classwide type in a formal. Both entities + -- designate the same type. + + elsif From_With_Type (T1) + and then Ekind (T1) = E_Incomplete_Type + and then T2 = Non_Limited_View (T1) + then + return True; + else return False; end if; diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 5ce3fb3284b..c48361092fe 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -332,19 +332,12 @@ package body Sem_Dist is RS_Pkg_Specif := Parent (Remote_Subp_Decl); RS_Pkg_E := Defining_Entity (RS_Pkg_Specif); - if Ekind (Remote_Subp) = E_Procedure - and then Is_Asynchronous (Remote_Subp) - then - Async_E := Standard_True; - else - Async_E := Standard_False; - end if; + Async_E := + Boolean_Literals (Ekind (Remote_Subp) = E_Procedure + and then Is_Asynchronous (Remote_Subp)); - if Has_All_Calls_Remote (RS_Pkg_E) then - All_Calls_Remote_E := Standard_True; - else - All_Calls_Remote_E := Standard_False; - end if; + All_Calls_Remote_E := + Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E)); Local_Addr := Make_Attribute_Reference (Loc, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0951d8413cd..db85ab27c95 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5588,11 +5588,8 @@ package body Sem_Util is function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is begin - if Range_Checks_Suppressed (E) then - return New_Occurrence_Of (Standard_False, Loc); - else - return New_Occurrence_Of (Standard_True, Loc); - end if; + return New_Occurrence_Of + (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc); end Rep_To_Pos_Flag; -------------------- diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads index 91207695765..0970a06a6ee 100644 --- a/gcc/ada/stand.ads +++ b/gcc/ada/stand.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2001 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- -- @@ -310,6 +310,9 @@ package Stand is -- Highest List_Id value used by Standard (including those used by -- normal list headers, element list headers, and list elements) + Boolean_Literals : array (Boolean) of Entity_Id; + -- Entities for the two boolean literals, used by the expander + ------------------------------------- -- Semantic Phase Special Entities -- ------------------------------------- diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index 03124a1481c..67cee510139 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -562,6 +562,12 @@ package body Switch.M is case Switch_Chars (Ptr) is + -- processing for eI switch + + when 'I' => + Ptr := Ptr + 1; + Scan_Pos (Switch_Chars, Max, Ptr, Main_Index); + -- processing for eL switch when 'L' => diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 3adf3044049..b5903da0190 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -269,10 +269,12 @@ begin Write_Switch_Char ("Q"); Write_Line ("Don't quit, write ali/tree file even if compile errors"); - -- Line for -gnatR switch + -- Lines for -gnatR switch Write_Switch_Char ("R?"); - Write_Line ("List rep inf (?=0/1/2/3 for none/types/all/variable)"); + Write_Line ("List rep info (?=0/1/2/3 for none/types/all/variable)"); + Write_Switch_Char ("R?s"); + Write_Line ("List rep info to file.rep instead of standard output"); -- Lines for -gnats switch diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index fd9cb34057d..256d8a64a51 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -191,7 +191,6 @@ package VMS_Data is -- Switches for GNAT BIND -- ---------------------------- - S_Bind_Bind : aliased constant S := "/BIND_FILE=" & "ADA " & "-A " & @@ -490,7 +489,6 @@ package VMS_Data is "!-b,!-v"; -- NODOC (see /REPORT_ERRORS) - S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " & "-r"; -- /NORESTRICTION_LIST (D) @@ -814,6 +812,13 @@ package VMS_Data is -- -- Output a message explaining the usage of gnatclean. + S_Clean_Index : aliased constant S := "/SOURCE_INDEX=#" & + "-i#"; + -- /SOURCE_INDEX=nnn + -- + -- Specifies the index of the units in the source file + -- By default, source files are mono-unit and there is no index + S_Clean_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & "DEFAULT " & "-vP0 " & @@ -833,7 +838,6 @@ package VMS_Data is -- HIGH A great number of messages are output, most of them not -- being useful for the user. - S_Clean_Object : aliased constant S := "/OBJECT_SEARCH=*" & "-aO*"; -- /OBJECT_SEARCH=(directory,...) @@ -892,6 +896,7 @@ package VMS_Data is S_Clean_Ext 'Access, S_Clean_Full 'Access, S_Clean_Help 'Access, + S_Clean_Index 'Access, S_Clean_Mess 'Access, S_Clean_Object 'Access, S_Clean_Project'Access, @@ -3738,6 +3743,15 @@ package VMS_Data is -- are found on the Ada object path, the new object and ALI files are -- created in the directory containing the source being compiled. + S_Make_Index : aliased constant S := "/SOURCE_INDEX=#" & + "-eI#"; + -- /SOURCE_INDEX=nnn + -- + -- Specifies the index of the units in the source file + -- By default, source files are mono-unit and there is no index + -- When /SOURCE_INDEX=nnn is specified, only one main may be specified + -- on the command line. + S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" & "-L*"; -- /LIBRARY_SEARCH=(directory[,...]) @@ -3965,6 +3979,7 @@ package VMS_Data is S_Make_Force 'Access, S_Make_Full 'Access, S_Make_Inplace 'Access, + S_Make_Index 'Access, S_Make_Library 'Access, S_Make_Link 'Access, S_Make_Make 'Access, -- 2.30.2