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

[multiple changes] 

2004-04-21  Pascal Obry  <obry@gnat.com>

	* adaint.c (__gnat_portable_spawn): Quote first argument (argv[0])
	passed to spawnvp() to properly handle program pathname with spaces on
	Win32.

2004-04-21  Emmanuel Briot  <briot@act-europe.fr>

	* g-debpoo.adb (Print_Info): Avoid extra work if Display_Slots is False.
	(Allocate, Deallocate, Free_Physically): Make sure the tasks are
	unlocked in case of exceptions.

2004-04-21  Joel Brobecker  <brobecker@gnat.com>

	* gigi.h (get_target_no_dollar_in_label): Remove extern declaration.
	This function does not exist anymore.

2004-04-21  Thomas Quinot  <quinot@act-europe.fr>

	* gnatbind.adb, gnatlink.adb: Update name of imported C symbol.

	* link.c: Move variables to the __gnat name space.

	* Makefile.in: list link.o explicitly when needed.

	* mlib.adb: Remove pragma Linker_Option for "link.o" from mlib.

2004-04-21  Javier Miranda  <miranda@gnat.com>

	* einfo.adb (Original_Access_Type): New subprogram
	(Set_Original_Access_Type): New subprogram
	(Write_Field21_Name): Write the name of the new field

	* einfo.ads (Original_Access_Type): New field present in access to
	subprogram types.
	Addition of two new entities: E_Anonymous_Access_Subprogram_Type, and
	E_Anonymous_Access_Protected_Subprogram_Type.

	* lib-xref.adb (Output_One_Ref): Give support to anonymous access to
	subprogram types.

	* lib-xref.ads (Xref_Entity_Letters): Initialize values corresponding
	to anonymous access to subprogram types.

	* sem_attr.adb (Resolve_Attribute): Give support to anonymous access
	to subprogram types.

	* sem_ch3.adb (Access_Definition): Complete decoration of entities
	corresponding to anonymous access to subprogram types.
	(Analyze_Component_Declaration): Add new actual to the call to
	subprogram replace_anonymous_access_to_protected_subprogram.
	(Array_Type_Declaration): Add new actual to the call to subprogram
	replace_anonymous_access_to_protected_subprogram.
	(Process_Discriminants): Add new actual to the call to subprogram
	replace_anonymous_access_to_protected_subprogram.
	(Replace_Anonymous_Access_To_Protected_Subprogram): New formal.

	* sem_ch3.ads (Replace_Anonymous_Access_To_Protected_Subprogram): New
	formal.

	* sem_ch6.adb, sem_type.adb, sem_res.adb: Give support to anonymous
	access to subprogram types.

	* sem_util.adb (Has_Declarations): Addition of package_specification
	nodes.

2004-04-21  Ed Schonberg  <schonberg@gnat.com>

	* sem_prag.adb (Make_Inline): If subprogram is a renaming, propagate
	inlined flags to renamed entity only if in current unit.

2004-04-21  Thomas Quinot  <quinot@act-europe.fr>

	* s-parint.ads: Add DSA implementation marker.

	* rtsfind.ads, rtsfind.adb, snames.ads, snames.adb, s-rpc.adb: Use the
	value of System.Partition_Interface.DSA_Implementation to determine
	what version of the distributed systems annex is available (no
	implementation, GLADE, or PolyORB).

2004-04-21  Joel Brobecker  <brobecker@gnat.com>

	* targtyps.c (get_target_no_dollar_in_label): Remove, no longer used.

2004-04-21  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* utils.c (convert, case CONSTRUCTOR, COMPONENT_REF): Do not make node
	with new type if alias sets differ.
	Fixes ACATS c41103b.

2004-04-21  Vincent Celier  <celier@gnat.com>

	* prj.ads: Remove FORTRAN as an accepted language: not tested yet.
	Add array Lang_Args for the language specific compiling argument
	switches.

	* gnat_ugn.texi: Explain in more details when a library is rebuilt.

2004-04-21  Sergey Rybin  <rybin@act-europe.fr>

	* gnat_rm.texi: Update the descripton of the Eliminate pragma
	according to the recent changes in the format of the parameters of the
	pragma (replacing Homonym_Number with Source_Location).

From-SVN: r80956
This commit is contained in:
Arnaud Charlet 2004-04-21 12:10:33 +02:00
parent 0a7460199f
commit af4b94345e
32 changed files with 1231 additions and 891 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
gcc/ada/ChangeLog
View File

@ -1,3 +1,107 @@
2004-04-21 Pascal Obry <obry@gnat.com>
* adaint.c (__gnat_portable_spawn): Quote first argument (argv[0])
passed to spawnvp() to properly handle program pathname with spaces on
Win32.
2004-04-21 Emmanuel Briot <briot@act-europe.fr>
* g-debpoo.adb (Print_Info): Avoid extra work if Display_Slots is False.
(Allocate, Deallocate, Free_Physically): Make sure the tasks are
unlocked in case of exceptions.
2004-04-21 Joel Brobecker <brobecker@gnat.com>
* gigi.h (get_target_no_dollar_in_label): Remove extern declaration.
This function does not exist anymore.
2004-04-21 Thomas Quinot <quinot@act-europe.fr>
* gnatbind.adb, gnatlink.adb: Update name of imported C symbol.
* link.c: Move variables to the __gnat name space.
* Makefile.in: list link.o explicitly when needed.
* mlib.adb: Remove pragma Linker_Option for "link.o" from mlib.
2004-04-21 Javier Miranda <miranda@gnat.com>
* einfo.adb (Original_Access_Type): New subprogram
(Set_Original_Access_Type): New subprogram
(Write_Field21_Name): Write the name of the new field
* einfo.ads (Original_Access_Type): New field present in access to
subprogram types.
Addition of two new entities: E_Anonymous_Access_Subprogram_Type, and
E_Anonymous_Access_Protected_Subprogram_Type.
* lib-xref.adb (Output_One_Ref): Give support to anonymous access to
subprogram types.
* lib-xref.ads (Xref_Entity_Letters): Initialize values corresponding
to anonymous access to subprogram types.
* sem_attr.adb (Resolve_Attribute): Give support to anonymous access
to subprogram types.
* sem_ch3.adb (Access_Definition): Complete decoration of entities
corresponding to anonymous access to subprogram types.
(Analyze_Component_Declaration): Add new actual to the call to
subprogram replace_anonymous_access_to_protected_subprogram.
(Array_Type_Declaration): Add new actual to the call to subprogram
replace_anonymous_access_to_protected_subprogram.
(Process_Discriminants): Add new actual to the call to subprogram
replace_anonymous_access_to_protected_subprogram.
(Replace_Anonymous_Access_To_Protected_Subprogram): New formal.
* sem_ch3.ads (Replace_Anonymous_Access_To_Protected_Subprogram): New
formal.
* sem_ch6.adb, sem_type.adb, sem_res.adb: Give support to anonymous
access to subprogram types.
* sem_util.adb (Has_Declarations): Addition of package_specification
nodes.
2004-04-21 Ed Schonberg <schonberg@gnat.com>
* sem_prag.adb (Make_Inline): If subprogram is a renaming, propagate
inlined flags to renamed entity only if in current unit.
2004-04-21 Thomas Quinot <quinot@act-europe.fr>
* s-parint.ads: Add DSA implementation marker.
* rtsfind.ads, rtsfind.adb, snames.ads, snames.adb, s-rpc.adb: Use the
value of System.Partition_Interface.DSA_Implementation to determine
what version of the distributed systems annex is available (no
implementation, GLADE, or PolyORB).
2004-04-21 Joel Brobecker <brobecker@gnat.com>
* targtyps.c (get_target_no_dollar_in_label): Remove, no longer used.
2004-04-21 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* utils.c (convert, case CONSTRUCTOR, COMPONENT_REF): Do not make node
with new type if alias sets differ.
Fixes ACATS c41103b.
2004-04-21 Vincent Celier <celier@gnat.com>
* prj.ads: Remove FORTRAN as an accepted language: not tested yet.
Add array Lang_Args for the language specific compiling argument
switches.
* gnat_ugn.texi: Explain in more details when a library is rebuilt.
2004-04-21 Sergey Rybin <rybin@act-europe.fr>
* gnat_rm.texi: Update the descripton of the Eliminate pragma
according to the recent changes in the format of the parameters of the
pragma (replacing Homonym_Number with Source_Location).
2004-04-19 Arnaud Charlet <charlet@act-europe.fr>
* 5isystem.ads: Removed, unused.

15
gcc/ada/Makefile.in
View File

@ -251,7 +251,7 @@ LIBIBERTY = ../../libiberty/libiberty.a
# and the system's installed libraries.
LIBS = $(LIBINTL) $(LIBIBERTY) $(SYSLIBS)
LIBDEPS = $(LIBINTL_DEP) $(LIBIBERTY)
TOOLS_LIBS = $(LIBGNAT) $(EXTRA_GNATTOOLS_OBJS) ../../../libiberty/libiberty.a $(SYSLIBS)
TOOLS_LIBS = $(LIBGNAT) $(EXTRA_GNATTOOLS_OBJS) link.o ../../../libiberty/libiberty.a $(SYSLIBS)
# Specify the directories to be searched for header files.
# Both . and srcdir are used, in that order,
@ -299,7 +299,7 @@ Makefile: ../config.status $(srcdir)/Makefile.in $(srcdir)/../version.c
# Lists of files for various purposes.
GNATLINK_OBJS = gnatlink.o link.o \
GNATLINK_OBJS = gnatlink.o \
a-except.o ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o gnatvsn.o \
hostparm.o interfac.o i-c.o i-cstrin.o namet.o opt.o osint.o output.o rident.o \
s-exctab.o s-secsta.o s-stalib.o s-stoele.o sdefault.o stylesw.o switch.o system.o \
@ -308,7 +308,7 @@ GNATLINK_OBJS = gnatlink.o link.o \
GNATMAKE_OBJS = a-except.o ctrl_c.o ali.o ali-util.o s-casuti.o \
alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o elists.o einfo.o\
erroutc.o errutil.o err_vars.o fmap.o fname.o fname-uf.o fname-sf.o \
gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o link.o \
gnatmake.o gnatvsn.o hostparm.o interfac.o i-c.o i-cstrin.o krunch.o lib.o \
make.o makeusg.o makeutl.o mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \
namet.o nlists.o opt.o osint.o osint-m.o output.o \
prj.o prj-attr.o prj-com.o prj-dect.o prj-env.o prj-err.o prj-ext.o prj-nmsc.o \
@ -583,7 +583,6 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
a-intnam.ads<4zintnam.ads \
s-osinte.ads<5zosinte.ads \
s-parame.ads<5zparame.ads \
s-taspri.ads<5ztaspri.ads \
s-vxwork.ads<5pvxwork.ads \
a-taside.adb<1ataside.adb \
@ -1660,7 +1659,7 @@ endif
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxaddr2line
$(GNATLINK) -v vxaddr2line -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(CLIB)
gnatmake-re: ../stamp-tools
gnatmake-re: ../stamp-tools link.o
$(GNATMAKE) $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)"
$(GNATMAKE) -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmake
@ -1673,7 +1672,7 @@ gnatlink-re: ../stamp-tools link.o
$(GNATMAKE) -c $(ADA_INCLUDES) gnatlink --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlink
$(GNATLINK) -v gnatlink -o ../../gnatlinknew$(exeext) \
--GCC="$(CC) $(ADA_INCLUDES)" link.o $(TOOLS_LIBS)
--GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
$(MV) ../../gnatlinknew$(exeext) ../../gnatlink$(exeext)
# Needs to be built with CC=gcc
@ -1681,11 +1680,11 @@ gnatlink-re: ../stamp-tools link.o
# stamp target in the parent directory whenever gnat1 is rebuilt
# Likewise for the tools
../../gnatmake$(exeext): $(P) b_gnatm.o $(GNATMAKE_OBJS)
../../gnatmake$(exeext): $(P) b_gnatm.o link.o $(GNATMAKE_OBJS)
$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatm.o $(GNATMAKE_OBJS) \
$(TOOLS_LIBS)
../../gnatlink$(exeext): $(P) b_gnatl.o $(GNATLINK_OBJS)
../../gnatlink$(exeext): $(P) b_gnatl.o link.o $(GNATLINK_OBJS)
$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatl.o $(GNATLINK_OBJS) \
$(TOOLS_LIBS)

14
gcc/ada/adaint.c
View File

@ -1543,7 +1543,19 @@ __gnat_portable_spawn (char *args[])
int pid ATTRIBUTE_UNUSED;
#if defined (MSDOS) || defined (_WIN32)
status = spawnvp (P_WAIT, args[0],(const char* const*)args);
/* args[0] must be quotes as it could contain a full pathname with spaces */
const char *args_0 = args[0];
args[0] = (char *)xmalloc (strlen (args_0) + 3);
strcpy (args[0], "\"");
strcat (args[0], args_0);
strcat (args[0], "\"");
status = spawnvp (P_WAIT, args_0, (const char* const*)args);
/* restore previous value */
free (args[0]);
args[0] = args_0;
if (status < 0)
return -1;
else

21
gcc/ada/einfo.adb
View File

@ -1845,6 +1845,14 @@ package body Einfo is
return Node17 (Id);
end Object_Ref;
function Original_Access_Type (Id : E) return E is
begin
pragma Assert
(Ekind (Id) = E_Access_Subprogram_Type
or else Ekind (Id) = E_Access_Protected_Subprogram_Type);
return Node21 (Id);
end Original_Access_Type;
function Original_Array_Type (Id : E) return E is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
@ -3747,7 +3755,6 @@ package body Einfo is
Set_Flag136 (Id, V);
end Set_No_Strict_Aliasing;
procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Modular_Integer_Type);
@ -3796,6 +3803,14 @@ package body Einfo is
Set_Node17 (Id, V);
end Set_Object_Ref;
procedure Set_Original_Access_Type (Id : E; V : E) is
begin
pragma Assert
(Ekind (Id) = E_Access_Subprogram_Type
or else Ekind (Id) = E_Access_Protected_Subprogram_Type);
Set_Node21 (Id, V);
end Set_Original_Access_Type;
procedure Set_Original_Array_Type (Id : E; V : E) is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
@ -6996,6 +7011,10 @@ package body Einfo is
Modular_Integer_Kind =>
Write_Str ("Original_Array_Type");
when E_Access_Subprogram_Type |
E_Access_Protected_Subprogram_Type =>
Write_Str ("Original_Access_Type");
when others =>
Write_Str ("Field21??");
end case;

34
gcc/ada/einfo.ads
View File

@ -2633,6 +2633,12 @@ package Einfo is
-- Applies to subprograms and subprogram types. Yields the number of
-- formals as a value of type Pos.
-- Original_Access_Type (Node21)
-- Present in access to subprogram types. Anonymous access to protected
-- subprogram types are replaced by an occurrence of an internal access
-- to subprogram type. This field links the replacement entity with the
-- original entity.
-- Original_Array_Type (Node21)
-- Present in modular types and array types and subtypes. Set only
-- if the Is_Packed_Array_Type flag is set, indicating that the type
@ -3113,7 +3119,11 @@ package Einfo is
-- The following three entity kinds are introduced by the corresponding
-- type definitions:
-- E_Access_Type, E_General_Access_Type, E_Anonymous_Access_Type.
-- E_Access_Type,
-- E_General_Access_Type,
-- E_Anonymous_Access_Subprogram_Type,
-- E_Anonymous_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Type.
-- In addition, we define the kind E_Allocator_Type to label
-- allocators. This is because special resolution rules apply to this
@ -3321,6 +3331,14 @@ package Einfo is
-- and a protected operation within, and have different compile-time
-- and run-time properties than other access to subprograms.
E_Anonymous_Access_Subprogram_Type,
-- An anonymous access to subprogram type, created by an access to
-- subprogram declaration.
E_Anonymous_Access_Protected_Subprogram_Type,
-- An anonymous access to protected subprogram type, created by an
-- access to subprogram declaration.
E_Anonymous_Access_Type,
-- An anonymous access type created by an access parameter or access
-- discriminant.
@ -3542,6 +3560,8 @@ package Einfo is
-- E_General_Access_Type
-- E_Access_Subprogram_Type
-- E_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
E_Anonymous_Access_Type;
subtype Array_Kind is Entity_Kind range
@ -3637,6 +3657,8 @@ package Einfo is
-- E_General_Access_Type
-- E_Access_Subprogram_Type
-- E_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
E_Anonymous_Access_Type;
subtype Enumeration_Kind is Entity_Kind range
@ -3809,6 +3831,8 @@ package Einfo is
-- E_General_Access_Type
-- E_Access_Subprogram_Type,
-- E_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Type
-- E_Array_Type
-- E_Array_Subtype
@ -3994,12 +4018,14 @@ package Einfo is
-- E_Access_Protected_Subprogram_Type
-- Equivalent_Type (Node18)
-- Directly_Designated_Type (Node20)
-- Original_Access_Type (Node21)
-- Needs_No_Actuals (Flag22)
-- (plus type attributes)
-- E_Access_Subprogram_Type
-- Equivalent_Type (Node18) (remote types only)
-- Directly_Designated_Type (Node20)
-- Original_Access_Type (Node21)
-- Needs_No_Actuals (Flag22)
-- (plus type attributes)
@ -4025,6 +4051,8 @@ package Einfo is
-- Directly_Designated_Type (Node20)
-- (plus type attributes)
-- E_Anonymous_Access_Subprogram_Type
-- E_Anonymous_Access_Protected_Subprogram_Type
-- E_Anonymous_Access_Type
-- Storage_Size_Variable (Node15) ??? is this needed ???
-- Directly_Designated_Type (Node20)
@ -5180,6 +5208,7 @@ package Einfo is
function Normalized_Position (Id : E) return U;
function Normalized_Position_Max (Id : E) return U;
function Object_Ref (Id : E) return E;
function Original_Access_Type (Id : E) return E;
function Original_Array_Type (Id : E) return E;
function Original_Record_Component (Id : E) return E;
function Packed_Array_Type (Id : E) return E;
@ -5653,6 +5682,7 @@ package Einfo is
procedure Set_Normalized_Position (Id : E; V : U);
procedure Set_Normalized_Position_Max (Id : E; V : U);
procedure Set_Object_Ref (Id : E; V : E);
procedure Set_Original_Access_Type (Id : E; V : E);
procedure Set_Original_Array_Type (Id : E; V : E);
procedure Set_Original_Record_Component (Id : E; V : E);
procedure Set_Packed_Array_Type (Id : E; V : E);
@ -6180,6 +6210,7 @@ package Einfo is
pragma Inline (Normalized_Position);
pragma Inline (Normalized_Position_Max);
pragma Inline (Object_Ref);
pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type);
pragma Inline (Original_Record_Component);
pragma Inline (Packed_Array_Type);
@ -6486,6 +6517,7 @@ package Einfo is
pragma Inline (Set_Normalized_Position);
pragma Inline (Set_Normalized_Position_Max);
pragma Inline (Set_Object_Ref);
pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Packed_Array_Type);

133
gcc/ada/g-debpoo.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- --
@ -769,6 +769,11 @@ package body GNAT.Debug_Pools is
end if;
Unlock_Task.all;
exception
when others =>
Unlock_Task.all;
raise;
end Allocate;
------------------
@ -1056,6 +1061,11 @@ package body GNAT.Debug_Pools is
end if;
Unlock_Task.all;
exception
when others =>
Unlock_Task.all;
raise;
end Free_Physically;
----------------
@ -1166,6 +1176,11 @@ package body GNAT.Debug_Pools is
Unlock_Task.all;
end if;
exception
when others =>
Unlock_Task.all;
raise;
end Deallocate;
--------------------
@ -1310,71 +1325,71 @@ package body GNAT.Debug_Pools is
Put_Line ("");
Data := Backtrace_Htable.Get_First;
while Data /= null loop
if Data.Kind in Alloc .. Dealloc then
Elem :=
new Traceback_Htable_Elem'
(Traceback => new Tracebacks_Array'(Data.Traceback.all),
Count => Data.Count,
Kind => Data.Kind,
Total => Data.Total,
Next => null);
Backtrace_Htable_Cumulate.Set (Elem);
if Cumulate then
if Data.Kind = Alloc then
K := Indirect_Alloc;
else
K := Indirect_Dealloc;
end if;
-- Propagate the direct call to all its parents
for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
Elem := Backtrace_Htable_Cumulate.Get
(Data.Traceback
(T .. Data.Traceback'Last)'Unrestricted_Access);
-- If not, insert it
if Elem = null then
Elem := new Traceback_Htable_Elem'
(Traceback => new Tracebacks_Array'
(Data.Traceback (T .. Data.Traceback'Last)),
Count => Data.Count,
Kind => K,
Total => Data.Total,
Next => null);
Backtrace_Htable_Cumulate.Set (Elem);
-- Properly take into account that the subprograms
-- indirectly called might be doing either allocations
-- or deallocations. This needs to be reflected in the
-- counts.
if Display_Slots then
Data := Backtrace_Htable.Get_First;
while Data /= null loop
if Data.Kind in Alloc .. Dealloc then
Elem :=
new Traceback_Htable_Elem'
(Traceback => new Tracebacks_Array'(Data.Traceback.all),
Count => Data.Count,
Kind => Data.Kind,
Total => Data.Total,
Next => null);
Backtrace_Htable_Cumulate.Set (Elem);
if Cumulate then
if Data.Kind = Alloc then
K := Indirect_Alloc;
else
Elem.Count := Elem.Count + Data.Count;
K := Indirect_Dealloc;
end if;
if K = Elem.Kind then
Elem.Total := Elem.Total + Data.Total;
-- Propagate the direct call to all its parents
elsif Elem.Total > Data.Total then
Elem.Total := Elem.Total - Data.Total;
for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
Elem := Backtrace_Htable_Cumulate.Get
(Data.Traceback
(T .. Data.Traceback'Last)'Unrestricted_Access);
-- If not, insert it
if Elem = null then
Elem := new Traceback_Htable_Elem'
(Traceback => new Tracebacks_Array'
(Data.Traceback (T .. Data.Traceback'Last)),
Count => Data.Count,
Kind => K,
Total => Data.Total,
Next => null);
Backtrace_Htable_Cumulate.Set (Elem);
-- Properly take into account that the subprograms
-- indirectly called might be doing either allocations
-- or deallocations. This needs to be reflected in the
-- counts.
else
Elem.Kind := K;
Elem.Total := Data.Total - Elem.Total;
Elem.Count := Elem.Count + Data.Count;
if K = Elem.Kind then
Elem.Total := Elem.Total + Data.Total;
elsif Elem.Total > Data.Total then
Elem.Total := Elem.Total - Data.Total;
else
Elem.Kind := K;
Elem.Total := Data.Total - Elem.Total;
end if;
end if;
end if;
end loop;
end loop;
end if;
Data := Backtrace_Htable.Get_Next;
end if;
end loop;
Data := Backtrace_Htable.Get_Next;
end if;
end loop;
if Display_Slots then
Put_Line ("List of allocations/deallocations: ");
Data := Backtrace_Htable_Cumulate.Get_First;
@ -1397,6 +1412,8 @@ package body GNAT.Debug_Pools is
Data := Backtrace_Htable_Cumulate.Get_Next;
end loop;
Backtrace_Htable_Cumulate.Reset;
end if;
if Display_Leaks then
@ -1421,8 +1438,6 @@ package body GNAT.Debug_Pools is
Current := Header.Next;
end loop;
end if;
Backtrace_Htable_Cumulate.Reset;
end Print_Info;
------------------

3
gcc/ada/gigi.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* 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- *
@ -756,7 +756,6 @@ extern Pos get_target_double_size (void);
extern Pos get_target_long_double_size (void);
extern Pos get_target_pointer_size (void);
extern Pos get_target_maximum_alignment (void);
extern Boolean get_target_no_dollar_in_label (void);
extern Nat get_float_words_be (void);
extern Nat get_words_be (void);
extern Nat get_bytes_be (void);

88
gcc/ada/gnat_rm.texi
View File

@ -1341,18 +1341,32 @@ pragma Eliminate (
[Entity =>] IDENTIFIER |
SELECTED_COMPONENT |
STRING_LITERAL
[,[Parameter_Types =>] PARAMETER_TYPES]
[,[Result_Type =>] result_SUBTYPE_NAME]
[,[Homonym_Number =>] INTEGER_LITERAL]);
[,OVERLOADING_RESOLUTION]);
OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
SOURCE_LOCATION
PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
FUNCTION_PROFILE
PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
Result_Type => result_SUBTYPE_NAME]
PARAMETER_TYPES ::= (SUBTYPE_NAME @{, SUBTYPE_NAME@})
SUBTYPE_NAME ::= STRING_LITERAL
SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
SOURCE_TRACE ::= STRING_LITERAL
@end smallexample
@noindent
This pragma indicates that the given entity is not used outside the
compilation unit it is defined in. The entity may be either a subprogram
or a variable.
compilation unit it is defined in. The entity an explicitly declared
subprogram, including subprogram declared by subprogram instantiations and
subprograms declared in package instantiations.
If the entity to be eliminated is a library level subprogram, then
the first form of pragma @code{Eliminate} is used with only a single argument.
@ -1366,29 +1380,55 @@ the particular entity. If the second argument is in string form, it must
correspond to the internal manner in which GNAT stores entity names (see
compilation unit Namet in the compiler sources for details).
The remaining parameters are optionally used to distinguish
between overloaded subprograms. There are two ways of doing this.
The remaining parameters (OVERLOADING_RESOLUTION) are optionally used
to distinguish between overloaded subprograms. If a pragma does not contain
the OVERLOADING_RESOLUTION parameter(s), it is applied to all the overloaded
subprograms denoted by the first two parameters.
Use @code{Parameter_Types} and @code{Result_Type} to specify the
profile of the subprogram to be eliminated in a manner similar to that
used for
the extended @code{Import} and @code{Export} pragmas, except that the
subtype names are always given as string literals, again corresponding
to the internal manner in which GNAT stores entity names.
Use PARAMETER_AND_RESULT_TYPE_PROFILE to specify the profile of the subprogram
to be eliminated in a manner similar to that used for the extended
@code{Import} and @code{Export} pragmas, except that the subtype names are
always given as string literals. At the moment, this form of distinguishing
overloaded subprograms is implemented only partially, so we do not recommend
using it for practical subprogram elimination.
Alternatively, the @code{Homonym_Number} parameter is used to specify
which overloaded alternative is to be eliminated. A value of 1 indicates
the first subprogram (in lexical order), 2 indicates the second etc.
Note, that in case of a parameterless procedure its profile is represented
as @code{Parameter_Types => ("")}
Alternatively, the @code{Source_Location} parameter is used to specify
which overloaded alternative is to be eliminated by pointing to the
location of the DEFINING_PROGRAM_UNIT_NAME of this subprogram in the
source text. The string literal submitted as SOURCE_TRACE should have
the following format:
@smallexample @c ada
SOURCE_TRACE ::= SOURCE_LOCATION@{LBRACKET SOURCE_LOCATION RBRACKET@}
LBRACKET ::= [
RBRACKET ::= ]
SOURCE_LOCATION ::= FILE_NAME:LINE_NUMBER
FILE_NAME ::= STRING_LITERAL
LINE_NUMBER ::= DIGIT @{DIGIT@}
@end smallexample
SOURCE_TRACE should be the short name of the source file (with no directory
information), and LINE_NUMBER is supposed to point to the line where the
defining name of the subprogram is located.
For the subprograms that are not a part of generic instantiations, only one
SOURCE_LOCATION is used. If a subprogram is declared in a package
instantiation, SOURCE_TRACE contains two SOURCE_LOCATIONs, the first one is
the location of the (DEFINING_PROGRAM_UNIT_NAME of the) instantiation, and the
second one denotes the declaration of the corresponding subprogram in the
generic package. This approach is recursively used to create SOURCE_LOCATIONs
in case of nested instantiations.
The effect of the pragma is to allow the compiler to eliminate
the code or data associated with the named entity. Any reference to
an eliminated entity outside the compilation unit it is defined in,
causes a compile time or link time error.
The parameters of this pragma may be given in any order, as long as
the usual rules for use of named parameters and position parameters
are used.
The intention of pragma @code{Eliminate} is to allow a program to be compiled
in a system independent manner, with unused entities eliminated, without
the requirement of modifying the source text. Normally the required set
@ -1400,6 +1440,10 @@ Note that the reason this pragma takes string literals where names might
be expected is that a pragma @code{Eliminate} can appear in a context where the
relevant names are not visible.
Note that any change in the source files that includes removing, splitting of
adding lines may make the set of Eliminate pragmas using SOURCE_LOCATION
parameter illegal.
@node Pragma Export_Exception
@unnumberedsec Pragma Export_Exception
@cindex OpenVMS
@ -12568,7 +12612,6 @@ primarily intended to be constructed automatically using a binding generator
tool, although it is possible to construct them by hand. No suitable binding
generator tool is supplied with GNAT though.
Using these pragmas it is possible to achieve complete
inter-operability between Ada tagged types and C class definitions.
See @ref{Implementation Defined Pragmas}, for more details.
@ -12692,7 +12735,7 @@ including machine instructions in a subprogram.
The two features are similar, and both are closely related to the mechanism
provided by the asm instruction in the GNU C compiler. Full understanding
and use of the facilities in this package requires understanding the asm
instruction as described in @cite{Using the GNU Compiler Collection (GCC)}
instruction as described in @cite{Using the GNU Compiler Collection (GCC)}
by Richard Stallman. The relevant section is titled ``Extensions to the C
Language Family'' -> ``Assembler Instructions with C Expression Operands''.
@ -14099,3 +14142,4 @@ environment in which the gnat tool will execute.
@contents
@bye

31
gcc/ada/gnat_ugn.texi
View File

@ -12441,12 +12441,37 @@ When @command{gnatmake} detects that a project file
is a library project file, it will check all immediate sources of the project
and rebuild the library if any of the sources have been recompiled.
When a library is built or rebuilt, an attempt is made to delete all
Standard project files can import library project files. In such cases,
the libraries will only be rebuild if some of its sources are recompiled
because they are in the closure of some other source in an importing project.
Sources of the library project files that are not in such a closure will
not be checked, unless the full library is checked, because one of its sources
needs to be recompiled.
For instance, assume the project file @code{A} imports the library project file
@code{L}. The immediate sources of A are @file{a1.adb}, @file{a2.ads} and
@file{a2.adb}. The immediate sources of L are @file{l1.ads}, @file{l1.adb},
@file{l2.ads}, @file{l2.adb}.
If @file{l1.adb} has been modified, then the library associated with @code{L}
will be rebuild when compiling all the immediate sources of @code{A} only
if @file{a1.ads}, @file{a2.ads} or @file{a2.adb} includes a statement
@code{"with L1;"}.
To be sure that all the sources in the library associated with @code{L} are
up to date, and that all the sources of parject @code{A} are also up to date,
the following two commands needs to be used:
@smallexample
gnatmake -Pl.gpr
gnatmake -Pa.gpr
@end smallexample
When a library is built or rebuilt, an attempt is made first to delete all
files in the library directory.
All @file{ALI} files will also be copied from the object directory to the
library directory. To build executables, @command{gnatmake} will use the
library rather than the individual object files. The copy of the @file{ALI}
files are made read-only.
library rather than the individual object files.
@c **********************************************

3
gcc/ada/gnatbind.adb
View File

@ -364,7 +364,8 @@ begin
declare
Shared_Libgnat_Default : Character;
pragma Import (C, Shared_Libgnat_Default, "shared_libgnat_default");
pragma Import
(C, Shared_Libgnat_Default, "__gnat_shared_libgnat_default");
SHARED : constant Character := 'H';
STATIC : constant Character := 'T';

14
gcc/ada/gnatlink.adb
View File

@ -158,7 +158,8 @@ procedure Gnatlink is
-- Set to False if bind file is not to be compiled
Object_List_File_Supported : Boolean;
pragma Import (C, Object_List_File_Supported, "objlist_file_supported");
pragma Import
(C, Object_List_File_Supported, "__gnat_objlist_file_supported");
-- Predicate indicating whether the linker has an option whereby the
-- names of object files can be passed to the linker in a file.
@ -587,7 +588,7 @@ procedure Gnatlink is
-- Projected number of bytes for the linker command line
Link_Max : Integer;
pragma Import (C, Link_Max, "link_max");
pragma Import (C, Link_Max, "__gnat_link_max");
-- Maximum number of bytes on the command line supported by the OS
-- linker. Passed this limit the response file mechanism must be used
-- if supported.
@ -649,23 +650,24 @@ procedure Gnatlink is
RB_Nfirst : Integer; -- Slice first index
Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Run_Path_Option_Ptr, "run_path_option");
pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
-- Pointer to string representing the native linker option which
-- specifies the path where the dynamic loader should find shared
-- libraries. Equal to null string if this system doesn't support it.
Object_Library_Ext_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Object_Library_Ext_Ptr, "object_library_extension");
pragma Import
(C, Object_Library_Ext_Ptr, "__gnat_object_library_extension");
-- Pointer to string specifying the default extension for
-- object libraries, e.g. Unix uses ".a", VMS uses ".olb".
Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Object_File_Option_Ptr, "object_file_option");
pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option");
-- Pointer to a string representing the linker option which specifies
-- the response file.
Using_GNU_Linker : Boolean;
pragma Import (C, Using_GNU_Linker, "using_gnu_linker");
pragma Import (C, Using_GNU_Linker, "__gnat_using_gnu_linker");
-- Predicate indicating whether this target uses the GNU linker. In
-- this case we must output a GNU linker compatible response file.

25
gcc/ada/lib-xref.adb
View File

@ -1147,16 +1147,25 @@ package body Lib.Xref is
-- Special handling for access parameter
if Ekind (Etype (XE.Ent)) = E_Anonymous_Access_Type
and then Is_Formal (XE.Ent)
then
Ctyp := 'p';
declare
K : constant Entity_Kind := Ekind (Etype (XE.Ent));
-- Special handling for Boolean
begin
if (K = E_Anonymous_Access_Type
or else
K = E_Anonymous_Access_Subprogram_Type
or else K =
E_Anonymous_Access_Protected_Subprogram_Type)
and then Is_Formal (XE.Ent)
then
Ctyp := 'p';
elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
Ctyp := 'b';
end if;
-- Special handling for Boolean
elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
Ctyp := 'b';
end if;
end;
end if;
-- Special handling for abstract types and operations.

4
gcc/ada/lib-xref.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1998-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1998-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- --
@ -395,6 +395,8 @@ package Lib.Xref is
E_Access_Subprogram_Type => 'P',
E_Access_Protected_Subprogram_Type => 'P',
E_Anonymous_Access_Subprogram_Type => ' ',
E_Anonymous_Access_Protected_Subprogram_Type => ' ',
E_Anonymous_Access_Type => ' ',
E_Array_Type => 'A',
E_Array_Subtype => 'A',

175
gcc/ada/link.c
View File

@ -30,10 +30,9 @@
* *
****************************************************************************/
/* This file contains parameterizations used by gnatlink.adb in handling */
/* very long linker lines in systems where there are limitations on the */
/* argument length when the command line is used to pass items to the */
/* linker */
/* This file contains host-specific parameters describing the behaviour */
/* of the linker. It is used by gnatlink as well as all tools that use */
/* Mlib. */
#include <string.h>
@ -83,113 +82,113 @@
#define STATIC 'T'
#if defined (__osf__)
const char *object_file_option = "-Wl,-input,";
const char *run_path_option = "-Wl,-rpath,";
int link_max = 10000;
unsigned char objlist_file_supported = 1;
char shared_libgnat_default = STATIC;
unsigned char using_gnu_linker = 0;
const char *object_library_extension = ".a";
const char *__gnat_object_file_option = "-Wl,-input,";
const char *__gnat_run_path_option = "-Wl,-rpath,";
int __gnat_link_max = 10000;
unsigned char __gnat_objlist_file_supported = 1;
char __gnat_shared_libgnat_default = STATIC;
unsigned char __gnat_using_gnu_linker = 0;
const char *__gnat_object_library_extension = ".a";
#elif defined (sgi)
const char *object_file_option = "-Wl,-objectlist,";
const char *run_path_option = "-Wl,-rpath,";
int link_max = 5000;
unsigned char objlist_file_supported = 1;
char shared_libgnat_default = STATIC;
unsigned char using_gnu_linker = 0;
const char *object_library_extension = ".a";
const char *__gnat_object_file_option = "-Wl,-objectlist,";
const char *__gnat_run_path_option = "-Wl,-rpath,";
int __gnat_link_max = 5000;
unsigned char __gnat_objlist_file_supported = 1;
char __gnat_shared_libgnat_default = STATIC;
unsigned char __gnat_using_gnu_linker = 0;
const char *__gnat_object_library_extension = ".a";
#elif defined (__WIN32)
const char *object_file_option = "";
const char *run_path_option = "";
int link_max = 30000;
unsigned char objlist_file_supported = 1;
char shared_libgnat_default = STATIC;
unsigned char using_gnu_linker = 1;
const char *object_library_extension = ".a";
const char *__gnat_object_file_option = "";
const char *__gnat_run_path_option = "";
int __gnat_link_max = 30000;
unsigned char __gnat_objlist_file_supported = 1;
char __gnat_shared_libgnat_default = STATIC;
unsigned char __gnat_using_gnu_linker = 1;
const char *__gnat_object_library_extension = ".a";
#elif defined (__INTERIX)
const char *object_file_option = "";
const char *run_path_option = "";
int link_max = 5000;
unsigned char objlist_file_supported = 1;
char shared_libgnat_default = STATIC;
unsigned char using_gnu_linker = 1;
const char *object_library_extension = ".a";
const char *__gnat_object_file_option = "";
const char *__gnat_run_path_option = "";
int __gnat_link_max = 5000;
unsigned char __gnat_objlist_file_supported = 1;
char __gnat_shared_libgnat_default = STATIC;
unsigned char __gnat_using_gnu_linker = 1;
const char *__gnat_object_library_extension = ".a";
#elif defined (hpux)
const char *object_file_option = "-Wl,-c,";
const char *run_path_option = "-Wl,+b,";
int link_max = 5000;
unsigned char objlist_file_supported = 1;
char shared_libgnat_default = STATIC;
unsigned char using_gnu_linker = 0;
const char *object_library_extension = ".a";
const char *__gnat_object_file_option = "-Wl,-c,";
const char *__gnat_run_path_option = "-Wl,+b,";
int __gnat_link_max = 5000;
unsigned char __gnat_objlist_file_supported = 1;
char __gnat_shared_libgnat_default = STATIC;
unsigned char __gnat_using_gnu_linker = 0;
const char *__gnat_object_library_extension = ".a";
#elif defined (_AIX)
const char *object_file_option = "-Wl,-f,";
const char *run_path_option = "";
int link_max = 15000;
const unsigned char objlist_file_supported = 1;
char shared_libgnat_default = STATIC;
unsigned char using_gnu_linker = 0;
const char *object_library_extension = ".a";
const char *__gnat_object_file_option = "-Wl,-f,";
const char *__gnat_run_path_option = "";
int __gnat_link_max = 15000;
const unsigned char __gnat_objlist_file_supported = 1;
char __gnat_shared_libgnat_default = STATIC;
unsigned char __gnat_using_gnu_linker = 0;
const char *__gnat_object_library_extension = ".a";
#elif defined (VMS)
const char *object_file_option = "";
const char *run_path_option = "";
char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;
unsigned char using_gnu_linker = 0;
const char *object_library_extension = ".olb";
const char *__gnat_object_file_option = "";
const char *__gnat_run_path_option = "";
char __gnat_shared_libgnat_default = STATIC;
int __gnat_link_max = 2147483647;
unsigned char __gnat_objlist_file_supported = 0;
unsigned char __gnat_using_gnu_linker = 0;
const char *__gnat_object_library_extension = ".olb";
#elif defined (sun)
const char *object_file_option = "";
const char *run_path_option = "-Wl,-R,";
char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;
unsigned char using_gnu_linker = 0;
const char *object_library_extension = ".a";
const char *__gnat_object_file_option = "";
const char *__gnat_run_path_option = "-Wl,-R";
char __gnat_shared_libgnat_default = STATIC;
int __gnat_link_max = 2147483647;
unsigned char __gnat_objlist_file_supported = 0;
unsigned char __gnat_using_gnu_linker = 0;
const char *__gnat_object_library_extension = ".a";
#elif defined (__FreeBSD__)
char *object_file_option = "";
char *run_path_option = "-Wl,-rpath,";
char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;
unsigned char using_gnu_linker = 0;
char *object_library_extension = ".a";
char *__gnat_object_file_option = "";
char *__gnat_run_path_option = "-Wl,-rpath,";
char __gnat_shared_libgnat_default = STATIC;
int __gnat_link_max = 2147483647;
unsigned char __gnat_objlist_file_supported = 0;
unsigned char __gnat_using_gnu_linker = 0;
char *__gnat_object_library_extension = ".a";
#elif defined (linux)
const char *object_file_option = "";
const char *run_path_option = "-Wl,-rpath,";
char shared_libgnat_default = STATIC;
int link_max = 8192;
unsigned char objlist_file_supported = 1;
unsigned char using_gnu_linker = 1;
const char *object_library_extension = ".a";
const char *__gnat_object_file_option = "";
const char *__gnat_run_path_option = "-Wl,-rpath,";
char __gnat_shared_libgnat_default = STATIC;
int __gnat_link_max = 8192;
unsigned char __gnat_objlist_file_supported = 1;
unsigned char __gnat_using_gnu_linker = 1;
const char *__gnat_object_library_extension = ".a";
#elif defined (__svr4__) && defined (i386)
const char *object_file_option = "";
const char *run_path_option = "";
char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;
unsigned char using_gnu_linker = 0;
const char *object_library_extension = ".a";
const char *__gnat_object_file_option = "";
const char *__gnat_run_path_option = "";
char __gnat_shared_libgnat_default = STATIC;
int __gnat_link_max = 2147483647;
unsigned char __gnat_objlist_file_supported = 0;
unsigned char __gnat_using_gnu_linker = 0;
const char *__gnat_object_library_extension = ".a";
#else
/* These are the default settings for all other systems. No response file
is supported, the shared library default is STATIC. */
const char *run_path_option = "";
const char *object_file_option = "";
char shared_libgnat_default = STATIC;
int link_max = 2147483647;
unsigned char objlist_file_supported = 0;
unsigned char using_gnu_linker = 0;
const char *object_library_extension = ".a";
const char *__gnat_run_path_option = "";
const char *__gnat_object_file_option = "";
char __gnat_shared_libgnat_default = STATIC;
int __gnat_link_max = 2147483647;
unsigned char __gnat_objlist_file_supported = 0;
unsigned char __gnat_using_gnu_linker = 0;
const char *__gnat_object_library_extension = ".a";
#endif

5
gcc/ada/mlib.adb
View File

@ -41,9 +41,6 @@ with System;
package body MLib is
pragma Linker_Options ("link.o");
-- For run_path_option string.
-------------------
-- Build_Library --
-------------------
@ -296,7 +293,7 @@ package body MLib is
function Linker_Library_Path_Option return String_Access is
Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
pragma Import (C, Run_Path_Option_Ptr, "run_path_option");
pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
-- Pointer to string representing the native linker option which
-- specifies the path where the dynamic loader should find shared
-- libraries. Equal to null string if this system doesn't support it.

26
gcc/ada/prj.ads
View File

@ -71,7 +71,7 @@ package Prj is
-- To specify how to process project files
type Programming_Language is
(Lang_Ada, Lang_C, Lang_C_Plus_Plus, Lang_Fortran);
(Lang_Ada, Lang_C, Lang_C_Plus_Plus);
-- The list of language supported
subtype Other_Programming_Language is
@ -85,12 +85,10 @@ package Prj is
Lang_Ada_Name : aliased String := "ada";
Lang_C_Name : aliased String := "c";
Lang_C_Plus_Plus_Name : aliased String := "c++";
Lang_Fortran_Name : aliased String := "for";
Lang_Names : constant array (Programming_Language) of String_Access :=
(Lang_Ada => Lang_Ada_Name 'Access,
Lang_C => Lang_C_Name 'Access,
Lang_C_Plus_Plus => Lang_C_Plus_Plus_Name'Access,
Lang_Fortran => Lang_Fortran_Name'Access);
Lang_C_Plus_Plus => Lang_C_Plus_Plus_Name'Access);
-- Names of the supported programming languages, to be used after switch
-- -x when using a GCC compiler.
@ -100,25 +98,21 @@ package Prj is
Lang_Ada_Display_Name : aliased String := "Ada";
Lang_C_Display_Name : aliased String := "C";
Lang_C_Plus_Plus_Display_Name : aliased String := "C++";
Lang_Fortran_Display_Name : aliased String := "Fortran";
Lang_Display_Names :
constant array (Programming_Language) of String_Access :=
(Lang_Ada => Lang_Ada_Display_Name 'Access,
Lang_C => Lang_C_Display_Name 'Access,
Lang_C_Plus_Plus => Lang_C_Plus_Plus_Display_Name'Access,
Lang_Fortran => Lang_Fortran_Display_Name'Access);
Lang_C_Plus_Plus => Lang_C_Plus_Plus_Display_Name'Access);
-- Names of the supported programming languages, to be used for display
-- purposes.
Ada_Impl_Suffix : aliased String := ".adb";
C_Impl_Suffix : aliased String := ".c";
C_Plus_Plus_Impl_Suffix : aliased String := ".cc";
Fortran_Impl_Suffix : aliased String := ".for";
Lang_Suffixes : constant array (Programming_Language) of String_Access :=
(Lang_Ada => Ada_Impl_Suffix 'Access,
Lang_C => C_Impl_Suffix 'Access,
Lang_C_Plus_Plus => C_Plus_Plus_Impl_Suffix'Access,
Lang_Fortran => Fortran_Impl_Suffix'Access);
Lang_C_Plus_Plus => C_Plus_Plus_Impl_Suffix'Access);
-- Default extension of the sources of the different languages.
Lang_Suffix_Ids : array (Programming_Language) of Name_Id;
@ -127,17 +121,23 @@ package Prj is
Gnatmake_String : aliased String := "gnatmake";
Gcc_String : aliased String := "gcc";
G_Plus_Plus_String : aliased String := "g++";
G77_String : aliased String := "g77";
Default_Compiler_Names :
constant array (Programming_Language) of String_Access :=
(Lang_Ada => Gnatmake_String 'Access,
Lang_C => Gcc_String 'Access,
Lang_C_Plus_Plus => G_Plus_Plus_String'Access,
Lang_Fortran => G77_String 'Access);
Lang_C_Plus_Plus => G_Plus_Plus_String'Access);
-- Default names of the compilers for the supported languages.
-- Used when no IDE'Compiler_Command is specified for a language.
-- For Ada, specify the gnatmake executable.
Ada_Args_Strings : aliased String := "";
C_Args_String : aliased String := "c";
C_Plus_Plus_Args_String : aliased String := "xx";
Lang_Args : constant array (Programming_Language) of String_Access :=
(Lang_Ada => Ada_Args_Strings 'Access,
Lang_C => C_Args_String 'Access,
Lang_C_Plus_Plus => C_Plus_Plus_Args_String'Access);
type Other_Source_Id is new Nat;
No_Other_Source : constant Other_Source_Id := 0;
type Other_Source is record

63
gcc/ada/rtsfind.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- --
@ -786,9 +786,6 @@ package body Rtsfind is
---------------
procedure Check_RPC is
Body_Name : Unit_Name_Type;
Unum : Unit_Number_Type;
begin
-- Bypass this check if debug flag -gnatdR set
@ -799,47 +796,33 @@ package body Rtsfind is
-- Otherwise we need the check if we are going after one of
-- the critical entities in System.RPC in stubs mode.
-- ??? Should we do this for other s-parint/s-polint entities
-- too?
if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
or else
Distribution_Stub_Mode = Generate_Caller_Stub_Body)
and then (E = RE_Do_Rpc
or else E = RE_Do_Apc
or else E = RE_Params_Stream_Type
or else E = RE_RPC_Receiver)
or else
E = RE_Do_Apc
or else
E = RE_Params_Stream_Type
or else
E = RE_RPC_Receiver)
then
-- Load body of System.Rpc, and abort if this is the body that is
-- provided by GNAT, for which these features are not supported
-- on current target. We identify the gnat body by the presence
-- of a local entity called Gnat in the first declaration.
Lib_Unit := Unit (Cunit (U.Unum));
Body_Name := Get_Body_Name (Get_Unit_Name (Lib_Unit));
Unum :=
Load_Unit
(Load_Name => Body_Name,
Required => False,
Subunit => False,
Error_Node => Empty,
Renamings => True);
if Unum /= No_Unit then
declare
Decls : constant List_Id :=
Declarations (Unit (Cunit (Unum)));
begin
if Present (Decls)
and then Nkind (First (Decls)) = N_Object_Declaration
and then
Chars (Defining_Identifier (First (Decls))) = Name_Gnat
then
Set_Standard_Error;
Write_Str ("distribution feature not supported");
Write_Eol;
raise Unrecoverable_Error;
end if;
end;
end if;
declare
DSA_Implementation : constant Entity_Id :=
RTE (RE_DSA_Implementation);
begin
if Chars (Entity (Expression
(Parent (DSA_Implementation)))) = Name_No_DSA
then
Set_Standard_Error;
Write_Str ("distribution feature not supported");
Write_Eol;
raise Unrecoverable_Error;
end if;
end;
end if;
end Check_RPC;

2
gcc/ada/rtsfind.ads
View File

@ -997,6 +997,7 @@ package Rtsfind is
RE_Size_Type, -- System.Parameters
RE_Unspecified_Size, -- System.Parameters
RE_DSA_Implementation, -- System.Partition_Interface
RE_Get_Active_Partition_Id, -- System.Partition_Interface
RE_Get_Passive_Partition_Id, -- System.Partition_Interface
RE_Get_Local_Partition_Id, -- System.Partition_Interface
@ -2066,6 +2067,7 @@ package Rtsfind is
RE_Size_Type => System_Parameters,
RE_Unspecified_Size => System_Parameters,
RE_DSA_Implementation => System_Partition_Interface,
RE_Get_Active_Partition_Id => System_Partition_Interface,
RE_Get_Passive_Partition_Id => System_Partition_Interface,
RE_Get_Local_Partition_Id => System_Partition_Interface,

3
gcc/ada/s-parint.ads
View File

@ -42,6 +42,9 @@ package System.Partition_Interface is
pragma Elaborate_Body;
type DSA_Implementation_Name is (No_DSA, GLADE_DSA, PolyORB_DSA);
DSA_Implementation : constant DSA_Implementation_Name := No_DSA;
type Subprogram_Id is new Natural;
-- This type is used exclusively by stubs

9
gcc/ada/s-rpc.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- --
@ -43,13 +43,6 @@ with Ada.Exceptions; use Ada.Exceptions;
package body System.RPC is
GNAT : constant Boolean := True;
pragma Unreferenced (GNAT);
-- This dummy entity allows the compiler to recognize that this is the
-- version of this package that is supplied by GNAT, not by the user.
-- This is used to cause a compile time error if an attempt is made to
-- use features in System.RPC that are only available from a true PCS.
CRLF : constant String := ASCII.CR & ASCII.LF;
Msg : constant String :=

26
gcc/ada/sem_attr.adb
View File

@ -6507,7 +6507,12 @@ package body Sem_Attr is
-- also be accessibility checks on those, this is where the
-- checks can eventually be centralized ???
if Ekind (Btyp) = E_Access_Subprogram_Type then
if Ekind (Btyp) = E_Access_Subprogram_Type
or else
Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
or else
Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type
then
if Convention (Btyp) /= Convention (Entity (P)) then
Error_Msg_N
("subprogram has invalid convention for context", P);
@ -6533,8 +6538,12 @@ package body Sem_Attr is
-- warning is needed.
elsif Attr_Id = Attribute_Access
and then Subprogram_Access_Level (Entity (P))
> Type_Access_Level (Btyp)
and then Subprogram_Access_Level (Entity (P)) >
Type_Access_Level (Btyp)
and then Ekind (Btyp) /=
E_Anonymous_Access_Subprogram_Type
and then Ekind (Btyp) /=
E_Anonymous_Access_Protected_Subprogram_Type
then
if not In_Instance_Body then
Error_Msg_N
@ -6617,9 +6626,12 @@ package body Sem_Attr is
-- The rule does not apply to 'Unrestricted_Access.
if not (Ekind (Btyp) = E_Access_Subprogram_Type
or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
or else (Is_Record_Type (Btyp) and then
Present (Corresponding_Remote_Type (Btyp)))
or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
or else Ekind (Btyp)
= E_Anonymous_Access_Protected_Subprogram_Type
or else Is_Access_Constant (Btyp)
or else Is_Variable (P)
or else Attr_Id = Attribute_Unrestricted_Access)
@ -6791,13 +6803,17 @@ package body Sem_Attr is
end if;
end if;
if Ekind (Btyp) = E_Access_Protected_Subprogram_Type
if (Ekind (Btyp) = E_Access_Protected_Subprogram_Type
or else
Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type)
and then Is_Entity_Name (P)
and then not Is_Protected_Type (Scope (Entity (P)))
then
Error_Msg_N ("context requires a protected subprogram", P);
elsif Ekind (Btyp) = E_Access_Subprogram_Type
elsif (Ekind (Btyp) = E_Access_Subprogram_Type
or else
Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type)
and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
then
Error_Msg_N ("context requires a non-protected subprogram", P);

49
gcc/ada/sem_ch3.adb
View File

@ -684,6 +684,15 @@ package body Sem_Ch3 is
Access_Subprogram_Declaration
(T_Name => Anon_Type,
T_Def => Access_To_Subprogram_Definition (N));
if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then
Set_Ekind
(Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type);
else
Set_Ekind
(Anon_Type, E_Anonymous_Access_Subprogram_Type);
end if;
return Anon_Type;
end if;
@ -992,7 +1001,7 @@ package body Sem_Ch3 is
(Access_Definition
(Component_Definition (N))))
then
T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
T := Replace_Anonymous_Access_To_Protected_Subprogram (N, T);
end if;
else
@ -2986,14 +2995,17 @@ package body Sem_Ch3 is
-- Ada 0Y (AI-254)
if Present (Access_To_Subprogram_Definition
(Access_Definition (Component_Def)))
and then Protected_Present (Access_To_Subprogram_Definition
(Access_Definition (Component_Def)))
then
Element_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram (Def);
end if;
declare
CD : constant Node_Id :=
Access_To_Subprogram_Definition
(Access_Definition (Component_Def));
begin
if Present (CD) and then Protected_Present (CD) then
Element_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram
(Def, Element_Type);
end if;
end;
else
pragma Assert (False);
@ -3142,7 +3154,8 @@ package body Sem_Ch3 is
------------------------------------------------------
function Replace_Anonymous_Access_To_Protected_Subprogram
(N : Node_Id) return Entity_Id
(N : Node_Id;
Prev_E : Entity_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (N);
@ -3184,17 +3197,23 @@ package body Sem_Ch3 is
Decl := Make_Full_Type_Declaration (Loc,
Defining_Identifier => Anon,
Type_Definition =>
Access_To_Subprogram_Definition (Acc));
Copy_Separate_Tree (Access_To_Subprogram_Definition (Acc)));
Mark_Rewrite_Insertion (Decl);
-- Insert the new declaration in the nearest enclosing scope
while not Has_Declarations (P) loop
while Present (P) and then not Has_Declarations (P) loop
P := Parent (P);
end loop;
Prepend (Decl, Declarations (P));
pragma Assert (Present (P));
if Nkind (P) = N_Package_Specification then
Prepend (Decl, Visible_Declarations (P));
else
Prepend (Decl, Declarations (P));
end if;
-- Replace the anonymous type with an occurrence of the new declaration.
-- In all cases the rewriten node does not have the null-exclusion
@ -3221,6 +3240,7 @@ package body Sem_Ch3 is
Analyze (Decl);
Scope_Stack.Append (Curr_Scope);
Set_Original_Access_Type (Anon, Prev_E);
return Anon;
end Replace_Anonymous_Access_To_Protected_Subprogram;
@ -11613,7 +11633,8 @@ package body Sem_Ch3 is
(Discriminant_Type (Discr)))
then
Discr_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
Replace_Anonymous_Access_To_Protected_Subprogram
(Discr, Discr_Type);
end if;
else

7
gcc/ada/sem_ch3.ads
View File

@ -207,11 +207,14 @@ package Sem_Ch3 is
-- Prev is entity on the partial view, on which references are posted.
function Replace_Anonymous_Access_To_Protected_Subprogram
(N : Node_Id) return Entity_Id;
(N : Node_Id;
Prev_E : Entity_Id) return Entity_Id;
-- Ada 0Y (AI-254): Create and decorate an internal full type declaration
-- in the enclosing scope corresponding to an anonymous access to protected
-- subprogram. In addition, replace the anonymous access by an occurrence
-- of this internal type. Return the entity of this type declaration.
-- of this internal type. Prev_Etype is used to link the new internal
-- entity with the anonymous entity. Return the entity of this type
-- declaration.
procedure Set_Completion_Referenced (E : Entity_Id);
-- If E is the completion of a private or incomplete type declaration,

55
gcc/ada/sem_ch6.adb
View File

@ -2956,6 +2956,7 @@ package body Sem_Ch6 is
is
Type_1 : Entity_Id := T1;
Type_2 : Entity_Id := T2;
Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
-- If neither T1 nor T2 are generic actual types, or if they are
@ -3030,11 +3031,32 @@ package body Sem_Ch6 is
or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
end if;
-- Ada 0Y (AI-254): Detect anonymous access to subprogram types. In
-- case of anonymous access to protected subprogram types the anonymous
-- type declaration has been replaced by an occurrence of an internal
-- access to subprogram type declaration
Are_Anonymous_Access_To_Subprogram_Types :=
(Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
and then Ekind (Type_2) = E_Anonymous_Access_Subprogram_Type)
or else
((Ekind (Type_1) = E_Access_Protected_Subprogram_Type
and then Ekind (Type_2) = E_Access_Protected_Subprogram_Type)
and then (not Comes_From_Source (Type_1)
and not Comes_From_Source (Type_2))
and then (Present (Original_Access_Type (Type_1))
and Present (Original_Access_Type (Type_2)))
and then (Ekind (Original_Access_Type (Type_1))
= E_Anonymous_Access_Protected_Subprogram_Type
and Ekind (Original_Access_Type (Type_2))
= E_Anonymous_Access_Protected_Subprogram_Type));
-- Test anonymous access type case. For this case, static subtype
-- matching is required for mode conformance (RM 6.3.1(15))
if Ekind (Type_1) = E_Anonymous_Access_Type
and then Ekind (Type_2) = E_Anonymous_Access_Type
if (Ekind (Type_1) = E_Anonymous_Access_Type
and then Ekind (Type_2) = E_Anonymous_Access_Type)
or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 0Y (AI-254)
then
declare
Desig_1 : Entity_Id;
@ -3083,11 +3105,17 @@ package body Sem_Ch6 is
Conforming_Types
(Etype (Base_Type (Desig_1)),
Etype (Base_Type (Desig_2)), Ctype);
elsif Are_Anonymous_Access_To_Subprogram_Types then
return Ctype = Type_Conformant
or else
Subtypes_Statically_Match (Desig_1, Desig_2);
else
return Base_Type (Desig_1) = Base_Type (Desig_2)
and then (Ctype = Type_Conformant
or else
Subtypes_Statically_Match (Desig_1, Desig_2));
or else
Subtypes_Statically_Match (Desig_1, Desig_2));
end if;
end;
@ -4958,14 +4986,17 @@ package body Sem_Ch6 is
-- Ada 0Y (AI-254)
if Present (Access_To_Subprogram_Definition
(Parameter_Type (Param_Spec)))
and then Protected_Present (Access_To_Subprogram_Definition
(Parameter_Type (Param_Spec)))
then
Formal_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram (Param_Spec);
end if;
declare
AD : constant Node_Id :=
Access_To_Subprogram_Definition
(Parameter_Type (Param_Spec));
begin
if Present (AD) and then Protected_Present (AD) then
Formal_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram
(Param_Spec, Formal_Type);
end if;
end;
end if;
Set_Etype (Formal, Formal_Type);

17
gcc/ada/sem_prag.adb
View File

@ -2949,21 +2949,24 @@ package body Sem_Prag is
-- Processing for procedure, operator or function.
-- If subprogram is aliased (as for an instance) indicate
-- that the renamed entity is inlined.
-- that the renamed entity (if declared in the same unit)
-- is inlined.
if Is_Subprogram (Subp) then
while Present (Alias (Inner_Subp)) loop
Inner_Subp := Alias (Inner_Subp);
end loop;
Set_Inline_Flags (Inner_Subp);
if In_Same_Source_Unit (Subp, Inner_Subp) then
Set_Inline_Flags (Inner_Subp);
Decl := Parent (Parent (Inner_Subp));
Decl := Parent (Parent (Inner_Subp));
if Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
Set_Inline_Flags (Corresponding_Body (Decl));
if Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
Set_Inline_Flags (Corresponding_Body (Decl));
end if;
end if;
Applies := True;

4
gcc/ada/sem_res.adb
View File

@ -7076,7 +7076,9 @@ package body Sem_Res is
end if;
end;
elsif Ekind (Target_Type) = E_Access_Subprogram_Type
elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
or else
Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
and then Conversion_Check
(Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
"illegal operand for access subprogram conversion")

21
gcc/ada/sem_type.adb
View File

@ -731,6 +731,27 @@ package body Sem_Type is
then
return True;
-- Ada 0Y (AI-254): An Anonymous_Access_To_Subprogram is compatible with
-- itself, or with an anonymous type created for an attribute
-- reference Access.
elsif (Ekind (Base_Type (T1)) = E_Anonymous_Access_Subprogram_Type
or else
Ekind (Base_Type (T1))
= E_Anonymous_Access_Protected_Subprogram_Type)
and then Is_Access_Type (T2)
and then (not Comes_From_Source (T1)
or else not Comes_From_Source (T2))
and then (Is_Overloadable (Designated_Type (T2))
or else
Ekind (Designated_Type (T2)) = E_Subprogram_Type)
and then
Type_Conformant (Designated_Type (T1), Designated_Type (T2))
and then
Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
then
return True;
-- The context can be a remote access type, and the expression the
-- corresponding source type declared in a categorized package, or
-- viceversa.

3
gcc/ada/sem_util.adb
View File

@ -2688,7 +2688,8 @@ package body Sem_Util is
or else K = N_Package_Body
or else K = N_Protected_Body
or else K = N_Subprogram_Body
or else K = N_Task_Body;
or else K = N_Task_Body
or else K = N_Package_Specification;
end Has_Declarations;
--------------------

3
gcc/ada/snames.adb
View File

@ -119,6 +119,9 @@ package body Snames is
"system#" &
"text_io#" &
"wide_text_io#" &
"no_dsa#" &
"glade_dsa#" &
"polyorb_dsa#" &
"addr#" &
"async#" &
"get_active_partition_id#" &

1142
gcc/ada/snames.ads
View File

File diff suppressed because it is too large Load Diff

12
gcc/ada/targtyps.c
View File

@ -6,7 +6,7 @@
* *
* Body *
* *
* 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- *
@ -148,16 +148,6 @@ get_target_maximum_alignment (void)
return BIGGEST_ALIGNMENT / BITS_PER_UNIT;
}
Boolean
get_target_no_dollar_in_label (void)
{
#ifdef NO_DOLLAR_IN_LABEL
return 1;
#else
return 0;
#endif
}
#ifndef FLOAT_WORDS_BIG_ENDIAN
#define FLOAT_WORDS_BIG_ENDIAN WORDS_BIG_ENDIAN
#endif

11
gcc/ada/utils.c
View File

@ -2994,11 +2994,13 @@ convert (tree type, tree expr)
case STRING_CST:
case CONSTRUCTOR:
/* If we are converting a STRING_CST to another constrained array type,
just make a new one in the proper type. Likewise for a
CONSTRUCTOR. */
just make a new one in the proper type. Likewise for
CONSTRUCTOR if the alias sets are the same. */
if (code == ecode && AGGREGATE_TYPE_P (etype)
&& ! (TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
&& TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
&& TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
&& (TREE_CODE (expr) == STRING_CST
|| get_alias_set (etype) == get_alias_set (type)))
{
expr = copy_node (expr);
TREE_TYPE (expr) = type;
@ -3014,7 +3016,8 @@ convert (tree type, tree expr)
if (code == ecode && TYPE_MODE (type) == TYPE_MODE (etype)
&& AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
&& TYPE_ALIGN (type) == TYPE_ALIGN (etype)
&& operand_equal_p (TYPE_SIZE (type), TYPE_SIZE (etype), 0))
&& operand_equal_p (TYPE_SIZE (type), TYPE_SIZE (etype), 0)
&& get_alias_set (type) == get_alias_set (etype))
return build (COMPONENT_REF, type, TREE_OPERAND (expr, 0),
TREE_OPERAND (expr, 1));