OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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

From-SVN: r81519
This commit is contained in:
Arnaud Charlet 2004-05-05 12:09:56 +02:00
parent 68ea5833ec
commit aa720a546a
62 changed files with 2171 additions and 1504 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/ada/5qsystem.ads
View File

@ -62,7 +62,10 @@ pragma Pure (System);
-- Storage-related Declarations
type Address is private;
type Address is new Long_Integer;
subtype Short_Address is Address
range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1;
for Short_Address'Object_Size use 32;
Null_Address : constant Address;
Storage_Unit : constant := 8;
@ -83,6 +86,18 @@ pragma Pure (System);
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Abstract declarations for arithmetic operations on type address.
-- These declarations are needed when Address is non-private. They
-- avoid excessive visibility of arithmetic operations on address
-- which are typically available elsewhere (e.g. Storage_Elements)
-- and which would cause excessive ambiguities in application code.
function "+" (Left, Right : Address) return Address is abstract;
function "-" (Left, Right : Address) return Address is abstract;
function "/" (Left, Right : Address) return Address is abstract;
function "*" (Left, Right : Address) return Address is abstract;
function "mod" (Left, Right : Address) return Address is abstract;
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
@ -101,7 +116,6 @@ pragma Pure (System);
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------

2
gcc/ada/5vinmaop.adb
View File

@ -114,7 +114,7 @@ package body System.Interrupt_Management.Operations is
--------------------
function To_unsigned_long is new
Unchecked_Conversion (System.Address, unsigned_long);
Unchecked_Conversion (System.Short_Address, unsigned_long);
function Interrupt_Wait (Mask : access Interrupt_Mask)
return Interrupt_ID

3
gcc/ada/5vsystem.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- (OpenVMS DEC Threads Version) --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -63,6 +63,7 @@ pragma Pure (System);
-- Storage-related Declarations
type Address is private;
subtype Short_Address is Address;
Null_Address : constant Address;
Storage_Unit : constant := 8;

3
gcc/ada/5xsystem.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- (OpenVMS GCC_ZCX DEC Threads Version) --
-- --
-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -63,6 +63,7 @@ pragma Pure (System);
-- Storage-related Declarations
type Address is private;
subtype Short_Address is Address;
Null_Address : constant Address;
Storage_Unit : constant := 8;

162
gcc/ada/ChangeLog
View File

@ -1,3 +1,165 @@
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.

25
gcc/ada/Make-lang.in
View File

@ -2953,10 +2953,10 @@ ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/table.ads ada/table.adb ada/tbuild.ads ada/tbuild.adb \
ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
ada/urealp.ads ada/urealp.adb
ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
ada/unchdeal.ads ada/urealp.ads ada/urealp.adb
ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
@ -3457,14 +3457,15 @@ ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \
ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
ada/eval_fat.ads ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \
ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \
ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \
ada/sem.ads ada/sem_cat.ads ada/sem_ch8.ads ada/sem_eval.ads \
ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \
ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \
ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \
ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \
ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
ada/sem_cat.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \
ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \

261
gcc/ada/Makefile.in
View File

@ -549,40 +549,6 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb
EXTRA_HIE_NONE_TARGET_PAIRS= \
system.ads<50system.ads
EXTRA_RAVEN_SOURCES=i-vxwork.ads s-vxwork.ads
EXTRA_RAVEN_OBJS=i-vxwork.o s-vxwork.o
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
HIE_RAVEN_TARGET_PAIRS=\
$(HIE_NONE_TARGET_PAIRS) \
a-reatim.ads<1areatim.ads \
a-reatim.adb<1areatim.adb \
a-retide.adb<1aretide.adb \
a-interr.adb<1ainterr.adb \
s-interr.ads<1sinterr.ads \
s-interr.adb<1sinterr.adb \
s-taskin.ads<1staskin.ads \
s-taskin.adb<1staskin.adb \
s-taspri.ads<1staspri.ads \
s-tarest.adb<1starest.adb \
s-tposen.ads<1stposen.ads \
s-tposen.adb<1stposen.adb \
s-osinte.adb<1sosinte.adb \
s-taprop.ads<1staprop.ads \
s-taprop.adb<1staprop.adb \
s-taprob.ads<1staprob.ads \
s-taprob.adb<1staprob.adb \
a-sytaco.ads<1asytaco.ads \
a-sytaco.adb<1asytaco.adb \
a-intnam.ads<4zintnam.ads \
s-osinte.ads<5zosinte.ads \
s-parame.ads<5zparame.ads \
s-vxwork.ads<5pvxwork.ads \
a-taside.adb<1ataside.adb \
ifeq ($(strip $(filter-out yes,$(TRACE))),)
LIBGNAT_TARGET_PAIRS += \
s-traces.adb<7straces.adb \
@ -593,22 +559,6 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
endif
endif
ifeq ($(strip $(filter-out powerpc% unknown elf,$(targ))),)
EXTRA_HIE_NONE_TARGET_PAIRS= \
system.ads<59system.ads
LIBGNAT_TARGET_PAIRS = \
$(HIE_NONE_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),)
EXTRA_HIE_NONE_TARGET_PAIRS= \
system.ads<5rsystem.ads
LIBGNAT_TARGET_PAIRS = \
$(HIE_NONE_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \
a-sytaco.ads<4zsytaco.ads \
@ -1182,6 +1132,10 @@ ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(host))),
soext = .exe
hyphen = _
ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
AR = iar
endif
.SUFFIXES: .sym
.o.sym:
@ -1394,131 +1348,6 @@ include $(fsrcdir)/Makefile.rtl
GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \
g-trasym.o memtrack.o
# Files which are suitable in no run time/hi integrity mode
COMPILABLE_HIE_SOURCES= \
system.ads \
ada.ads \
gnat.ads \
g-souinf.ads \
interfac.ads \
i-c.ads \
s-stoele.ads \
s-stoele.adb \
s-maccod.ads \
s-unstyp.ads \
s-fatflt.ads \
s-fatlfl.ads \
s-fatllf.ads \
s-fatsfl.ads \
s-secsta.ads \
s-secsta.adb \
a-tags.ads \
a-tags.adb \
a-except.ads \
a-except.adb $(EXTRA_HIE_SOURCES)
NON_COMPILABLE_HIE_SOURCES= \
a-unccon.ads \
a-uncdea.ads \
s-fatgen.adb \
s-fatgen.ads \
unchconv.ads \
s-atacco.ads \
s-atacco.adb \
unchdeal.ads
HIE_SOURCES = $(NON_COMPILABLE_HIE_SOURCES) $(COMPILABLE_HIE_SOURCES)
# Object to generate for the HI run time
HIE_OBJS = \
system.o \
ada.o \
a-except.o \
gnat.o \
g-souinf.o \
interfac.o \
i-c.o \
s-stoele.o \
s-maccod.o \
s-unstyp.o \
s-fatflt.o \
s-fatlfl.o \
s-fatllf.o \
s-fatsfl.o \
s-secsta.o \
a-tags.o $(EXTRA_HIE_OBJS)
# Files which are needed in ravenscar mode
COMPILABLE_RAVEN_SOURCES = \
$(COMPILABLE_HIE_SOURCES) \
s-parame.ads \
s-parame.adb \
s-purexc.ads \
s-osinte.ads \
s-osinte.adb \
s-tasinf.ads \
s-tasinf.adb \
s-taspri.ads \
s-taprop.ads \
s-taprop.adb \
s-taskin.ads \
s-taskin.adb \
s-interr.ads \
s-interr.adb \
a-interr.ads \
a-interr.adb \
a-intnam.ads \
a-reatim.ads \
a-reatim.adb \
a-retide.ads \
a-retide.adb \
s-taprob.ads \
s-taprob.adb \
s-tposen.ads \
s-tposen.adb \
s-tasres.ads \
s-tarest.ads \
s-tarest.adb \
a-sytaco.ads \
a-sytaco.adb \
a-taside.ads \
a-taside.adb $(EXTRA_RAVEN_SOURCES)
NON_COMPILABLE_RAVEN_SOURCES= $(NON_COMPILABLE_HIE_SOURCES)
RAVEN_SOURCES = $(NON_COMPILABLE_RAVEN_SOURCES) $(COMPILABLE_RAVEN_SOURCES)
# Objects to generate for the ravenscar run time
RAVEN_LIBGNARL_OBJS = \
s-parame.o \
s-purexc.o \
s-osinte.o \
s-tasinf.o \
s-taspri.o \
s-taprop.o \
s-taskin.o \
s-interr.o \
a-interr.o \
a-intnam.o \
a-reatim.o \
a-retide.o \
s-osinte.o \
s-taprob.o \
s-tposen.o \
s-tasres.o \
s-tarest.o \
a-sytaco.o \
a-taside.o $(EXTRA_RAVEN_OBJS)
RAVEN_OBJS = \
$(HIE_OBJS) \
$(RAVEN_LIBGNARL_OBJS)
# Default run time files
ADA_INCLUDE_SRCS =\
@ -1878,88 +1707,6 @@ gnatlib: ../stamp-gnatlib1 ../stamp-gnatlib2
$(CHMOD) a-wx rts/*.ali
touch ../stamp-gnatlib
HIE_NONE_TARGET_PAIRS=\
a-except.ads<1aexcept.ads \
a-except.adb<1aexcept.adb \
a-tags.ads<1atags.ads \
a-tags.adb<1atags.adb \
s-secsta.ads<1ssecsta.ads \
s-secsta.adb<1ssecsta.adb \
i-c.ads<1ic.ads $(EXTRA_HIE_NONE_TARGET_PAIRS)
# This target needs RTS_NAME, RTS_SRCS, RTS_TARGET_PAIRS to be set properly
# it creates a rts with the proper structure and the right target
# dependant srcs
prepare-rts:
$(RMDIR) rts-$(RTS_NAME)
$(MKDIR) rts-$(RTS_NAME)
$(CHMOD) u+w rts-$(RTS_NAME)
$(MKDIR) rts-$(RTS_NAME)/adalib
$(MKDIR) rts-$(RTS_NAME)/adainclude
$(CHMOD) u+w rts-$(RTS_NAME)/*
# Generate the project file
$(ECHO) "project $(RTS_NAME) is" > rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) " for Source_Dirs use (\"adainclude\");" \
>> rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) " for Object_Dir use \"adalib\";" \
>> rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) " for Source_List_File use " \
>>rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) " \"rts-$(RTS_NAME)_source_list.txt\";" \
>>rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) " package Builder is" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) " for Default_Switches (\"Ada\") use (\"-a\");" \
>>rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) " end Builder;" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) " package Compiler is" >> rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) " for Default_Switches (\"Ada\") use (\"-nostdinc\");" \
>>rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) " end Compiler;" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(ECHO) "end $(RTS_NAME);" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
$(foreach f, $(COMPILABLE_SOURCES), \
$(ECHO) $(f) >> \
rts-$(RTS_NAME)/rts-$(RTS_NAME)_source_list.txt ;) true
# Copy target independent sources
$(foreach f,$(RTS_SRCS), \
$(CP) $(fsrcpfx)$(f) rts-$(RTS_NAME)/adainclude/ ;) true
# Remove files to be replaced by target dependent sources
$(RM) $(foreach PAIR,$(RTS_TARGET_PAIRS), \
rts-$(RTS_NAME)/adainclude/$(word 1,$(subst <, ,$(PAIR))))
# Copy new target dependent sources
$(foreach PAIR,$(RTS_TARGET_PAIRS), \
$(CP) $(fsrcpfx)$(word 2,$(subst <, ,$(PAIR))) \
rts-$(RTS_NAME)/adainclude/$(word 1,$(subst <, ,$(PAIR)));)
install-rts: force
$(CP) -r rts-$(RTS_NAME) $(DESTDIR)$(libsubdir)/
rts-zfp: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
RTS_NAME=zfp RTS_SRCS="$(HIE_SOURCES)" \
RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
$(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
cd rts-zfp/adalib/ ; $(AR) r libgnat.a *.o
$(RM) rts-zfp/adalib/*.o
$(CHMOD) a-wx rts-zfp/adalib/*.ali
$(CHMOD) a-wx rts-zfp/adalib/libgnat.a
rts-ravenscar: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
RTS_NAME=ravenscar RTS_SRCS="$(RAVEN_SOURCES)" \
RTS_TARGET_PAIRS="$(HIE_RAVEN_TARGET_PAIRS)" \
COMPILABLE_SOURCES="$(COMPILABLE_RAVEN_SOURCES)"
$(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
--GCC="../../../xgcc -B../../../"
cd rts-ravenscar/adalib ; \
$(foreach FILE,$(RAVEN_LIBGNARL_OBJS), $(AR) r libgnarl.a $(FILE);) \
$(foreach FILE,$(HIE_OBJS), $(AR) r libgnat.a $(FILE);)
$(RM) rts-ravenscar/adalib/*.o
$(CHMOD) a-wx rts-ravenscar/adalib/*.ali
$(CHMOD) a-wx rts-ravenscar/adalib/libgnat.a
$(CHMOD) a-wx rts-ravenscar/adalib/libgnarl.a
# Warning: this target assumes that LIBRARY_VERSION has been set correctly.
gnatlib-shared-default:
$(MAKE) $(FLAGS_TO_PASS) \

35
gcc/ada/adaint.c
View File

@ -862,7 +862,7 @@ win32_filetime (HANDLE h)
/* Return a GNAT time stamp given a file name. */
time_t
OS_Time
__gnat_file_time_name (char *name)
{
@ -870,7 +870,7 @@ __gnat_file_time_name (char *name)
int fd = open (name, O_RDONLY | O_BINARY);
time_t ret = __gnat_file_time_fd (fd);
close (fd);
return ret;
return (OS_Time)ret;
#elif defined (_WIN32)
time_t ret = 0;
@ -882,22 +882,25 @@ __gnat_file_time_name (char *name)
ret = win32_filetime (h);
CloseHandle (h);
}
return ret;
return (OS_Time) ret;
#else
struct stat statbuf;
(void) __gnat_stat (name, &statbuf);
if (__gnat_stat (name, &statbuf) != 0) {
return (OS_Time)-1;
} else {
#ifdef VMS
/* VMS has file versioning. */
return statbuf.st_ctime;
/* VMS has file versioning. */
return (OS_Time)statbuf.st_ctime;
#else
return statbuf.st_mtime;
return (OS_Time)statbuf.st_mtime;
#endif
}
#endif
}
/* Return a GNAT time stamp given a file descriptor. */
time_t
OS_Time
__gnat_file_time_fd (int fd)
{
/* The following workaround code is due to the fact that under EMX and
@ -965,24 +968,26 @@ __gnat_file_time_fd (int fd)
tot_secs += file_hour * 3600;
tot_secs += file_min * 60;
tot_secs += file_tsec * 2;
return tot_secs;
return (OS_Time) tot_secs;
#elif defined (_WIN32)
HANDLE h = (HANDLE) _get_osfhandle (fd);
time_t ret = win32_filetime (h);
return ret;
return (OS_Time) ret;
#else
struct stat statbuf;
(void) fstat (fd, &statbuf);
if (fstat (fd, &statbuf) != 0) {
return (OS_Time) -1;
} else {
#ifdef VMS
/* VMS has file versioning. */
return statbuf.st_ctime;
/* VMS has file versioning. */
return (OS_Time) statbuf.st_ctime;
#else
return statbuf.st_mtime;
return (OS_Time) statbuf.st_mtime;
#endif
}
#endif
}

7
gcc/ada/adaint.h
View File

@ -70,8 +70,11 @@ extern long __gnat_named_file_length (char *);
extern void __gnat_tmp_name (char *);
extern char *__gnat_readdir (DIR *, char *);
extern int __gnat_readdir_is_thread_safe (void);
extern time_t __gnat_file_time_name (char *);
extern time_t __gnat_file_time_fd (int);
extern OS_Time __gnat_file_time_name (char *);
extern OS_Time __gnat_file_time_fd (int);
/* return -1 in case of error */
extern void __gnat_set_file_time_name (char *, time_t);
extern void __gnat_get_env_value_ptr (char *, int *,
char **);

461
gcc/ada/clean.adb
View File

@ -24,10 +24,13 @@
-- --
------------------------------------------------------------------------------
with Ada.Command_Line; use Ada.Command_Line;
with ALI; use ALI;
with Csets;
with Gnatvsn;
with Hostparm;
with Makeutl; use Makeutl;
with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
@ -43,12 +46,10 @@ with System;
with Table;
with Types; use Types;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.IO; use GNAT.IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
package body Clean is
Initialized : Boolean := False;
@ -136,15 +137,13 @@ package body Clean is
procedure Init_Q;
-- Must be called to initialize the Q
procedure Insert_Q
(Source_File : File_Name_Type);
-- If Source_File is not marked, inserts it at the end of Q and mark it
procedure Insert_Q (Lib_File : File_Name_Type);
-- If Lib_File is not marked, inserts it at the end of Q and mark it
function Empty_Q return Boolean;
-- Returns True if Q is empty.
procedure Extract_From_Q
(Source_File : out File_Name_Type);
procedure Extract_From_Q (Lib_File : out File_Name_Type);
-- Extracts the first element from the Q.
Q_Front : Natural;
@ -367,14 +366,14 @@ package body Clean is
Main_Source_File : File_Name_Type;
-- Current main source
Source_File : File_Name_Type;
-- Current source file
Main_Lib_File : File_Name_Type;
-- ALI file of the current main
Lib_File : File_Name_Type;
-- Current library file
-- Current ALI file
Full_Lib_File : File_Name_Type;
-- Full name of the current library file
-- Full name of the current ALI file
Text : Text_Buffer_Ptr;
The_ALI : ALI_Id;
@ -393,12 +392,13 @@ package body Clean is
for N_File in 1 .. Osint.Number_Of_Files loop
Main_Source_File := Next_Main_Source;
Insert_Q (Main_Source_File);
Main_Lib_File := Osint.Lib_File_Name
(Main_Source_File, Current_File_Index);
Insert_Q (Main_Lib_File);
while not Empty_Q loop
Sources.Set_Last (0);
Extract_From_Q (Source_File);
Lib_File := Osint.Lib_File_Name (Source_File);
Extract_From_Q (Lib_File);
Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
-- If we have an existing ALI file that is not read-only,
@ -428,7 +428,7 @@ package body Clean is
for K in ALI.Units.Table (J).First_With ..
ALI.Units.Table (J).Last_With
loop
Insert_Q (Withs.Table (K).Sfile);
Insert_Q (Withs.Table (K).Afile);
end loop;
end loop;
@ -499,7 +499,7 @@ package body Clean is
if not Compile_Only then
declare
Source : constant Name_Id := Strip_Suffix (Main_Source_File);
Source : constant Name_Id := Strip_Suffix (Main_Lib_File);
Executable : constant String := Get_Name_String
(Executable_Name (Source));
begin
@ -529,7 +529,10 @@ package body Clean is
Data : constant Project_Data := Projects.Table (Project);
U_Data : Prj.Com.Unit_Data;
File_Name1 : Name_Id;
Index1 : Int;
File_Name2 : Name_Id;
Index2 : Int;
Lib_File : File_Name_Type;
use Prj.Com;
@ -583,14 +586,18 @@ package body Clean is
(U_Data.File_Names (Specification).Project, Project)
then
File_Name1 := U_Data.File_Names (Body_Part).Name;
Index1 := U_Data.File_Names (Body_Part).Index;
File_Name2 := U_Data.File_Names (Specification).Name;
Index2 := U_Data.File_Names (Specification).Index;
-- If there is no body file name, then there may be only a
-- spec.
if File_Name1 = No_Name then
File_Name1 := File_Name2;
Index1 := Index2;
File_Name2 := No_Name;
Index2 := 0;
end if;
end if;
@ -598,11 +605,13 @@ package body Clean is
-- object directory.
if File_Name1 /= No_Name then
Lib_File := Osint.Lib_File_Name (File_Name1, Index1);
declare
Asm : constant String := Assembly_File_Name (File_Name1);
ALI : constant String := ALI_File_Name (File_Name1);
Obj : constant String := Object_File_Name (File_Name1);
Adt : constant String := Tree_File_Name (File_Name1);
Asm : constant String := Assembly_File_Name (Lib_File);
ALI : constant String := ALI_File_Name (Lib_File);
Obj : constant String := Object_File_Name (Lib_File);
Adt : constant String := Tree_File_Name (Lib_File);
Deb : constant String := Debug_File_Name (File_Name1);
Rep : constant String := Repinfo_File_Name (File_Name1);
Del : Boolean := True;
@ -776,7 +785,11 @@ package body Clean is
Main_Source_File := Next_Main_Source;
if not Compile_Only then
Executable := Executable_Of (Main_Project, Main_Source_File);
Executable :=
Executable_Of
(Main_Project,
Main_Source_File,
Current_File_Index);
if Is_Regular_File (Get_Name_String (Executable)) then
Delete (Exec_Dir, Get_Name_String (Executable));
@ -938,12 +951,12 @@ package body Clean is
-- Extract_From_Q --
--------------------
procedure Extract_From_Q (Source_File : out File_Name_Type) is
File : constant File_Name_Type := Q.Table (Q_Front);
procedure Extract_From_Q (Lib_File : out File_Name_Type) is
Lib : constant File_Name_Type := Q.Table (Q_Front);
begin
Q_Front := Q_Front + 1;
Source_File := File;
Q_Front := Q_Front + 1;
Lib_File := Lib;
end Extract_From_Q;
---------------
@ -1019,12 +1032,14 @@ package body Clean is
if Main_Project /= No_Project and then Osint.Number_Of_Files = 0 then
declare
Value : String_List_Id := Projects.Table (Main_Project).Mains;
Main : String_Element;
begin
while Value /= Prj.Nil_String loop
Get_Name_String (String_Elements.Table (Value).Value);
Osint.Add_File (Name_Buffer (1 .. Name_Len));
Value := String_Elements.Table (Value).Next;
Main := String_Elements.Table (Value);
Osint.Add_File
(File_Name => Get_Name_String (Main.Value),
Index => Main.Index);
Value := Main.Next;
end loop;
end;
end if;
@ -1152,19 +1167,17 @@ package body Clean is
-- Insert_Q --
--------------
procedure Insert_Q (Source_File : File_Name_Type) is
procedure Insert_Q (Lib_File : File_Name_Type) is
begin
-- Do not insert an empty name or an already marked source
if Source_File /= No_Name
and then Get_Name_Table_Byte (Source_File) = 0
then
Q.Table (Q.Last) := Source_File;
if Lib_File /= No_Name and then not Is_Marked (Lib_File) then
Q.Table (Q.Last) := Lib_File;
Q.Increment_Last;
-- Mark the source that has been just added to the Q
Set_Name_Table_Byte (Source_File, 1);
Mark (Lib_File);
end if;
end Insert_Q;
@ -1196,165 +1209,236 @@ package body Clean is
--------------------
procedure Parse_Cmd_Line is
Source_Index : Int := 0;
Index : Positive := 1;
Last : constant Natural := Argument_Count;
begin
loop
case
GNAT.Command_Line.Getopt
("aO: c D: F h I: I- n P: q r v vP0 vP1 vP2 X:")
is
when ASCII.NUL =>
exit;
when 'a' =>
Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
when 'c' =>
Compile_Only := True;
when 'D' =>
declare
Dir : constant String := GNAT.Command_Line.Parameter;
begin
if Object_Directory_Path /= null then
Fail ("duplicate -D switch");
elsif Project_File_Name /= null then
Fail ("-P and -D cannot be used simultaneously");
elsif not Is_Directory (Dir) then
Fail (Dir, " is not a directory");
else
Add_Lib_Search_Dir (Dir);
end if;
end;
when 'F' =>
Full_Path_Name_For_Brief_Errors := True;
when 'h' =>
Usage;
when 'I' =>
if Full_Switch = "I-" then
Opt.Look_In_Primary_Dir := False;
else
Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
end if;
when 'n' =>
Do_Nothing := True;
when 'P' =>
if Project_File_Name /= null then
Fail ("multiple -P switches");
elsif Object_Directory_Path /= null then
Fail ("-D and -P cannot be used simultaneously");
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));
else
Project_File_Name := new String'(Prj);
end if;
end;
end if;
when 'q' =>
Quiet_Output := True;
when 'r' =>
All_Projects := True;
when 'v' =>
if Full_Switch = "v" then
Verbose_Mode := True;
elsif Full_Switch = "vP0" then
Prj.Com.Current_Verbosity := Prj.Default;
elsif Full_Switch = "vP1" then
Prj.Com.Current_Verbosity := Prj.Medium;
else
Prj.Com.Current_Verbosity := Prj.High;
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;
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 =>
Fail ("INTERNAL ERROR, please report");
end case;
end loop;
-- Get the file names
loop
while Index <= Last loop
declare
S : constant String := GNAT.Command_Line.Get_Argument;
Arg : constant String := Argument (Index);
procedure Bad_Argument;
-- Signal bad argument
------------------
-- Bad_Argument --
------------------
procedure Bad_Argument is
begin
Fail ("invalid argument """, Arg, """");
end Bad_Argument;
begin
exit when S'Length = 0;
if Arg'Length /= 0 then
if Arg (1) = '-' then
if Arg'Length = 1 then
Bad_Argument;
end if;
Add_File (S);
case Arg (2) is
when 'a' =>
if Arg'Length < 4 or else Arg (3) /= 'O' then
Bad_Argument;
end if;
Add_Lib_Search_Dir (Arg (3 .. Arg'Last));
when 'c' =>
Compile_Only := True;
when 'D' =>
if Object_Directory_Path /= null then
Fail ("duplicate -D switch");
elsif Project_File_Name /= null then
Fail ("-P and -D cannot be used simultaneously");
end if;
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
if Index = Last then
Fail ("no directory specified after -D");
end if;
Index := Index + 1;
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;
when 'F' =>
Full_Path_Name_For_Brief_Errors := True;
when 'h' =>
Usage;
when 'i' =>
if Arg'Length = 2 then
Bad_Argument;
end if;
Source_Index := 0;
for J in 3 .. Arg'Last loop
if Arg (J) not in '0' .. '9' then
Bad_Argument;
end if;
Source_Index :=
(20 * Source_Index) +
(Character'Pos (Arg (J)) - Character'Pos ('0'));
end loop;
when 'I' =>
if Arg = "-I-" then
Opt.Look_In_Primary_Dir := False;
else
if Arg'Length = 2 then
Bad_Argument;
end if;
Add_Lib_Search_Dir (Arg (3 .. Arg'Last));
end if;
when 'n' =>
Do_Nothing := True;
when 'P' =>
if Project_File_Name /= null then
Fail ("multiple -P switches");
elsif Object_Directory_Path /= null then
Fail ("-D and -P cannot be used simultaneously");
end if;
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;
else
if Index = Last then
Fail ("no project specified after -P");
end if;
Index := Index + 1;
Project_File_Name := new String'(Argument (Index));
end if;
when 'q' =>
Quiet_Output := True;
when 'r' =>
All_Projects := True;
when 'v' =>
if Arg = "-v" then
Verbose_Mode := True;
elsif Arg = "-vP0" then
Prj.Com.Current_Verbosity := Prj.Default;
elsif Arg = "-vP1" then
Prj.Com.Current_Verbosity := Prj.Medium;
elsif Arg = "-vP2" then
Prj.Com.Current_Verbosity := Prj.High;
else
Bad_Argument;
end if;
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;
exception
when GNAT.Command_Line.Invalid_Switch =>
Usage;
Fail ("invalid switch : "& GNAT.Command_Line.Full_Switch);
when GNAT.Command_Line.Invalid_Parameter =>
Usage;
Fail ("parameter missing for : " & GNAT.Command_Line.Full_Switch);
end Parse_Cmd_Line;
-----------------------
@ -1398,7 +1482,7 @@ package body Clean is
if not Usage_Displayed then
Usage_Displayed := True;
Display_Copyright;
Put_Line ("Usage: gnatclean [switches] names");
Put_Line ("Usage: gnatclean [switches] {[-innn] name}");
New_Line;
Put_Line (" names is one or more file names from which " &
@ -1411,6 +1495,7 @@ package body Clean is
Put_Line (" -F Full project path name " &
"in brief error messages");
Put_Line (" -h Display this message");
Put_Line (" -innn Index of unit in source for following names");
Put_Line (" -n Nothing to do: only list files to delete");
Put_Line (" -Pproj Use GNAT Project File proj");
Put_Line (" -q Be quiet/terse");

5
gcc/ada/cstand.adb
View File

@ -402,6 +402,11 @@ package body CStand is
Set_Etype (R_Node, Standard_Boolean);
Set_Parent (R_Node, Standard_Boolean);
-- Record entity identifiers for boolean literals in the
-- Boolean_Literals array, for easy reference during expansion.
Boolean_Literals := (False => Standard_False, True => Standard_True);
-- Create type definition nodes for predefined integer types
Build_Signed_Integer_Type

26
gcc/ada/exp_attr.adb
View File

@ -1182,13 +1182,8 @@ package body Exp_Attr is
Res := Is_Constrained (Etype (Ent));
end if;
if Res then
Rewrite (N,
New_Reference_To (Standard_True, Loc));
else
Rewrite (N,
New_Reference_To (Standard_False, Loc));
end if;
Rewrite (N,
New_Reference_To (Boolean_Literals (Res), Loc));
end;
-- Prefix is not an entity name. These are also cases where
@ -1196,16 +1191,13 @@ package body Exp_Attr is
-- and type of the prefix.
else
if not Is_Variable (Pref)
or else Nkind (Pref) = N_Explicit_Dereference
or else Is_Constrained (Etype (Pref))
then
Rewrite (N,
New_Reference_To (Standard_True, Loc));
else
Rewrite (N,
New_Reference_To (Standard_False, Loc));
end if;
Rewrite (N,
New_Reference_To (
Boolean_Literals (
not Is_Variable (Pref)
or else Nkind (Pref) = N_Explicit_Dereference
or else Is_Constrained (Etype (Pref))),
Loc));
end if;
Analyze_And_Resolve (N, Standard_Boolean);

9
gcc/ada/exp_ch2.adb
View File

@ -218,12 +218,13 @@ package body Exp_Ch2 is
and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
-- Same for Asm_Input and Asm_Output attribute references.
-- Same for Asm_Input and Asm_Output attribute references
and then not (Nkind (Parent (N)) = N_Attribute_Reference
and then (Attribute_Name (Parent (N)) = Name_Asm_Input
or else Attribute_Name (Parent (N)) = Name_Asm_Output))
and then
(Attribute_Name (Parent (N)) = Name_Asm_Input
or else
Attribute_Name (Parent (N)) = Name_Asm_Output))
then
-- Case of Current_Value is a compile time known value

10
gcc/ada/exp_ch5.adb
View File

@ -702,13 +702,9 @@ package body Exp_Ch5 is
Duplicate_Subexpr (Right_Lo, Name_Req => True),
Duplicate_Subexpr (Right_Hi, Name_Req => True));
if Forwards_OK (N) then
Append_To (Actuals,
New_Occurrence_Of (Standard_False, Loc));
else
Append_To (Actuals,
New_Occurrence_Of (Standard_True, Loc));
end if;
Append_To (Actuals,
New_Occurrence_Of (
Boolean_Literals (not Forwards_OK (N)), Loc));
Rewrite (N,
Make_Procedure_Call_Statement (Loc,

13
gcc/ada/exp_ch9.adb
View File

@ -5735,19 +5735,16 @@ package body Exp_Ch9 is
RTS_Call : Entity_Id;
begin
if Abort_Present (N) then
Abortable := New_Occurrence_Of (Standard_True, Loc);
else
Abortable := New_Occurrence_Of (Standard_False, Loc);
end if;
Abortable :=
New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc);
-- Set up the target object.
-- Set up the target object
Extract_Entry (N, Concval, Ename, Index);
Conctyp := Etype (Concval);
New_Param := Concurrent_Ref (Concval);
-- The target entry index and abortable flag are the same for all cases.
-- The target entry index and abortable flag are the same for all cases
Params := New_List (
Entry_Index_Expression (Loc, Entity (Ename), Index, Conctyp),
@ -5804,7 +5801,7 @@ package body Exp_Ch9 is
end if;
end loop;
-- Create the GNARLI call.
-- Create the GNARLI call
Rcall := Make_Procedure_Call_Statement (Loc,
Name =>

26
gcc/ada/exp_disp.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -876,24 +876,22 @@ package body Exp_Disp is
Node2 => Position)));
end;
-- Generate: Set_Remotely_Callable (DT_Ptr, status);
-- where status is described in E.4 (18)
-- Generate: Set_Remotely_Callable (DT_Ptr, Status);
-- where Status is described in E.4 (18)
declare
Status : Entity_Id;
begin
if Is_Pure (Typ)
or else Is_Shared_Passive (Typ)
or else
((Is_Remote_Types (Typ) or else Is_Remote_Call_Interface (Typ))
and then Original_View_In_Visible_Part (Typ))
or else not Comes_From_Source (Typ)
then
Status := Standard_True;
else
Status := Standard_False;
end if;
Status :=
Boolean_Literals
(Is_Pure (Typ)
or else Is_Shared_Passive (Typ)
or else
((Is_Remote_Types (Typ)
or else Is_Remote_Call_Interface (Typ))
and then Original_View_In_Visible_Part (Typ))
or else not Comes_From_Source (Typ));
Append_To (Elab_Code,
Make_DT_Access_Action (Typ,

14
gcc/ada/exp_fixd.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -561,11 +561,7 @@ package body Exp_Fixd is
-- call the runtime routine to compute the quotient and remainder
else
if Rounded_Result_Set (N) then
Rnd := Standard_True;
else
Rnd := Standard_False;
end if;
Rnd := Boolean_Literals (Rounded_Result_Set (N));
Code := New_List (
Make_Object_Declaration (Loc,
@ -947,11 +943,7 @@ package body Exp_Fixd is
-- call the runtime routine to compute the quotient and remainder
else
if Rounded_Result_Set (N) then
Rnd := Standard_True;
else
Rnd := Standard_False;
end if;
Rnd := Boolean_Literals (Rounded_Result_Set (N));
Code := New_List (
Make_Object_Declaration (Loc,

7
gcc/ada/g-os_lib.ads
View File

@ -103,6 +103,7 @@ pragma Elaborate_Body (OS_Lib);
-- file (of course in Unix systems, this *is* in GMT form).
type OS_Time is private;
Invalid_Time : constant OS_Time;
subtype Year_Type is Integer range 1900 .. 2099;
subtype Month_Type is Integer range 1 .. 12;
@ -368,9 +369,11 @@ pragma Elaborate_Body (OS_Lib);
function File_Time_Stamp (Name : String) return OS_Time;
-- Given the name of a file or directory, Name, obtains and returns the
-- time stamp. This function can be used for an unopened file.
-- Returns Invalid_Time is Name doesn't correspond to an existing file.
function File_Time_Stamp (FD : File_Descriptor) return OS_Time;
-- Get time stamp of file from file descriptor FD
-- Returns Invalid_Time is FD doesn't correspond to an existing file.
function Normalize_Pathname
(Name : String;
@ -542,6 +545,7 @@ pragma Elaborate_Body (OS_Lib);
Success : out Boolean);
function File_Time_Stamp (Name : C_File_Name) return OS_Time;
-- Returns Invalid_Time is Name doesn't correspond to an existing file.
function Is_Regular_File (Name : C_File_Name) return Boolean;
@ -735,6 +739,9 @@ private
-- but this was not properly supported till GNAT 3.15a, so that would
-- cause bootstrap path problems. To be changed later ???
Invalid_Time : constant OS_Time := -1;
-- This value should match the return valud by __gnat_file_time_*
pragma Inline ("<");
pragma Inline (">");
pragma Inline ("<=");

22
gcc/ada/g-regpat.adb
View File

@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1986 by University of Toronto. --
-- Copyright (C) 1996-2003 Ada Core Technologies, Inc. --
-- Copyright (C) 1996-2004 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -3406,9 +3406,9 @@ package body GNAT.Regpat is
(Expression : String;
Data : String;
Matches : out Match_Array;
Size : Program_Size := 0;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
Size : Program_Size := Auto_Size;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
is
PM : Pattern_Matcher (Size);
Finalize_Size : Program_Size;
@ -3426,12 +3426,12 @@ package body GNAT.Regpat is
-- Match --
-----------
function Match
function Match
(Expression : String;
Data : String;
Size : Program_Size := 0;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last) return Natural
Size : Program_Size := Auto_Size;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last) return Natural
is
PM : Pattern_Matcher (Size);
Final_Size : Program_Size; -- unused
@ -3452,9 +3452,9 @@ package body GNAT.Regpat is
function Match
(Expression : String;
Data : String;
Size : Program_Size := 0;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last) return Boolean
Size : Program_Size := Auto_Size;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last) return Boolean
is
Matches : Match_Array (0 .. 0);
PM : Pattern_Matcher (Size);

214
gcc/ada/g-regpat.ads
View File

@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1986 by University of Toronto. --
-- Copyright (C) 1996-2003 Ada Core Technologies, Inc. --
-- Copyright (C) 1996-2004 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -300,19 +300,32 @@ pragma Preelaborate (Regpat);
-- This is limited by the size of a Character, as found in the
-- byte-compiled version of regular expressions.
Max_Program_Size : constant := 2**15 - 1;
-- Maximum size that can be allocated for a program
Max_Curly_Repeat : constant := 32767;
-- Maximum number of repetition for the curly operator.
-- The digits in the {n}, {n,} and {n,m } operators can not be higher
-- than this constant, since they have to fit on two characters in the
-- byte-compiled version of regular expressions.
Max_Program_Size : constant := 2**15 - 1;
-- Maximum size that can be allocated for a program
type Program_Size is range 0 .. Max_Program_Size;
for Program_Size'Size use 16;
-- Number of bytes allocated for the byte-compiled version of a regular
-- expression.
-- expression. The size required depends on the complexity of the regular
-- expression in a complex manner that is undocumented (other than in the
-- body of the Compile procedure). Normally the size is automatically set
-- and the programmer need not be concerned about it. There are two
-- exceptions to this. First in the calls to Match, it is possible to
-- specify a non-zero size that is known to be large enough. This can
-- slightly increase the efficiency by avoiding a copy. Second, in the
-- case of calling compile, it is possible using the procedural form
-- of Compile to use a single Pattern_Matcher variable for several
-- different expressions by setting its size sufficiently large.
Auto_Size : constant := 0;
-- Used in calls to Match to indicate that the Size should be set to
-- a value appropriate to the expression being used automatically.
type Regexp_Flags is mod 256;
for Regexp_Flags'Size use 8;
@ -368,9 +381,14 @@ pragma Preelaborate (Regpat);
-- matching a null string at position 1, which uses (1, 0)
-- and no match at all.
------------------------------
-- Pattern_Matcher Creation --
------------------------------
---------------------------------
-- Pattern_Matcher Compilation --
---------------------------------
-- The subprograms here are used to precompile regular expressions
-- for use in subsequent Match calls. Precompilation improves
-- efficiency if the same regular expression is to be used in
-- more than one Match call.
type Pattern_Matcher (Size : Program_Size) is private;
-- Type used to represent a regular expression compiled into byte code
@ -381,14 +399,18 @@ pragma Preelaborate (Regpat);
function Compile
(Expression : String;
Flags : Regexp_Flags := No_Flags) return Pattern_Matcher;
-- Compile a regular expression into internal code.
-- Raises Expression_Error if Expression is not a legal regular expression.
-- The appropriate size is calculated automatically, but this means that
-- the regular expression has to be compiled twice (the first time to
-- calculate the size, the second time to actually generate the byte code).
-- Compile a regular expression into internal code
--
-- Flags is the default value to use to set properties for Expression (case
-- sensitivity,...).
-- Raises Expression_Error if Expression is not a legal regular expression
--
-- The appropriate size is calculated automatically to correspond to the
-- provided expression. This is the normal default method of compilation.
-- Note that it is generally not possible to assign the result of two
-- different calls to this Compile function to the same Pattern_Matcher
-- variable, since the sizes will differ.
--
-- Flags is the default value to use to set properties for Expression
-- (e.g. case sensitivity,...).
procedure Compile
(Matcher : out Pattern_Matcher;
@ -396,11 +418,28 @@ pragma Preelaborate (Regpat);
Final_Code_Size : out Program_Size;
Flags : Regexp_Flags := No_Flags);
-- Compile a regular expression into into internal code
-- This procedure is significantly faster than the function
-- Compile, as there is a known maximum size for the matcher.
-- This function raises Storage_Error if Matcher is too small
-- to hold the resulting code, or Expression_Error is Expression
-- is not a legal regular expression.
-- This procedure is significantly faster than the Compile function
-- since it avoids the extra step of precomputing the required size.
--
-- However, it requires the user to provide a Pattern_Matcher variable
-- whose size is preset to a large enough value. One advantage of this
-- approach, in addition to the improved efficiency, is that the same
-- Pattern_Matcher variable can be used to hold the compiled code for
-- several different regular expressions by setting a size that is
-- large enough to accomodate all possibilities.
--
-- In this version of the procedure call, the actual required code
-- size is returned. Also if Matcher.Size is zero on entry, then the
-- resulting code is not stored. A call with Matcher.Size set to Auto_Size
-- can thus be used to determine the space required for compiling the
-- given regular expression.
--
-- This function raises Storage_Error if Matcher is too small to hold
-- the resulting code (i.e. Matcher.Size has too small a value).
--
-- Expression_Error is raised if the string Expression does not contain
-- a valid regular expression.
--
-- Flags is the default value to use to set properties for Expression (case
-- sensitivity,...).
@ -410,7 +449,7 @@ pragma Preelaborate (Regpat);
Expression : String;
Flags : Regexp_Flags := No_Flags);
-- Same procedure as above, expect it does not return the final
-- program size.
-- program size, and Matcher.Size cannot be Auto_Size.
function Paren_Count (Regexp : Pattern_Matcher) return Match_Count;
pragma Inline (Paren_Count);
@ -442,83 +481,96 @@ pragma Preelaborate (Regpat);
-- Matching --
--------------
procedure Match
(Expression : String;
Data : String;
Matches : out Match_Array;
Size : Program_Size := 0;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last);
-- Match Expression against Data (Data_First .. Data_Last) and store
-- result in Matches.
--
-- Data_First defaults to Data'First if unspecified (that is the
-- dummy value of -1 is interpreted to mean Data'First).
--
-- Data_Last defaults to Data'Last if unspecified (that is the
-- dummy value of Positive'Last is interpreted to mean Data'Last)
--
-- It is important that Data contains the whole string (or file) you
-- want to matched against, even if you start in the middle, since
-- otherwise regular expressions starting with "^" or ending with "$" will
-- be improperly processed.
--
-- 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.
--
-- At most Matches'Length parenthesis are returned.
-- 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.
function Match
-- 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
--
-- 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;
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.
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
(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 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 := Auto_Size;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last) return Boolean;
-- This version returns True if the match succeeds, False otherwise
------------------------------------------------
-- Matching a pre-compiled regular expression --
-- Matching a Pre-Compiled Regular Expression --
------------------------------------------------
-- The following functions are significantly faster if you need to reuse
-- the same regular expression multiple times, since you only have to
-- compile it once.
-- compile it once. For these functions you must first compile the
-- expression with a call to Compile as previously described.
-- The parameters Data, Data_First and Data_Last are as described
-- in the previous section.
function Match
(Self : Pattern_Matcher;
Data : String;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last) return Natural;
-- Match Data using the given pattern matcher.
-- Return the position where Data matches, or (Data'First - 1) if there is
-- no match.
--
-- See description of Data_First and Data_Last above.
-- Match Data using the given pattern matcher. Returns the position
-- where Data matches, or (Data'First - 1) if there is no match.
function Match
(Self : Pattern_Matcher;
@ -526,8 +578,6 @@ pragma Preelaborate (Regpat);
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last) return Boolean;
-- Return True if Data matches using the given pattern matcher.
--
-- See description of Data_First and Data_Last above.
pragma Inline (Match);
-- All except the last one below
@ -542,8 +592,6 @@ pragma Preelaborate (Regpat);
-- The expression matches if Matches (0) /= No_Match.
--
-- At most Matches'Length parenthesis are returned.
--
-- See description of Data_First and Data_Last above.
-----------
-- Debug --

34
gcc/ada/gnat_rm.texi
View File

@ -2970,14 +2970,13 @@ There are no semantic dependencies on the package Ada.Calendar.
@item No_Relative_Delay
There are no delay_relative_statements.
@item No_Task_Attributes
There are no semantic dependencies on the Ada.Task_Attributes package and
there are no references to the attributes Callable and Terminated [RM 9.9].
@item No_Task_Attributes_Package
There are no semantic dependencies on the Ada.Task_Attributes package.
@item Boolean_Entry_Barriers
Entry barrier condition expressions shall be boolean
objects which are declared in the protected type
which contains the entry.
@item Simple_Barriers
Entry barrier condition expressions shall be either static
boolean expressions or boolean objects which are declared in
the protected type which contains the entry.
@item Max_Asynchronous_Select_Nesting = 0
[RM D.7] Specifies the maximum dynamic nesting level of asynchronous_selects.
@ -3023,7 +3022,7 @@ and whose most recent description is available at
The above set is a superset of the restrictions provided by pragma
@code{Restricted_Run_Time}, it includes five additional restrictions
(@code{Boolean_Entry_Barriers}, @code{No_Select_Statements},
(@code{Simple_Barriers}, @code{No_Select_Statements},
@code{No_Calendar},
@code{No_Relative_Delay} and @code{No_Task_Termination}). This means
that pragma @code{Ravenscar}, like the pragma @code{Restricted_Run_Time},
@ -3054,7 +3053,7 @@ A configuration pragma that establishes the following set of restrictions:
@item No_Protected_Type_Allocators
@item No_Local_Protected_Objects
@item No_Requeue_Statements
@item No_Task_Attributes
@item No_Task_Attributes_Package
@item Max_Asynchronous_Select_Nesting = 0
@item Max_Task_Entries = 0
@item Max_Protected_Entries = 1
@ -6847,13 +6846,14 @@ then all compilation units in the partition must obey the restriction.
@table @code
@item Boolean_Entry_Barriers
@findex Boolean_Entry_Barriers
@item Simple_Barriers
@findex Simple_Barriers
This restriction ensures at compile time that barriers in entry declarations
for protected types are restricted to references to simple boolean variables
defined in the private part of the protected type. No other form of entry
barriers is permitted. This is one of the restrictions of the Ravenscar
profile for limited tasking (see also pragma @code{Ravenscar}).
for protected types are restricted to either static boolean expressions or
references to simple boolean variables defined in the private part of the
protected type. No other form of entry barriers is permitted. This is one
of the restrictions of the Ravenscar profile for limited tasking (see also
pragma @code{Ravenscar}).
@item Max_Entry_Queue_Depth => Expr
@findex Max_Entry_Queue_Depth
@ -6990,8 +6990,8 @@ user-defined storage pool.
This restriction ensures at compile time that there are no implicit or
explicit dependencies on the package @code{Ada.Streams}.
@item No_Task_Attributes
@findex No_Task_Attributes
@item No_Task_Attributes_Package
@findex No_Task_Attributes_Package
This restriction ensures at compile time that there are no implicit or
explicit dependencies on the package @code{Ada.Task_Attributes}.

5
gcc/ada/gnatcmd.adb
View File

@ -839,8 +839,9 @@ begin
(Name => Name_Default_Switches,
In_Arrays => Element.Decl.Arrays);
The_Switches := Prj.Util.Value_Of
(Index => Name_Ada,
In_Array => Default_Switches_Array);
(Index => Name_Ada,
Src_Index => 0,
In_Array => Default_Switches_Array);
end if;
end if;

7
gcc/ada/init.c
View File

@ -1281,11 +1281,14 @@ __gnat_initialize (void)
#elif defined (VMS)
#ifdef IN_RTS
/* The prehandler actually gets control first on a condition. It swaps the
stack pointer and calls the handler (__gnat_error_handler). */
extern long __gnat_error_prehandler (void);
extern char *__gnat_error_prehandler_stack; /* Alternate signal stack */
#endif
/* Conditions that don't have an Ada exception counterpart must raise
Non_Ada_Error. Since this is defined in s-auxdec, it should only be
@ -1474,6 +1477,7 @@ void
__gnat_install_handler (void)
{
long prvhnd;
#ifdef IN_RTS
char *c;
c = (char *) xmalloc (2049);
@ -1482,6 +1486,9 @@ __gnat_install_handler (void)
/* __gnat_error_prehandler is an assembly function. */
SYS$SETEXV (1, __gnat_error_prehandler, 3, &prvhnd);
#else
SYS$SETEXV (1, __gnat_error_handler, 3, &prvhnd);
#endif
__gnat_handler_installed = 1;
}

9
gcc/ada/lib-writ.adb
View File

@ -600,6 +600,7 @@ package body Lib.Writ is
Pname : constant Unit_Name_Type :=
Get_Parent_Spec_Name (Unit_Name (Main_Unit));
Body_Fname : File_Name_Type;
Body_Index : Nat;
begin
-- Loop to build the with table. A with on the main unit itself
@ -657,12 +658,18 @@ package body Lib.Writ is
(Get_Body_Name (Uname),
Subunit => False, May_Fail => True);
Body_Index :=
Get_Unit_Index
(Get_Body_Name (Uname));
if Body_Fname = No_File then
Body_Fname := Get_File_Name (Uname, Subunit => False);
Body_Index := Get_Unit_Index (Uname);
end if;
else
Body_Fname := Get_File_Name (Uname, Subunit => False);
Body_Index := Get_Unit_Index (Uname);
end if;
-- A package is considered to have a body if it requires
@ -675,7 +682,7 @@ package body Lib.Writ is
Write_Info_Name (Body_Fname);
Write_Info_Tab (49);
Write_Info_Name
(Lib_File_Name (Body_Fname, Munit_Index (Unum)));
(Lib_File_Name (Body_Fname, Body_Index));
else
Write_Info_Name (Fname);
Write_Info_Tab (49);

718
gcc/ada/make.adb
View File

File diff suppressed because it is too large Load Diff

7
gcc/ada/make.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -112,6 +112,7 @@ package Make is
Most_Recent_Obj_Stamp : out Time_Stamp_Type;
Main_Unit : out Boolean;
Compilation_Failures : out Natural;
Main_Index : Int := 0;
Check_Readonly_Files : Boolean := False;
Do_Not_Execute : Boolean := False;
Force_Compilations : Boolean := False;
@ -148,6 +149,10 @@ package Make is
-- Compilation_Failures is a count of compilation failures. This count
-- is used to extract compilation failure reports with Extract_Failure.
--
-- Main_Index, when not zero, is the index of the main unit in source
-- file Main_Source which is a multi-unit source.
-- Zero indicates that Main_Source is a single unit source file.
--
-- Check_Readonly_Files set it to True to compile source files
-- which library files are read-only. When compiling GNAT predefined
-- files the "-gnatg" flag is used.

233
gcc/ada/makegpr.adb
View File

@ -178,7 +178,6 @@ package body Makegpr is
Options : array (Programming_Language) of Comp_Opts.Instance;
-- Tables to store compiling options for the different compilers
package Linker_Options is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Integer,
@ -354,9 +353,9 @@ package body Makegpr is
-- or Linker (depending on Proc) of a specified project file.
procedure Build_Archive (Project : Project_Id; Unconditionally : Boolean);
-- Build the archive for a specified project.
-- If Unconditionally is False, first check if the archive is up to date,
-- and build it only if it is not.
-- Build the archive for a specified project. If Unconditionally is
-- False, first check if the archive is up to date, and build it only
-- if it is not.
procedure Check_Compilation_Needed
(Source : Other_Source;
@ -369,7 +368,7 @@ package body Makegpr is
procedure Compile
(Source_Id : Other_Source_Id;
Data : in Project_Data;
Data : Project_Data;
Local_Errors : in out Boolean);
procedure Compile_Individual_Sources;
@ -378,9 +377,8 @@ package body Makegpr is
procedure Compile_Link_With_Gnatmake (Mains_Specified : Boolean);
-- Compile/Link with gnatmake when there are Ada sources in the main
-- project.
-- Arguments may already contain options to be used by gnatmake.
-- Used for both Ada mains and mains of other languages.
-- project. Arguments may already contain options to be used by
-- gnatmake. Used for both Ada mains and mains of other languages.
-- When Compile_Only is True, do not use the linking options
procedure Compile_Sources;
@ -390,7 +388,9 @@ package body Makegpr is
-- Output the Copyright notice
procedure Create_Archive_Dependency_File
(Name : String; First_Source : Other_Source_Id);
(Name : String;
First_Source : Other_Source_Id);
-- ??? needs comment
procedure Display_Command (Name : String; Path : String_Access);
-- Display the command for a spawned process, if in Verbose_Mode or
@ -431,6 +431,7 @@ package body Makegpr is
-- Process one command line argument
function Strip_CR_LF (Text : String) return String;
-- Needs comment ???
procedure Usage;
-- Display the usage
@ -467,6 +468,7 @@ package body Makegpr is
-- Nothing to do if the project has already been processed
if not Data.Seen then
-- Mark the project as processed, to avoid processing it again
Projects.Table (Project).Seen := True;
@ -496,6 +498,7 @@ package body Makegpr is
if Data.Sources_Present then
if Data.Library then
-- If it is a library project file, nothing to do if
-- gnatmake will be invoked, because gnatmake will take
-- care of it, even if the library is not an Ada library.
@ -633,16 +636,20 @@ package body Makegpr is
-- Nothing to do if no argument is specified or if argument is empty
if Arg /= null or else Arg'Length = 0 then
-- Reallocate arrays if necessary
if Last_Argument = Arguments'Last then
declare
New_Arguments : constant Argument_List_Access :=
new Argument_List
(1 .. Last_Argument + Initial_Argument_Count);
new Argument_List
(1 .. Last_Argument +
Initial_Argument_Count);
New_Arguments_Displayed : constant Booleans :=
new Boolean_Array
(1 .. Last_Argument + Initial_Argument_Count);
new Boolean_Array
(1 .. Last_Argument +
Initial_Argument_Count);
begin
New_Arguments (Arguments'Range) := Arguments.all;
@ -672,6 +679,7 @@ package body Makegpr is
procedure Add_Argument (Arg : String; Display : Boolean) is
Argument : String_Access := null;
begin
-- Nothing to do if argument is empty
@ -750,18 +758,21 @@ package body Makegpr is
procedure Add_Option (Arg : String) is
Option : constant String_Access := new String'(Arg);
begin
case Current_Processor is
when None =>
null;
when Linker =>
-- Add option to the linker table
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) := Option;
when Compiler =>
-- Add option to the compiler option table, depending on the
-- value of Current_Language.
@ -783,8 +794,9 @@ package body Makegpr is
if Last_Source = Source_Indexes'Last then
declare
New_Indexes : constant Source_Indexes_Ref :=
new Source_Index_Array
(1 .. Source_Indexes'Last + Initial_Source_Index_Count);
new Source_Index_Array
(1 .. Source_Indexes'Last +
Initial_Source_Index_Count);
begin
New_Indexes (Source_Indexes'Range) := Source_Indexes.all;
Free (Source_Indexes);
@ -801,7 +813,8 @@ package body Makegpr is
----------------------------
procedure Add_Search_Directories
(Data : Project_Data; Language : Programming_Language)
(Data : Project_Data;
Language : Programming_Language)
is
begin
-- If a GNU compiler is used, set the CPATH environment variable,
@ -858,6 +871,7 @@ package body Makegpr is
end case;
-- Get the Switches ("file name"), if they exist
Switches_Array := Prj.Util.Value_Of
(Name => Name_Switches,
In_Arrays =>
@ -865,8 +879,9 @@ package body Makegpr is
Switches :=
Prj.Util.Value_Of
(Index => File_Name,
In_Array => Switches_Array);
(Index => File_Name,
Src_Index => 0,
In_Array => Switches_Array);
-- Otherwise, get the Default_Switches ("language"), if they exist
@ -875,8 +890,9 @@ package body Makegpr is
(Name => Name_Default_Switches,
In_Arrays => Packages.Table (Pkg).Decl.Arrays);
Switches := Prj.Util.Value_Of
(Index => Lang_Name_Ids (Language),
In_Array => Defaults);
(Index => Lang_Name_Ids (Language),
Src_Index => 0,
In_Array => Defaults);
end if;
-- If there are switches, add them to Arguments
@ -923,6 +939,7 @@ package body Makegpr is
Time_Stamp : Time_Stamp_Type;
Saved_Last_Argument : Natural;
begin
-- First, make sure that the archive builder (ar) is on the path
@ -961,6 +978,8 @@ package body Makegpr is
Write_Line (" -> archive does not exist");
end if;
-- Archive does exist
else
-- Check the archive dependency file
@ -1000,8 +1019,7 @@ package body Makegpr is
Object_Name := Name_Find;
Source_Id := No_Other_Source;
-- Check if this object file is for a source of this
-- project.
-- Check if this object file is for a source of this project
for S in 1 .. Last_Source loop
if (not Source_Indexes (S).Found) and then
@ -1088,6 +1106,7 @@ package body Makegpr is
Close (File);
if not Need_To_Rebuild then
-- Now, check if all object files of the project have been
-- accounted for. If any of them is not in the dependency
-- file, the archive needs to be rebuilt.
@ -1120,6 +1139,7 @@ package body Makegpr is
-- Build the archive if necessary
if Need_To_Rebuild then
-- If an archive is built, then linking will need to occur
-- unconditionally.
@ -1131,10 +1151,12 @@ package body Makegpr is
-- in the library directory.
if Data.Library then
-- If there are sources in Ada, then gnatmake will build the
-- library, so nothing to do.
if not Data.Languages (Lang_Ada) then
-- Get all the object files of the project
Source_Id := Data.First_Other_Source;
@ -1174,13 +1196,11 @@ package body Makegpr is
end if;
end if;
-- Create a fake empty archive, to be able to check its time stamp
-- later.
-- Create fake empty archive, so we can check its time stamp later
declare
Archive : Ada.Text_IO.File_Type;
use Ada.Text_IO;
begin
Create (Archive, Out_File, Archive_Name);
Close (Archive);
@ -1239,6 +1259,7 @@ package body Makegpr is
end loop;
if Success then
-- If the archive was built, run the archive indexer (ranlib),
-- if there is one.
@ -1251,6 +1272,7 @@ package body Makegpr is
Spawn (Archive_Indexer_Path.all, Arguments (1 .. 1), Success);
if not Success then
-- Running ranlib failed, delete the dependency file,
-- if it exists.
@ -1309,7 +1331,9 @@ package body Makegpr is
-- object file.
Dep_File : Prj.Util.Text_File;
Start, Finish : Natural;
Start : Natural;
Finish : Natural;
begin
-- Assume the worst, so that statement "return;" may be used if there
-- is any problem.
@ -1378,8 +1402,7 @@ package body Makegpr is
Open (Dep_File, Dep_Name);
-- If the dependency file cannot be open, we need to recompile the
-- source.
-- If dependency file cannot be open, we need to recompile the source
if not Is_Valid (Dep_File) then
if Verbose_Mode then
@ -1392,6 +1415,7 @@ package body Makegpr is
declare
End_Of_File_Reached : Boolean := False;
begin
loop
if End_Of_File (Dep_File) then
@ -1445,8 +1469,10 @@ package body Makegpr is
declare
Line : constant String := Name_Buffer (1 .. Name_Len);
Last : constant Natural := Name_Len;
begin
Name_Loop : loop
-- Find the beginning of the next source path name
while Start < Last and then Line (Start) = ' ' loop
@ -1484,13 +1510,13 @@ package body Makegpr is
declare
Src_Name : constant String :=
Normalize_Pathname
(Name => Line (Start .. Finish),
Case_Sensitive => False);
Normalize_Pathname
(Name => Line (Start .. Finish),
Case_Sensitive => False);
Src_TS : Time_Stamp_Type;
begin
-- If it is the original source,
-- set Source_In_Dependencies.
-- If it is original source, set Source_In_Dependencies
if Src_Name = Source_Path then
Source_In_Dependencies := True;
@ -1599,6 +1625,7 @@ package body Makegpr is
is
Source : Other_Source := Other_Sources.Table (Source_Id);
Success : Boolean;
begin
-- If the compiler is not know yet, get its path name
@ -1668,6 +1695,7 @@ package body Makegpr is
declare
S : constant String := Strip_CR_LF (Expect_Out (FD));
begin
-- Each line of the output is put in the dependency
-- file, including errors. If there are errors, the
@ -1679,8 +1707,8 @@ package body Makegpr is
end;
end loop;
-- If we are here, it means we had a timeout.
-- So, the dependency file may be incomplete: it is safer to
-- If we are here, it means we had a timeout, so the
-- dependency file may be incomplete. It is safer to
-- delete it, otherwise the dependencies may be wrong.
Close (FD, Status);
@ -1688,13 +1716,15 @@ package body Makegpr is
Delete_File (Get_Name_String (Source.Dep_Name), Success);
exception
when Process_Died =>
-- This is the normal outcome. Just close the file.
when Process_Died =>
-- This is the normal outcome. Just close the file
Close (FD, Status);
Close (Dep_File);
when others =>
when others =>
-- Something wrong happened. It is safer to delete the
-- dependency file, otherwise the dependencies may be wrong.
@ -1719,10 +1749,9 @@ package body Makegpr is
Last_Argument := 0;
-- For GCC compilers, make sure the language is always
-- specified to the GCC driver, in case the extension is
-- not recognized by the GCC driver as a source of the
-- language.
-- For GCC compilers, make sure the language is always specified to
-- to the GCC driver, in case the extension is not recognized by the
-- GCC driver as a source of the language.
if Compiler_Is_Gcc (Source.Language) then
Add_Argument (Dash_x, Verbose_Mode);
@ -1731,13 +1760,14 @@ package body Makegpr is
end if;
-- Specify the source to be compiled
Add_Argument (Dash_c, True);
Add_Argument (Get_Name_String (Source.Path_Name), True);
-- If it is a non static library project, compile with the PIC option
-- if there is one (when there is no PIC option, function
-- MLib.Tgt.PIC_Option returns an empty string, and Add_Argument with
-- an empty string has no effect).
-- If non static library project, compile with the PIC option if there
-- is one (when there is no PIC option, function MLib.Tgt.PIC_Option
-- returns an empty string, and Add_Argument with an empty string has
-- no effect).
if Data.Library and then Data.Library_Kind /= Static then
Add_Argument (PIC_Option, True);
@ -1790,6 +1820,7 @@ package body Makegpr is
Success);
if Success then
-- Compilation was successful, update the time stamp
-- of the object file.
@ -1812,8 +1843,7 @@ package body Makegpr is
" has not been modified");
else
-- Everything looks fine, update the Other_Sources
-- table.
-- Everything looks fine, update the Other_Sources table
Other_Sources.Table (Source_Id) := Source;
end if;
@ -1832,13 +1862,15 @@ package body Makegpr is
--------------------------------
procedure Compile_Individual_Sources is
Data : Project_Data := Projects.Table (Main_Project);
Source_Id : Other_Source_Id;
Source : Other_Source;
Source_Name : Name_Id;
Data : Project_Data := Projects.Table (Main_Project);
Source_Id : Other_Source_Id;
Source : Other_Source;
Source_Name : Name_Id;
Project_Name : String := Get_Name_String (Data.Name);
Dummy : Boolean := False;
Ada_Is_A_Language : constant Boolean := Data.Languages (Lang_Ada);
begin
Ada_Mains.Init;
@ -1914,6 +1946,7 @@ package body Makegpr is
end if;
if Ada_Mains.Last > 0 then
-- Invoke gnatmake for all sources that are not of a non Ada language
Last_Argument := 0;
@ -1933,8 +1966,9 @@ package body Makegpr is
--------------------------------
procedure Compile_Link_With_Gnatmake (Mains_Specified : Boolean) is
Data : constant Project_Data := Projects.Table (Main_Project);
Data : constant Project_Data := Projects.Table (Main_Project);
Success : Boolean;
begin
-- Array Arguments may already contain some arguments, so we don't
-- set Last_Argument to 0.
@ -2074,9 +2108,8 @@ package body Makegpr is
Source : Other_Source;
Local_Errors : Boolean := False;
-- Set to True when there is a compilation error.
-- Used only when Keep_Going is True, to inhibit the building of the
-- archive.
-- Set to True when there is a compilation error. Used only when
-- Keep_Going is True, to inhibit the building of the archive.
Need_To_Compile : Boolean;
-- Set to True when a source needs to be compiled/recompiled.
@ -2092,6 +2125,7 @@ package body Makegpr is
Data := Projects.Table (Project);
if not Data.Virtual then
-- If the imported directory switches are unknown, compute them
if not Data.Include_Data_Set then
@ -2100,8 +2134,7 @@ package body Makegpr is
Projects.Table (Project) := Data;
end if;
-- Nothing to do when there are no sources of language other than
-- Ada.
-- Nothing to do when no sources of language other than Ada
if Data.Sources_Present then
Need_To_Rebuild_Archive := Force_Compilations;
@ -2116,7 +2149,6 @@ package body Makegpr is
while Source_Id /= No_Other_Source loop
Source := Other_Sources.Table (Source_Id);
Need_To_Compile := Force_Compilations;
-- Check if compilation is needed
@ -2128,11 +2160,11 @@ package body Makegpr is
-- Proceed, if compilation is needed
if Need_To_Compile then
-- If a source is compiled/recompiled, of course the
-- archive will need to be built/rebuilt.
Need_To_Rebuild_Archive := True;
Compile (Source_Id, Data, Local_Errors);
end if;
@ -2175,11 +2207,12 @@ package body Makegpr is
------------------------------------
procedure Create_Archive_Dependency_File
(Name : String; First_Source : Other_Source_Id)
(Name : String;
First_Source : Other_Source_Id)
is
Source_Id : Other_Source_Id := First_Source;
Source : Other_Source;
Dep_File : Ada.Text_IO.File_Type;
Dep_File : Ada.Text_IO.File_Type;
use Ada.Text_IO;
begin
@ -2246,14 +2279,18 @@ package body Makegpr is
-- The id of the package IDE in the project file
Compiler : constant Variable_Value :=
Value_Of (Lang_Name_Ids (For_Language), Name_Compiler_Command, Ide);
-- The value of Compiler_Command ("language") in package IDE, if it is
-- defined.
Value_Of
(Name => Lang_Name_Ids (For_Language),
Index => 0,
Attribute_Or_Array_Name => Name_Compiler_Command,
In_Package => Ide);
-- The value of Compiler_Command ("language") in package IDE, if defined
begin
-- No need to do it again if the compiler is known for this language
if Compiler_Names (For_Language) = null then
-- If compiler command is not defined for this language in package
-- IDE, use the default compiler for this language.
@ -2266,8 +2303,7 @@ package body Makegpr is
new String'(Get_Name_String (Compiler.Value));
end if;
-- Check if compiler is a GCC compiler: its name end with "gcc" or
-- "g++".
-- Check we have a GCC compiler (name ends with "gcc" or "g++")
declare
Comp_Name : constant String := Compiler_Names (For_Language).all;
@ -2277,7 +2313,6 @@ package body Makegpr is
Last3 := Comp_Name (Comp_Name'Last - 2 .. Comp_Name'Last);
Compiler_Is_Gcc (For_Language) :=
(Last3 = "gcc") or (Last3 = "g++");
else
Compiler_Is_Gcc (For_Language) := False;
end if;
@ -2315,6 +2350,7 @@ package body Makegpr is
Data : in out Project_Data)
is
Imported_Projects : Project_List := Data.Imported_Projects;
Path_Length : Natural := 0;
Position : Natural := 0;
@ -2380,8 +2416,9 @@ package body Makegpr is
------------------------
procedure Recursive_Get_Dirs (Prj : Project_Id) is
Data : Project_Data;
Data : Project_Data;
Imported : Project_List;
begin
-- Nothing to do if project is undefined
@ -2391,6 +2428,7 @@ package body Makegpr is
-- Nothing to do if project has already been processed
if not Data.Seen then
-- Mark the project as processed, to avoid multiple processing
-- of the same project.
@ -2427,8 +2465,7 @@ package body Makegpr is
Last_Argument := 0;
-- Process this project individually, the project data are already
-- known.
-- Process this project individually, project data are already known
Projects.Table (Project).Seen := True;
@ -2518,7 +2555,6 @@ package body Makegpr is
end if;
else
-- First compile sources and build archives, if necessary
Compile_Sources;
@ -2676,6 +2712,7 @@ package body Makegpr is
File : Ada.Text_IO.File_Type;
use Ada.Text_IO;
begin
Create (File, Out_File, Cpp_Linker);
@ -2693,11 +2730,8 @@ package body Makegpr is
end if;
end Choose_C_Plus_Plus_Link_Process;
begin
-- If no mains were specified, get the mains from attribute Main, if
-- it exists.
-- If no mains specified, get mains from attribute Main, if it exists
if not Mains_Specified then
declare
@ -2844,6 +2878,7 @@ package body Makegpr is
(Executable_Of
(Project => Main_Project,
Main => Other_Mains.Table (Main).File_Name,
Index => 0,
Ada_Main => False)),
True);
end if;
@ -2959,24 +2994,30 @@ package body Makegpr is
Executable_Name : constant String :=
Get_Name_String
(Executable_Of
(Main_Project, Main_Id, Ada_Main => False));
(Project => Main_Project,
Main => Main_Id,
Index => 0,
Ada_Main => False));
-- File name of the executable
Executable_Path : constant String :=
Get_Name_String (Data.Exec_Directory) &
Directory_Separator & Executable_Name;
Get_Name_String
(Data.Exec_Directory) &
Directory_Separator &
Executable_Name;
-- Path name of the executable
Exec_Time_Stamp : Time_Stamp_Type;
begin
begin
-- Now, check if the executable is up to date.
-- It is considered up to date if its time stamp is
-- not earlier that the time stamp of any archive.
-- Only do that if we don't know if we need to link.
if not Need_To_Relink then
-- Get the time stamp of the excutable
-- Get the time stamp of the executable
Name_Len := 0;
Add_Str_To_Name_Buffer (Executable_Path);
@ -3003,6 +3044,7 @@ package body Makegpr is
declare
Prj_Data : Project_Data;
begin
for Prj in 1 .. Projects.Last loop
Prj_Data := Projects.Table (Prj);
@ -3052,7 +3094,6 @@ package body Makegpr is
end;
end if;
-- If Need_To_Relink is False, we are done
if Verbose_Mode and (not Need_To_Relink) then
@ -3076,7 +3117,10 @@ package body Makegpr is
Directory_Separator &
Get_Name_String
(Executable_Of
(Main_Project, Main_Id, Ada_Main => False)),
(Project => Main_Project,
Main => Main_Id,
Index => 0,
Ada_Main => False)),
True);
-- Specify the object file of the main source
@ -3156,7 +3200,10 @@ package body Makegpr is
Write_Str
(Get_Name_String
(Executable_Of
(Main_Project, Main_Id, Ada_Main => False)));
(Project => Main_Project,
Main => Main_Id,
Index => 0,
Ada_Main => False)));
Write_Line (""" up to date");
end;
@ -3173,10 +3220,12 @@ package body Makegpr is
------------------
procedure Report_Error
(S1 : String; S2 : String := ""; S3 : String := "")
(S1 : String;
S2 : String := "";
S3 : String := "")
is
begin
-- If keep_Going is True, output the error message, preceded by the
-- If Keep_Going is True, output the error message, preceded by the
-- error header.
if Keep_Going then
@ -3231,7 +3280,6 @@ package body Makegpr is
if Project_File_Name_Expected then
if Arg (1) = '-' then
Osint.Fail ("project file name missing after -P");
else
Project_File_Name_Expected := False;
Project_File_Name := new String'(Arg);
@ -3243,7 +3291,6 @@ package body Makegpr is
elsif Output_File_Name_Expected then
if Arg (1) = '-' then
Osint.Fail ("output file name missing after -o");
else
Output_File_Name_Expected := False;
Output_File_Name := new String'(Arg);
@ -3255,10 +3302,11 @@ package body Makegpr is
elsif Arg'Length >= 6 and then
Arg (Arg'First .. Arg'First + 1) = "-c" and then
Arg (Arg'Last - 3 .. Arg'Last) = "args"
Arg (Arg'Last - 3 .. Arg'Last) = "args"
then
declare
OK : Boolean := False;
OK : Boolean := False;
Args_String : constant String :=
Arg (Arg'First + 2 .. Arg'Last - 4);
@ -3287,9 +3335,8 @@ package body Makegpr is
elsif Arg = "-gargs" then
Current_Processor := None;
-- A special test is needed for the -o switch within a -largs
-- since that is another way to specify the name of the final
-- executable.
-- A special test is needed for the -o switch within a -largs since
-- that is another way to specify the name of the final executable.
elsif Current_Processor = Linker and then Arg = "-o" then
Osint.Fail

5
gcc/ada/makeusg.adb
View File

@ -88,6 +88,11 @@ begin
Write_Str (" -D dir Specify dir as the object directory");
Write_Eol;
-- Line for -eI
Write_Str (" -eI Index of unit in multi-unit source file");
Write_Eol;
-- Line for -eL
Write_Str (" -eL Follow symbolic links when processing " &

120
gcc/ada/makeutl.adb
View File

@ -25,6 +25,7 @@
------------------------------------------------------------------------------
with Namet; use Namet;
with Osint; use Osint;
with Prj; use Prj;
with Prj.Ext;
with Prj.Util;
@ -32,8 +33,32 @@ with Snames; use Snames;
with Table;
with Types; use Types;
with System.HTable;
package body Makeutl is
type Mark_Key is record
File : File_Name_Type;
Index : Int;
end record;
-- Identify either a mono-unit source (when Index = 0) or a specific unit
-- in a multi-unit source.
Max_Mask_Num : constant := 2048;
subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;
function Hash (Key : Mark_Key) return Mark_Num;
package Marks is new System.HTable.Simple_HTable
(Header_Num => Mark_Num,
Element => Boolean,
No_Element => False,
Key => Mark_Key,
Hash => Hash,
Equal => "=");
-- A hash table to keep tracks of the marked units.
type Linker_Options_Data is record
Project : Project_Id;
Options : String_List_Id;
@ -83,6 +108,24 @@ package body Makeutl is
end if;
end Add_Linker_Option;
----------------------
-- Delete_All_Marks --
----------------------
procedure Delete_All_Marks is
begin
Marks.Reset;
end Delete_All_Marks;
----------
-- Hash --
----------
function Hash (Key : Mark_Key) return Mark_Num is
begin
return Union_Id (Key.File) mod Max_Mask_Num;
end Hash;
----------------------------
-- Is_External_Assignment --
----------------------------
@ -124,6 +167,19 @@ package body Makeutl is
end if;
end Is_External_Assignment;
---------------
-- Is_Marked --
---------------
function Is_Marked
(Source_File : File_Name_Type;
Index : Int := 0)
return Boolean
is
begin
return Marks.Get (K => (File => Source_File, Index => Index));
end Is_Marked;
-----------------------------
-- Linker_Options_Switches --
-----------------------------
@ -166,6 +222,7 @@ package body Makeutl is
Options :=
Prj.Util.Value_Of
(Name => Name_Ada,
Index => 0,
Attribute_Or_Array_Name => Name_Linker_Options,
In_Package => Linker_Package);
@ -305,6 +362,15 @@ package body Makeutl is
end Mains;
----------
-- Mark --
----------
procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is
begin
Marks.Set (K => (File => Source_File, Index => Index), E => True);
end Mark;
---------------------------
-- Test_If_Relative_Path --
---------------------------
@ -384,4 +450,58 @@ package body Makeutl is
end if;
end Test_If_Relative_Path;
-------------------
-- Unit_Index_Of --
-------------------
function Unit_Index_Of (ALI_File : File_Name_Type) return Int is
Start : Natural;
Finish : Natural;
Result : Int := 0;
begin
Get_Name_String (ALI_File);
-- First, find the last dot
Finish := Name_Len;
while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop
Finish := Finish - 1;
end loop;
if Finish = 1 then
return 0;
end if;
-- Now check that the dot is preceded by digits
Start := Finish;
Finish := Finish - 1;
while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop
Start := Start - 1;
end loop;
-- If there is no difits, or if the digits are not preceded by
-- the character that precedes a unit index, this is not the ALI file
-- of a unit in a multi-unit source.
if Start > Finish or else
Start = 1 or else
Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
then
return 0;
end if;
-- Build the index from the digit(s)
while Start <= Finish loop
Result := (Result * 10) + Character'Pos (Name_Buffer (Start))
- Character'Pos ('0');
Start := Start + 1;
end loop;
return Result;
end Unit_Index_Of;
end Makeutl;

22
gcc/ada/makeutl.ads
View File

@ -27,6 +27,7 @@
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Osint;
with Prj; use Prj;
with Types; use Types;
package Makeutl is
@ -34,6 +35,9 @@ package Makeutl is
(S1 : String; S2 : String := ""; S3 : String := "");
Do_Fail : Fail_Proc := Osint.Fail'Access;
function Unit_Index_Of (ALI_File : File_Name_Type) return Int;
-- Find the index of a unit in a source file. Return zero if the file
-- is not a multi-unit source file.
function Is_External_Assignment (Argv : String) return Boolean;
-- Verify that an external assignment switch is syntactically correct.
@ -85,4 +89,22 @@ package Makeutl is
-- For gnatbind switches, Including_L_Switch is False, because the
-- argument of the -L switch is not a path.
----------------------
-- Marking Routines --
----------------------
procedure Mark (Source_File : File_Name_Type; Index : Int := 0);
-- Mark a unit, identified by its source file and, when Index is not 0,
-- the index of the unit in the source file. Marking is used to signal
-- that the unit has already been inserted in the Q.
function Is_Marked
(Source_File : File_Name_Type;
Index : Int := 0)
return Boolean;
-- Returns True if the unit was previously marked.
procedure Delete_All_Marks;
-- Remove all file/index couples marked
end Makeutl;

4
gcc/ada/mlib-prj.adb
View File

@ -815,7 +815,9 @@ package body MLib.Prj is
if Defaults /= No_Array_Element then
Switches :=
Value_Of
(Index => Name_Ada, In_Array => Defaults);
(Index => Name_Ada,
Src_Index => 0,
In_Array => Defaults);
if not Switches.Default then
Switch := Switches.Values;

5
gcc/ada/opt.ads
View File

@ -638,6 +638,11 @@ package Opt is
-- Set to True when either Compile_Only, Bind_Only or Link_Only is
-- set to True.
Main_Index : Int := 0;
-- GNATMAKE
-- This is set to non-zero by gnatmake switch -eInnn to indicate that
-- the main program is the nnn unit in a multi-unit source file.
Mapping_File_Name : String_Ptr := null;
-- GNAT
-- File name of mapping between unit names, file names and path names.

16
gcc/ada/osint.adb
View File

@ -520,7 +520,7 @@ package body Osint is
-- Add_File --
--------------
procedure Add_File (File_Name : String) is
procedure Add_File (File_Name : String; Index : Int := No_Index) is
begin
Number_File_Names := Number_File_Names + 1;
@ -530,9 +530,12 @@ package body Osint is
if Number_File_Names > File_Names'Last then
File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
File_Indexes :=
new File_Index_Array'(File_Indexes.all & File_Indexes.all);
end if;
File_Names (Number_File_Names) := new String'(File_Name);
File_Names (Number_File_Names) := new String'(File_Name);
File_Indexes (Number_File_Names) := Index;
end Add_File;
------------------------
@ -670,6 +673,15 @@ package body Osint is
end if;
end Create_File_And_Check;
------------------------
-- Current_File_Index --
------------------------
function Current_File_Index return Int is
begin
return File_Indexes (Current_File_Name_Index);
end Current_File_Index;
--------------------------------
-- Current_Library_File_Stamp --
--------------------------------

12
gcc/ada/osint.ads
View File

@ -92,7 +92,9 @@ package Osint is
function Number_Of_Files return Int;
-- gives the total number of filenames found on the command line.
procedure Add_File (File_Name : String);
No_Index : constant := -1;
procedure Add_File (File_Name : String; Index : Int := No_Index);
-- Called by the subprogram processing the command line for each
-- file name found.
@ -379,6 +381,9 @@ package Osint is
-- every single time the routines are called unless you have previously
-- called Source_File_Data (Cache => True). See below.
function Current_File_Index return Int;
-- Return the index in its source file of the current main unit
function Matching_Full_Source_Name
(N : File_Name_Type;
T : Time_Stamp_Type) return File_Name_Type;
@ -573,6 +578,11 @@ private
-- extensible, because when using project files, there may be
-- more files than arguments on the command line.
type File_Index_Array is array (Int range <>) of Int;
type File_Index_Array_Ptr is access File_Index_Array;
File_Indexes : File_Index_Array_Ptr :=
new File_Index_Array (1 .. Int (Argument_Count) + 2);
Current_File_Name_Index : Int := 0;
-- The index in File_Names of the last file opened by Next_Main_Source
-- or Next_Main_Lib_File. The value 0 indicates that no files have been

58
gcc/ada/prj-attr.adb
View File

@ -39,7 +39,9 @@ package body Prj.Attr is
-- The first letter is one of
-- 'S' for Single
-- 'L' for list
-- 's' for Single with optional index
-- 'L' for List
-- 'l' for List of strings with optional indexes
-- The second letter is one of
-- 'V' for single variable
@ -47,6 +49,7 @@ package body Prj.Attr is
-- 'a' for case insensitive associative array
-- 'b' for associative array, case insensitive if file names are case
-- insensitive
-- 'c' same as 'b', with optional index
-- End is indicated by two consecutive '#'.
@ -72,7 +75,7 @@ package body Prj.Attr is
"SVlibrary_symbol_file#" &
"SVlibrary_symbol_policy#" &
"SVlibrary_reference_symbol_file#" &
"LVmain#" &
"lVmain#" &
"LVlanguages#" &
"SVmain_language#" &
@ -86,10 +89,10 @@ package body Prj.Attr is
"SVseparate_suffix#" &
"SVcasing#" &
"SVdot_replacement#" &
"SAspecification#" &
"SAspec#" &
"SAimplementation#" &
"SAbody#" &
"sAspecification#" &
"sAspec#" &
"sAimplementation#" &
"sAbody#" &
"Laspecification_exceptions#" &
"Laimplementation_exceptions#" &
@ -97,15 +100,15 @@ package body Prj.Attr is
"Pcompiler#" &
"Ladefault_switches#" &
"Lbswitches#" &
"Lcswitches#" &
"SVlocal_configuration_pragmas#" &
-- package Builder
"Pbuilder#" &
"Ladefault_switches#" &
"Lbswitches#" &
"Sbexecutable#" &
"Lcswitches#" &
"Scexecutable#" &
"SVexecutable_suffix#" &
"SVglobal_configuration_pragmas#" &
@ -118,13 +121,13 @@ package body Prj.Attr is
"Pbinder#" &
"Ladefault_switches#" &
"Lbswitches#" &
"Lcswitches#" &
-- package Linker
"Plinker#" &
"Ladefault_switches#" &
"Lbswitches#" &
"Lcswitches#" &
"LVlinker_options#" &
-- package Cross_Reference
@ -184,6 +187,7 @@ package body Prj.Attr is
Current_Attribute : Attribute_Node_Id := Empty_Attribute;
Is_An_Attribute : Boolean := False;
Kind_1 : Variable_Kind := Undefined;
Optional_Index : Boolean := False;
Kind_2 : Attribute_Kind := Single;
Package_Name : Name_Id := No_Name;
Attribute_Name : Name_Id := No_Name;
@ -232,10 +236,20 @@ package body Prj.Attr is
Start := Finish + 1;
when 'S' =>
Kind_1 := Single;
Kind_1 := Single;
Optional_Index := False;
when 's' =>
Kind_1 := Single;
Optional_Index := True;
when 'L' =>
Kind_1 := List;
Kind_1 := List;
Optional_Index := False;
when 'l' =>
Kind_1 := List;
Optional_Index := True;
when others =>
raise Program_Error;
@ -263,6 +277,14 @@ package body Prj.Attr is
Kind_2 := Case_Insensitive_Associative_Array;
end if;
when 'c' =>
if File_Names_Case_Sensitive then
Kind_2 := Optional_Index_Associative_Array;
else
Kind_2 :=
Optional_Index_Case_Insensitive_Associative_Array;
end if;
when others =>
raise Program_Error;
end case;
@ -279,6 +301,7 @@ package body Prj.Attr is
To_Lower (Initialization_Data (Start .. Finish - 1));
Attribute_Name := Name_Find;
Attributes.Increment_Last;
if Current_Attribute = Empty_Attribute then
First_Attribute := Attributes.Last;
@ -306,10 +329,11 @@ package body Prj.Attr is
Current_Attribute := Attributes.Last;
Attributes.Table (Current_Attribute) :=
(Name => Attribute_Name,
Kind_1 => Kind_1,
Kind_2 => Kind_2,
Next => Empty_Attribute);
(Name => Attribute_Name,
Kind_1 => Kind_1,
Optional_Index => Optional_Index,
Kind_2 => Kind_2,
Next => Empty_Attribute);
Start := Finish + 1;
end if;
end loop;

15
gcc/ada/prj-attr.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -53,13 +53,16 @@ package Prj.Attr is
type Attribute_Kind is
(Single,
Associative_Array,
Case_Insensitive_Associative_Array);
Optional_Index_Associative_Array,
Case_Insensitive_Associative_Array,
Optional_Index_Case_Insensitive_Associative_Array);
type Attribute_Record is record
Name : Name_Id;
Kind_1 : Variable_Kind;
Kind_2 : Attribute_Kind;
Next : Attribute_Node_Id;
Name : Name_Id;
Kind_1 : Variable_Kind;
Optional_Index : Boolean;
Kind_2 : Attribute_Kind;
Next : Attribute_Node_Id;
end record;
package Attributes is

1
gcc/ada/prj-com.ads
View File

@ -56,6 +56,7 @@ package Prj.Com is
type File_Name_Data is record
Name : Name_Id := No_Name;
Index : Int := 0;
Display_Name : Name_Id := No_Name;
Path : Name_Id := No_Name;
Display_Path : Name_Id := No_Name;

50
gcc/ada/prj-dect.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -33,6 +33,7 @@ with Scans; use Scans;
with Snames;
with Types; use Types;
with Prj.Attr; use Prj.Attr;
with Uintp; use Uintp;
package body Prj.Dect is
@ -121,6 +122,7 @@ package body Prj.Dect is
Current_Attribute : Attribute_Node_Id := First_Attribute;
Full_Associative_Array : Boolean := False;
Attribute_Name : Name_Id := No_Name;
Optional_Index : Boolean := False;
begin
Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration);
@ -194,8 +196,9 @@ package body Prj.Dect is
-- Set, if appropriate the index case insensitivity flag
elsif Attributes.Table (Current_Attribute).Kind_2 =
Case_Insensitive_Associative_Array
elsif Attributes.Table (Current_Attribute).Kind_2 in
Case_Insensitive_Associative_Array ..
Optional_Index_Case_Insensitive_Associative_Array
then
Set_Case_Insensitive (Attribute, To => True);
end if;
@ -245,6 +248,40 @@ package body Prj.Dect is
if Token = Tok_String_Literal then
Set_Associative_Array_Index_Of (Attribute, Token_Name);
Scan; -- past the literal string index
if Token = Tok_At then
case Attributes.Table (Current_Attribute).Kind_2 is
when Optional_Index_Associative_Array |
Optional_Index_Case_Insensitive_Associative_Array =>
Scan;
Expect (Tok_Integer_Literal, "integer literal");
if Token = Tok_Integer_Literal then
declare
Index : constant Int :=
UI_To_Int (Int_Literal_Value);
begin
if Index = 0 then
Error_Msg ("index cannot be zero", Token_Ptr);
else
-- Set the index
Set_Source_Index_Of (Attribute, To => Index);
end if;
end;
Scan;
end if;
when others =>
Error_Msg ("index not allowed here", Token_Ptr);
Scan;
if Token = Tok_Integer_Literal then
Scan;
end if;
end case;
end if;
end if;
Expect (Tok_Right_Paren, "`)`");
@ -271,6 +308,7 @@ package body Prj.Dect is
if Current_Attribute /= Empty_Attribute then
Set_Expression_Kind_Of
(Attribute, To => Attributes.Table (Current_Attribute).Kind_1);
Optional_Index := Attributes.Table (Current_Attribute).Optional_Index;
end if;
Expect (Tok_Use, "USE");
@ -439,7 +477,8 @@ package body Prj.Dect is
Parse_Expression
(Expression => Expression,
Current_Project => Current_Project,
Current_Package => Current_Package);
Current_Package => Current_Package,
Optional_Index => Optional_Index);
Set_Expression_Of (Attribute, To => Expression);
-- If the expression is legal, but not of the right kind
@ -1225,7 +1264,8 @@ package body Prj.Dect is
Parse_Expression
(Expression => Expression,
Current_Project => Current_Project,
Current_Package => Current_Package);
Current_Package => Current_Package,
Optional_Index => False);
Set_Expression_Of (Variable, To => Expression);
if Expression /= Empty_Node then

24
gcc/ada/prj-env.adb
View File

@ -584,7 +584,8 @@ package body Prj.Env is
procedure Put
(Unit_Name : Name_Id;
File_Name : Name_Id;
Unit_Kind : Spec_Or_Body);
Unit_Kind : Spec_Or_Body;
Index : Int);
-- Put an SFN pragma in the temporary file
procedure Put (File : File_Descriptor; S : String);
@ -742,7 +743,8 @@ package body Prj.Env is
procedure Put
(Unit_Name : Name_Id;
File_Name : Name_Id;
Unit_Kind : Spec_Or_Body)
Unit_Kind : Spec_Or_Body;
Index : Int)
is
begin
-- A temporary file needs to be open
@ -761,7 +763,14 @@ package body Prj.Env is
end if;
Put (File, Namet.Get_Name_String (File_Name));
Put_Line (File, """);");
Put (File, """");
if Index /= 0 then
Put (File, ", Index =>");
Put (File, Index'Img);
end if;
Put_Line (File, ");");
end Put;
procedure Put (File : File_Descriptor; S : String) is
@ -788,7 +797,7 @@ package body Prj.Env is
Last : Natural;
begin
-- Add an ASCII.LF to the string. As this gnat.adc is supposed to
-- Add an ASCII.LF to the string. As this config file is supposed to
-- be used only by the compiler, we don't care about the characters
-- for the end of line. In fact we could have put a space, but
-- it is more convenient to be able to read gnat.adc during
@ -831,13 +840,15 @@ package body Prj.Env is
if Unit.File_Names (Specification).Needs_Pragma then
Put (Unit.Name,
Unit.File_Names (Specification).Name,
Specification);
Specification,
Unit.File_Names (Specification).Index);
end if;
if Unit.File_Names (Body_Part).Needs_Pragma then
Put (Unit.Name,
Unit.File_Names (Body_Part).Name,
Body_Part);
Body_Part,
Unit.File_Names (Body_Part).Index);
end if;
Current_Unit := Current_Unit + 1;
@ -1269,7 +1280,6 @@ package body Prj.Env is
Write_Line (" OK");
end if;
if Full_Path then
return Get_Name_String
(Unit.File_Names (Specification).Path);

211
gcc/ada/prj-makr.adb
View File

@ -136,9 +136,10 @@ package body Prj.Makr is
Args : Argument_List (1 .. Preproc_Switches'Length + 6);
type SFN_Pragma is record
Unit : Name_Id;
File : Name_Id;
Spec : Boolean;
Unit : Name_Id;
File : Name_Id;
Index : Int := 0;
Spec : Boolean;
end record;
package SFN_Pragmas is new Table.Table
@ -254,7 +255,7 @@ package body Prj.Makr is
then
Output.Write_Str (" Checking """);
Output.Write_Str (Str (1 .. Last));
Output.Write_Str (""": ");
Output.Write_Line (""": ");
end if;
-- If the file name matches one of the regular expressions,
@ -362,7 +363,7 @@ package body Prj.Makr is
if End_Of_File (File) then
if Opt.Verbose_Mode then
if not Success then
Output.Write_Str ("(process died) ");
Output.Write_Str (" (process died) ");
end if;
end if;
@ -383,10 +384,11 @@ package body Prj.Makr is
Name_Buffer (1 .. Name_Len) :=
Text_Line (6 .. J - 7);
SFN_Prag :=
(Unit => Name_Find,
File => File_Name_Id,
Spec => Text_Line (J - 5 .. J) =
"(spec)");
(Unit => Name_Find,
File => File_Name_Id,
Index => 0,
Spec => Text_Line (J - 5 .. J) =
"(spec)");
SFN_Pragmas.Increment_Last;
SFN_Pragmas.Table
@ -400,107 +402,116 @@ package body Prj.Makr is
if Save_Last_Pragma_Index = SFN_Pragmas.Last then
if Opt.Verbose_Mode then
Output.Write_Line ("not a unit");
end if;
elsif SFN_Pragmas.Last >
Save_Last_Pragma_Index + 1
then
SFN_Pragmas.Set_Last (Save_Last_Pragma_Index);
if Opt.Verbose_Mode then
Output.Write_Line
("file contains multiple units");
Output.Write_Line (" not a unit");
end if;
else
SFN_Prag := SFN_Pragmas.Table
(SFN_Pragmas.Last);
if Opt.Verbose_Mode then
if SFN_Prag.Spec then
Output.Write_Str ("spec of ");
else
Output.Write_Str ("body of ");
end if;
Output.Write_Line
(Get_Name_String (SFN_Prag.Unit));
if SFN_Pragmas.Last >
Save_Last_Pragma_Index + 1
then
for Index in Save_Last_Pragma_Index + 1 ..
SFN_Pragmas.Last
loop
SFN_Pragmas.Table (Index).Index :=
Int (Index - Save_Last_Pragma_Index);
end loop;
end if;
if Project_File then
-- Add the corresponding attribute in the
-- Naming package of the naming project.
declare
Decl_Item : constant Project_Node_Id :=
Default_Project_Node
(Of_Kind =>
N_Declarative_Item);
Attribute : constant Project_Node_Id :=
Default_Project_Node
(Of_Kind =>
N_Attribute_Declaration);
Expression : constant Project_Node_Id :=
Default_Project_Node
(Of_Kind => N_Expression,
And_Expr_Kind => Single);
Term : constant Project_Node_Id :=
Default_Project_Node
(Of_Kind => N_Term,
And_Expr_Kind => Single);
Value : constant Project_Node_Id :=
Default_Project_Node
(Of_Kind => N_Literal_String,
And_Expr_Kind => Single);
begin
Set_Next_Declarative_Item
(Decl_Item,
To => First_Declarative_Item_Of
(Naming_Package));
Set_First_Declarative_Item_Of
(Naming_Package, To => Decl_Item);
Set_Current_Item_Node
(Decl_Item, To => Attribute);
-- Is it a spec or a body?
for Index in Save_Last_Pragma_Index + 1 ..
SFN_Pragmas.Last
loop
SFN_Prag := SFN_Pragmas.Table (Index);
if Opt.Verbose_Mode then
if SFN_Prag.Spec then
Set_Name_Of
(Attribute, To => Name_Spec);
Output.Write_Str (" spec of ");
else
Set_Name_Of
(Attribute,
To => Name_Body);
Output.Write_Str (" body of ");
end if;
-- Get the name of the unit
Output.Write_Line
(Get_Name_String (SFN_Prag.Unit));
end if;
Get_Name_String (SFN_Prag.Unit);
To_Lower (Name_Buffer (1 .. Name_Len));
Set_Associative_Array_Index_Of
(Attribute, To => Name_Find);
if Project_File then
Set_Expression_Of
(Attribute, To => Expression);
Set_First_Term
(Expression, To => Term);
Set_Current_Term (Term, To => Value);
-- Add the corresponding attribute in the
-- Naming package of the naming project.
-- And set the name of the file
declare
Decl_Item : constant Project_Node_Id :=
Default_Project_Node
(Of_Kind =>
N_Declarative_Item);
Set_String_Value_Of
(Value, To => File_Name_Id);
end;
Attribute : constant Project_Node_Id :=
Default_Project_Node
(Of_Kind =>
N_Attribute_Declaration);
-- Add source file name to source list file
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 the name of the unit
Get_Name_String (SFN_Prag.Unit);
To_Lower (Name_Buffer (1 .. Name_Len));
Set_Associative_Array_Index_Of
(Attribute, To => Name_Find);
Set_Expression_Of
(Attribute, To => Expression);
Set_First_Term
(Expression, To => Term);
Set_Current_Term (Term, To => Value);
-- And set the name of the file
Set_String_Value_Of
(Value, To => File_Name_Id);
Set_Source_Index_Of
(Value, To => SFN_Prag.Index);
end;
end if;
end loop;
if Project_File then
-- Add source file name to source list
-- file.
Last := Last + 1;
Str (Last) := ASCII.LF;
@ -1273,7 +1284,15 @@ package body Prj.Makr is
Write_A_String
(Get_Name_String (SFN_Pragmas.Table (Index).File));
Write_A_String (""");");
Write_A_String ("""");
if SFN_Pragmas.Table (Index).Index /= 0 then
Write_A_String (", Index =>");
Write_A_String (SFN_Pragmas.Table (Index).Index'Img);
end if;
Write_A_String (");");
Write_Eol;
end loop;

468
gcc/ada/prj-nmsc.adb
View File

@ -38,6 +38,7 @@ with Prj.Err;
with Prj.Util; use Prj.Util;
with Sinput.P;
with Snames; use Snames;
with Table; use Table;
with Types; use Types;
with Ada.Characters.Handling; use Ada.Characters.Handling;
@ -97,27 +98,48 @@ package body Prj.Nmsc is
-- several times, and to avoid cycles that may be introduced by symbolic
-- links.
type Ada_Naming_Exception_Id is new Nat;
No_Ada_Naming_Exception : constant Ada_Naming_Exception_Id := 0;
type Unit_Info is record
Kind : Spec_Or_Body;
Unit : Name_Id;
Next : Ada_Naming_Exception_Id := No_Ada_Naming_Exception;
end record;
No_Unit : constant Unit_Info := (Specification, No_Name);
-- No_Unit : constant Unit_Info :=
-- (Specification, No_Name, No_Ada_Naming_Exception);
package Ada_Naming_Exception_Table is new Table.Table
(Table_Component_Type => Unit_Info,
Table_Index_Type => Ada_Naming_Exception_Id,
Table_Low_Bound => 1,
Table_Initial => 20,
Table_Increment => 100,
Table_Name => "Prj.Nmsc.Ada_Naming_Exception_Table");
package Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Unit_Info,
No_Element => No_Unit,
Element => Ada_Naming_Exception_Id,
No_Element => No_Ada_Naming_Exception,
Key => Name_Id,
Hash => Hash,
Equal => "=");
-- A hash table to store naming exceptions for Ada
-- A hash table to store naming exceptions for Ada. For each file name
-- there is one or several unit in table Ada_Naming_Exception_Table.
function Hash (Unit : Unit_Info) return Header_Num;
type Name_And_Index is record
Name : Name_Id := No_Name;
Index : Int := 0;
end record;
No_Name_And_Index : constant Name_And_Index :=
(Name => No_Name, Index => 0);
package Reverse_Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Name_Id,
No_Element => No_Name,
Element => Name_And_Index,
No_Element => No_Name_And_Index,
Key => Unit_Info,
Hash => Hash,
Equal => "=");
@ -198,12 +220,15 @@ package body Prj.Nmsc is
procedure Get_Unit
(Canonical_File_Name : Name_Id;
Naming : Naming_Data;
Exception_Id : out Ada_Naming_Exception_Id;
Unit_Name : out Name_Id;
Unit_Kind : out Spec_Or_Body;
Needs_Pragma : out Boolean);
-- Find out, from a file name, the unit name, the unit kind and if a
-- specific SFN pragma is needed. If the file name corresponds to no
-- unit, then Unit_Name will be No_Name.
-- unit, then Unit_Name will be No_Name. If the file is a multi-unit source
-- or an exception to the naming scheme, then Exception_Id is set to
-- the unit or units that the source contains.
function Is_Illegal_Suffix
(Suffix : String;
@ -362,7 +387,7 @@ package body Prj.Nmsc is
Write_Line (Get_Name_String (Name));
end if;
-- Register the source if it is an Ada compilation unit..
-- Register the source if it is an Ada compilation unit.
Record_Ada_Source
(File_Name => Name,
@ -574,7 +599,6 @@ package body Prj.Nmsc is
(Name_Locally_Removed_Files,
Data.Decl.Attributes);
begin
pragma Assert
(Sources.Kind = List,
@ -896,6 +920,7 @@ package body Prj.Nmsc is
String_Elements.Increment_Last;
String_Elements.Table (String_Elements.Last) :=
(Value => ALI_Name_Id,
Index => 0,
Display_Value => ALI_Name_Id,
Location => String_Elements.Table
(Interfaces).Location,
@ -2099,8 +2124,9 @@ package body Prj.Nmsc is
declare
Ada_Spec_Suffix : constant Variable_Value :=
Prj.Util.Value_Of
(Index => Name_Ada,
In_Array => Data.Naming.Spec_Suffix);
(Index => Name_Ada,
Src_Index => 0,
In_Array => Data.Naming.Spec_Suffix);
begin
if Ada_Spec_Suffix.Kind = Single
@ -2128,8 +2154,9 @@ package body Prj.Nmsc is
declare
Ada_Body_Suffix : constant Variable_Value :=
Prj.Util.Value_Of
(Index => Name_Ada,
In_Array => Data.Naming.Body_Suffix);
(Index => Name_Ada,
Src_Index => 0,
In_Array => Data.Naming.Body_Suffix);
begin
if Ada_Body_Suffix.Kind = Single
@ -2491,6 +2518,7 @@ package body Prj.Nmsc is
procedure Free_Ada_Naming_Exceptions is
begin
Ada_Naming_Exception_Table.Set_Last (0);
Ada_Naming_Exceptions.Reset;
Reverse_Ada_Naming_Exceptions.Reset;
end Free_Ada_Naming_Exceptions;
@ -2591,57 +2619,42 @@ package body Prj.Nmsc is
procedure Get_Unit
(Canonical_File_Name : Name_Id;
Naming : Naming_Data;
Exception_Id : out Ada_Naming_Exception_Id;
Unit_Name : out Name_Id;
Unit_Kind : out Spec_Or_Body;
Needs_Pragma : out Boolean)
is
function Check_Exception (Canonical : Name_Id) return Boolean;
pragma Inline (Check_Exception);
-- Check if Canonical is one of the exceptions in List.
-- Returns True if Get_Unit should exit
---------------------
-- Check_Exception --
---------------------
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);
end if;
if Info = No_Unit then
return False;
end if;
end if;
Unit_Kind := Info.Kind;
Unit_Name := Info.Unit;
Needs_Pragma := True;
return True;
end Check_Exception;
-- Start of processing for Get_Unit
Info_Id : Ada_Naming_Exception_Id
:= Ada_Naming_Exceptions.Get (Canonical_File_Name);
VMS_Name : Name_Id;
begin
Needs_Pragma := False;
if Info_Id = No_Ada_Naming_Exception then
if Hostparm.OpenVMS then
VMS_Name := Canonical_File_Name;
Get_Name_String (VMS_Name);
if Check_Exception (Canonical_File_Name) then
if Name_Buffer (Name_Len) = '.' then
Name_Len := Name_Len - 1;
VMS_Name := Name_Find;
end if;
Info_Id := Ada_Naming_Exceptions.Get (VMS_Name);
end if;
end if;
if Info_Id /= No_Ada_Naming_Exception then
Exception_Id := Info_Id;
Unit_Name := No_Name;
Unit_Kind := Specification;
Needs_Pragma := True;
return;
end if;
Needs_Pragma := False;
Exception_Id := No_Ada_Naming_Exception;
Get_Name_String (Canonical_File_Name);
declare
@ -3004,7 +3017,8 @@ package body Prj.Nmsc is
Display_Value => Non_Canonical_Path,
Location => No_Location,
Flag => False,
Next => Nil_String);
Next => Nil_String,
Index => 0);
-- Case of first source directory
@ -3380,7 +3394,8 @@ package body Prj.Nmsc is
Display_Value => Data.Display_Directory,
Location => No_Location,
Flag => False,
Next => Nil_String);
Next => Nil_String,
Index => 0);
if Current_Verbosity = High then
Write_Line ("Single source directory:");
@ -3747,10 +3762,11 @@ package body Prj.Nmsc is
if Suffix2 = No_Array_Element then
Array_Elements.Increment_Last;
Array_Elements.Table (Array_Elements.Last) :=
(Index => Element.Index,
(Index => Element.Index,
Src_Index => Element.Src_Index,
Index_Case_Sensitive => False,
Value => Element.Value,
Next => Spec_Suffixs);
Value => Element.Value,
Next => Spec_Suffixs);
Spec_Suffixs := Array_Elements.Last;
end if;
@ -3823,6 +3839,7 @@ package body Prj.Nmsc is
Array_Elements.Increment_Last;
Array_Elements.Table (Array_Elements.Last) :=
(Index => Element.Index,
Src_Index => Element.Src_Index,
Index_Case_Sensitive => False,
Value => Element.Value,
Next => Impl_Suffixs);
@ -4091,8 +4108,9 @@ package body Prj.Nmsc is
declare
Naming_Exceptions : constant Variable_Value :=
Value_Of
(Index => Lang_Name_Ids (Lang),
In_Array => Data.Naming.Implementation_Exceptions);
(Index => Lang_Name_Ids (Lang),
Src_Index => 0,
In_Array => Data.Naming.Implementation_Exceptions);
Element_Id : String_List_Id;
Element : String_Element;
File_Id : Name_Id;
@ -4325,6 +4343,8 @@ package body Prj.Nmsc is
Current : Array_Element_Id := List;
Element : Array_Element;
Unit : Unit_Info;
begin
-- Traverse the list
@ -4332,12 +4352,18 @@ package body Prj.Nmsc is
Element := Array_Elements.Table (Current);
if Element.Index /= No_Name then
Ada_Naming_Exceptions.Set
(Element.Value.Value,
(Kind => Kind, Unit => Element.Index));
Unit :=
(Kind => Kind,
Unit => Element.Index,
Next => No_Ada_Naming_Exception);
Reverse_Ada_Naming_Exceptions.Set
((Kind => Kind, Unit => Element.Index),
Element.Value.Value);
(Unit, (Element.Value.Value, Element.Value.Index));
Unit.Next := Ada_Naming_Exceptions.Get (Element.Value.Value);
Ada_Naming_Exception_Table.Increment_Last;
Ada_Naming_Exception_Table.Table
(Ada_Naming_Exception_Table.Last) := Unit;
Ada_Naming_Exceptions.Set
(Element.Value.Value, Ada_Naming_Exception_Table.Last);
end if;
Current := Element.Next;
@ -4382,16 +4408,22 @@ package body Prj.Nmsc is
is
Canonical_File_Name : Name_Id;
Canonical_Path_Name : Name_Id;
Exception_Id : Ada_Naming_Exception_Id;
Unit_Name : Name_Id;
Unit_Kind : Spec_Or_Body;
Unit_Index : Int := 0;
Info : Unit_Info;
Name_Index : Name_And_Index;
Needs_Pragma : Boolean;
The_Location : Source_Ptr := Location;
Previous_Source : constant String_List_Id := Current_Source;
Except_Name : Name_Id := No_Name;
Except_Name : Name_And_Index := No_Name_And_Index;
Unit_Prj : Unit_Project;
File_Name_Recorded : Boolean := False;
begin
Get_Name_String (File_Name);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
@ -4415,11 +4447,14 @@ package body Prj.Nmsc is
Get_Unit
(Canonical_File_Name => Canonical_File_Name,
Naming => Data.Naming,
Exception_Id => Exception_Id,
Unit_Name => Unit_Name,
Unit_Kind => Unit_Kind,
Needs_Pragma => Needs_Pragma);
if Unit_Name = No_Name then
if Exception_Id = No_Ada_Naming_Exception and then
Unit_Name = No_Name
then
if Current_Verbosity = High then
Write_Str (" """);
Write_Str (Get_Name_String (Canonical_File_Name));
@ -4427,19 +4462,21 @@ package body Prj.Nmsc is
end if;
else
-- Check to see if the source has been hidden by an exception,
-- but only if it is not an exception.
if not Needs_Pragma then
Except_Name :=
Reverse_Ada_Naming_Exceptions.Get ((Unit_Kind, Unit_Name));
Reverse_Ada_Naming_Exceptions.Get
((Unit_Kind, Unit_Name, No_Ada_Naming_Exception));
if Except_Name /= No_Name then
if Except_Name /= No_Name_And_Index then
if Current_Verbosity = High then
Write_Str (" """);
Write_Str (Get_Name_String (Canonical_File_Name));
Write_Str (""" contains a unit that is found in """);
Write_Str (Get_Name_String (Except_Name));
Write_Str (Get_Name_String (Except_Name.Name));
Write_Line (""" (ignored).");
end if;
@ -4451,145 +4488,173 @@ package body Prj.Nmsc is
end if;
end if;
-- Put the file name in the list of sources of the project
loop
if Exception_Id /= No_Ada_Naming_Exception then
Info := Ada_Naming_Exception_Table.Table (Exception_Id);
Exception_Id := Info.Next;
Info.Next := No_Ada_Naming_Exception;
Name_Index := Reverse_Ada_Naming_Exceptions.Get (Info);
String_Elements.Increment_Last;
String_Elements.Table (String_Elements.Last) :=
(Value => Canonical_File_Name,
Display_Value => File_Name,
Location => No_Location,
Flag => False,
Next => Nil_String);
Unit_Name := Info.Unit;
Unit_Index := Name_Index.Index;
Unit_Kind := Info.Kind;
end if;
-- Put the file name in the list of sources of the project
if Current_Source = Nil_String then
Data.Sources := String_Elements.Last;
else
String_Elements.Table (Current_Source).Next :=
String_Elements.Last;
end if;
Current_Source := String_Elements.Last;
-- Put the unit in unit list
declare
The_Unit : Unit_Id := Units_Htable.Get (Unit_Name);
The_Unit_Data : Unit_Data;
begin
if Current_Verbosity = High then
Write_Str ("Putting ");
Write_Str (Get_Name_String (Unit_Name));
Write_Line (" in the unit list.");
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;
-- 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 /= Prj.Com.No_Unit then
The_Unit_Data := Units.Table (The_Unit);
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;
-- 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;
Current_Source := Previous_Source;
else
-- It is an error to have two units with the same name
-- and the same kind (spec or body).
if The_Location = No_Location then
The_Location := Projects.Table (Project).Location;
end if;
Err_Vars.Error_Msg_Name_1 := Unit_Name;
Error_Msg (Project, "duplicate source {", 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);
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);
end if;
-- It is a new unit, create a new record
if Current_Source = Nil_String then
Data.Sources := String_Elements.Last;
else
-- First, check if there is no other unit with this file name
-- in another project. If it is, report an error.
String_Elements.Table (Current_Source).Next :=
String_Elements.Last;
end if;
Unit_Prj := Files_Htable.Get (Canonical_File_Name);
Current_Source := String_Elements.Last;
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);
-- Put the unit in unit list
declare
The_Unit : Unit_Id := Units_Htable.Get (Unit_Name);
The_Unit_Data : Unit_Data;
begin
if Current_Verbosity = High then
Write_Str ("Putting ");
Write_Str (Get_Name_String (Unit_Name));
Write_Line (" in the unit list.");
end if;
-- 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 /= Prj.Com.No_Unit then
The_Unit_Data := Units.Table (The_Unit);
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;
-- 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;
Current_Source := Previous_Source;
else
-- It is an error to have two units with the same name
-- and the same kind (spec or body).
if The_Location = No_Location then
The_Location := Projects.Table (Project).Location;
end if;
Err_Vars.Error_Msg_Name_1 := Unit_Name;
Error_Msg (Project, "duplicate source {", 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);
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);
end if;
-- It is a new unit, create a new record
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;
-- 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.
Unit_Prj := Files_Htable.Get (Canonical_File_Name);
if not File_Name_Recorded and then
Unit_Prj /= No_Unit_Project
then
Error_Msg_Name_1 := File_Name;
Error_Msg_Name_2 :=
Projects.Table (Unit_Prj.Project).Name;
Error_Msg
(Project,
"{ is already a source of project {",
Location);
else
Units.Increment_Last;
The_Unit := Units.Last;
Units_Htable.Set (Unit_Name, The_Unit);
Unit_Prj := (Unit => The_Unit, Project => Project);
Files_Htable.Set (Canonical_File_Name, Unit_Prj);
The_Unit_Data.Name := Unit_Name;
The_Unit_Data.File_Names (Unit_Kind) :=
(Name => Canonical_File_Name,
Index => Unit_Index,
Display_Name => File_Name,
Path => Canonical_Path_Name,
Display_Path => Path_Name,
Project => Project,
Needs_Pragma => Needs_Pragma);
Units.Table (The_Unit) := The_Unit_Data;
Source_Recorded := True;
end if;
end if;
end if;
end;
end;
exit when Exception_Id = No_Ada_Naming_Exception;
File_Name_Recorded := True;
end loop;
end if;
end Record_Ada_Source;
@ -4797,8 +4862,9 @@ package body Prj.Nmsc is
is
Suffix : constant Variable_Value :=
Value_Of
(Index => Lang_Name_Ids (Language),
In_Array => Naming.Body_Suffix);
(Index => Lang_Name_Ids (Language),
Src_Index => 0,
In_Array => Naming.Body_Suffix);
begin
-- If no suffix for this language is found in package Naming, use the
-- default.

13
gcc/ada/prj-pp.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -454,6 +454,11 @@ package body Prj.PP is
pragma Debug (Indicate_Tested (N_Literal_String));
Output_String (String_Value_Of (Node));
if Source_Index_Of (Node) /= 0 then
Write_String (" at ");
Write_String (Source_Index_Of (Node)'Img);
end if;
when N_Attribute_Declaration =>
pragma Debug (Indicate_Tested (N_Attribute_Declaration));
Print (First_Comment_Before (Node), Indent);
@ -464,6 +469,12 @@ package body Prj.PP is
if Associative_Array_Index_Of (Node) /= No_Name then
Write_String (" (");
Output_String (Associative_Array_Index_Of (Node));
if Source_Index_Of (Node) /= 0 then
Write_String (" at ");
Write_String (Source_Index_Of (Node)'Img);
end if;
Write_String (")");
end if;

24
gcc/ada/prj-proc.adb
View File

@ -182,7 +182,8 @@ package body Prj.Proc is
Kind => Single,
Location => No_Location,
Default => True,
Value => Empty_String);
Value => Empty_String,
Index => 0);
-- List attributes have a default value of nil list
@ -275,6 +276,7 @@ package body Prj.Proc is
when Single =>
Add (Result.Value, String_Value_Of (The_Current_Term));
Result.Index := Source_Index_Of (The_Current_Term);
when List =>
@ -295,6 +297,7 @@ package body Prj.Proc is
Last := String_Elements.Last;
String_Elements.Table (Last) :=
(Value => String_Value_Of (The_Current_Term),
Index => Source_Index_Of (The_Current_Term),
Display_Value => No_Name,
Location => Location_Of (The_Current_Term),
Flag => False,
@ -342,7 +345,8 @@ package body Prj.Proc is
Display_Value => No_Name,
Location => Value.Location,
Flag => False,
Next => Nil_String);
Next => Nil_String,
Index => Value.Index);
loop
-- Add the other element of the literal string list
@ -370,7 +374,8 @@ package body Prj.Proc is
Display_Value => No_Name,
Location => Value.Location,
Flag => False,
Next => Nil_String);
Next => Nil_String,
Index => Value.Index);
end loop;
end if;
@ -560,7 +565,8 @@ package body Prj.Proc is
Kind => Single,
Location => No_Location,
Default => True,
Value => Empty_String);
Value => Empty_String,
Index => 0);
end if;
end if;
end;
@ -623,7 +629,8 @@ package body Prj.Proc is
Display_Value => No_Name,
Location => Location_Of (The_Current_Term),
Flag => False,
Next => Nil_String);
Next => Nil_String,
Index => 0);
when List =>
@ -653,7 +660,8 @@ package body Prj.Proc is
Location => Location_Of
(The_Current_Term),
Flag => False,
Next => Nil_String);
Next => Nil_String,
Index => 0);
The_List :=
String_Elements.Table (The_List).Next;
end loop;
@ -725,7 +733,8 @@ package body Prj.Proc is
Display_Value => No_Name,
Location => Location_Of (The_Current_Term),
Flag => False,
Next => Nil_String);
Next => Nil_String,
Index => 0);
end case;
end;
@ -1582,6 +1591,7 @@ package body Prj.Proc is
Array_Elements.Table (The_Array_Element) :=
(Index => Index_Name,
Src_Index => Source_Index_Of (Current_Item),
Index_Case_Sensitive =>
not Case_Insensitive (Current_Item),
Value => New_Value,

52
gcc/ada/prj-strt.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -33,6 +33,7 @@ with Scans; use Scans;
with Snames;
with Table;
with Types; use Types;
with Uintp; use Uintp;
package body Prj.Strt is
@ -115,7 +116,8 @@ package body Prj.Strt is
(Term : out Project_Node_Id;
Expr_Kind : in out Variable_Kind;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id);
Current_Package : Project_Node_Id;
Optional_Index : Boolean);
-- Recursive procedure to parse one term or several terms concatenated
-- using "&".
@ -454,7 +456,8 @@ package body Prj.Strt is
procedure Parse_Expression
(Expression : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
Current_Package : Project_Node_Id;
Optional_Index : Boolean)
is
First_Term : Project_Node_Id := Empty_Node;
Expression_Kind : Variable_Kind := Undefined;
@ -470,7 +473,8 @@ package body Prj.Strt is
Terms (Term => First_Term,
Expr_Kind => Expression_Kind,
Current_Project => Current_Project,
Current_Package => Current_Package);
Current_Package => Current_Package,
Optional_Index => Optional_Index);
-- Set the first term and the expression kind
@ -1077,7 +1081,8 @@ package body Prj.Strt is
(Term : out Project_Node_Id;
Expr_Kind : in out Variable_Kind;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
Current_Package : Project_Node_Id;
Optional_Index : Boolean)
is
Next_Term : Project_Node_Id := Empty_Node;
Term_Id : Project_Node_Id := Empty_Node;
@ -1143,7 +1148,8 @@ package body Prj.Strt is
Current_Location := Token_Ptr;
Parse_Expression (Expression => Next_Expression,
Current_Project => Current_Project,
Current_Package => Current_Package);
Current_Package => Current_Package,
Optional_Index => Optional_Index);
-- The expression kind is String list, report an error
@ -1199,6 +1205,37 @@ package body Prj.Strt is
Scan;
if Token = Tok_At then
if not Optional_Index then
Error_Msg ("index not allowed here", Token_Ptr);
Scan;
if Token = Tok_Integer_Literal then
Scan;
end if;
else
Scan;
Expect (Tok_Integer_Literal, "integer literal");
if Token = Tok_Integer_Literal then
declare
Index : constant Int := UI_To_Int (Int_Literal_Value);
begin
if Index = 0 then
Error_Msg ("index cannot be zero", Token_Ptr);
else
-- Set the index
Set_Source_Index_Of (Term_Id, To => Index);
end if;
end;
Scan;
end if;
end if;
end if;
when Tok_Identifier =>
Current_Location := Token_Ptr;
@ -1292,7 +1329,8 @@ package body Prj.Strt is
Terms (Term => Next_Term,
Expr_Kind => Expr_Kind,
Current_Project => Current_Project,
Current_Package => Current_Package);
Current_Package => Current_Package,
Optional_Index => Optional_Index);
-- And link the next term to this term

5
gcc/ada/prj-strt.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -70,7 +70,8 @@ private package Prj.Strt is
procedure Parse_Expression
(Expression : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id);
Current_Package : Project_Node_Id;
Optional_Index : Boolean);
-- Parse a simple string expression or a string list expression.
-- Current_Project is the node of the project file being parsed.
-- Current_Package is the node of the package being parsed,

41
gcc/ada/prj-tree.adb
View File

@ -111,6 +111,7 @@ package body Prj.Tree is
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Name,
Value => No_Name,
Field1 => Empty_Node,
@ -157,6 +158,7 @@ package body Prj.Tree is
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Name,
Value => Comments.Table (J).Value,
Field1 => Empty_Node,
@ -204,7 +206,6 @@ package body Prj.Tree is
Comments.Set_Last (0);
end Add_Comments;
--------------------------------
-- Associative_Array_Index_Of --
--------------------------------
@ -310,6 +311,7 @@ package body Prj.Tree is
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Name,
Value => No_Name,
Field1 => Empty_Node,
@ -379,6 +381,7 @@ package body Prj.Tree is
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Name,
Value => No_Name,
Field1 => Empty_Node,
@ -411,6 +414,7 @@ package body Prj.Tree is
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Name,
Value => No_Name,
Field1 => Empty_Node,
@ -441,6 +445,7 @@ package body Prj.Tree is
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
Path_Name => No_Name,
Value => Comments.Table (J).Value,
Field1 => Empty_Node,
@ -2323,6 +2328,24 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Field1 := To;
end Set_Project_Of_Renamed_Package_Of;
-------------------------
-- Set_Source_Index_Of --
-------------------------
procedure Set_Source_Index_Of
(Node : Project_Node_Id;
To : Int)
is
begin
pragma Assert
(Node /= Empty_Node
and then
(Project_Nodes.Table (Node).Kind = N_Literal_String
or else
Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
Project_Nodes.Table (Node).Src_Index := To;
end Set_Source_Index_Of;
------------------------
-- Set_String_Type_Of --
------------------------
@ -2368,6 +2391,21 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Value := To;
end Set_String_Value_Of;
---------------------
-- Source_Index_Of --
---------------------
function Source_Index_Of (Node : Project_Node_Id) return Int is
begin
pragma Assert
(Node /= Empty_Node
and then
(Project_Nodes.Table (Node).Kind = N_Literal_String
or else
Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
return Project_Nodes.Table (Node).Src_Index;
end Source_Index_Of;
--------------------
-- String_Type_Of --
--------------------
@ -2450,5 +2488,4 @@ package body Prj.Tree is
return Unkept_Comments;
end There_Are_Unkept_Comments;
end Prj.Tree;

13
gcc/ada/prj-tree.ads
View File

@ -269,6 +269,10 @@ package Prj.Tree is
pragma Inline (String_Value_Of);
-- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment
function Source_Index_Of (Node : Project_Node_Id) return Int;
pragma Inline (Source_Index_Of);
-- Only valid for N_Literal_String and N_Attribute_Declaration nodes
function First_With_Clause_Of
(Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_With_Clause_Of);
@ -694,6 +698,11 @@ package Prj.Tree is
To : Project_Node_Id);
pragma Inline (Set_Package_Node_Of);
procedure Set_Source_Index_Of
(Node : Project_Node_Id;
To : Int);
pragma Inline (Set_Source_Index_Of);
procedure Set_String_Type_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
@ -773,6 +782,10 @@ package Prj.Tree is
Name : Name_Id := No_Name;
-- See below for what Project_Node_Kind it is used
Src_Index : Int := 0;
-- Index of a unit in a multi-unit source.
-- Onli for some N_Attribute_Declaration and N_Literal_String.
Path_Name : Name_Id := No_Name;
-- See below for what Project_Node_Kind it is used

23
gcc/ada/prj-util.adb
View File

@ -76,6 +76,7 @@ package body Prj.Util is
function Executable_Of
(Project : Project_Id;
Main : Name_Id;
Index : Int;
Ada_Main : Boolean := True) return Name_Id
is
pragma Assert (Project /= No_Project);
@ -91,12 +92,14 @@ package body Prj.Util is
Executable : Variable_Value :=
Prj.Util.Value_Of
(Name => Main,
Index => Index,
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package);
Executable_Suffix : constant Variable_Value :=
Prj.Util.Value_Of
(Name => Main,
Index => 0,
Attribute_Or_Array_Name =>
Name_Executable_Suffix,
In_Package => Builder_Package);
@ -158,6 +161,7 @@ package body Prj.Util is
Executable :=
Prj.Util.Value_Of
(Name => Name_Find,
Index => 0,
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package);
end if;
@ -395,8 +399,8 @@ package body Prj.Util is
end Value_Of;
function Value_Of
(Index : Name_Id;
In_Array : Array_Element_Id) return Name_Id
(Index : Name_Id;
In_Array : Array_Element_Id) return Name_Id
is
Current : Array_Element_Id := In_Array;
Element : Array_Element;
@ -431,8 +435,9 @@ package body Prj.Util is
end Value_Of;
function Value_Of
(Index : Name_Id;
In_Array : Array_Element_Id) return Variable_Value
(Index : Name_Id;
Src_Index : Int := 0;
In_Array : Array_Element_Id) return Variable_Value
is
Current : Array_Element_Id := In_Array;
Element : Array_Element;
@ -454,7 +459,9 @@ package body Prj.Util is
while Current /= No_Array_Element loop
Element := Array_Elements.Table (Current);
if Real_Index = Element.Index then
if Real_Index = Element.Index and then
Src_Index = Element.Src_Index
then
return Element.Value;
else
Current := Element.Next;
@ -466,6 +473,7 @@ package body Prj.Util is
function Value_Of
(Name : Name_Id;
Index : Int := 0;
Attribute_Or_Array_Name : Name_Id;
In_Package : Package_Id) return Variable_Value
is
@ -483,8 +491,9 @@ package body Prj.Util is
In_Arrays => Packages.Table (In_Package).Decl.Arrays);
The_Attribute :=
Value_Of
(Index => Name,
In_Array => The_Array);
(Index => Name,
Src_Index => Index,
In_Array => The_Array);
-- If there is no array element, look for a variable

7
gcc/ada/prj-util.ads
View File

@ -35,6 +35,7 @@ package Prj.Util is
function Executable_Of
(Project : Project_Id;
Main : Name_Id;
Index : Int;
Ada_Main : Boolean := True) return Name_Id;
-- Return the value of the attribute Builder'Executable for file Main in
-- the project Project, if it exists. If there is no attribute Executable
@ -59,8 +60,9 @@ package Prj.Util is
-- associative array.
function Value_Of
(Index : Name_Id;
In_Array : Array_Element_Id) return Variable_Value;
(Index : Name_Id;
Src_Index : Int := 0;
In_Array : Array_Element_Id) return Variable_Value;
-- Get a string array component (single String or String list).
-- Returns Nil_Variable_Value if there is no component Index
-- or if In_Array is null.
@ -72,6 +74,7 @@ package Prj.Util is
function Value_Of
(Name : Name_Id;
Index : Int := 0;
Attribute_Or_Array_Name : Name_Id;
In_Package : Package_Id) return Variable_Value;
-- In a specific package,

14
gcc/ada/prj.adb
View File

@ -34,6 +34,7 @@ with Prj.Env;
with Prj.Err; use Prj.Err;
with Scans; use Scans;
with Snames; use Snames;
with Uintp; use Uintp;
with GNAT.OS_Lib; use GNAT.OS_Lib;
@ -240,6 +241,7 @@ package body Prj is
begin
if not Initialized then
Initialized := True;
Uintp.Initialize;
Name_Len := 0;
The_Empty_String := Name_Find;
Empty_Name := The_Empty_String;
@ -321,13 +323,15 @@ package body Prj is
if not Found then
Element :=
(Index => Lang,
(Index => Lang,
Src_Index => 0,
Index_Case_Sensitive => False,
Value => (Project => No_Project,
Kind => Single,
Location => No_Location,
Default => False,
Value => Default_Spec_Suffix),
Value => Default_Spec_Suffix,
Index => 0),
Next => Std_Naming_Data.Spec_Suffix);
Array_Elements.Increment_Last;
Array_Elements.Table (Array_Elements.Last) := Element;
@ -357,13 +361,15 @@ package body Prj is
if not Found then
Element :=
(Index => Lang,
(Index => Lang,
Src_Index => 0,
Index_Case_Sensitive => False,
Value => (Project => No_Project,
Kind => Single,
Location => No_Location,
Default => False,
Value => Default_Body_Suffix),
Value => Default_Body_Suffix,
Index => 0),
Next => Std_Naming_Data.Body_Suffix);
Array_Elements.Increment_Last;
Array_Elements.Table (Array_Elements.Last) := Element;

3
gcc/ada/prj.ads
View File

@ -197,6 +197,7 @@ package Prj is
Nil_String : constant String_List_Id := 0;
type String_Element is record
Value : Name_Id := No_Name;
Index : Int := 0;
Display_Value : Name_Id := No_Name;
Location : Source_Ptr := No_Location;
Flag : Boolean := False;
@ -233,6 +234,7 @@ package Prj is
Values : String_List_Id := Nil_String;
when Single =>
Value : Name_Id := No_Name;
Index : Int := 0;
end case;
end record;
-- Values for variables and array elements.
@ -267,6 +269,7 @@ package Prj is
No_Array_Element : constant Array_Element_Id := 0;
type Array_Element is record
Index : Name_Id;
Src_Index : Int := 0;
Index_Case_Sensitive : Boolean := True;
Value : Variable_Value;
Next : Array_Element_Id := No_Array_Element;

2
gcc/ada/raise.c
View File

@ -152,7 +152,7 @@ db_accepted_codes (void)
if (accepted_codes == -1)
{
char * db_env = getenv ("EH_DEBUG");
char * db_env = (char *) getenv ("EH_DEBUG");
accepted_codes = db_env ? (atoi (db_env) | DB_ERR) : 0;
/* Arranged for ERR stuff to always be visible when the variable

43
gcc/ada/sem_attr.adb
View File

@ -4820,19 +4820,9 @@ package body Sem_Attr is
--------------
when Attribute_Definite =>
declare
Result : Node_Id;
begin
if Is_Indefinite_Subtype (P_Entity) then
Result := New_Occurrence_Of (Standard_False, Loc);
else
Result := New_Occurrence_Of (Standard_True, Loc);
end if;
Rewrite (N, Result);
Analyze_And_Resolve (N, Standard_Boolean);
end;
Rewrite (N, New_Occurrence_Of (
Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
Analyze_And_Resolve (N, Standard_Boolean);
------------
-- Denorm --
@ -4961,19 +4951,9 @@ package body Sem_Attr is
-----------------------
when Attribute_Has_Discriminants =>
declare
Result : Node_Id;
begin
if Has_Discriminants (P_Entity) then
Result := New_Occurrence_Of (Standard_True, Loc);
else
Result := New_Occurrence_Of (Standard_False, Loc);
end if;
Rewrite (N, Result);
Analyze_And_Resolve (N, Standard_Boolean);
end;
Rewrite (N, New_Occurrence_Of (
Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
Analyze_And_Resolve (N, Standard_Boolean);
--------------
-- Identity --
@ -5962,13 +5942,10 @@ package body Sem_Attr is
Typ : constant Entity_Id := Underlying_Type (P_Type);
begin
if Is_Array_Type (P_Type)
and then not Is_Constrained (Typ)
then
Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
else
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
end if;
Rewrite (N, New_Occurrence_Of (
Boolean_Literals (
Is_Array_Type (P_Type)
and then not Is_Constrained (Typ)), Loc));
-- Analyze and resolve as boolean, note that this attribute is
-- a static attribute in GNAT.

4
gcc/ada/sem_ch13.adb
View File

@ -1399,6 +1399,10 @@ package body Sem_Ch13 is
-- Return true if the entity is a procedure with an
-- appropriate profile for the write attribute.
----------------------
-- Has_Good_Profile --
----------------------
function Has_Good_Profile (Subp : Entity_Id) return Boolean is
F : Entity_Id;
Ok : Boolean := False;

9
gcc/ada/sem_ch3.adb
View File

@ -734,9 +734,12 @@ package body Sem_Ch3 is
-- discriminant, in a private or a full type declaration. In
-- the case of a subprogram, If the designated type is incomplete,
-- the operation will be a primitive operation of the full type, to
-- be updated subsequently.
-- be updated subsequently. If the type is imported through a limited
-- with clause, it is not a primitive operation of the type (which
-- is declared elsewhere in some other scope).
if Ekind (Desig_Type) = E_Incomplete_Type
and then not From_With_Type (Desig_Type)
and then Is_Overloadable (Current_Scope)
then
Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
@ -9988,7 +9991,7 @@ package body Sem_Ch3 is
Defining_Identifier => T,
Subtype_Indication => Relocate_Node (Obj_Def)));
-- This subtype may need freezing and it will not be done
-- This subtype may need freezing, and this will not be done
-- automatically if the object declaration is not in a
-- declarative part. Since this is an object declaration, the
-- type cannot always be frozen here. Deferred constants do not
@ -10125,7 +10128,7 @@ package body Sem_Ch3 is
elsif Can_Derive_From (Standard_Long_Long_Float) then
Base_Typ := Standard_Long_Long_Float;
-- If we can't derive from any existing type, use long long float
-- If we can't derive from any existing type, use long_long_float
-- and give appropriate message explaining the problem.
else

13
gcc/ada/sem_ch6.adb
View File

@ -88,6 +88,8 @@ package body Sem_Ch6 is
-- subsequenty used for inline expansions at call sites. If subprogram can
-- be inlined (depending on size and nature of local declarations) this
-- function returns true. Otherwise subprogram body is treated normally.
-- If proper warnings are enabled and the subprogram contains a construct
-- that cannot be inlined, the offending construct is flagged accordingly.
type Conformance_Type is
(Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
@ -2986,6 +2988,17 @@ package body Sem_Ch6 is
or else not Is_Generic_Actual_Type (T2)
or else Scope (T1) /= Scope (T2);
-- In some cases a type imported through a limited_with clause,
-- and its non-limited view are both visible, for example in an
-- anonymous access_to_classwide type in a formal. Both entities
-- designate the same type.
elsif From_With_Type (T1)
and then Ekind (T1) = E_Incomplete_Type
and then T2 = Non_Limited_View (T1)
then
return True;
else
return False;
end if;

17
gcc/ada/sem_dist.adb
View File

@ -332,19 +332,12 @@ package body Sem_Dist is
RS_Pkg_Specif := Parent (Remote_Subp_Decl);
RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
if Ekind (Remote_Subp) = E_Procedure
and then Is_Asynchronous (Remote_Subp)
then
Async_E := Standard_True;
else
Async_E := Standard_False;
end if;
Async_E :=
Boolean_Literals (Ekind (Remote_Subp) = E_Procedure
and then Is_Asynchronous (Remote_Subp));
if Has_All_Calls_Remote (RS_Pkg_E) then
All_Calls_Remote_E := Standard_True;
else
All_Calls_Remote_E := Standard_False;
end if;
All_Calls_Remote_E :=
Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
Local_Addr :=
Make_Attribute_Reference (Loc,

7
gcc/ada/sem_util.adb
View File

@ -5588,11 +5588,8 @@ package body Sem_Util is
function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
begin
if Range_Checks_Suppressed (E) then
return New_Occurrence_Of (Standard_False, Loc);
else
return New_Occurrence_Of (Standard_True, Loc);
end if;
return New_Occurrence_Of
(Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
end Rep_To_Pos_Flag;
--------------------

5
gcc/ada/stand.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -310,6 +310,9 @@ package Stand is
-- Highest List_Id value used by Standard (including those used by
-- normal list headers, element list headers, and list elements)
Boolean_Literals : array (Boolean) of Entity_Id;
-- Entities for the two boolean literals, used by the expander
-------------------------------------
-- Semantic Phase Special Entities --
-------------------------------------

6
gcc/ada/switch-m.adb
View File

@ -562,6 +562,12 @@ package body Switch.M is
case Switch_Chars (Ptr) is
-- processing for eI switch
when 'I' =>
Ptr := Ptr + 1;
Scan_Pos (Switch_Chars, Max, Ptr, Main_Index);
-- processing for eL switch
when 'L' =>

6
gcc/ada/usage.adb
View File

@ -269,10 +269,12 @@ begin
Write_Switch_Char ("Q");
Write_Line ("Don't quit, write ali/tree file even if compile errors");
-- Line for -gnatR switch
-- Lines for -gnatR switch
Write_Switch_Char ("R?");
Write_Line ("List rep inf (?=0/1/2/3 for none/types/all/variable)");
Write_Line ("List rep info (?=0/1/2/3 for none/types/all/variable)");
Write_Switch_Char ("R?s");
Write_Line ("List rep info to file.rep instead of standard output");
-- Lines for -gnats switch

21
gcc/ada/vms_data.ads
View File

@ -191,7 +191,6 @@ package VMS_Data is
-- Switches for GNAT BIND --
----------------------------
S_Bind_Bind : aliased constant S := "/BIND_FILE=" &
"ADA " &
"-A " &
@ -490,7 +489,6 @@ package VMS_Data is
"!-b,!-v";
-- NODOC (see /REPORT_ERRORS)
S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " &
"-r";
-- /NORESTRICTION_LIST (D)
@ -814,6 +812,13 @@ package VMS_Data is
--
-- Output a message explaining the usage of gnatclean.
S_Clean_Index : aliased constant S := "/SOURCE_INDEX=#" &
"-i#";
-- /SOURCE_INDEX=nnn
--
-- Specifies the index of the units in the source file
-- By default, source files are mono-unit and there is no index
S_Clean_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
"DEFAULT " &
"-vP0 " &
@ -833,7 +838,6 @@ package VMS_Data is
-- HIGH A great number of messages are output, most of them not
-- being useful for the user.
S_Clean_Object : aliased constant S := "/OBJECT_SEARCH=*" &
"-aO*";
-- /OBJECT_SEARCH=(directory,...)
@ -892,6 +896,7 @@ package VMS_Data is
S_Clean_Ext 'Access,
S_Clean_Full 'Access,
S_Clean_Help 'Access,
S_Clean_Index 'Access,
S_Clean_Mess 'Access,
S_Clean_Object 'Access,
S_Clean_Project'Access,
@ -3738,6 +3743,15 @@ package VMS_Data is
-- are found on the Ada object path, the new object and ALI files are
-- created in the directory containing the source being compiled.
S_Make_Index : aliased constant S := "/SOURCE_INDEX=#" &
"-eI#";
-- /SOURCE_INDEX=nnn
--
-- Specifies the index of the units in the source file
-- By default, source files are mono-unit and there is no index
-- When /SOURCE_INDEX=nnn is specified, only one main may be specified
-- on the command line.
S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
"-L*";
-- /LIBRARY_SEARCH=(directory[,...])
@ -3965,6 +3979,7 @@ package VMS_Data is
S_Make_Force 'Access,
S_Make_Full 'Access,
S_Make_Inplace 'Access,
S_Make_Index 'Access,
S_Make_Library 'Access,
S_Make_Link 'Access,
S_Make_Make 'Access,