-- 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;
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);
private
- type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
--------------------
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
-- 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 --
-- Storage-related Declarations
type Address is private;
+ subtype Short_Address is Address;
Null_Address : constant Address;
Storage_Unit : constant := 8;
-- 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 --
-- Storage-related Declarations
type Address is private;
+ subtype Short_Address is Address;
Null_Address : constant Address;
Storage_Unit : constant := 8;
+2004-05-05 Emmanuel Briot <briot@act-europe.fr>
+
+ * 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 <dewar@gnat.com>
+
+ * 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 <guitton@act-europe.fr>
+
+ * Makefile.in: Remove unused targets and variables.
+
+2004-05-05 Vincent Celier <celier@gnat.com>
+
+ * 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 <schonberg@gnat.com>
+
+ 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 <schonberg@gnat.com>
+
+ 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 <quinot@act-europe.fr>
+
+ * 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 <rupp@gnat.com>
+
+ * 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 <ruiz@act-europe.fr>
+
+ * 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 <nobody@gnat.com>
+
+ * Make-lang.in: Makefile automatically updated
+
2004-05-03 Arnaud Charlet <charlet@act-europe.fr>
* 50system.ads, 59system.ads, s-thread.ads: Removed, no longer used.
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 \
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 \
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 \
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 \
soext = .exe
hyphen = _
+ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
+AR = iar
+endif
+
.SUFFIXES: .sym
.o.sym:
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 =\
$(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) \
/* Return a GNAT time stamp given a file name. */
-time_t
+OS_Time
__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;
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
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
}
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 **);
-- --
------------------------------------------------------------------------------
+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;
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;
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;
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;
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,
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;
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
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;
(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;
-- 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;
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));
-- 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;
---------------
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;
-- 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;
--------------------
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;
-----------------------
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 " &
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");
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
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
-- 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);
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
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,
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),
end if;
end loop;
- -- Create the GNARLI call.
+ -- Create the GNARLI call
Rcall := Make_Procedure_Call_Statement (Loc,
Name =>
-- --
-- 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- --
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,
-- --
-- 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- --
-- 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,
-- 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,
-- 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;
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;
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;
-- 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 ("<=");
-- 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- --
(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;
-- 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
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);
-- 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- --
-- 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;
-- 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
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;
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,...).
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);
-- 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;
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
-- 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 --
@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.
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},
@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
@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
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}.
(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;
#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
__gnat_install_handler (void)
{
long prvhnd;
+#ifdef IN_RTS
char *c;
c = (char *) xmalloc (2049);
/* __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;
}
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
(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
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);
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
-- 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,
-- 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 --
-------------------
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;
procedure Add_Switches
(The_Package : Package_Id;
File_Name : String;
+ Index : Int;
Program : Make_Program_Type);
procedure Add_Switch
(S : String_Access;
-- 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.
-- 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.
procedure Add_Switches
(The_Package : Package_Id;
File_Name : String;
+ Index : Int;
Program : Make_Program_Type)
is
Switches : Variable_Value;
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 =>
-----------
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
-- First, collect all the switches
- Collect_Arguments (Source_File, The_Args);
+ Collect_Arguments (Source_File, Source_Index, The_Args);
Prev_Switch := Dummy_Switch;
-----------------------
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;
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);
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;
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
-- 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,
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;
-- 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 --
-- 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
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
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;
-------------
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;
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.
-- 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;
-- 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
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
--------------------
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 --
--------------
-- 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;
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)
-- 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;
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;
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);
Add_Switches
(File_Name => Main_Unit_File_Name,
+ Index => Main_Index,
The_Package => Builder_Package,
Program => None);
Defaults : constant Variable_Value :=
Prj.Util.Value_Of
(Name => Name_Ada,
+ Index => 0,
Attribute_Or_Array_Name => Name_Default_Switches,
In_Package => Builder_Package);
Add_Switches
(File_Name => " ",
+ Index => 0,
The_Package => Builder_Package,
Program => None);
Add_Switches
(File_Name => Main_Unit_File_Name,
+ Index => Main_Index,
The_Package => Binder_Package,
Program => Binder);
end if;
Add_Switches
(File_Name => Main_Unit_File_Name,
+ Index => Main_Index,
The_Package => Linker_Package,
Program => Linker);
end if;
Bad_Compilation.Init;
+ Current_Main_Index := Main_Index;
+
-- Here is where the make process is started
-- We do the same process for each main
-- "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;
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,
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
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
Add_Switches
(File_Name => Main_Unit_File_Name,
+ Index => Main_Index,
The_Package => Binder_Package,
Program => Binder);
end if;
Add_Switches
(File_Name => Main_Unit_File_Name,
+ Index => Main_Index,
The_Package => Linker_Package,
Program => Linker);
end if;
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
Project_Object_Directory := No_Project;
- -- Set the marking label to a value that is not zero
-
- Marking_Label := 1;
end Initialize;
----------------------------
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;
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 --
----------
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 --
-- 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'
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
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
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
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;
-- --
-- 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- --
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;
-- 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.
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,
-- 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;
procedure Compile
(Source_Id : Other_Source_Id;
- Data : in Project_Data;
+ Data : Project_Data;
Local_Errors : in out Boolean);
procedure Compile_Individual_Sources;
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;
-- 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
-- Process one command line argument
function Strip_CR_LF (Text : String) return String;
+ -- Needs comment ???
procedure Usage;
-- Display the usage
-- 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;
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.
-- 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;
procedure Add_Argument (Arg : String; Display : Boolean) is
Argument : String_Access := null;
+
begin
-- Nothing to do if argument is empty
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.
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);
----------------------------
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,
end case;
-- Get the Switches ("file name"), if they exist
+
Switches_Array := Prj.Util.Value_Of
(Name => Name_Switches,
In_Arrays =>
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
(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
Time_Stamp : Time_Stamp_Type;
Saved_Last_Argument : Natural;
+
begin
-- First, make sure that the archive builder (ar) is on the path
Write_Line (" -> archive does not exist");
end if;
+ -- Archive does exist
+
else
-- Check the archive dependency file
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
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.
-- Build the archive if necessary
if Need_To_Rebuild then
+
-- If an archive is built, then linking will need to occur
-- unconditionally.
-- 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;
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);
end loop;
if Success then
+
-- If the archive was built, run the archive indexer (ranlib),
-- if there is one.
Spawn (Archive_Indexer_Path.all, Arguments (1 .. 1), Success);
if not Success then
+
-- Running ranlib failed, delete the dependency file,
-- if it exists.
-- 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.
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
declare
End_Of_File_Reached : Boolean := False;
+
begin
loop
if End_Of_File (Dep_File) then
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
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;
is
Source : Other_Source := Other_Sources.Table (Source_Id);
Success : Boolean;
+
begin
-- If the compiler is not know yet, get its path name
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
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);
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.
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);
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);
Success);
if Success then
+
-- Compilation was successful, update the time stamp
-- of the object file.
" 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;
--------------------------------
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;
end if;
if Ada_Mains.Last > 0 then
+
-- Invoke gnatmake for all sources that are not of a non Ada language
Last_Argument := 0;
--------------------------------
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.
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.
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
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;
while Source_Id /= No_Other_Source loop
Source := Other_Sources.Table (Source_Id);
-
Need_To_Compile := Force_Compilations;
-- Check if compilation is needed
-- 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;
------------------------------------
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
-- 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.
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;
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;
Data : in out Project_Data)
is
Imported_Projects : Project_List := Data.Imported_Projects;
+
Path_Length : Natural := 0;
Position : Natural := 0;
------------------------
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
-- 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.
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;
end if;
else
-
-- First compile sources and build archives, if necessary
Compile_Sources;
File : Ada.Text_IO.File_Type;
use Ada.Text_IO;
+
begin
Create (File, Out_File, Cpp_Linker);
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
(Executable_Of
(Project => Main_Project,
Main => Other_Mains.Table (Main).File_Name,
+ Index => 0,
Ada_Main => False)),
True);
end if;
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);
declare
Prj_Data : Project_Data;
+
begin
for Prj in 1 .. Projects.Last loop
Prj_Data := Projects.Table (Prj);
end;
end if;
-
-- If Need_To_Relink is False, we are done
if Verbose_Mode and (not Need_To_Relink) then
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
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;
------------------
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
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);
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);
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);
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
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 " &
------------------------------------------------------------------------------
with Namet; use Namet;
+with Osint; use Osint;
with Prj; use Prj;
with Prj.Ext;
with Prj.Util;
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;
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 --
----------------------------
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 --
-----------------------------
Options :=
Prj.Util.Value_Of
(Name => Name_Ada,
+ Index => 0,
Attribute_Or_Array_Name => Name_Linker_Options,
In_Package => Linker_Package);
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 --
---------------------------
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;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Osint;
with Prj; use Prj;
+with Types; use Types;
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.
-- 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;
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;
-- 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.
-- 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;
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;
------------------------
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 --
--------------------------------
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.
-- 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;
-- 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
-- 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
-- '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 '#'.
"SVlibrary_symbol_file#" &
"SVlibrary_symbol_policy#" &
"SVlibrary_reference_symbol_file#" &
- "LVmain#" &
+ "lVmain#" &
"LVlanguages#" &
"SVmain_language#" &
"SVseparate_suffix#" &
"SVcasing#" &
"SVdot_replacement#" &
- "SAspecification#" &
- "SAspec#" &
- "SAimplementation#" &
- "SAbody#" &
+ "sAspecification#" &
+ "sAspec#" &
+ "sAimplementation#" &
+ "sAbody#" &
"Laspecification_exceptions#" &
"Laimplementation_exceptions#" &
"Pcompiler#" &
"Ladefault_switches#" &
- "Lbswitches#" &
+ "Lcswitches#" &
"SVlocal_configuration_pragmas#" &
-- package Builder
"Pbuilder#" &
"Ladefault_switches#" &
- "Lbswitches#" &
- "Sbexecutable#" &
+ "Lcswitches#" &
+ "Scexecutable#" &
"SVexecutable_suffix#" &
"SVglobal_configuration_pragmas#" &
"Pbinder#" &
"Ladefault_switches#" &
- "Lbswitches#" &
+ "Lcswitches#" &
-- package Linker
"Plinker#" &
"Ladefault_switches#" &
- "Lbswitches#" &
+ "Lcswitches#" &
"LVlinker_options#" &
-- package Cross_Reference
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;
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;
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;
To_Lower (Initialization_Data (Start .. Finish - 1));
Attribute_Name := Name_Find;
Attributes.Increment_Last;
+
if Current_Attribute = Empty_Attribute then
First_Attribute := Attributes.Last;
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;
-- --
-- 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- --
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
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;
-- --
-- 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- --
with Snames;
with Types; use Types;
with Prj.Attr; use Prj.Attr;
+with Uintp; use Uintp;
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);
-- 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;
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, "`)`");
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");
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
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
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);
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
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
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
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;
Write_Line (" OK");
end if;
-
if Full_Path then
return Get_Name_String
(Unit.File_Names (Specification).Path);
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
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,
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;
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
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;
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;
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;
-- 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 => "=");
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;
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,
(Name_Locally_Removed_Files,
Data.Decl.Attributes);
-
begin
pragma Assert
(Sources.Kind = List,
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,
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
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
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;
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
Display_Value => Non_Canonical_Path,
Location => No_Location,
Flag => False,
- Next => Nil_String);
+ Next => Nil_String,
+ Index => 0);
-- Case of first source directory
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:");
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;
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);
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;
Current : Array_Element_Id := List;
Element : Array_Element;
+ Unit : Unit_Info;
+
begin
-- Traverse the list
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;
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));
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));
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;
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;
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.
-- --
-- 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- --
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);
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;
Kind => Single,
Location => No_Location,
Default => True,
- Value => Empty_String);
+ Value => Empty_String,
+ Index => 0);
-- List attributes have a default value of nil list
when Single =>
Add (Result.Value, String_Value_Of (The_Current_Term));
+ Result.Index := Source_Index_Of (The_Current_Term);
when List =>
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,
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
Display_Value => No_Name,
Location => Value.Location,
Flag => False,
- Next => Nil_String);
+ Next => Nil_String,
+ Index => Value.Index);
end loop;
end if;
Kind => Single,
Location => No_Location,
Default => True,
- Value => Empty_String);
+ Value => Empty_String,
+ Index => 0);
end if;
end if;
end;
Display_Value => No_Name,
Location => Location_Of (The_Current_Term),
Flag => False,
- Next => Nil_String);
+ Next => Nil_String,
+ Index => 0);
when List =>
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;
Display_Value => No_Name,
Location => Location_Of (The_Current_Term),
Flag => False,
- Next => Nil_String);
+ Next => Nil_String,
+ Index => 0);
end case;
end;
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,
-- --
-- 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- --
with Snames;
with Table;
with Types; use Types;
+with Uintp; use Uintp;
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 "&".
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;
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
(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;
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
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;
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
-- --
-- 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- --
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,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
+ Src_Index => 0,
Path_Name => No_Name,
Value => No_Name,
Field1 => Empty_Node,
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,
Comments.Set_Last (0);
end Add_Comments;
-
--------------------------------
-- Associative_Array_Index_Of --
--------------------------------
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
+ Src_Index => 0,
Path_Name => No_Name,
Value => No_Name,
Field1 => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
+ Src_Index => 0,
Path_Name => No_Name,
Value => No_Name,
Field1 => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
+ Src_Index => 0,
Path_Name => No_Name,
Value => No_Name,
Field1 => Empty_Node,
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,
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 --
------------------------
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 --
--------------------
return Unkept_Comments;
end There_Are_Unkept_Comments;
-
end Prj.Tree;
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);
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);
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
function Executable_Of
(Project : Project_Id;
Main : Name_Id;
+ Index : Int;
Ada_Main : Boolean := True) return Name_Id
is
pragma Assert (Project /= No_Project);
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);
Executable :=
Prj.Util.Value_Of
(Name => Name_Find,
+ Index => 0,
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package);
end if;
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;
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;
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;
function Value_Of
(Name : Name_Id;
+ Index : Int := 0;
Attribute_Or_Array_Name : Name_Id;
In_Package : Package_Id) return Variable_Value
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
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
-- 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.
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,
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;
begin
if not Initialized then
Initialized := True;
+ Uintp.Initialize;
Name_Len := 0;
The_Empty_String := Name_Find;
Empty_Name := The_Empty_String;
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;
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;
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;
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.
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;
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
--------------
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 --
-----------------------
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 --
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.
-- 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;
-- 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));
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
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
-- 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);
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;
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,
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;
--------------------
-- --
-- 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- --
-- 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 --
-------------------------------------
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' =>
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
-- Switches for GNAT BIND --
----------------------------
-
S_Bind_Bind : aliased constant S := "/BIND_FILE=" &
"ADA " &
"-A " &
"!-b,!-v";
-- NODOC (see /REPORT_ERRORS)
-
S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " &
"-r";
-- /NORESTRICTION_LIST (D)
--
-- 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 " &
-- 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,...)
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,
-- 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[,...])
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,
projects / gcc.git / commitdiff