diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-09-13 10:18:42 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-09-13 10:18:42 +0000 |
| commit | 44d43e97acb586d2eb6efaee9f3092e069a1642f (patch) | |
| tree | b660d80503dd74c8b52af273fa1a7b3c2af763e6 /gcc | |
| parent | 976bf0956590a27721a30d3d734c740ea65b5cdd (diff) | |
| download | gcc-44d43e97acb586d2eb6efaee9f3092e069a1642f.tar.gz | |
2004-09-09 Vincent Celier <celier@gnat.com>
* a-direct.ads: Add pragma Ada_05
(Directory_Entry_Type): Give default value to component Kind to avoid
not initialized warnings.
* a-direct.adb (Current_Directory): Remove directory separator at the
end.
(Delete_Directory, Delete_Tree): Raise Name_Error if Directory is not
an existing directory.
(Fetch_Next_Entry): Give default value to variable Kind to avoid warning
(Size (String)): Function C_Size returns Long_Integer, not File_Size.
Convert the result to File_Size.
* prj.ads: (Project_Error): New exception
* prj-attr.adb: Except in procedure Initialize, Fail comes from
Prj.Com, not from Osint.
(Attrs, Package_Attributes): Tables moved to private part of spec
(Add_Attribute, Add_Unknown_Package): Moved to new child package
Prj.Attr.PM.
(Register_New_Package (Name, Attributes), Register_New_Attribute): Raise
Prj.Project_Error after call to Fail.
(Register_New_Package (Name, Id)): Set Id to Empty_Package after calling
Fail. Check that package name is not already in use.
* prj-attr.ads: Comment updates to indicate that all subprograms may be
used by tools, not only by the project manager, and to indicate that
exception Prj.Prj_Error may be raised in case of problem.
(Add_Unknown_Package, Add_Attribute): Moved to new child package
Prj.Attr.PM.
(Attrs, Package_Attributes): Table instantiations moved from the body to
the private part to be accessible from Prj.Attr.PM body.
* prj-dect.adb (Parse_Package_Declaration): Call Add_Unknown_Package
from new package Prj.Attr.PM.
(Parse_Attribute_Declaration): Call Add_Attribute from new package
Prj.Attr.PM.
* Makefile.in: Add prj-attr-pm.o to gnatmake object list
* gnatbind.adb (Gnatbind): Correct warning message (Elaboration_Check
instead of Elaboration_Checks).
* a-calend.adb: Minor reformatting
2004-09-09 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* gigi.h (maybe_pad_type): New declaration.
(create_subprog_type): New arg RETURNS_BY_TARGET_PTR.
* ada-tree.h: (TYPE_RETURNS_BY_TARGET_PTR_P): New macro.
* cuintp.c: Convert to use buildN.
* decl.c (maybe_pad_type): No longer static.
(gnat_to_gnu_entity, case E_Function): Handle case of returning by
target pointer.
Convert to use buildN.
* trans.c (call_to_gnu): Add arg GNU_TARGET; support
TYPE_RETURNS_BY_TARGET_PTR_P. All callers changed.
(gnat_to_gnu, case N_Assignment_Statement): Call call_to_gnu if call on
RHS.
(gnat_to_gnu, case N_Return): Handle TYPE_RETURN_BY_TARGET_PTR_P.
(gnat_gimplify_expr, case ADDR_EXPR): New case.
Convert to use buildN.
* utils2.c (gnat_build_constructor): Also set TREE_INVARIANT and
TREE_READONLY for const.
Convert to use buildN.
* utils.c (create_subprog_type): New operand RETURNS_BY_TARGET_PTR.
(create_var_decl): Refine when TREE_STATIC is set.
Convert to use buildN.
2004-09-09 Gary Dismukes <dismukes@gnat.com>
* gnat_ugn.texi: Delete text relating to checking of ali and object
consistency.
* a-except.adb (Rcheck_*): Add pragmas No_Return for each of these
routines.
2004-09-09 Jose Ruiz <ruiz@act-europe.fr>
* gnat_ugn.texi: Add Detect_Blocking to the list of configuration
pragmas recognized by GNAT.
* gnat_rm.texi: Document pragma Detect_Blocking.
* s-solita.adb (Timed_Delay_T): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation.
* s-taprob.adb (Lock): When pragma Detect_Blocking is active increase
the protected action nesting level.
(Lock_Read_Only): When pragma Detect_Blocking is active increase the
protected action nesting level.
(Unlock): When pragma Detect_Blocking is active decrease the protected
action nesting level.
* s-taskin.adb (Initialize_ATCB): Initialize to 0 the
Protected_Action_Nesting.
* s-taskin.ads: Adding the field Protected_Action_Nesting to the
Common_ATCB record. It contains the dynamic level of protected action
nesting for each task. It is needed for checking whether potentially
blocking operations are called from protected operations.
(Detect_Blocking): Adding a Boolean constant reflecting whether pragma
Detect_Blocking is active or not in the partition.
* s-tasren.adb (Call_Simple): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation.
(Task_Entry_Call): When pragma Detect_Blocking is active, raise
Program_Error if called from a protected operation.
(Timed_Task_Entry_Call): When pragma Detect_Blocking is active, raise
Program_Error if called from a protected operation.
* s-tassta.adb (Abort_Tasks): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation.
* s-tpoben.adb (Lock_Entries): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation, and increase
the protected action nesting level.
(Lock_Read_Only_Entries): When pragma Detect_Blocking is active, raise
Program_Error if called from a protected operation, and increase the
protected action nesting level.
(Unlock_Entries): When pragma Detect_Blocking is active decrease the
protected action nesting level.
* s-tposen.adb (Lock_Entry): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation, and increase
the protected action nesting level.
(Lock_Read_Only_Entry): When pragma Detect_Blocking is active, raise
Program_Error if called from a protected operation, and increase the
protected action nesting level.
(Protected_Single_Entry_Call): When pragma Detect_Blocking is active,
raise Program_Error if called from a protected operation.
(Timed_Protected_Single_Entry_Call): When pragma Detect_Blocking is
active, raise Program_Error if called from a protected operation.
(Unlock_Entry): When pragma Detect_Blocking is active decrease the
protected action nesting level.
* sem_util.adb (Check_Potentially_Blocking_Operation): Remove the
insertion of the statement raising Program_Error. The run time
contains the required machinery for handling that.
* sem_util.ads: Change comment associated to procedure
Check_Potentially_Blocking_Operation.
This procedure does not insert a call for raising the exception because
that is currently done by the run time.
* raise.h (__gnat_set_globals): Pass the detect_blocking parameter.
* init.c: Add the global variable __gl_detect_blocking that indicates
whether pragma Detect_Blocking is active (1) or not (0). Needed for
making the pragma available at run time.
(__gnat_set_globals): Pass and update the detect_blocking parameter.
* lib-writ.adb (Write_ALI): Set the DB flag in the ali file if
pragma Detect_Blocking is active.
* lib-writ.ads: Document the Detect_Blocking flag (DB) in ali files.
* ali.adb (Scan_ALI): Set the Detect_Blocking value to true if the flag
DB is found in the ali file. Any unit compiled with pragma
Detect_Blocking active forces its effect in the whole partition.
* a-retide.adb (Delay_Until): Raise Program_Error if pragma
Detect_Blocking is active and delay is called from a protected
operation.
* bindgen.adb (Gen_Adainit_Ada): When generating the call to
__gnat_set_globals, pass 1 as Detect_Blocking parameter if pragma
Detect_Blocking is active (0 otherwise).
(Gen_Adainit_C): When generating the call to __gnat_set_globals, pass 1
as Detect_Blocking parameter if pragma Detect_Blocking is active (0
otherwise).
2004-09-09 Thomas Quinot <quinot@act-europe.fr>
* gnat_rm.texi: Rename GNAT.Perfect_Hash.Generators to
GNAT.Perfect_Hash_Generators, and remove the empty GNAT.Perfect_Hash
package.
* s-parint.ads, s-parint.adb (Get_RAS_Info): New subprogram.
(Register_Receiving_Stub): Add Subp_Info formal parameter.
Update API in placeholder implemetation of s-parint to reflect changes
in distribution runtime library.
* sem_ch3.adb (Expand_Derived_Record): Rename to
Expand_Record_Extension.
* sem_disp.adb (Check_Controlling_Formals): Improve error message for
primitive operations of potentially distributed object types that have
non-controlling anonymous access formals.
* sem_dist.ads, sem_dist.adb (Build_RAS_Primitive_Specification): New
subprogram.
New implementation of expansion for remote access-to-subprogram types,
based on the RACW infrastructure.
This version of sem_dist is compatible with PolyORB/DSA as well as
GLADE.
* sem_prag.adb (Analyze_Pragma, case Pragma_Asynchronous): For a pragma
Asynchrronous that applies to a remote access-to-subprogram type, mark
the underlying RACW type as asynchronous.
* link.c: FreeBSD uses GNU ld: set __gnat_objlist_file_supported and
__gnat_using_gnu_linker to 1.
* Makefile.rtl, impunit.adb, g-perhas.ads, g-pehage.ads,
g-pehage.adb: Rename GNAT.Perfect_Hash.Generators to
GNAT.Perfect_Hash_Generators, and remove the empty
GNAT.Perfect_Hash package.
* atree.adb: Minor reformatting
* exp_ch3.adb (Expand_Derived_Record): Rename to
Expand_Record_Extension.
(Build_Record_Init_Proc.Build_Assignment): The default expression in
a component declaration must remain attached at that point in the
tree so New_Copy_Tree copies it if the enclosing record type is derived.
It is therefore necessary to take a copy of the expression when building
the corresponding assignment statement in the init proc.
As a side effect, in the case of a derived record type, we now see the
original expression, without any rewriting that could have occurred
during expansion of the ancestor type's init proc, and we do not need
to go back to Original_Node.
* exp_ch3.ads (Expand_Derived_Record): Rename to
Expand_Record_Extension.
* exp_dist.ads, exp_dist.adb (Underlying_RACW_Type): New subprogram.
Returns the RACW type used to implement a remote access-to-subprogram
type.
(Add_RAS_Proxy_And_Analyze, Build_Remote_Subprogram_Proxy_Type):
New subprograms. Used to create a proxy tagged object for a remote
subprogram. The proxy object is used as the designated object
for RAS values on the same partition (unless All_Calls_Remote applies).
(Build_Get_Unique_RP_Call): New subprogram. Build a call to
System.Partition_Interface.Get_Unique_Remote_Pointer.
(Add_RAS_Access_TSS, Add_RAS_Dereference_TSS):
Renamed from Add_RAS_*_Attribute.
(Add_Receiving_Stubs_To_Declarations): Generate a table of local
subprograms.
New implementation of expansion for remote access-to-subprogram types,
based on the RACW infrastructure.
* exp_dist.ads (Copy_Specification): Update comment to note that this
function can copy the specification from either a subprogram
specification or an access-to-subprogram type definition.
2004-09-09 Ed Schonberg <schonberg@gnat.com>
* sem_type.adb (Disambiguate): Handle properly an accidental ambiguity
in an instance, between an explicit subprogram an one inherited from a
type derived from an actual.
* exp_ch6.adb (Expand_N_Subprogram_Body): If polling is enabled, do not
add a polling call if the subprogram is to be inlined by the back-end,
to avoid repeated calls with multiple inlinings.
* checks.adb (Apply_Alignment_Check): If the expression in the address
clause is a call whose name is not a static entity (e.g. a dispatching
call), treat as dynamic.
2004-09-09 Robert Dewar <dewar@gnat.com>
* g-trasym.ads: Minor reformatting
* exp_ch3.adb (Component_Needs_Simple_Initialization): Don't except
packed arrays, since unused bits are expected to be zero for a
comparison.
2004-09-09 Eric Botcazou <ebotcazou@act-europe.fr>
* exp_pakd.ads: Fix an inacurracy and a couple of typos in the head
comment.
2004-09-09 Pascal Obry <obry@gnat.com>
* mdll.ads, mdll.adb (Build_Dynamic_Library): New parameter Map_File to
enable map file generation. Add the right option to generate the map
file if Map_File is set to True.
* gnatdll.adb (Gen_Map_File): New variable.
(Syntax): Add info about new -m (Map_File) option.
(Parse_Command_Line): Add support for -m option.
(gnatdll): Pass Gen_Map_File to Build_Dynamic_Library calls.
Minor reformatting.
2004-09-09 Laurent Pautet <pautet@act-europe.fr>
* gnatls.adb: Add a very verbose mode -V. Such mode is required by the
new gnatdist implementation.
Define a subpackage isolating the output routines specific to this
verbose mode.
2004-09-09 Joel Brobecker <brobecker@gnat.com>
* Makefile.rtl: (GNATRTL_NONTASKING_OBJS): Add g-dynhta.
* gnat_ugn.texi (Main Subprograms): Fix typo. Deduced, not deducted.
2004-09-09 Cyrille Comar <comar@act-europe.fr>
* opt.adb (Set_Opt_Config_Switches): Use Ada_Version_Runtime to compile
internal unit.
* opt.ads: Add Ada_Version_Runtime constant used to decide which
version of the language is used to compile the run time.
2004-09-09 Arnaud Charlet <charlet@act-europe.fr>
* sem_util.adb (Requires_Transient_Scope): Re-enable handling
of variable length temporaries for function return now that the
back-end and gigi support it.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@87435 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
66 files changed, 3658 insertions, 1700 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d170497a59e..c824ae6d9ff 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,322 @@ +2004-09-09 Vincent Celier <celier@gnat.com> + + * a-direct.ads: Add pragma Ada_05 + (Directory_Entry_Type): Give default value to component Kind to avoid + not initialized warnings. + + * a-direct.adb (Current_Directory): Remove directory separator at the + end. + (Delete_Directory, Delete_Tree): Raise Name_Error if Directory is not + an existing directory. + (Fetch_Next_Entry): Give default value to variable Kind to avoid warning + (Size (String)): Function C_Size returns Long_Integer, not File_Size. + Convert the result to File_Size. + + * prj.ads: (Project_Error): New exception + + * prj-attr.adb: Except in procedure Initialize, Fail comes from + Prj.Com, not from Osint. + (Attrs, Package_Attributes): Tables moved to private part of spec + (Add_Attribute, Add_Unknown_Package): Moved to new child package + Prj.Attr.PM. + (Register_New_Package (Name, Attributes), Register_New_Attribute): Raise + Prj.Project_Error after call to Fail. + (Register_New_Package (Name, Id)): Set Id to Empty_Package after calling + Fail. Check that package name is not already in use. + + * prj-attr.ads: Comment updates to indicate that all subprograms may be + used by tools, not only by the project manager, and to indicate that + exception Prj.Prj_Error may be raised in case of problem. + (Add_Unknown_Package, Add_Attribute): Moved to new child package + Prj.Attr.PM. + (Attrs, Package_Attributes): Table instantiations moved from the body to + the private part to be accessible from Prj.Attr.PM body. + + * prj-dect.adb (Parse_Package_Declaration): Call Add_Unknown_Package + from new package Prj.Attr.PM. + (Parse_Attribute_Declaration): Call Add_Attribute from new package + Prj.Attr.PM. + + * Makefile.in: Add prj-attr-pm.o to gnatmake object list + + * gnatbind.adb (Gnatbind): Correct warning message (Elaboration_Check + instead of Elaboration_Checks). + + * a-calend.adb: Minor reformatting + +2004-09-09 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> + + * gigi.h (maybe_pad_type): New declaration. + (create_subprog_type): New arg RETURNS_BY_TARGET_PTR. + + * ada-tree.h: (TYPE_RETURNS_BY_TARGET_PTR_P): New macro. + + * cuintp.c: Convert to use buildN. + + * decl.c (maybe_pad_type): No longer static. + (gnat_to_gnu_entity, case E_Function): Handle case of returning by + target pointer. + Convert to use buildN. + + * trans.c (call_to_gnu): Add arg GNU_TARGET; support + TYPE_RETURNS_BY_TARGET_PTR_P. All callers changed. + (gnat_to_gnu, case N_Assignment_Statement): Call call_to_gnu if call on + RHS. + (gnat_to_gnu, case N_Return): Handle TYPE_RETURN_BY_TARGET_PTR_P. + (gnat_gimplify_expr, case ADDR_EXPR): New case. + Convert to use buildN. + + * utils2.c (gnat_build_constructor): Also set TREE_INVARIANT and + TREE_READONLY for const. + Convert to use buildN. + + * utils.c (create_subprog_type): New operand RETURNS_BY_TARGET_PTR. + (create_var_decl): Refine when TREE_STATIC is set. + Convert to use buildN. + +2004-09-09 Gary Dismukes <dismukes@gnat.com> + + * gnat_ugn.texi: Delete text relating to checking of ali and object + consistency. + + * a-except.adb (Rcheck_*): Add pragmas No_Return for each of these + routines. + +2004-09-09 Jose Ruiz <ruiz@act-europe.fr> + + * gnat_ugn.texi: Add Detect_Blocking to the list of configuration + pragmas recognized by GNAT. + + * gnat_rm.texi: Document pragma Detect_Blocking. + + * s-solita.adb (Timed_Delay_T): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation. + + * s-taprob.adb (Lock): When pragma Detect_Blocking is active increase + the protected action nesting level. + (Lock_Read_Only): When pragma Detect_Blocking is active increase the + protected action nesting level. + (Unlock): When pragma Detect_Blocking is active decrease the protected + action nesting level. + + * s-taskin.adb (Initialize_ATCB): Initialize to 0 the + Protected_Action_Nesting. + + * s-taskin.ads: Adding the field Protected_Action_Nesting to the + Common_ATCB record. It contains the dynamic level of protected action + nesting for each task. It is needed for checking whether potentially + blocking operations are called from protected operations. + (Detect_Blocking): Adding a Boolean constant reflecting whether pragma + Detect_Blocking is active or not in the partition. + + * s-tasren.adb (Call_Simple): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation. + (Task_Entry_Call): When pragma Detect_Blocking is active, raise + Program_Error if called from a protected operation. + (Timed_Task_Entry_Call): When pragma Detect_Blocking is active, raise + Program_Error if called from a protected operation. + + * s-tassta.adb (Abort_Tasks): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation. + + * s-tpoben.adb (Lock_Entries): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation, and increase + the protected action nesting level. + (Lock_Read_Only_Entries): When pragma Detect_Blocking is active, raise + Program_Error if called from a protected operation, and increase the + protected action nesting level. + (Unlock_Entries): When pragma Detect_Blocking is active decrease the + protected action nesting level. + + * s-tposen.adb (Lock_Entry): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation, and increase + the protected action nesting level. + (Lock_Read_Only_Entry): When pragma Detect_Blocking is active, raise + Program_Error if called from a protected operation, and increase the + protected action nesting level. + (Protected_Single_Entry_Call): When pragma Detect_Blocking is active, + raise Program_Error if called from a protected operation. + (Timed_Protected_Single_Entry_Call): When pragma Detect_Blocking is + active, raise Program_Error if called from a protected operation. + (Unlock_Entry): When pragma Detect_Blocking is active decrease the + protected action nesting level. + + * sem_util.adb (Check_Potentially_Blocking_Operation): Remove the + insertion of the statement raising Program_Error. The run time + contains the required machinery for handling that. + + * sem_util.ads: Change comment associated to procedure + Check_Potentially_Blocking_Operation. + This procedure does not insert a call for raising the exception because + that is currently done by the run time. + + * raise.h (__gnat_set_globals): Pass the detect_blocking parameter. + + * init.c: Add the global variable __gl_detect_blocking that indicates + whether pragma Detect_Blocking is active (1) or not (0). Needed for + making the pragma available at run time. + (__gnat_set_globals): Pass and update the detect_blocking parameter. + + * lib-writ.adb (Write_ALI): Set the DB flag in the ali file if + pragma Detect_Blocking is active. + + * lib-writ.ads: Document the Detect_Blocking flag (DB) in ali files. + + * ali.adb (Scan_ALI): Set the Detect_Blocking value to true if the flag + DB is found in the ali file. Any unit compiled with pragma + Detect_Blocking active forces its effect in the whole partition. + + * a-retide.adb (Delay_Until): Raise Program_Error if pragma + Detect_Blocking is active and delay is called from a protected + operation. + + * bindgen.adb (Gen_Adainit_Ada): When generating the call to + __gnat_set_globals, pass 1 as Detect_Blocking parameter if pragma + Detect_Blocking is active (0 otherwise). + (Gen_Adainit_C): When generating the call to __gnat_set_globals, pass 1 + as Detect_Blocking parameter if pragma Detect_Blocking is active (0 + otherwise). + +2004-09-09 Thomas Quinot <quinot@act-europe.fr> + + * gnat_rm.texi: Rename GNAT.Perfect_Hash.Generators to + GNAT.Perfect_Hash_Generators, and remove the empty GNAT.Perfect_Hash + package. + + * s-parint.ads, s-parint.adb (Get_RAS_Info): New subprogram. + (Register_Receiving_Stub): Add Subp_Info formal parameter. + Update API in placeholder implemetation of s-parint to reflect changes + in distribution runtime library. + + * sem_ch3.adb (Expand_Derived_Record): Rename to + Expand_Record_Extension. + + * sem_disp.adb (Check_Controlling_Formals): Improve error message for + primitive operations of potentially distributed object types that have + non-controlling anonymous access formals. + + * sem_dist.ads, sem_dist.adb (Build_RAS_Primitive_Specification): New + subprogram. + New implementation of expansion for remote access-to-subprogram types, + based on the RACW infrastructure. + This version of sem_dist is compatible with PolyORB/DSA as well as + GLADE. + + * sem_prag.adb (Analyze_Pragma, case Pragma_Asynchronous): For a pragma + Asynchrronous that applies to a remote access-to-subprogram type, mark + the underlying RACW type as asynchronous. + + * link.c: FreeBSD uses GNU ld: set __gnat_objlist_file_supported and + __gnat_using_gnu_linker to 1. + + * Makefile.rtl, impunit.adb, g-perhas.ads, g-pehage.ads, + g-pehage.adb: Rename GNAT.Perfect_Hash.Generators to + GNAT.Perfect_Hash_Generators, and remove the empty + GNAT.Perfect_Hash package. + + * atree.adb: Minor reformatting + + * exp_ch3.adb (Expand_Derived_Record): Rename to + Expand_Record_Extension. + (Build_Record_Init_Proc.Build_Assignment): The default expression in + a component declaration must remain attached at that point in the + tree so New_Copy_Tree copies it if the enclosing record type is derived. + It is therefore necessary to take a copy of the expression when building + the corresponding assignment statement in the init proc. + As a side effect, in the case of a derived record type, we now see the + original expression, without any rewriting that could have occurred + during expansion of the ancestor type's init proc, and we do not need + to go back to Original_Node. + + * exp_ch3.ads (Expand_Derived_Record): Rename to + Expand_Record_Extension. + + * exp_dist.ads, exp_dist.adb (Underlying_RACW_Type): New subprogram. + Returns the RACW type used to implement a remote access-to-subprogram + type. + (Add_RAS_Proxy_And_Analyze, Build_Remote_Subprogram_Proxy_Type): + New subprograms. Used to create a proxy tagged object for a remote + subprogram. The proxy object is used as the designated object + for RAS values on the same partition (unless All_Calls_Remote applies). + (Build_Get_Unique_RP_Call): New subprogram. Build a call to + System.Partition_Interface.Get_Unique_Remote_Pointer. + (Add_RAS_Access_TSS, Add_RAS_Dereference_TSS): + Renamed from Add_RAS_*_Attribute. + (Add_Receiving_Stubs_To_Declarations): Generate a table of local + subprograms. + New implementation of expansion for remote access-to-subprogram types, + based on the RACW infrastructure. + + * exp_dist.ads (Copy_Specification): Update comment to note that this + function can copy the specification from either a subprogram + specification or an access-to-subprogram type definition. + +2004-09-09 Ed Schonberg <schonberg@gnat.com> + + * sem_type.adb (Disambiguate): Handle properly an accidental ambiguity + in an instance, between an explicit subprogram an one inherited from a + type derived from an actual. + + * exp_ch6.adb (Expand_N_Subprogram_Body): If polling is enabled, do not + add a polling call if the subprogram is to be inlined by the back-end, + to avoid repeated calls with multiple inlinings. + + * checks.adb (Apply_Alignment_Check): If the expression in the address + clause is a call whose name is not a static entity (e.g. a dispatching + call), treat as dynamic. + +2004-09-09 Robert Dewar <dewar@gnat.com> + + * g-trasym.ads: Minor reformatting + + * exp_ch3.adb (Component_Needs_Simple_Initialization): Don't except + packed arrays, since unused bits are expected to be zero for a + comparison. + +2004-09-09 Eric Botcazou <ebotcazou@act-europe.fr> + + * exp_pakd.ads: Fix an inacurracy and a couple of typos in the head + comment. + +2004-09-09 Pascal Obry <obry@gnat.com> + + * mdll.ads, mdll.adb (Build_Dynamic_Library): New parameter Map_File to + enable map file generation. Add the right option to generate the map + file if Map_File is set to True. + + * gnatdll.adb (Gen_Map_File): New variable. + (Syntax): Add info about new -m (Map_File) option. + (Parse_Command_Line): Add support for -m option. + (gnatdll): Pass Gen_Map_File to Build_Dynamic_Library calls. + Minor reformatting. + +2004-09-09 Laurent Pautet <pautet@act-europe.fr> + + * gnatls.adb: Add a very verbose mode -V. Such mode is required by the + new gnatdist implementation. + Define a subpackage isolating the output routines specific to this + verbose mode. + +2004-09-09 Joel Brobecker <brobecker@gnat.com> + + * Makefile.rtl: (GNATRTL_NONTASKING_OBJS): Add g-dynhta. + + * gnat_ugn.texi (Main Subprograms): Fix typo. Deduced, not deducted. + +2004-09-09 Cyrille Comar <comar@act-europe.fr> + + * opt.adb (Set_Opt_Config_Switches): Use Ada_Version_Runtime to compile + internal unit. + + * opt.ads: Add Ada_Version_Runtime constant used to decide which + version of the language is used to compile the run time. + +2004-09-09 Arnaud Charlet <charlet@act-europe.fr> + + * sem_util.adb (Requires_Transient_Scope): Re-enable handling + of variable length temporaries for function return now that the + back-end and gigi support it. + 2004-09-01 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> * misc.c (gnat_print_type): Use TYPE_RM_SIZE_NUM. diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index e3b9507c1f6..1dba67473a3 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -308,7 +308,7 @@ GNATMAKE_OBJS = a-except.o ctrl_c.o ali.o ali-util.o s-casuti.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 \ + prj.o prj-attr.o prj-attr-pm.o prj-com.o prj-dect.o prj-env.o prj-err.o prj-ext.o prj-nmsc.o \ prj-pars.o prj-part.o prj-proc.o prj-strt.o prj-tree.o prj-util.o \ rident.o s-exctab.o s-secsta.o s-stalib.o s-stoele.o \ scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o \ diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 10031f8e07d..4c01553fe50 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -219,6 +219,7 @@ GNATRTL_NONTASKING_OBJS= \ g-diopit$(objext) \ g-dirope$(objext) \ g-dyntab$(objext) \ + g-dynhta$(objext) \ g-except$(objext) \ g-excact$(objext) \ g-exctra$(objext) \ @@ -235,7 +236,6 @@ GNATRTL_NONTASKING_OBJS= \ g-memdum$(objext) \ g-moreex$(objext) \ g-os_lib$(objext) \ - g-perhas$(objext) \ g-pehage$(objext) \ g-regexp$(objext) \ g-regpat$(objext) \ diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb index fdab0cb5572..e5788a473e2 100644 --- a/gcc/ada/a-calend.adb +++ b/gcc/ada/a-calend.adb @@ -417,7 +417,7 @@ package body Ada.Calendar is end if; -- Check for Day value too large (one might expect mktime to do this - -- check, as well as the basi checks we did with 'Valid, but it seems + -- check, as well as the basic checks we did with 'Valid, but it seems -- that at least on some systems, this built-in check is too weak). if Day > Days_In_Month (Month) diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb index 74757fe8077..db0a9317c75 100644 --- a/gcc/ada/a-direct.adb +++ b/gcc/ada/a-direct.adb @@ -38,22 +38,25 @@ with Ada.Unchecked_Deallocation; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regexp; use GNAT.Regexp; +-- ??? Ada units cannot depend on GNAT units with System; package body Ada.Directories is type Search_Data is record - Is_Valid : Boolean := False; - Name : Ada.Strings.Unbounded.Unbounded_String; - Pattern : Regexp; - Filter : Filter_Type; - Dir : Dir_Type; + Is_Valid : Boolean := False; + Name : Ada.Strings.Unbounded.Unbounded_String; + Pattern : Regexp; + Filter : Filter_Type; + Dir : Dir_Type; Entry_Fetched : Boolean := False; Dir_Entry : Directory_Entry_Type; end record; + -- Comment required ??? Empty_String : constant String := (1 .. 0 => ASCII.NUL); + -- Comment required ??? procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr); @@ -97,9 +100,8 @@ package body Ada.Directories is Name : String; Extension : String := "") return String is - Result : String (1 .. - Containing_Directory'Length + - Name'Length + Extension'Length + 2); + Result : String (1 .. Containing_Directory'Length + + Name'Length + Extension'Length + 2); Last : Natural; begin @@ -205,9 +207,9 @@ package body Ada.Directories is begin -- First, the invalid cases - if (not Is_Valid_Path_Name (Source_Name)) or else - (not Is_Valid_Path_Name (Target_Name)) or else - (not Is_Regular_File (Source_Name)) + if not Is_Valid_Path_Name (Source_Name) + or else not Is_Valid_Path_Name (Target_Name) + or else not Is_Regular_File (Source_Name) then raise Name_Error; @@ -328,10 +330,17 @@ package body Ada.Directories is ----------------------- function Current_Directory return String is - begin + -- The implementation uses GNAT.Directory_Operations.Get_Current_Dir - return Get_Current_Dir; + Cur : constant String := Get_Current_Dir; + + begin + if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then + return Cur (1 .. Cur'Last - 1); + else + return Cur; + end if; end Current_Directory; ---------------------- @@ -340,11 +349,14 @@ package body Ada.Directories is procedure Delete_Directory (Directory : String) is begin - -- First, the invalid case + -- First, the invalid cases if not Is_Valid_Path_Name (Directory) then raise Name_Error; + elsif not Is_Directory (Directory) then + raise Name_Error; + else -- The implementation uses GNAT.Directory_Operations.Remove_Dir @@ -391,11 +403,14 @@ package body Ada.Directories is procedure Delete_Tree (Directory : String) is begin - -- First, the invalid case + -- First, the invalid cases if not Is_Valid_Path_Name (Directory) then raise Name_Error; + elsif not Is_Directory (Directory) then + raise Name_Error; + else -- The implementation uses GNAT.Directory_Operations.Remove_Dir @@ -439,13 +454,12 @@ package body Ada.Directories is raise Name_Error; else - -- Look fir the first dot that is not followed by a directory - -- separator. + -- Look for first dot that is not followed by a directory separator for Pos in reverse Name'Range loop - -- If a directory separator is found before a dot, there is no - -- extension. + -- If a directory separator is found before a dot, there + -- is no extension. if Name (Pos) = Dir_Separator then return Empty_String; @@ -459,6 +473,8 @@ package body Ada.Directories is begin Result := Name (Pos + 1 .. Name'Last); return Result; + -- This should be done with a subtype conversion, avoiding + -- the unnecessary junk copy ??? end; end if; end loop; @@ -476,7 +492,9 @@ package body Ada.Directories is procedure Fetch_Next_Entry (Search : Search_Type) is Name : String (1 .. 255); Last : Natural; - Kind : File_Kind; + + Kind : File_Kind := Ordinary_File; + -- Initialized to avoid a compilation warning begin -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called @@ -499,7 +517,7 @@ package body Ada.Directories is Compose (To_String (Search.Value.Name), Name (1 .. Last)); - Found : Boolean := False; + Found : Boolean := False; begin if File_Exists (Full_Name) then @@ -553,7 +571,6 @@ package body Ada.Directories is begin C_Name (1 .. Name'Length) := Name; C_Name (C_Name'Last) := ASCII.NUL; - return C_File_Exists (C_Name (1)'Address) = 1; end File_Exists; @@ -587,8 +604,9 @@ package body Ada.Directories is raise Name_Error; else - -- Build the return value with lower bound 1. - -- Use GNAT.OS_Lib.Normalize_Pathname. + -- Build the return value with lower bound 1 + + -- Use GNAT.OS_Lib.Normalize_Pathname declare Value : constant String := Normalize_Pathname (Name); @@ -596,6 +614,7 @@ package body Ada.Directories is begin Result := Value; return Result; + -- Should use subtype conversion, not junk copy ??? end; end if; end Full_Name; @@ -775,7 +794,7 @@ package body Ada.Directories is raise Use_Error; else - -- The implemewntation uses GNAT.OS_Lib.Rename_File + -- The implementation uses GNAT.OS_Lib.Rename_File Rename_File (Old_Name, New_Name, Success); @@ -812,16 +831,18 @@ package body Ada.Directories is raise Name_Error; else - -- Build the value to return with lower bound 1. - -- The implementation uses GNAT.Directory_Operations.Base_Name. + -- Build the value to return with lower bound 1 + + -- The implementation uses GNAT.Directory_Operations.Base_Name declare - Value : constant String := + Value : constant String := GNAT.Directory_Operations.Base_Name (Name); Result : String (1 .. Value'Length); begin Result := Value; return Result; + -- Should use subtype conversion instead of junk copy ??? end; end if; end Simple_Name; @@ -849,7 +870,7 @@ package body Ada.Directories is function Size (Name : String) return File_Size is C_Name : String (1 .. Name'Length + 1); - function C_Size (Name : System.Address) return File_Size; + function C_Size (Name : System.Address) return Long_Integer; pragma Import (C, C_Size, "__gnat_named_file_length"); begin @@ -861,7 +882,7 @@ package body Ada.Directories is else C_Name (1 .. Name'Length) := Name; C_Name (C_Name'Last) := ASCII.NUL; - return C_Size (C_Name'Address); + return File_Size (C_Size (C_Name'Address)); end if; end Size; diff --git a/gcc/ada/a-direct.ads b/gcc/ada/a-direct.ads index d71e49357ed..4cd2340a79c 100644 --- a/gcc/ada/a-direct.ads +++ b/gcc/ada/a-direct.ads @@ -77,6 +77,9 @@ with Ada.Strings.Unbounded; package Ada.Directories is + pragma Ada_05; + -- To be removed later ??? + ----------------------------------- -- Directory and File Operations -- ----------------------------------- @@ -386,7 +389,7 @@ private Is_Valid : Boolean := False; Simple : Ada.Strings.Unbounded.Unbounded_String; Full : Ada.Strings.Unbounded.Unbounded_String; - Kind : File_Kind; + Kind : File_Kind := Ordinary_File; end record; -- The type Search_Data is defined in the body, so that the spec does not diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 3f574085a48..22331f318dd 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -516,6 +516,37 @@ package body Ada.Exceptions is pragma Export (C, Rcheck_28, "__gnat_rcheck_28"); pragma Export (C, Rcheck_29, "__gnat_rcheck_29"); + pragma No_Return (Rcheck_00); + pragma No_Return (Rcheck_01); + pragma No_Return (Rcheck_02); + pragma No_Return (Rcheck_03); + pragma No_Return (Rcheck_04); + pragma No_Return (Rcheck_05); + pragma No_Return (Rcheck_06); + pragma No_Return (Rcheck_07); + pragma No_Return (Rcheck_08); + pragma No_Return (Rcheck_09); + pragma No_Return (Rcheck_10); + pragma No_Return (Rcheck_11); + pragma No_Return (Rcheck_12); + pragma No_Return (Rcheck_13); + pragma No_Return (Rcheck_14); + pragma No_Return (Rcheck_15); + pragma No_Return (Rcheck_16); + pragma No_Return (Rcheck_17); + pragma No_Return (Rcheck_18); + pragma No_Return (Rcheck_19); + pragma No_Return (Rcheck_20); + pragma No_Return (Rcheck_21); + pragma No_Return (Rcheck_22); + pragma No_Return (Rcheck_23); + pragma No_Return (Rcheck_24); + pragma No_Return (Rcheck_25); + pragma No_Return (Rcheck_26); + pragma No_Return (Rcheck_27); + pragma No_Return (Rcheck_28); + pragma No_Return (Rcheck_29); + --------------------------------------------- -- Reason Strings for Run-Time Check Calls -- --------------------------------------------- diff --git a/gcc/ada/a-retide.adb b/gcc/ada/a-retide.adb index ca747a16609..325a6b3717a 100644 --- a/gcc/ada/a-retide.adb +++ b/gcc/ada/a-retide.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,13 +31,24 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Exceptions; +-- Used for Raise_Exception + +with System.Tasking; +-- Used for Task_Id + with System.Task_Primitives.Operations; -- Used for Timed_Delay +-- Self package body Ada.Real_Time.Delays is package STPO renames System.Task_Primitives.Operations; + ---------------- + -- Local Data -- + ---------------- + Absolute_RT : constant := 2; ----------------- @@ -45,8 +56,21 @@ package body Ada.Real_Time.Delays is ----------------- procedure Delay_Until (T : Time) is + Self_Id : constant System.Tasking.Task_Id := STPO.Self; + begin - STPO.Timed_Delay (STPO.Self, To_Duration (T), Absolute_RT); + -- If pragma Detect_Blocking is active, Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + STPO.Timed_Delay (Self_Id, To_Duration (T), Absolute_RT); + end if; end Delay_Until; ----------------- diff --git a/gcc/ada/ada-tree.h b/gcc/ada/ada-tree.h index 7cbbac1d3f5..21f1cafb2ca 100644 --- a/gcc/ada/ada-tree.h +++ b/gcc/ada/ada-tree.h @@ -131,6 +131,11 @@ struct lang_type GTY(()) {tree t; }; #define TYPE_RETURNS_BY_REF_P(NODE) \ TYPE_LANG_FLAG_4 (FUNCTION_TYPE_CHECK (NODE)) +/* For FUNCTION_TYPEs, nonzero if function returns by being passed a pointer + to a place to store its result. */ +#define TYPE_RETURNS_BY_TARGET_PTR_P(NODE) \ + TYPE_LANG_FLAG_5 (FUNCTION_TYPE_CHECK (NODE)) + /* For VOID_TYPE, ENUMERAL_TYPE, UNION_TYPE, and RECORD_TYPE, nonzero if this is a dummy type, made to correspond to a private or incomplete type. */ #define TYPE_DUMMY_P(NODE) TYPE_LANG_FLAG_4 (NODE) diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 3326ecaafad..c1e51b4d472 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -815,6 +815,12 @@ package body ALI is Checkc ('E'); ALIs.Table (Id).Compile_Errors := True; + -- Processing for DB + + elsif C = 'D' then + Checkc ('B'); + Detect_Blocking := True; + -- Processing for FD/FG/FI elsif C = 'F' then diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index c03a1836194..daf0641cfe6 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -1429,7 +1429,6 @@ package body Atree is Set_Field5 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node))); - -- Adjust Sloc of new node if necessary if New_Sloc /= No_Location then diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index fe9192a251e..dca5bbe67f4 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -100,7 +100,8 @@ package body Bindgen is -- Num_Interrupt_States : Integer; -- Unreserve_All_Interrupts : Integer; -- Exception_Tracebacks : Integer; - -- Zero_Cost_Exceptions : Integer); + -- Zero_Cost_Exceptions : Integer; + -- Detect_Blocking : Integer); -- Main_Priority is the priority value set by pragma Priority in the -- main program. If no such pragma is present, the value is -1. @@ -162,6 +163,11 @@ package body Bindgen is -- this partition, and to zero if longjmp/setjmp exceptions are used. -- the use of zero + -- Detect_Blocking indicates whether pragma Detect_Blocking is + -- active or not. A value of zero indicates that the pragma is not + -- present, while a value of 1 signals its presence in the + -- partition. + ----------------------- -- Local Subprograms -- ----------------------- @@ -524,12 +530,14 @@ package body Bindgen is WBI (" Locking_Policy : Character;"); WBI (" Queuing_Policy : Character;"); WBI (" Task_Dispatching_Policy : Character;"); + WBI (" Restrictions : System.Address;"); WBI (" Interrupt_States : System.Address;"); WBI (" Num_Interrupt_States : Integer;"); WBI (" Unreserve_All_Interrupts : Integer;"); WBI (" Exception_Tracebacks : Integer;"); - WBI (" Zero_Cost_Exceptions : Integer);"); + WBI (" Zero_Cost_Exceptions : Integer;"); + WBI (" Detect_Blocking : Integer);"); WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");"); -- Import entry point for elaboration time signal handler @@ -630,6 +638,17 @@ package body Bindgen is Set_String ("0"); end if; + Set_String (","); + Write_Statement_Buffer; + + Set_String (" Detect_Blocking => "); + + if Detect_Blocking then + Set_Int (1); + else + Set_Int (0); + end if; + Set_String (");"); Write_Statement_Buffer; @@ -863,10 +882,23 @@ package body Bindgen is Set_String (" "); Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified)); - Set_String (");"); + Set_String (","); Tab_To (24); Set_String ("/* Zero_Cost_Exceptions */"); Write_Statement_Buffer; + + Set_String (" "); + + if Detect_Blocking then + Set_Int (1); + else + Set_Int (0); + end if; + + Set_String (");"); + Tab_To (24); + Set_String ("/* Detect_Blocking */"); + Write_Statement_Buffer; WBI (""); -- Install elaboration time signal handler @@ -2427,7 +2459,7 @@ package body Bindgen is WBI ("extern void __gnat_set_globals"); WBI (" (int, int, char, char, char, char,"); WBI (" const char *, const char *,"); - WBI (" int, int, int, int);"); + WBI (" int, int, int, int, int);"); WBI ("extern void " & Ada_Final_Name.all & " (void);"); WBI ("extern void " & Ada_Init_Name.all & " (void);"); WBI ("extern void system__standard_library__adafinal (void);"); diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 3c7839754e4..6f741011377 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -492,6 +492,7 @@ package body Checks is Expr := Expression (Expr); elsif Nkind (Expr) = N_Function_Call + and then Is_Entity_Name (Name (Expr)) and then Is_RTE (Entity (Name (Expr)), RE_To_Address) then Expr := First (Parameter_Associations (Expr)); diff --git a/gcc/ada/cuintp.c b/gcc/ada/cuintp.c index a6ce488f374..ecd21ca65d3 100644 --- a/gcc/ada/cuintp.c +++ b/gcc/ada/cuintp.c @@ -95,18 +95,18 @@ UI_To_gnu (Uint Input, tree type) gnu_ret = build_cst_from_int (comp_type, First); if (First < 0) for (Idx++, Length--; Length; Idx++, Length--) - gnu_ret = fold (build (MINUS_EXPR, comp_type, - fold (build (MULT_EXPR, comp_type, - gnu_ret, gnu_base)), - build_cst_from_int (comp_type, - Udigits_Ptr[Idx]))); + gnu_ret = fold (build2 (MINUS_EXPR, comp_type, + fold (build2 (MULT_EXPR, comp_type, + gnu_ret, gnu_base)), + build_cst_from_int (comp_type, + Udigits_Ptr[Idx]))); else for (Idx++, Length--; Length; Idx++, Length--) - gnu_ret = fold (build (PLUS_EXPR, comp_type, - fold (build (MULT_EXPR, comp_type, - gnu_ret, gnu_base)), - build_cst_from_int (comp_type, - Udigits_Ptr[Idx]))); + gnu_ret = fold (build2 (PLUS_EXPR, comp_type, + fold (build2 (MULT_EXPR, comp_type, + gnu_ret, gnu_base)), + build_cst_from_int (comp_type, + Udigits_Ptr[Idx]))); } gnu_ret = convert (type, gnu_ret); diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 33bbbb1dd61..604c47151d1 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -89,8 +89,6 @@ static bool is_variable_size (tree); static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree, bool, bool); static tree make_packable_type (tree); -static tree maybe_pad_type (tree, tree, unsigned int, Entity_Id, const char *, - bool, bool, bool); static tree gnat_to_gnu_field (Entity_Id, tree, int, bool); static void components_to_record (tree, Node_Id, tree, int, bool, tree *, bool, bool); @@ -877,13 +875,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_expr = gnu_address; else gnu_expr - = build (COMPOUND_EXPR, gnu_type, - build_binary_op - (MODIFY_EXPR, NULL_TREE, - build_unary_op (INDIRECT_REF, NULL_TREE, - gnu_address), - gnu_expr), - gnu_address); + = build2 (COMPOUND_EXPR, gnu_type, + build_binary_op + (MODIFY_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, NULL_TREE, + gnu_address), + gnu_expr), + gnu_address); } /* If it has an address clause and we are not defining it, mark it @@ -1234,8 +1232,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { TYPE_MODULAR_P (gnu_type) = 1; SET_TYPE_MODULUS (gnu_type, gnu_modulus); - gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus, - convert (gnu_type, integer_one_node))); + gnu_high = fold (build2 (MINUS_EXPR, gnu_type, gnu_modulus, + convert (gnu_type, integer_one_node))); } /* If we have to set TYPE_PRECISION different from its natural value, @@ -1511,9 +1509,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* Build a reference to the template from a PLACEHOLDER_EXPR that is the fat pointer. This will be used to access the individual fields once we build them. */ - tem = build (COMPONENT_REF, gnu_ptr_template, - build (PLACEHOLDER_EXPR, gnu_fat_type), - TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE); + tem = build3 (COMPONENT_REF, gnu_ptr_template, + build0 (PLACEHOLDER_EXPR, gnu_fat_type), + TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE); gnu_template_reference = build_unary_op (INDIRECT_REF, gnu_template_type, tem); TREE_READONLY (gnu_template_reference) = 1; @@ -1559,10 +1557,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* We can't use build_component_ref here since the template type isn't complete yet. */ - gnu_min = build (COMPONENT_REF, gnu_ind_subtype, - gnu_template_reference, gnu_min_field, NULL_TREE); - gnu_max = build (COMPONENT_REF, gnu_ind_subtype, - gnu_template_reference, gnu_max_field, NULL_TREE); + gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype, + gnu_template_reference, gnu_min_field, + NULL_TREE); + gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype, + gnu_template_reference, gnu_max_field, + NULL_TREE); TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1; /* Make a range type with the new ranges, but using @@ -1802,9 +1802,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && TREE_CODE (gnu_max) == INTEGER_CST && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max) && (!TREE_OVERFLOW - (fold (build (MINUS_EXPR, gnu_index_subtype, - TYPE_MAX_VALUE (gnu_index_subtype), - TYPE_MIN_VALUE (gnu_index_subtype)))))) + (fold (build2 (MINUS_EXPR, gnu_index_subtype, + TYPE_MAX_VALUE (gnu_index_subtype), + TYPE_MIN_VALUE (gnu_index_subtype)))))) TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max) = TREE_CONSTANT_OVERFLOW (gnu_min) = TREE_CONSTANT_OVERFLOW (gnu_max) = 0; @@ -2360,11 +2360,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) COMPONENT_REF which will be filled in below, once the parent type can be safely built. */ - gnu_get_parent = build (COMPONENT_REF, void_type_node, - build (PLACEHOLDER_EXPR, gnu_type), - build_decl (FIELD_DECL, NULL_TREE, - NULL_TREE), - NULL_TREE); + gnu_get_parent = build3 (COMPONENT_REF, void_type_node, + build0 (PLACEHOLDER_EXPR, gnu_type), + build_decl (FIELD_DECL, NULL_TREE, + NULL_TREE), + NULL_TREE); if (Has_Discriminants (gnat_entity)) for (gnat_field = First_Stored_Discriminant (gnat_entity); @@ -2373,13 +2373,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (Present (Corresponding_Discriminant (gnat_field))) save_gnu_tree (gnat_field, - build (COMPONENT_REF, - get_unpadded_type (Etype (gnat_field)), - gnu_get_parent, - gnat_to_gnu_entity (Corresponding_Discriminant - (gnat_field), + build3 (COMPONENT_REF, + get_unpadded_type (Etype (gnat_field)), + gnu_get_parent, + gnat_to_gnu_entity (Corresponding_Discriminant + (gnat_field), NULL_TREE, 0), - NULL_TREE), + NULL_TREE), true); gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity)); @@ -2418,10 +2418,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) corresponding GNAT defining identifier. Then add to the list of fields. */ save_gnu_tree (gnat_field, - build (COMPONENT_REF, TREE_TYPE (gnu_field), - build (PLACEHOLDER_EXPR, - DECL_CONTEXT (gnu_field)), - gnu_field, NULL_TREE), + build3 (COMPONENT_REF, TREE_TYPE (gnu_field), + build0 (PLACEHOLDER_EXPR, + DECL_CONTEXT (gnu_field)), + gnu_field, NULL_TREE), true); TREE_CHAIN (gnu_field) = gnu_field_list; @@ -3243,6 +3243,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) bool volatile_flag = No_Return (gnat_entity); bool returns_by_ref = false; bool returns_unconstrained = false; + bool returns_by_target_ptr = false; tree gnu_ext_name = create_concat_name (gnat_entity, 0); bool has_copy_in_out = false; int parmnum; @@ -3323,9 +3324,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) || Has_Foreign_Convention (gnat_entity))) gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type)); - /* Look at all our parameters and get the type of - each. While doing this, build a copy-out structure if - we need one. */ + /* If the return type is unconstrained, that means it must have a + maximum size. We convert the function into a procedure and its + caller will pass a pointer to an object of that maximum size as the + first parameter when we call the function. */ + if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type))) + { + returns_by_target_ptr = true; + gnu_param_list + = create_param_decl (get_identifier ("TARGET"), + build_reference_type (gnu_return_type), + true); + gnu_return_type = void_type_node; + } /* If the return type has a size that overflows, we cannot have a function that returns that type. This usage doesn't make @@ -3339,9 +3350,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_SIZE (gnu_return_type) = bitsize_zero_node; TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node; TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type; - TYPE_NEXT_VARIANT (gnu_return_type) = 0; + TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE; } + /* Look at all our parameters and get the type of + each. While doing this, build a copy-out structure if + we need one. */ + for (gnat_param = First_Formal (gnat_entity), parmnum = 0; Present (gnat_param); gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++) @@ -3599,7 +3614,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = create_subprog_type (gnu_return_type, gnu_param_list, gnu_return_list, returns_unconstrained, returns_by_ref, - Function_Returns_With_DSP (gnat_entity)); + Function_Returns_With_DSP (gnat_entity), + returns_by_target_ptr); /* A subprogram (something that doesn't return anything) shouldn't be considered Pure since there would be no reason for such a @@ -4524,9 +4540,9 @@ elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity, here. We have to hope it will be at the highest level of the expression in these cases. */ if (TREE_CODE (gnu_expr) == FIELD_DECL) - gnu_expr = build (COMPONENT_REF, TREE_TYPE (gnu_expr), - build (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)), - gnu_expr, NULL_TREE); + gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr), + build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)), + gnu_expr, NULL_TREE); /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable that is a constant, make a variable that is initialized to contain the @@ -4576,7 +4592,7 @@ tree make_aligning_type (tree type, int align, tree size) { tree record_type = make_node (RECORD_TYPE); - tree place = build (PLACEHOLDER_EXPR, record_type); + tree place = build0 (PLACEHOLDER_EXPR, record_type); tree size_addr_place = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, place)); @@ -4701,7 +4717,7 @@ make_packable_type (tree type) set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original type. */ -static tree +tree maybe_pad_type (tree type, tree size, unsigned int align, Entity_Id gnat_entity, const char *name_trailer, bool is_user_type, bool definition, bool same_rm_size) @@ -5587,7 +5603,7 @@ annotate_value (tree gnu_size) temp = build1 (NEGATE_EXPR, bitsizetype, negative_size); if (adjust) - temp = build (MINUS_EXPR, bitsizetype, temp, bitsize_one_node); + temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node); return annotate_value (temp); } diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 39d704efab5..631900a7c93 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1400,17 +1400,10 @@ package body Exp_Ch3 is (T : Entity_Id) return Boolean; -- Determines if a component needs simple initialization, given its -- type T. This is the same as Needs_Simple_Initialization except - -- for the following differences. The types Tag and Vtable_Ptr, - -- which are access types which would normally require simple - -- initialization to null, do not require initialization as - -- components, since they are explicitly initialized by other - -- means. The other relaxation is for packed bit arrays that are - -- associated with a modular type, which in some cases require - -- zero initialization to properly support comparisons, except - -- that comparison of such components always involves an explicit - -- selection of only the component's specific bits (whether or not - -- there are adjacent components or gaps), so zero initialization - -- is never needed for components. + -- for the following difference: the types Tag and Vtable_Ptr, which + -- are access types which would normally require simple initialization + -- to null, do not require initialization as components, since they + -- are explicitly initialized by other means. procedure Constrain_Array (SI : Node_Id; @@ -1457,16 +1450,14 @@ package body Exp_Ch3 is Selector_Name => New_Occurrence_Of (Id, Loc)); Set_Assignment_OK (Lhs); - -- Case of an access attribute applied to the current - -- instance. Replace the reference to the type by a - -- reference to the actual object. (Note that this - -- handles the case of the top level of the expression - -- being given by such an attribute, but doesn't cover - -- uses nested within an initial value expression. - -- Nested uses are unlikely to occur in practice, - -- but theoretically possible. It's not clear how - -- to handle them without fully traversing the - -- expression. ???) + -- Case of an access attribute applied to the current instance. + -- Replace the reference to the type by a reference to the actual + -- object. (Note that this handles the case of the top level of + -- the expression being given by such an attribute, but does not + -- cover uses nested within an initial value expression. Nested + -- uses are unlikely to occur in practice, but are theoretically + -- possible. It is not clear how to handle them without fully + -- traversing the expression. ??? if Kind = N_Attribute_Reference and then (Attribute_Name (N) = Name_Unchecked_Access @@ -1482,23 +1473,8 @@ package body Exp_Ch3 is Attribute_Name => Name_Unrestricted_Access); end if; - -- For a derived type the default value is copied from the component - -- declaration of the parent. In the analysis of the init_proc for - -- the parent the default value may have been expanded into a local - -- variable, which is of course not usable here. We must copy the - -- original expression and reanalyze. - - if Nkind (Exp) = N_Identifier - and then not Comes_From_Source (Exp) - and then Analyzed (Exp) - and then not In_Open_Scopes (Scope (Entity (Exp))) - and then Nkind (Original_Node (Exp)) = N_Aggregate - then - Exp := New_Copy_Tree (Original_Node (Exp)); - end if; - -- Ada 2005 (AI-231): Generate conversion to the null-excluding - -- type to force the corresponding run-time check + -- type to force the corresponding run-time check. if Ada_Version >= Ada_05 and then Can_Never_Be_Null (Etype (Id)) -- Lhs @@ -1509,6 +1485,12 @@ package body Exp_Ch3 is Analyze_And_Resolve (Exp, Etype (Id)); end if; + -- Take a copy of Exp to ensure that later copies of this + -- component_declaration in derived types see the original tree, + -- not a node rewritten during expansion of the init_proc. + + Exp := New_Copy_Tree (Exp); + Res := New_List ( Make_Assignment_Statement (Loc, Name => Lhs, @@ -2243,8 +2225,7 @@ package body Exp_Ch3 is return Needs_Simple_Initialization (T) and then not Is_RTE (T, RE_Tag) - and then not Is_RTE (T, RE_Vtable_Ptr) - and then not Is_Bit_Packed_Array (T); + and then not Is_RTE (T, RE_Vtable_Ptr); end Component_Needs_Simple_Initialization; --------------------- @@ -3049,9 +3030,9 @@ package body Exp_Ch3 is end if; end Check_Stream_Attributes; - --------------------------- - -- Expand_Derived_Record -- - --------------------------- + ----------------------------- + -- Expand_Record_Extension -- + ----------------------------- -- Add a field _parent at the beginning of the record extension. This is -- used to implement inheritance. Here are some examples of expansion: @@ -3075,7 +3056,7 @@ package body Exp_Ch3 is -- D : Int; -- end; - procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id) is + procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is Indic : constant Node_Id := Subtype_Indication (Def); Loc : constant Source_Ptr := Sloc (Def); Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); @@ -3087,7 +3068,7 @@ package body Exp_Ch3 is List_Constr : constant List_Id := New_List; begin - -- Expand_Tagged_Extension is called directly from the semantics, so + -- Expand_Record_Extension is called directly from the semantics, so -- we must check to see whether expansion is active before proceeding if not Expander_Active then @@ -3170,7 +3151,7 @@ package body Exp_Ch3 is end if; Analyze (Comp_Decl); - end Expand_Derived_Record; + end Expand_Record_Extension; ------------------------------------ -- Expand_N_Full_Type_Declaration -- @@ -5605,7 +5586,6 @@ package body Exp_Ch3 is elsif Is_Access_Type (T) or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) - or else (Is_Bit_Packed_Array (T) and then Is_Modular_Integer_Type (Packed_Array_Type (T))) then diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 7fc124aeb9a..27cd7d8c1a3 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -43,7 +43,7 @@ package Exp_Ch3 is -- the master for that access type, now that it is known to denote an -- object with tasks. - procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id); + procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id); -- Add a field _parent in the extension part of the record. procedure Build_Discr_Checking_Funcs (N : Node_Id); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 0dd84eaf22c..df976adec6f 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3043,7 +3043,8 @@ package body Exp_Ch6 is -- Expand_N_Subprogram_Body -- ------------------------------ - -- Add poll call if ATC polling is enabled + -- Add poll call if ATC polling is enabled, unless the body will be + -- inlined by the back-end. -- Add return statement if last statement in body is not a return -- statement (this makes things easier on Gigi which does not want @@ -3272,14 +3273,6 @@ package body Exp_Ch6 is L := Statements (Handled_Statement_Sequence (N)); end if; - -- Need poll on entry to subprogram if polling enabled. We only - -- do this for non-empty subprograms, since it does not seem - -- necessary to poll for a dummy null subprogram. - - if Is_Non_Empty_List (L) then - Generate_Poll_Call (First (L)); - end if; - -- Find entity for subprogram Body_Id := Defining_Entity (N); @@ -3290,6 +3283,23 @@ package body Exp_Ch6 is Spec_Id := Body_Id; end if; + -- Need poll on entry to subprogram if polling enabled. We only + -- do this for non-empty subprograms, since it does not seem + -- necessary to poll for a dummy null subprogram. Do not add polling + -- point if calls to this subprogram will be inlined by the back-end, + -- to avoid repeated polling points in nested inlinings. + + if Is_Non_Empty_List (L) then + if Is_Inlined (Spec_Id) + and then Front_End_Inlining + and then Optimization_Level > 1 + then + null; + else + Generate_Poll_Call (First (L)); + end if; + end if; + -- If this is a Pure function which has any parameters whose root -- type is System.Address, reset the Pure indication, since it will -- likely cause incorrect code to be generated as the parameter is diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index e3c176ad178..70150793269 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -76,27 +76,63 @@ package body Exp_Dist is -- to fake half a derivation to ensure that the subprograms do have -- the same dispatching table. + First_RCI_Subprogram_Id : constant := 2; + -- RCI subprograms are numbered starting at 2. The RCI receiver for + -- an RCI package can thus identify calls received through remote + -- access-to-subprogram dereferences by the fact that they have a + -- (primitive) subprogram id of 0, and 1 is used for the internal + -- RAS information lookup operation. + ----------------------- -- Local subprograms -- ----------------------- + procedure Add_RAS_Proxy_And_Analyze + (Decls : List_Id; + Vis_Decl : Node_Id; + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : out Entity_Id); + -- Add the proxy type necessary to call the subprogram declared + -- by Vis_Decl through a remote access to subprogram type. + -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote + -- applies, Standard_False otherwise. The new proxy type is appended + -- to Decls. Proxy_Object_Addr is a constant of type System.Address that + -- designates an instance of the proxy object. + + function Build_Remote_Subprogram_Proxy_Type + (Loc : Source_Ptr; + ACR_Expression : Node_Id) return Node_Id; + -- Build and return a tagged record type definition for an RCI + -- subprogram proxy type. + -- ACR_Expression is use as the initialization value for + -- the All_Calls_Remote component. + function Get_Subprogram_Id (E : Entity_Id) return Int; -- Given a subprogram defined in a RCI package, get its subprogram id -- which will be used for remote calls. + function Build_Get_Unique_RP_Call + (Loc : Source_Ptr; + Pointer : Entity_Id; + Stub_Type : Entity_Id) return List_Id; + -- Build a call to Get_Unique_Remote_Pointer (Pointer), + -- followed by a tag fixup (Get_Unique_Remote_Pointer may have + -- changed Pointer'Tag to RACW_Stub_Type'Tag, while the desired + -- tag is that of Stub_Type). + procedure Build_General_Calling_Stubs - (Decls : in List_Id; - Statements : in List_Id; - Target_Partition : in Entity_Id; - RPC_Receiver : in Node_Id; - Subprogram_Id : in Node_Id; - Asynchronous : in Node_Id := Empty; - Is_Known_Asynchronous : in Boolean := False; - Is_Known_Non_Asynchronous : in Boolean := False; - Is_Function : in Boolean; - Spec : in Node_Id; - Object_Type : in Entity_Id := Empty; - Nod : in Node_Id); + (Decls : List_Id; + Statements : List_Id; + Target_Partition : Entity_Id; + RPC_Receiver : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Object_Type : Entity_Id := Empty; + Nod : Node_Id); -- Build calling stubs for general purpose. The parameters are: -- Decls : a place to put declarations -- Statements : a place to put statements @@ -124,8 +160,7 @@ package body Exp_Dist is Dynamically_Asynchronous : Boolean := False; Stub_Type : Entity_Id := Empty; Locator : Entity_Id := Empty; - New_Name : Name_Id := No_Name) - return Node_Id; + New_Name : Name_Id := No_Name) return Node_Id; -- Build the calling stub for a given subprogram with the subprogram ID -- being Subp_Id. If Stub_Type is given, then the "addr" field of -- parameters of this type will be marshalled instead of the object @@ -142,8 +177,7 @@ package body Exp_Dist is Dynamically_Asynchronous : Boolean := False; Stub_Type : Entity_Id := Empty; RACW_Type : Entity_Id := Empty; - Parent_Primitive : Entity_Id := Empty) - return Node_Id; + Parent_Primitive : Entity_Id := Empty) return Node_Id; -- Build the receiving stub for a given subprogram. The subprogram -- declaration is also built by this procedure, and the value returned -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is @@ -155,31 +189,32 @@ package body Exp_Dist is function Build_RPC_Receiver_Specification (RPC_Receiver : Entity_Id; Stream_Parameter : Entity_Id; - Result_Parameter : Entity_Id) - return Node_Id; + Result_Parameter : Entity_Id) return Node_Id; -- Make a subprogram specification for an RPC receiver, -- with the given defining unit name and formal parameters. function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; -- Return an ordered parameter list: unconstrained parameters are put -- at the beginning of the list and constrained ones are put after. If - -- there are no parameters, an empty list is returned. + -- there are no parameters, an empty list is returned. Special case: + -- the controlling formal of the equivalent RACW operation for a RAS + -- type is always left in first position. procedure Add_Calling_Stubs_To_Declarations - (Pkg_Spec : in Node_Id; - Decls : in List_Id); + (Pkg_Spec : Node_Id; + Decls : List_Id); -- Add calling stubs to the declarative part procedure Add_Receiving_Stubs_To_Declarations - (Pkg_Spec : in Node_Id; - Decls : in List_Id); + (Pkg_Spec : Node_Id; + Decls : List_Id); -- Add receiving stubs to the declarative part - procedure Add_RAS_Dereference_Attribute (N : in Node_Id); - -- Add a subprogram body for RAS dereference + procedure Add_RAS_Dereference_TSS (N : Node_Id); + -- Add a subprogram body for RAS Dereference TSS - procedure Add_RAS_Access_Attribute (N : in Node_Id); - -- Add a subprogram body for RAS Access attribute + procedure Add_RAS_Access_TSS (N : Node_Id); + -- Add a subprogram body for RAS Access TSS function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; -- Return True if nothing prevents the program whose specification is @@ -194,8 +229,7 @@ package body Exp_Dist is (Loc : Source_Ptr; Stream : Node_Id; Object : Entity_Id; - Etyp : Entity_Id := Empty) - return Node_Id; + Etyp : Entity_Id := Empty) return Node_Id; -- Pack Object (of type Etyp) into Stream. If Etyp is not given, -- then Etype (Object) will be used if present. If the type is -- constrained, then 'Write will be used to output the object, @@ -205,30 +239,16 @@ package body Exp_Dist is (Loc : Source_Ptr; Stream : Entity_Id; Object : Node_Id; - Etyp : Entity_Id) - return Node_Id; + Etyp : Entity_Id) return Node_Id; -- Similar to above, with an arbitrary node instead of an entity function Pack_Node_Into_Stream_Access (Loc : Source_Ptr; Stream : Node_Id; Object : Node_Id; - Etyp : Entity_Id) - return Node_Id; + Etyp : Entity_Id) return Node_Id; -- Similar to above, with Stream instead of Stream'Access - function Copy_Specification - (Loc : Source_Ptr; - Spec : Node_Id; - Object_Type : Entity_Id := Empty; - Stub_Type : Entity_Id := Empty; - New_Name : Name_Id := No_Name) - return Node_Id; - -- Build a specification from another one. If Object_Type is not Empty - -- and any access to Object_Type is found, then it is replaced by an - -- access to Stub_Type. If New_Name is given, then it will be used as - -- the name for the newly created spec. - function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; -- Return the scope represented by a given spec @@ -237,8 +257,7 @@ package body Exp_Dist is -- its constrained status. function Is_RACW_Controlling_Formal - (Parameter : Node_Id; Stub_Type : Entity_Id) - return Boolean; + (Parameter : Node_Id; Stub_Type : Entity_Id) return Boolean; -- Return True if the current parameter is a controlling formal argument -- of type Stub_Type or access to Stub_Type. @@ -301,9 +320,9 @@ package body Exp_Dist is -- Mapping between a RCI subprogram and the corresponding calling stubs procedure Add_Stub_Type - (Designated_Type : in Entity_Id; - RACW_Type : in Entity_Id; - Decls : in List_Id; + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Decls : List_Id; Stub_Type : out Entity_Id; Stub_Type_Access : out Entity_Id; Object_RPC_Receiver : out Entity_Id; @@ -314,28 +333,28 @@ package body Exp_Dist is -- anyhow and Existing is set to True. procedure Add_RACW_Read_Attribute - (RACW_Type : in Entity_Id; - Stub_Type : in Entity_Id; - Stub_Type_Access : in Entity_Id; - Declarations : in List_Id); + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Declarations : List_Id); -- Add Read attribute in Decls for the RACW type. The Read attribute -- is added right after the RACW_Type declaration while the body is -- inserted after Declarations. procedure Add_RACW_Write_Attribute - (RACW_Type : in Entity_Id; - Stub_Type : in Entity_Id; - Stub_Type_Access : in Entity_Id; - Object_RPC_Receiver : in Entity_Id; - Declarations : in List_Id); + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Object_RPC_Receiver : Entity_Id; + Declarations : List_Id); -- Same thing for the Write attribute procedure Add_RACW_Read_Write_Attributes - (RACW_Type : in Entity_Id; - Stub_Type : in Entity_Id; - Stub_Type_Access : in Entity_Id; - Object_RPC_Receiver : in Entity_Id; - Declarations : in List_Id); + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Object_RPC_Receiver : Entity_Id; + Declarations : List_Id); -- Add Read and Write attributes declarations and bodies for a given -- RACW type. The declarations are added just after the declaration -- of the RACW type itself, while the bodies are inserted at the end @@ -343,8 +362,7 @@ package body Exp_Dist is function RCI_Package_Locator (Loc : Source_Ptr; - Package_Spec : Node_Id) - return Node_Id; + Package_Spec : Node_Id) return Node_Id; -- Instantiate the generic package RCI_Info in order to locate the -- RCI package whose spec is given as argument. @@ -361,8 +379,7 @@ package body Exp_Dist is function Input_With_Tag_Check (Loc : Source_Ptr; Var_Type : Entity_Id; - Stream : Entity_Id) - return Node_Id; + Stream : Entity_Id) return Node_Id; -- Return a function with the following form: -- function R return Var_Type is -- begin @@ -392,16 +409,16 @@ package body Exp_Dist is --------------------------------------- procedure Add_Calling_Stubs_To_Declarations - (Pkg_Spec : in Node_Id; - Decls : in List_Id) + (Pkg_Spec : Node_Id; + Decls : List_Id) is - Current_Subprogram_Number : Int := 0; - Current_Declaration : Node_Id; + Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; + -- Subprogram id 0 is reserved for calls received from + -- remote access-to-subprogram dereferences. + Current_Declaration : Node_Id; Loc : constant Source_Ptr := Sloc (Pkg_Spec); - RCI_Instantiation : Node_Id; - Subp_Stubs : Node_Id; begin @@ -424,9 +441,7 @@ package body Exp_Dist is -- do the correct dispatching. Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Current_Declaration /= Empty loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration and then Comes_From_Source (Current_Declaration) then @@ -453,14 +468,13 @@ package body Exp_Dist is Next (Current_Declaration); end loop; - end Add_Calling_Stubs_To_Declarations; ----------------------- -- Add_RACW_Features -- ----------------------- - procedure Add_RACW_Features (RACW_Type : in Entity_Id) + procedure Add_RACW_Features (RACW_Type : Entity_Id) is Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); @@ -554,7 +568,7 @@ package body Exp_Dist is Loc : constant Source_Ptr := Sloc (Insertion_Node); Stub_Elements : constant Stub_Structure := - Stubs_Table.Get (Designated_Type); + Stubs_Table.Get (Designated_Type); pragma Assert (Stub_Elements /= Empty_Stub_Structure); @@ -593,9 +607,7 @@ package body Exp_Dist is Current_Primitive_Elmt := First_Elmt (Primitive_Operations (Designated_Type)); - while Current_Primitive_Elmt /= No_Elmt loop - Current_Primitive := Node (Current_Primitive_Elmt); -- Copy the primitive of all the parents, except predefined @@ -748,10 +760,10 @@ package body Exp_Dist is ----------------------------- procedure Add_RACW_Read_Attribute - (RACW_Type : in Entity_Id; - Stub_Type : in Entity_Id; - Stub_Type_Access : in Entity_Id; - Declarations : in List_Id) + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Declarations : List_Id) is Loc : constant Source_Ptr := Sloc (RACW_Type); @@ -777,6 +789,9 @@ package body Exp_Dist is Source_Address : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Local_Stub : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('L')); Stubbed_Result : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); @@ -836,9 +851,20 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), + + Make_Object_Declaration (Loc, Defining_Identifier => Stubbed_Result, Object_Definition => - New_Occurrence_Of (Stub_Type_Access, Loc))); + New_Occurrence_Of (Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => + Name_Unchecked_Access))); -- Read the source Partition_ID and RPC_Receiver from incoming stream @@ -869,6 +895,10 @@ package body Exp_Dist is Stream_Parameter, New_Occurrence_Of (Source_Address, Loc)))); + -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result + + Set_Etype (Stubbed_Result, Stub_Type_Access); + -- If the Address is Null_Address, then return a null object Append_To (Statements, @@ -901,12 +931,6 @@ package body Exp_Dist is Remote_Statements := New_List ( Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Stubbed_Result, Loc), - Expression => - Make_Allocator (Loc, - New_Occurrence_Of (Stub_Type, Loc))), - - Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Stubbed_Result, Loc), Selector_Name => Make_Identifier (Loc, Name_Origin)), @@ -935,13 +959,18 @@ package body Exp_Dist is Expression => New_Occurrence_Of (Asynchronous_Flag, Loc))); - Append_To (Remote_Statements, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), - New_Occurrence_Of (Stubbed_Result, Loc))))); + Append_List_To (Remote_Statements, + Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); + -- ??? Issue with asynchronous calls here: the Asynchronous + -- flag is set on the stub type if, and only if, the RACW type + -- has a pragma Asynchronous. This is incorrect for RACWs that + -- implement RAS types, because in that case the /designated + -- subprogram/ (not the type) might be asynchronous, and + -- that causes the stub to need to be asynchronous too. + -- A solution is to transport a RAS as a struct containing + -- a RACW and an asynchronous flag, and to properly alter + -- the Asynchronous component in the stub type in the RAS's + -- Input TSS. Append_To (Remote_Statements, Make_Assignment_Statement (Loc, @@ -991,11 +1020,11 @@ package body Exp_Dist is ------------------------------------ procedure Add_RACW_Read_Write_Attributes - (RACW_Type : in Entity_Id; - Stub_Type : in Entity_Id; - Stub_Type_Access : in Entity_Id; - Object_RPC_Receiver : in Entity_Id; - Declarations : in List_Id) + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Object_RPC_Receiver : Entity_Id; + Declarations : List_Id) is begin Add_RACW_Write_Attribute @@ -1017,18 +1046,22 @@ package body Exp_Dist is ------------------------------ procedure Add_RACW_Write_Attribute - (RACW_Type : in Entity_Id; - Stub_Type : in Entity_Id; - Stub_Type_Access : in Entity_Id; - Object_RPC_Receiver : in Entity_Id; - Declarations : in List_Id) + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Object_RPC_Receiver : Entity_Id; + Declarations : List_Id) is Loc : constant Source_Ptr := Sloc (RACW_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + Body_Node : Node_Id; Proc_Decl : Node_Id; Attr_Decl : Node_Id; + RPC_Receiver : Node_Id; + Statements : List_Id; Local_Statements : List_Id; Remote_Statements : List_Id; @@ -1056,6 +1089,26 @@ package body Exp_Dist is -- Build the code fragment corresponding to the marshalling of a -- local object. + if Is_RAS then + + -- For a RAS, the RPC receiver is that of the RCI unit, + -- not that of the corresponding distributed object type. + -- We retrieve its address from the local proxy object. + + RPC_Receiver := Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)); + + else + RPC_Receiver := Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Object_RPC_Receiver, Loc), + Attribute_Name => + Name_Address); + end if; + Local_Statements := New_List ( Pack_Entity_Into_Stream_Access (Loc, @@ -1064,21 +1117,18 @@ package body Exp_Dist is Pack_Node_Into_Stream_Access (Loc, Stream => Stream_Parameter, - Object => OK_Convert_To (RTE (RE_Unsigned_64), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc), - Attribute_Name => Name_Address)), + Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), Etyp => RTE (RE_Unsigned_64)), - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => OK_Convert_To (RTE (RE_Unsigned_64), - Make_Attribute_Reference (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - Prefix => Object), - Attribute_Name => Name_Address)), - Etyp => RTE (RE_Unsigned_64))); + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Prefix => Object), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64))); -- Build the code fragment corresponding to the marshalling of -- a remote object. @@ -1180,34 +1230,79 @@ package body Exp_Dist is Append_To (Declarations, Body_Node); end Add_RACW_Write_Attribute; - ------------------------------ - -- Add_RAS_Access_Attribute -- - ------------------------------ + ------------------------ + -- Add_RAS_Access_TSS -- + ------------------------ + + procedure Add_RAS_Access_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); - procedure Add_RAS_Access_Attribute (N : in Node_Id) is Ras_Type : constant Entity_Id := Defining_Identifier (N); Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); -- Ras_Type is the access to subprogram type while Fat_Type points to -- the record type corresponding to a remote access to subprogram type. - Proc_Decls : constant List_Id := New_List; - Proc_Statements : constant List_Id := New_List; + RACW_Type : constant Entity_Id := + Underlying_RACW_Type (Ras_Type); + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); - Proc_Spec : Node_Id; - Proc : Node_Id; - Local_Addr : Entity_Id; - Package_Name : Entity_Id; - Subp_Id : Entity_Id; - Asynch_P : Entity_Id; - Origin : Entity_Id; - Return_Value : Entity_Id; + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Desig); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); - All_Calls_Remote : Entity_Id; + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); + Proc_Spec : Node_Id; + + -- Formal parameters + + Package_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_P); + -- Target package + + Subp_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_S); + -- Target subprogram + + Asynch_P : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_Asynchronous); + -- Is the procedure to which the 'Access applies asynchronous? + + All_Calls_Remote : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_All_Calls_Remote); -- True if an All_Calls_Remote pragma applies to the RCI unit - -- that contains the subprogram (currently unused, all RAS - -- dereferences are handled through the PCS). + -- that contains the subprogram. - Loc : constant Source_Ptr := Sloc (N); + -- Common local variables + + Proc_Decls : List_Id; + Proc_Statements : List_Id; + + Origin : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); + + -- Additional local variables for the local case + + Proxy_Addr : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); + + -- Additional local variables for the remote case + + Local_Stub : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + Stub_Ptr : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); function Set_Field (Field_Name : Name_Id; @@ -1228,26 +1323,17 @@ package body Exp_Dist is Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Return_Value, Loc), + Prefix => New_Occurrence_Of (Stub_Ptr, Loc), Selector_Name => Make_Identifier (Loc, Field_Name)), Expression => Value); end Set_Field; - -- Start of processing for Add_RAS_Access_Attribute + -- Start of processing for Add_RAS_Access_TSS begin - Local_Addr := Make_Defining_Identifier (Loc, New_Internal_Name ('L')); - Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); - Asynch_P := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - Origin := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - All_Calls_Remote := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - - -- Create the object which will be returned of type Fat_Type + Proc_Decls := New_List ( - Append_List_To (Proc_Decls, New_List ( + -- Common declarations Make_Object_Declaration (Loc, Defining_Identifier => Origin, @@ -1261,41 +1347,75 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc)))), + -- Declaration use only in the local case: proxy address + + Make_Object_Declaration (Loc, + Defining_Identifier => Proxy_Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + -- Declarations used only in the remote case: stub object and + -- stub pointer. + Make_Object_Declaration (Loc, - Defining_Identifier => Return_Value, + Defining_Identifier => Local_Stub, + Aliased_Present => True, Object_Definition => - New_Occurrence_Of (Fat_Type, Loc)))); + New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => + Stub_Ptr, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => Name_Unchecked_Access))); - -- Initialize the fields of the record type with the appropriate data + Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); + -- Build_Get_Unique_RP_Call needs this information. + + -- Note: Here we assume that the Fat_Type is a record + -- containing just a pointer to a proxy or stub object. + + Proc_Statements := New_List ( + + -- Get_RAS_Info (Pkg, Subp, PA); + -- if Origin = Local_Partition_Id and then not All_Calls_Remote then + -- return Fat_Type!(PA); + -- end if; + + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc), + New_Occurrence_Of (Subp_Id, Loc), + New_Occurrence_Of (Proxy_Addr, Loc))), - Append_List_To (Proc_Statements, New_List ( Make_Implicit_If_Statement (N, Condition => Make_And_Then (Loc, - Left_Opnd => - Make_Op_Not (Loc, - New_Occurrence_Of (All_Calls_Remote, Loc)), - Right_Opnd => + Left_Opnd => Make_Op_Eq (Loc, Left_Opnd => New_Occurrence_Of (Origin, Loc), Right_Opnd => Make_Function_Call (Loc, New_Occurrence_Of ( - RTE (RE_Get_Local_Partition_Id), Loc)))), - + RTE (RE_Get_Local_Partition_Id), Loc))), + Right_Opnd => + Make_Op_Not (Loc, + New_Occurrence_Of (All_Calls_Remote, Loc))), Then_Statements => New_List ( - Set_Field (Name_Ras, - OK_Convert_To (RTE (RE_Unsigned_64), - New_Occurrence_Of (Local_Addr, Loc)))), - - Else_Statements => New_List ( - Set_Field (Name_Ras, - Make_Integer_Literal (Loc, Uint_0)))), + Make_Return_Statement (Loc, + Unchecked_Convert_To (Fat_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Proxy_Addr, Loc)))))), Set_Field (Name_Origin, - Unchecked_Convert_To (Standard_Integer, - New_Occurrence_Of (Origin, Loc))), + New_Occurrence_Of (Origin, Loc)), Set_Field (Name_Receiver, Make_Function_Call (Loc, @@ -1304,33 +1424,36 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (Package_Name, Loc)))), - Set_Field (Name_Subp_Id, - New_Occurrence_Of (Subp_Id, Loc)), + Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), + + Set_Field (Name_Asynchronous, + Make_Or_Else (Loc, + New_Occurrence_Of (Asynch_P, Loc), + New_Occurrence_Of (Boolean_Literals ( + Is_Asynchronous (Ras_Type)), Loc)))); + -- E.4.1(9) A remote call is asynchronous if it is a call to + -- a procedure, or a call through a value of an access-to-procedure + -- type, to which a pragma Asynchronous applies. + -- Parameter Asynch_P is true when the procedure is asynchronous; + -- Expression Asynch_T is true when the type is asynchronous. - Set_Field (Name_Async, - New_Occurrence_Of (Asynch_P, Loc)))); + Append_List_To (Proc_Statements, + Build_Get_Unique_RP_Call + (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); -- Return the newly created value Append_To (Proc_Statements, Make_Return_Statement (Loc, Expression => - New_Occurrence_Of (Return_Value, Loc))); - - Proc := - Make_Defining_Identifier (Loc, - Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); + Unchecked_Convert_To (Fat_Type, + New_Occurrence_Of (Stub_Ptr, Loc)))); Proc_Spec := Make_Function_Specification (Loc, Defining_Unit_Name => Proc, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => Local_Addr, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Address), Loc)), - - Make_Parameter_Specification (Loc, Defining_Identifier => Package_Name, Parameter_Type => New_Occurrence_Of (Standard_String, Loc)), @@ -1338,7 +1461,7 @@ package body Exp_Dist is Make_Parameter_Specification (Loc, Defining_Identifier => Subp_Id, Parameter_Type => - New_Occurrence_Of (Standard_Natural, Loc)), + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Asynch_P, @@ -1368,139 +1491,127 @@ package body Exp_Dist is Statements => Proc_Statements))); Set_TSS (Fat_Type, Proc); + end Add_RAS_Access_TSS; - end Add_RAS_Access_Attribute; - - ----------------------------------- - -- Add_RAS_Dereference_Attribute -- - ----------------------------------- + ----------------------------- + -- Add_RAS_Dereference_TSS -- + ----------------------------- - procedure Add_RAS_Dereference_Attribute (N : in Node_Id) is + procedure Add_RAS_Dereference_TSS (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Type_Def : constant Node_Id := Type_Definition (N); - Ras_Type : constant Entity_Id := Defining_Identifier (N); - - Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + RAS_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); + RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); + Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); - Proc_Decls : constant List_Id := New_List; - Proc_Statements : constant List_Id := New_List; + Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); - Inner_Decls : constant List_Id := New_List; - Inner_Statements : constant List_Id := New_List; + RACW_Primitive_Name : Node_Id; - Direct_Statements : constant List_Id := New_List; + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference)); - Proc : Node_Id; Proc_Spec : Node_Id; - Param_Specs : constant List_Id := New_List; + Param_Specs : List_Id; Param_Assoc : constant List_Id := New_List; + Stmts : constant List_Id := New_List; - Pointer : Node_Id; - - Converted_Ras : Node_Id; - Target_Partition : Node_Id; - RPC_Receiver : Node_Id; - Subprogram_Id : Node_Id; - Asynchronous : Node_Id; + RAS_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); Is_Function : constant Boolean := Nkind (Type_Def) = N_Access_Function_Definition; + Is_Degenerate : Boolean; + -- Set to True if the subprogram_specification for this RAS has + -- an anonymous access parameter (see Process_Remote_AST_Declaration). + Spec : constant Node_Id := Type_Def; Current_Parameter : Node_Id; begin - -- The way to do it is test if the Ras field is non-null and then if - -- the Origin field is equal to the current partition ID (which is in - -- fact Current_Package'Partition_ID). If this is the case, then it - -- is safe to dereference the Ras field directly rather than - -- performing a remote call. + Param_Specs := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => RAS_Parameter, + In_Present => True, + Parameter_Type => + New_Occurrence_Of (Fat_Type, Loc))); - Pointer := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Is_Degenerate := False; + Current_Parameter := First (Parameter_Specifications (Type_Def)); + Parameters : while Current_Parameter /= Empty loop + if Nkind (Parameter_Type (Current_Parameter)) + = N_Access_Definition + then + Is_Degenerate := True; + end if; + Append_To (Param_Specs, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter))), + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Parameter_Type => + New_Copy_Tree (Parameter_Type (Current_Parameter)), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); + + Append_To (Param_Assoc, + Make_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter)))); - Target_Partition := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Next (Current_Parameter); + end loop Parameters; - Append_To (Proc_Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Target_Partition, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc), - Expression => - Unchecked_Convert_To (RTE (RE_Partition_ID), - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Pointer, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Origin))))); - - RPC_Receiver := - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Pointer, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Receiver)); - - Subprogram_Id := - Unchecked_Convert_To (RTE (RE_Subprogram_Id), - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Pointer, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Subp_Id))); - - -- A function is never asynchronous. A procedure may or may not be - -- asynchronous depending on whether a pragma Asynchronous applies - -- on it. Since a RAST may point onto various subprograms, this is - -- only known at runtime so both versions (synchronous and asynchronous) - -- must be built every times it is not a function. + if Is_Degenerate then + Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc)); - if Is_Function then - Asynchronous := Empty; + -- Generate a dummy body recursing on the Dereference TSS, since + -- actually it will never be executed. + + Append_To (Stmts, + Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); + RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc); else - Asynchronous := + Prepend_To (Param_Assoc, + Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (RAS_Parameter, Loc))); + + RACW_Primitive_Name := Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Pointer, Loc), + Prefix => + New_Occurrence_Of (Scope (RACW_Type), Loc), Selector_Name => - Make_Identifier (Loc, Name_Async)); - + Make_Identifier (Loc, Name_Call)); end if; - if Present (Parameter_Specifications (Type_Def)) then - Current_Parameter := First (Parameter_Specifications (Type_Def)); - - while Current_Parameter /= Empty loop - Append_To (Param_Specs, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => - Chars (Defining_Identifier (Current_Parameter))), - In_Present => In_Present (Current_Parameter), - Out_Present => Out_Present (Current_Parameter), - Parameter_Type => - New_Copy_Tree (Parameter_Type (Current_Parameter)), - Expression => - New_Copy_Tree (Expression (Current_Parameter)))); - - Append_To (Param_Assoc, - Make_Identifier (Loc, - Chars => Chars (Defining_Identifier (Current_Parameter)))); + if Is_Function then + Append_To (Stmts, + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + RACW_Primitive_Name, + Parameter_Associations => Param_Assoc))); - Next (Current_Parameter); - end loop; + else + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + RACW_Primitive_Name, + Parameter_Associations => Param_Assoc)); end if; - Proc := - Make_Defining_Identifier (Loc, - Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Dereference)); + -- Build the complete subprogram. if Is_Function then Proc_Spec := @@ -1512,7 +1623,6 @@ package body Exp_Dist is Entity (Subtype_Mark (Spec)), Loc)); Set_Ekind (Proc, E_Function); - Set_Etype (Proc, New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); @@ -1526,96 +1636,213 @@ package body Exp_Dist is Set_Etype (Proc, Standard_Void_Type); end if; - -- Build the calling stubs for the dereference of the RAS + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))); + + Set_TSS (Fat_Type, Proc); + end Add_RAS_Dereference_TSS; - Build_General_Calling_Stubs - (Decls => Inner_Decls, - Statements => Inner_Statements, - Target_Partition => Target_Partition, - RPC_Receiver => RPC_Receiver, - Subprogram_Id => Subprogram_Id, - Asynchronous => Asynchronous, - Is_Known_Non_Asynchronous => Is_Function, - Is_Function => Is_Function, - Spec => Proc_Spec, - Nod => N); - - Converted_Ras := - Unchecked_Convert_To (Ras_Type, - OK_Convert_To (RTE (RE_Address), - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Pointer, Loc), - Selector_Name => Make_Identifier (Loc, Name_Ras)))); + ------------------------------- + -- Add_RAS_Proxy_And_Analyze -- + ------------------------------- - if Is_Function then - Append_To (Direct_Statements, - Make_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => - Make_Explicit_Dereference (Loc, - Prefix => Converted_Ras), - Parameter_Associations => Param_Assoc))); + procedure Add_RAS_Proxy_And_Analyze + (Decls : List_Id; + Vis_Decl : Node_Id; + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); - else - Append_To (Direct_Statements, + Subp_Name : constant Entity_Id := + Defining_Unit_Name (Specification (Vis_Decl)); + + Pkg_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (Subp_Name), 'P', -1)); + + Proxy_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name ( + Related_Id => Chars (Subp_Name), + Suffix => 'P')); + + Proxy_Type_Full_View : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars (Proxy_Type)); + + Subp_Decl_Spec : constant Node_Id := + Build_RAS_Primitive_Specification + (Subp_Spec => Specification (Vis_Decl), + Remote_Object_Type => Proxy_Type); + + Subp_Body_Spec : constant Node_Id := + Build_RAS_Primitive_Specification + (Subp_Spec => Specification (Vis_Decl), + Remote_Object_Type => Proxy_Type); + + Vis_Decls : constant List_Id := New_List; + Pvt_Decls : constant List_Id := New_List; + Actuals : constant List_Id := New_List; + Formal : Node_Id; + Perform_Call : Node_Id; + + begin + -- type subpP is tagged limited private; + + Append_To (Vis_Decls, + Make_Private_Type_Declaration (Loc, + Defining_Identifier => Proxy_Type, + Tagged_Present => True, + Limited_Present => True)); + + -- [subprogram] Call + -- (Self : access subpP; + -- ...other-formals...) + -- [return T]; + + Append_To (Vis_Decls, + Make_Subprogram_Declaration (Loc, + Specification => Subp_Decl_Spec)); + + -- A : constant System.Address; + + Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA); + + Append_To (Vis_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Proxy_Object_Addr, + Constant_Present => + True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); + + -- private + + -- type subpP is tagged limited record + -- All_Calls_Remote : Boolean := [All_Calls_Remote?]; + -- ... + -- end record; + + Append_To (Pvt_Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Proxy_Type_Full_View, + Type_Definition => + Build_Remote_Subprogram_Proxy_Type (Loc, + New_Occurrence_Of (All_Calls_Remote_E, Loc)))); + + -- Trick semantic analysis into swapping the public and + -- full view when freezing the public view. + + Set_Comes_From_Source (Proxy_Type_Full_View, True); + + + -- procedure Call + -- (Self : access O; + -- ...other-formals...) is + -- begin + -- P (...other-formals...); + -- end Call; + + -- function Call + -- (Self : access O; + -- ...other-formals...) + -- return T is + -- begin + -- return F (...other-formals...); + -- end Call; + + if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then + Perform_Call := Make_Procedure_Call_Statement (Loc, - Name => - Make_Explicit_Dereference (Loc, - Prefix => Converted_Ras), - Parameter_Associations => Param_Assoc)); + Name => + New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => + Actuals); + else + Perform_Call := + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => + Actuals)); end if; - Prepend_To (Param_Specs, - Make_Parameter_Specification (Loc, - Defining_Identifier => Pointer, - In_Present => True, - Parameter_Type => - New_Occurrence_Of (Fat_Type, Loc))); + Formal := First (Parameter_Specifications (Subp_Decl_Spec)); + pragma Assert (Present (Formal)); + Next (Formal); - Append_To (Proc_Statements, - Make_Implicit_If_Statement (N, - Condition => - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Pointer, Loc), - Selector_Name => Make_Identifier (Loc, Name_Ras)), - Right_Opnd => - Make_Integer_Literal (Loc, Uint_0)), + while Present (Formal) loop + Append_To (Actuals, New_Occurrence_Of ( + Defining_Identifier (Formal), Loc)); + Next (Formal); + end loop; - Right_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - New_Occurrence_Of (Target_Partition, Loc), - Right_Opnd => - Make_Function_Call (Loc, - New_Occurrence_Of ( - RTE (RE_Get_Local_Partition_Id), Loc)))), + -- O : aliased subpP; - Then_Statements => - Direct_Statements, + Append_To (Pvt_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_uO), + Aliased_Present => + True, + Object_Definition => + New_Occurrence_Of (Proxy_Type, Loc))); - Else_Statements => New_List ( - Make_Block_Statement (Loc, - Declarations => Inner_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Inner_Statements))))); + -- A : constant System.Address := O'Address; - Discard_Node ( - Make_Subprogram_Body (Loc, - Specification => Proc_Spec, - Declarations => Proc_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Proc_Statements))); + Append_To (Pvt_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars (Proxy_Object_Addr)), + Constant_Present => + True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Defining_Identifier (Last (Pvt_Decls)), Loc), + Attribute_Name => + Name_Address))); - Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec)); + Append_To (Decls, + Make_Package_Declaration (Loc, + Specification => Make_Package_Specification (Loc, + Defining_Unit_Name => Pkg_Name, + Visible_Declarations => Vis_Decls, + Private_Declarations => Pvt_Decls, + End_Label => Empty))); + Analyze (Last (Decls)); - end Add_RAS_Dereference_Attribute; + Append_To (Decls, + Make_Package_Body (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars (Pkg_Name)), + Declarations => New_List ( + Make_Subprogram_Body (Loc, + Specification => + Subp_Body_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Perform_Call)))))); + Analyze (Last (Decls)); + end Add_RAS_Proxy_And_Analyze; ----------------------- -- Add_RAST_Features -- @@ -1633,8 +1860,8 @@ package body Exp_Dist is return; end if; - Add_RAS_Dereference_Attribute (Vis_Decl); - Add_RAS_Access_Attribute (Vis_Decl); + Add_RAS_Dereference_TSS (Vis_Decl); + Add_RAS_Access_TSS (Vis_Decl); end Add_RAST_Features; ----------------------------------------- @@ -1642,8 +1869,8 @@ package body Exp_Dist is ----------------------------------------- procedure Add_Receiving_Stubs_To_Declarations - (Pkg_Spec : in Node_Id; - Decls : in List_Id) + (Pkg_Spec : Node_Id; + Decls : List_Id) is Loc : constant Source_Ptr := Sloc (Pkg_Spec); @@ -1658,20 +1885,78 @@ package body Exp_Dist is Pkg_RPC_Receiver_Body : Node_Id; -- A Pkg_RPC_Receiver is built to decode the request - Subp_Id : Node_Id; + Lookup_RAS_Info : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + -- A remote subprogram is created to allow peers to look up + -- RAS information using subprogram ids. + + Subp_Id : Node_Id; -- Subprogram_Id as read from the incoming stream Current_Declaration : Node_Id; - Current_Subprogram_Number : Int := 0; + Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; Current_Stubs : Node_Id; - Actuals : List_Id; + Subp_Info_Array : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + + Subp_Info_List : constant List_Id := New_List; Dummy_Register_Name : Name_Id; Dummy_Register_Spec : Node_Id; Dummy_Register_Decl : Node_Id; Dummy_Register_Body : Node_Id; + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : Entity_Id; + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Declaration : Node_Id; + Stubs : Node_Id; + Subprogram_Number : Int); + -- Add one case to the specified RPC receiver case list + -- associating Subprogram_Number with the subprogram declared + -- by Declaration, for which we have receiving stubs in Stubs. + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Declaration : Node_Id; + Stubs : Node_Id; + Subprogram_Number : Int) + is + Actuals : constant List_Id := + New_List (New_Occurrence_Of (Stream_Parameter, Loc)); + begin + if Nkind (Specification (Declaration)) = N_Function_Specification + or else not + Is_Asynchronous (Defining_Entity (Specification (Declaration))) + then + -- An asynchronous procedure does not want an output parameter + -- since no result and no exception will ever be returned. + + Append_To (Actuals, + New_Occurrence_Of (Result_Parameter, Loc)); + end if; + + Append_To (RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List ( + Make_Integer_Literal (Loc, Subprogram_Number)), + + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Entity (Stubs), Loc), + Parameter_Associations => + Actuals)))); + end Append_Stubs_To; + + -- Start of processing for Add_Receiving_Stubs_To_Declarations + begin -- Building receiving stubs consist in several operations: @@ -1724,14 +2009,78 @@ package body Exp_Dist is New_Occurrence_Of (Stream_Parameter, Loc), New_Occurrence_Of (Subp_Id, Loc)))); + -- A null subp_id denotes a call through a RAS, in which case the + -- next Uint_64 element in the stream is the address of the local + -- proxy object, from which we can retrieve the actual subprogram id. + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + Make_Op_Eq (Loc, + New_Occurrence_Of (Subp_Id, Loc), + Make_Integer_Literal (Loc, 0)), + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Subp_Id, Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), + OK_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Input, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc))))), + Selector_Name => + Make_Identifier (Loc, Name_Subp_Id)))))); + + All_Calls_Remote_E := Boolean_Literals ( + Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); + + -- Build a subprogram for RAS information lookups + + Current_Declaration := + Make_Subprogram_Declaration (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => + Lookup_RAS_Info, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Subp_Id), + In_Present => + True, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); + Append_To (Decls, Current_Declaration); + Analyze (Current_Declaration); + + Current_Stubs := Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Declaration, + Asynchronous => False); + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Declaration => + Current_Declaration, + Stubs => + Current_Stubs, + Subprogram_Number => 1); + -- For each subprogram, the receiving stub will be built and a -- case statement will be made on the Subprogram_Id to dispatch -- to the right subprogram. Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Current_Declaration /= Empty loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration and then Comes_From_Source (Current_Declaration) then @@ -1739,6 +2088,8 @@ package body Exp_Dist is Get_Subprogram_Id (Defining_Unit_Name (Specification ( Current_Declaration)))); + -- Build receiving stub + Current_Stubs := Build_Subprogram_Receiving_Stubs (Vis_Decl => Current_Declaration, @@ -1750,40 +2101,44 @@ package body Exp_Dist is (Current_Declaration)))); Append_To (Decls, Current_Stubs); - Analyze (Current_Stubs); - Actuals := New_List (New_Occurrence_Of (Stream_Parameter, Loc)); - - if Nkind (Specification (Current_Declaration)) - = N_Function_Specification - or else - not Is_Asynchronous ( - Defining_Entity (Specification (Current_Declaration))) - then - -- An asynchronous procedure does not want an output parameter - -- since no result and no exception will ever be returned. - - Append_To (Actuals, - New_Occurrence_Of (Result_Parameter, Loc)); - - end if; - - Append_To (Pkg_RPC_Receiver_Cases, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_List ( - Make_Integer_Literal (Loc, Current_Subprogram_Number)), - - Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of ( - Defining_Entity (Current_Stubs), Loc), - Parameter_Associations => - Actuals)))); - + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => + Current_Declaration, + All_Calls_Remote_E => + All_Calls_Remote_E, + Proxy_Object_Addr => + Proxy_Object_Addr); + + -- Add subprogram descriptor (RCI_Subp_Info) to the + -- subprograms table for this receiver. The aggregate + -- below must be kept consistent with the declaration + -- of type RCI_Subp_Info in System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, + Current_Subprogram_Number)), + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Declaration => + Current_Declaration, + Stubs => + Current_Stubs, + Subprogram_Number => + Current_Subprogram_Number); Current_Subprogram_Number := Current_Subprogram_Number + 1; end if; @@ -1811,6 +2166,53 @@ package body Exp_Dist is New_Occurrence_Of (Subp_Id, Loc), Alternatives => Pkg_RPC_Receiver_Cases)); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Info_Array, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id), + High_Bound => + Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))), + Expression => + Make_Aggregate (Loc, + Component_Associations => Subp_Info_List))); + Analyze (Last (Decls)); + + Append_To (Decls, + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Parent (Lookup_RAS_Info)), + Declarations => + No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Selected_Component (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Expressions => New_List ( + Convert_To (Standard_Integer, + Make_Identifier (Loc, Name_Subp_Id)))), + Selector_Name => + Make_Identifier (Loc, Name_Addr)))))))); + Analyze (Last (Decls)); + Pkg_RPC_Receiver_Body := Make_Subprogram_Body (Loc, Specification => Pkg_RPC_Receiver_Spec, @@ -1867,7 +2269,17 @@ package body Exp_Dist is Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), Attribute_Name => - Name_Version)))))); + Name_Version), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => + Name_Address), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => + Name_Length)))))); Append_To (Decls, Dummy_Register_Body); Analyze (Dummy_Register_Body); @@ -1878,9 +2290,9 @@ package body Exp_Dist is ------------------- procedure Add_Stub_Type - (Designated_Type : in Entity_Id; - RACW_Type : in Entity_Id; - Decls : in List_Id; + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Decls : List_Id; Stub_Type : out Entity_Id; Stub_Type_Access : out Entity_Id; Object_RPC_Receiver : out Entity_Id; @@ -1992,6 +2404,7 @@ package body Exp_Dist is Defining_Identifier => Stub_Type_Access, Type_Definition => Make_Access_To_Object_Definition (Loc, + All_Present => True, Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); Append_To (Decls, Stub_Type_Access_Declaration); @@ -2152,19 +2565,16 @@ package body Exp_Dist is Subprogram_Id))); Current_Parameter := First (Ordered_Parameters_List); - while Current_Parameter /= Empty loop - declare Typ : constant Node_Id := - Parameter_Type (Current_Parameter); + Parameter_Type (Current_Parameter); Etyp : Entity_Id; Constrained : Boolean; Value : Node_Id; Extra_Parameter : Entity_Id; begin - if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then -- In the case of a controlling formal argument, we marshall @@ -2370,19 +2780,18 @@ package body Exp_Dist is -- have changed since they are remote, so we do not read them -- from the stream. - Current_Parameter := - First (Ordered_Parameters_List); - + Current_Parameter := First (Ordered_Parameters_List); while Current_Parameter /= Empty loop - declare Typ : constant Node_Id := - Parameter_Type (Current_Parameter); + Parameter_Type (Current_Parameter); Etyp : Entity_Id; Value : Node_Id; + begin - Value := New_Occurrence_Of - (Defining_Identifier (Current_Parameter), Loc); + Value := + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); if Nkind (Typ) = N_Access_Definition then Value := Make_Explicit_Dereference (Loc, Value); @@ -2392,7 +2801,7 @@ package body Exp_Dist is end if; if (Out_Present (Current_Parameter) - or else Nkind (Typ) = N_Access_Definition) + or else Nkind (Typ) = N_Access_Definition) and then Etyp /= Object_Type then Append_To (Non_Asynchronous_Statements, @@ -2434,6 +2843,7 @@ package body Exp_Dist is Prefix => New_Occurrence_Of (Stream_Parameter, Loc), Attribute_Name => Name_Access), New_Occurrence_Of (Standard_True, Loc)))); + Prepend_To (Non_Asynchronous_Statements, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Standard_Boolean, Loc), @@ -2443,6 +2853,7 @@ package body Exp_Dist is Prefix => New_Occurrence_Of (Stream_Parameter, Loc), Attribute_Name => Name_Access), New_Occurrence_Of (Standard_False, Loc)))); + Append_To (Statements, Make_Implicit_If_Statement (Nod, Condition => Asynchronous, @@ -2451,6 +2862,86 @@ package body Exp_Dist is end if; end Build_General_Calling_Stubs; + ------------------------------ + -- Build_Get_Unique_RP_Call -- + ------------------------------ + + function Build_Get_Unique_RP_Call + (Loc : Source_Ptr; + Pointer : Entity_Id; + Stub_Type : Entity_Id) return List_Id + is + begin + return New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Pointer, Loc)))), + + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Pointer, Loc), + Selector_Name => + New_Occurrence_Of (Tag_Component + (Designated_Type (Etype (Pointer))), Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => + Name_Tag))); + + -- Note: The assignment to Pointer._Tag is safe here because + -- we carefully ensured that Stub_Type has exactly the same layout + -- as System.Partition_Interface.RACW_Stub_Type. + + end Build_Get_Unique_RP_Call; + + ---------------------------------------- + -- Build_Remote_Subprogram_Proxy_Type -- + ---------------------------------------- + + function Build_Remote_Subprogram_Proxy_Type + (Loc : Source_Ptr; + ACR_Expression : Node_Id) return Node_Id + is + begin + return + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, + + Component_Items => New_List ( + Make_Component_Declaration (Loc, + Make_Defining_Identifier (Loc, + Name_All_Calls_Remote), + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)), + ACR_Expression), + + Make_Component_Declaration (Loc, + Make_Defining_Identifier (Loc, + Name_Receiver), + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Address), Loc)), + New_Occurrence_Of (RTE (RE_Null_Address), Loc)), + + Make_Component_Declaration (Loc, + Make_Defining_Identifier (Loc, + Name_Subp_Id), + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); + end Build_Remote_Subprogram_Proxy_Type; + ----------------------------------- -- Build_Ordered_Parameters_List -- ----------------------------------- @@ -2460,6 +2951,9 @@ package body Exp_Dist is Unconstrained_List : List_Id; Current_Parameter : Node_Id; + First_Parameter : Node_Id; + For_RAS : Boolean := False; + begin if not Present (Parameter_Specifications (Spec)) then return New_List; @@ -2467,17 +2961,24 @@ package body Exp_Dist is Constrained_List := New_List; Unconstrained_List := New_List; + First_Parameter := First (Parameter_Specifications (Spec)); + + if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition + and then Chars (Defining_Identifier (First_Parameter)) = Name_uS + then + For_RAS := True; + end if; -- Loop through the parameters and add them to the right list - Current_Parameter := First (Parameter_Specifications (Spec)); + Current_Parameter := First_Parameter; while Current_Parameter /= Empty loop - - if Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition + if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition or else - Is_Constrained (Etype (Parameter_Type (Current_Parameter))) + Is_Constrained (Etype (Parameter_Type (Current_Parameter))) or else - Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))) + Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter)))) + and then not (For_RAS and then Current_Parameter = First_Parameter) then Append_To (Constrained_List, New_Copy (Current_Parameter)); else @@ -2492,7 +2993,6 @@ package body Exp_Dist is Append_List_To (Unconstrained_List, Constrained_List); return Unconstrained_List; - end Build_Ordered_Parameters_List; ---------------------------------- @@ -2512,7 +3012,6 @@ package body Exp_Dist is declare Dist_OK : Entity_Id; pragma Warnings (Off, Dist_OK); - begin Dist_OK := RTE (RE_Params_Stream_Type); end; @@ -2549,8 +3048,7 @@ package body Exp_Dist is function Build_RPC_Receiver_Specification (RPC_Receiver : Entity_Id; Stream_Parameter : Entity_Id; - Result_Parameter : Entity_Id) - return Node_Id + Result_Parameter : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (RPC_Receiver); @@ -2586,8 +3084,7 @@ package body Exp_Dist is Dynamically_Asynchronous : Boolean := False; Stub_Type : Entity_Id := Empty; Locator : Entity_Id := Empty; - New_Name : Name_Id := No_Name) - return Node_Id + New_Name : Name_Id := No_Name) return Node_Id is Loc : constant Source_Ptr := Sloc (Vis_Decl); @@ -2609,7 +3106,7 @@ package body Exp_Dist is Spec_To_Use : Node_Id; - procedure Insert_Partition_Check (Parameter : in Node_Id); + procedure Insert_Partition_Check (Parameter : Node_Id); -- Check that the parameter has been elaborated on the same partition -- than the controlling parameter (E.4(19)). @@ -2617,7 +3114,7 @@ package body Exp_Dist is -- Insert_Partition_Check -- ---------------------------- - procedure Insert_Partition_Check (Parameter : in Node_Id) is + procedure Insert_Partition_Check (Parameter : Node_Id) is Parameter_Entity : constant Entity_Id := Defining_Identifier (Parameter); Condition : Node_Id; @@ -2633,7 +3130,7 @@ package body Exp_Dist is -- then -- raise Constraint_Error; -- end if; - -- + -- Condition contains the reversed condition. Also, Parameter is -- dereferenced if it is an access type. We do not check that -- Parameter is in Stub_Type since such a check has been inserted @@ -2827,8 +3324,7 @@ package body Exp_Dist is Dynamically_Asynchronous : Boolean := False; Stub_Type : Entity_Id := Empty; RACW_Type : Entity_Id := Empty; - Parent_Primitive : Entity_Id := Empty) - return Node_Id + Parent_Primitive : Entity_Id := Empty) return Node_Id is Loc : constant Source_Ptr := Sloc (Vis_Decl); @@ -2935,6 +3431,7 @@ package body Exp_Dist is declare Etyp : Entity_Id; + RACW_Controlling : Boolean; Constrained : Boolean; Object : Entity_Id; Expr : Node_Id := Empty; @@ -2943,9 +3440,11 @@ package body Exp_Dist is Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); Set_Ekind (Object, E_Variable); - if - Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) - then + RACW_Controlling := + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type); + + if RACW_Controlling then + -- We have a controlling formal parameter. Read its address -- rather than a real object. The address is in Unsigned_64 -- form. @@ -2959,8 +3458,9 @@ package body Exp_Dist is Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); if In_Present (Current_Parameter) - or else not Out_Present (Current_Parameter) - or else not Constrained + or else not Out_Present (Current_Parameter) + or else not Constrained + or else RACW_Controlling then -- If an input parameter is contrained, then its reading is -- deferred until the beginning of the subprogram body. If @@ -2968,7 +3468,7 @@ package body Exp_Dist is -- the object declaration and the variable is set using -- 'Input instead of 'Read. - if Constrained then + if Constrained and then not RACW_Controlling then Append_To (Statements, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Etyp, Loc), @@ -3024,7 +3524,6 @@ package body Exp_Dist is if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then - if Nkind (Parameter_Type (Current_Parameter)) /= N_Access_Definition then @@ -3038,6 +3537,7 @@ package body Exp_Dist is Unchecked_Convert_To (RACW_Type, OK_Convert_To (RTE (RE_Address), New_Occurrence_Of (Object, Loc)))))); + else Append_To (Parameter_List, Make_Parameter_Association (Loc, @@ -3049,6 +3549,7 @@ package body Exp_Dist is OK_Convert_To (RTE (RE_Address), New_Occurrence_Of (Object, Loc))))); end if; + else Append_To (Parameter_List, Make_Parameter_Association (Loc, @@ -3178,7 +3679,6 @@ package body Exp_Dist is Parameter_Associations => Parameter_List)); Append_List_To (Statements, After_Statements); - end if; if Asynchronous and then not Dynamically_Asynchronous then @@ -3266,7 +3766,6 @@ package body Exp_Dist is Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements, Exception_Handlers => New_List (Excep_Handler))); - end Build_Subprogram_Receiving_Stubs; ------------------------ @@ -3278,14 +3777,14 @@ package body Exp_Dist is Spec : Node_Id; Object_Type : Entity_Id := Empty; Stub_Type : Entity_Id := Empty; - New_Name : Name_Id := No_Name) - return Node_Id + New_Name : Name_Id := No_Name) return Node_Id is Parameters : List_Id := No_List; - Current_Parameter : Node_Id; - Current_Type : Node_Id; - Current_Etype : Entity_Id; + Current_Parameter : Node_Id; + Current_Identifier : Entity_Id; + Current_Type : Node_Id; + Current_Etype : Entity_Id; Name_For_New_Spec : Name_Id; @@ -3293,34 +3792,35 @@ package body Exp_Dist is begin if New_Name = No_Name then + pragma Assert (Nkind (Spec) = N_Function_Specification + or else Nkind (Spec) = N_Procedure_Specification); + Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); else Name_For_New_Spec := New_Name; end if; if Present (Parameter_Specifications (Spec)) then - Parameters := New_List; Current_Parameter := First (Parameter_Specifications (Spec)); - while Current_Parameter /= Empty loop - - Current_Type := Parameter_Type (Current_Parameter); + Current_Identifier := Defining_Identifier (Current_Parameter); + Current_Type := Parameter_Type (Current_Parameter); if Nkind (Current_Type) = N_Access_Definition then Current_Etype := Entity (Subtype_Mark (Current_Type)); - if Object_Type = Empty then + if Present (Object_Type) then + pragma Assert ( + Root_Type (Current_Etype) = Root_Type (Object_Type)); Current_Type := Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (Current_Etype, Loc)); + Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc)); else - pragma Assert - (Root_Type (Current_Etype) = Root_Type (Object_Type)); Current_Type := Make_Access_Definition (Loc, - Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc)); + Subtype_Mark => + New_Occurrence_Of (Current_Etype, Loc)); end if; else @@ -3336,7 +3836,7 @@ package body Exp_Dist is end if; New_Identifier := Make_Defining_Identifier (Loc, - Chars (Defining_Identifier (Current_Parameter))); + Chars (Current_Identifier)); Append_To (Parameters, Make_Parameter_Specification (Loc, @@ -3351,25 +3851,29 @@ package body Exp_Dist is end loop; end if; - if Nkind (Spec) = N_Function_Specification then - return - Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => Name_For_New_Spec), - Parameter_Specifications => Parameters, - Subtype_Mark => - New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); + case Nkind (Spec) is - else - return - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => Name_For_New_Spec), - Parameter_Specifications => Parameters); - end if; + when N_Function_Specification | N_Access_Function_Definition => + return + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters, + Subtype_Mark => + New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); + + when N_Procedure_Specification | N_Access_Procedure_Definition => + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters); + when others => + raise Program_Error; + end case; end Copy_Specification; --------------------------- @@ -3398,7 +3902,7 @@ package body Exp_Dist is -- Expand_All_Calls_Remote_Subprogram_Call -- --------------------------------------------- - procedure Expand_All_Calls_Remote_Subprogram_Call (N : in Node_Id) is + procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is Called_Subprogram : constant Entity_Id := Entity (Name (N)); RCI_Package : constant Entity_Id := Scope (Called_Subprogram); Loc : constant Source_Ptr := Sloc (N); @@ -3468,7 +3972,7 @@ package body Exp_Dist is -- Expand_Calling_Stubs_Bodies -- --------------------------------- - procedure Expand_Calling_Stubs_Bodies (Unit_Node : in Node_Id) is + procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is Spec : constant Node_Id := Specification (Unit_Node); Decls : constant List_Id := Visible_Declarations (Spec); @@ -3483,7 +3987,7 @@ package body Exp_Dist is -- Expand_Receiving_Stubs_Bodies -- ----------------------------------- - procedure Expand_Receiving_Stubs_Bodies (Unit_Node : in Node_Id) is + procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is Spec : Node_Id; Decls : List_Id; Temp : List_Id; @@ -3543,7 +4047,7 @@ package body Exp_Dist is function Get_Subprogram_Id (E : Entity_Id) return Int is Current_Declaration : Node_Id; - Result : Int := 0; + Result : Int := First_RCI_Subprogram_Id; begin pragma Assert @@ -3698,8 +4202,7 @@ package body Exp_Dist is (Loc : Source_Ptr; Stream : Node_Id; Object : Entity_Id; - Etyp : Entity_Id := Empty) - return Node_Id + Etyp : Entity_Id := Empty) return Node_Id is Typ : Entity_Id; @@ -3725,8 +4228,7 @@ package body Exp_Dist is (Loc : Source_Ptr; Stream : Entity_Id; Object : Node_Id; - Etyp : Entity_Id) - return Node_Id + Etyp : Entity_Id) return Node_Id is Write_Attribute : Name_Id := Name_Write; @@ -3754,8 +4256,7 @@ package body Exp_Dist is (Loc : Source_Ptr; Stream : Node_Id; Object : Node_Id; - Etyp : Entity_Id) - return Node_Id + Etyp : Entity_Id) return Node_Id is Write_Attribute : Name_Id := Name_Write; @@ -3777,10 +4278,9 @@ package body Exp_Dist is -- RACW_Type_Is_Asynchronous -- ------------------------------- - procedure RACW_Type_Is_Asynchronous (RACW_Type : in Entity_Id) is + procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type); pragma Assert (N /= Empty); - begin Replace (N, New_Occurrence_Of (Standard_True, Sloc (N))); end RACW_Type_Is_Asynchronous; @@ -3791,8 +4291,7 @@ package body Exp_Dist is function RCI_Package_Locator (Loc : Source_Ptr; - Package_Spec : Node_Id) - return Node_Id + Package_Spec : Node_Id) return Node_Id is Inst : constant Node_Id := Make_Package_Instantiation (Loc, @@ -3819,7 +4318,7 @@ package body Exp_Dist is ----------------------------------------------- procedure Remote_Types_Tagged_Full_View_Encountered - (Full_View : in Entity_Id) + (Full_View : Entity_Id) is Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Full_View); @@ -3848,4 +4347,26 @@ package body Exp_Dist is return Unit_Name; end Scope_Of_Spec; + -------------------------- + -- Underlying_RACW_Type -- + -------------------------- + + function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is + Record_Type : Entity_Id; + + begin + if Ekind (RAS_Typ) = E_Record_Type then + Record_Type := RAS_Typ; + else + pragma Assert (Present (Equivalent_Type (RAS_Typ))); + Record_Type := Equivalent_Type (RAS_Typ); + end if; + + return + Etype (Subtype_Indication ( + Component_Definition ( + First (Component_Items (Component_List ( + Type_Definition (Declaration_Node (Record_Type)))))))); + end Underlying_RACW_Type; + end Exp_Dist; diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads index 10cbc60bdb4..7d11ce34c0f 100644 --- a/gcc/ada/exp_dist.ads +++ b/gcc/ada/exp_dist.ads @@ -83,4 +83,21 @@ package Exp_Dist is E : Entity_Id) return Node_Id; -- Build a literal representing the remote subprogram identifier of E + function Copy_Specification + (Loc : Source_Ptr; + Spec : Node_Id; + Object_Type : Entity_Id := Empty; + Stub_Type : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id; + -- Build a subprogram specification from another one, or from + -- an access-to-subprogram definition. If Object_Type is not Empty + -- and any access to Object_Type is found, then it is replaced by an + -- access to Stub_Type. If New_Name is given, then it will be used as + -- the name for the newly created spec. + + function Underlying_RACW_Type + (RAS_Typ : Entity_Id) return Entity_Id; + -- Given a remote access-to-subprogram type or its equivalent + -- record type, return the RACW type generated to implement it. + end Exp_Dist; diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads index 9c3044bddff..ac52ecb962b 100644 --- a/gcc/ada/exp_pakd.ads +++ b/gcc/ada/exp_pakd.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -119,9 +119,9 @@ package Exp_Pakd is -- a packed array. There are two reasonable rules for deciding this: -- Store the first bit at right end (low order) word. This means - -- that the scaled subscript can be used directly as a right shift + -- that the scaled subscript can be used directly as a left shift -- count (if we put bit 0 at the left end, then we need an extra - -- subtract to compute the shift count. + -- subtract to compute the shift count). -- Layout the bits so that if the packed boolean array is overlaid on -- a record, using unchecked conversion, then bit 0 of the array is @@ -156,7 +156,7 @@ package Exp_Pakd is -- that a worthwhile price to pay for the consistency. -- One more important point arises in the case where we have a constrained - -- subtype of an unconstrained array. Take the case of 20-bits. For the + -- subtype of an unconstrained array. Take the case of 20 bits. For the -- unconstrained representation, we would use an array of bytes: -- Little-endian case diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb index 91ec4182d7d..32eaf0d33a1 100644 --- a/gcc/ada/g-pehage.adb +++ b/gcc/ada/g-pehage.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- G N A T . P E R F E C T _ H A S H . G E N E R A T O R S -- +-- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2003 Ada Core Technologies, Inc. -- +-- Copyright (C) 2002-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- -- @@ -38,7 +38,7 @@ with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Table; -package body GNAT.Perfect_Hash.Generators is +package body GNAT.Perfect_Hash_Generators is -- We are using the algorithm of J. Czech as described in Zbigniew -- J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal @@ -2397,4 +2397,4 @@ package body GNAT.Perfect_Hash.Generators is end case; end Value; -end GNAT.Perfect_Hash.Generators; +end GNAT.Perfect_Hash_Generators; diff --git a/gcc/ada/g-pehage.ads b/gcc/ada/g-pehage.ads index 3db2e70b71b..c5c36666cf9 100644 --- a/gcc/ada/g-pehage.ads +++ b/gcc/ada/g-pehage.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- G N A T . P E R F E C T _ H A S H . G E N E R A T O R S -- +-- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2002 Ada Core Technologies, Inc. -- +-- Copyright (C) 2002-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- -- @@ -31,16 +31,45 @@ -- -- ------------------------------------------------------------------------------ --- This package provides a single generator of static minimal perfect --- hash functions. No collisions occur and each item can be retrieved --- from the table in one probe (perfect property). The hash table --- size corresponds to the exact size of W and *no larger* (minimal --- property). The key set has to be know in advance (static --- property). The hash functions are also order preservering. If w2 --- is inserted after w1 in the generator, then f (w1) < f (w2). These --- hashing functions are convenient for use with realtime applications. - -package GNAT.Perfect_Hash.Generators is +-- This package provides a generator of static minimal perfect hash +-- functions. To understand what a perfect hash function is, we +-- define several notions. These definitions are inspired from the +-- following paper: + +-- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An +-- Optimal Algorithm for Generating Minimal Perfect Hash Functions'', +-- Information Processing Letters, 43(1992) pp.257-264, Oct.1992 + +-- Let W be a set of m words. A hash function h is a function that +-- maps the set of words W into some given interval of integers +-- [0, k-1], where k is an integer, usually k >= m. h (w) where w +-- is a word computes an address or an integer from I for the +-- storage or the retrieval of that item. The storage area used to +-- store items is known as a hash table. Words for which the same +-- address is computed are called synonyms. Due to the existence +-- of synonyms a situation called collision may arise in which two +-- items w1 and w2 have the same address. Several schemes for +-- resolving known. A perfect hash function is an injection from +-- the word set W to the integer interval I with k >= m. If k = m, +-- then h is a minimal perfect hash function. A hash function is +-- order preserving if it puts entries into the hash table in a +-- prespecified order. + +-- A minimal perfect hash function is defined by two properties: + +-- Since no collisions occur each item can be retrieved from the +-- table in *one* probe. This represents the "perfect" property. + +-- The hash table size corresponds to the exact size of W and +-- *no larger*. This represents the "minimal" property. + +-- The functions generated by this package require the key set to +-- be known in advance (they are "static" hash functions). +-- The hash functions are also order preservering. If w2 is inserted +-- after w1 in the generator, then f (w1) < f (w2). These hashing +-- functions are convenient for use with realtime applications. + +package GNAT.Perfect_Hash_Generators is Default_K_To_V : constant Float := 2.05; -- Default ratio for the algorithm. When K is the number of keys, @@ -57,7 +86,8 @@ package GNAT.Perfect_Hash.Generators is Default_Optimization : constant Optimization := CPU_Time; -- Optimize either the memory space or the execution time. - Verbose : Boolean := False; + Verbose : Boolean := False; + -- Comment required ??? procedure Initialize (Seed : Natural; @@ -183,4 +213,4 @@ package GNAT.Perfect_Hash.Generators is -- Return the value of the component (I, J) of the table -- Name. When the table has only one dimension, J is ignored. -end GNAT.Perfect_Hash.Generators; +end GNAT.Perfect_Hash_Generators; diff --git a/gcc/ada/g-perhas.ads b/gcc/ada/g-perhas.ads deleted file mode 100644 index 92a899cf600..00000000000 --- a/gcc/ada/g-perhas.ads +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . P E R F E C T _ H A S H -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2003 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package GNAT.Perfect_Hash is -pragma Pure (Perfect_Hash); - - -- The packages in this hierarchy implement perfect hash - -- functions. To understand what a perfect hash function is, we - -- define several notions. These definitions are inspired from the - -- following paper: - -- - -- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An - -- Optimal Algorithm for Generating Minimal Perfect Hash Functions'', - -- Information Processing Letters, 43(1992) pp.257-264, Oct.1992 - -- - -- Let W be a set of m words. A hash function h is a function that - -- maps the set of words W into some given interval of integers - -- [0, k-1], where k is an integer, usually k >= m. h (w) where w - -- is a word computes an address or an integer from I for the - -- storage or the retrieval of that item. The storage area used to - -- store items is known as a hash table. Words for which the same - -- address is computed are called synonyms. Due to the existence - -- of synonyms a situation called collision may arise in which two - -- items w1 and w2 have the same address. Several schemes for - -- resolving known. A perfect hash function is an injection from - -- the word set W to the integer interval I with k >= m. If k = m, - -- then h is a minimal perfect hash function. A hash function is - -- order preserving if it puts entries into the hash table in a - -- prespecified order. - -- - -- A minimal perfect hash function is defined by two properties: - -- * Since no collisions occur each item can be retrieved from the - -- table in *one* probe. This represents the "perfect" property. - -- * The hash table size corresponds to the exact size of W and - -- *no larger*. This represents the "minimal" property. - -end GNAT.Perfect_Hash; diff --git a/gcc/ada/g-trasym.ads b/gcc/ada/g-trasym.ads index aa899d93179..dc7b6dbe7c3 100644 --- a/gcc/ada/g-trasym.ads +++ b/gcc/ada/g-trasym.ads @@ -52,8 +52,8 @@ -- On all platforms except VMS, this package is not intended to be used -- within a shared library, symbolic tracebacks are only supported for the --- main executable and not for shared libraries. --- You should consider using gdb to obtain symbolic traceback in such cases. +-- main executable and not for shared libraries. You should consider using +-- gdb to obtain symbolic traceback in such cases. -- On VMS, there is no restriction on using this facility with shared -- libraries. However, the OS should be at least v7.3-1 and OS patch diff --git a/gcc/ada/gigi.h b/gcc/ada/gigi.h index 8d0917435d6..233c22be5ed 100644 --- a/gcc/ada/gigi.h +++ b/gcc/ada/gigi.h @@ -114,6 +114,22 @@ extern tree maybe_variable (tree); position so that it is aligned to ALIGN bits and is SIZE bytes long. */ extern tree make_aligning_type (tree, int, tree); +/* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type + if needed. We have already verified that SIZE and TYPE are large enough. + + GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and + to issue a warning. + + IS_USER_TYPE is true if we must be sure we complete the original type. + + DEFINITION is true if this type is being defined. + + SAME_RM_SIZE is true if the RM_Size of the resulting type is to be + set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original + type. */ +extern tree maybe_pad_type (tree, tree, unsigned int, Entity_Id, + const char *, bool, bool, bool); + /* Given a GNU tree and a GNAT list of choices, generate an expression to test the value passed against the list of choices. */ extern tree choices_to_gnu (tree, Node_Id); @@ -446,8 +462,10 @@ extern void finish_record_type (tree, tree, bool, bool); RETURNS_UNCONSTRAINED is true if the function returns an unconstrained object. RETURNS_BY_REF is true if the function returns by reference. RETURNS_WITH_DSP is true if the function is to return with a - depressed stack pointer. */ -extern tree create_subprog_type (tree, tree, tree, bool, bool, bool); + depressed stack pointer. RETURNS_BY_TARGET_PTR is true if the function + is to be passed (as its first parameter) the address of the place to copy + its result. */ +extern tree create_subprog_type (tree, tree, tree, bool, bool, bool, bool); /* Return a copy of TYPE, but safe to modify in any way. */ extern tree copy_type (tree); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 82c390ab34f..08a668317b2 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -117,6 +117,7 @@ Implementation Defined Pragmas * Pragma CPP_Virtual:: * Pragma CPP_Vtable:: * Pragma Debug:: +* Pragma Detect_Blocking:: * Pragma Elaboration_Checks:: * Pragma Eliminate:: * Pragma Export_Exception:: @@ -308,7 +309,7 @@ The GNAT Library * GNAT.Memory_Dump (g-memdum.ads):: * GNAT.Most_Recent_Exception (g-moreex.ads):: * GNAT.OS_Lib (g-os_lib.ads):: -* GNAT.Perfect_Hash.Generators (g-pehage.ads):: +* GNAT.Perfect_Hash_Generators (g-pehage.ads):: * GNAT.Regexp (g-regexp.ads):: * GNAT.Registry (g-regist.ads):: * GNAT.Regpat (g-regpat.ads):: @@ -632,6 +633,7 @@ consideration, the use of these pragmas should be minimized. * Pragma CPP_Virtual:: * Pragma CPP_Vtable:: * Pragma Debug:: +* Pragma Detect_Blocking:: * Pragma Elaboration_Checks:: * Pragma Eliminate:: * Pragma Export_Exception:: @@ -1330,6 +1332,21 @@ with a terminating semicolon. Pragmas are permitted in sequences of declarations, so you can use pragma @code{Debug} to intersperse calls to debug procedures in the middle of declarations. +@node Pragma Detect_Blocking +@unnumberedsec Pragma Detect_Blocking +@findex Detect_Blocking +@noindent +Syntax: + +@smallexample @c ada +pragma Detect_Blocking; +@end smallexample + +@noindent +This is a configuration pragma that forces the detection of potentially +blocking operations within a protected operation, and to raise Program_Error +if that happens. + @node Pragma Elaboration_Checks @unnumberedsec Pragma Elaboration_Checks @cindex Elaboration control @@ -11495,7 +11512,7 @@ of GNAT, and will generate a warning message. * GNAT.Memory_Dump (g-memdum.ads):: * GNAT.Most_Recent_Exception (g-moreex.ads):: * GNAT.OS_Lib (g-os_lib.ads):: -* GNAT.Perfect_Hash.Generators (g-pehage.ads):: +* GNAT.Perfect_Hash_Generators (g-pehage.ads):: * GNAT.Regexp (g-regexp.ads):: * GNAT.Registry (g-regist.ads):: * GNAT.Regpat (g-regpat.ads):: @@ -12137,9 +12154,9 @@ including time/date management, file operations, subprocess management, including a portable spawn procedure, and access to environment variables and error return codes. -@node GNAT.Perfect_Hash.Generators (g-pehage.ads) -@section @code{GNAT.Perfect_Hash.Generators} (@file{g-pehage.ads}) -@cindex @code{GNAT.Perfect_Hash.Generators} (@file{g-pehage.ads}) +@node GNAT.Perfect_Hash_Generators (g-pehage.ads) +@section @code{GNAT.Perfect_Hash_Generators} (@file{g-pehage.ads}) +@cindex @code{GNAT.Perfect_Hash_Generators} (@file{g-pehage.ads}) @cindex Hash functions @noindent diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index b9617b4a1f6..c8da0d86467 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -98,8 +98,6 @@ @set FILE gnat_ugn_vms @end ifset - - @settitle @value{EDITION} User's Guide for Native Platforms / @value{PLATFORM} @dircategory GNU Ada tools @direntry @@ -149,7 +147,6 @@ A copy of the license is included in the section entitled @end titlepage - @ifnottex @node Top, About This Guide, (dir), (dir) @top @value{EDITION} User's Guide @@ -321,7 +318,6 @@ The GNAT Make Program gnatmake * How gnatmake Works:: * Examples of gnatmake Usage:: - Improving Performance * Performance Considerations:: * Reducing the Size of Ada Executables with gnatelim:: @@ -384,7 +380,6 @@ GNAT Project Manager * An Extended Example:: * Project File Complete Syntax:: - The Cross-Referencing Tools gnatxref and gnatfind * gnatxref Switches:: @@ -394,13 +389,11 @@ The Cross-Referencing Tools gnatxref and gnatfind * Examples of gnatxref Usage:: * Examples of gnatfind Usage:: - The GNAT Pretty-Printer gnatpp * Switches for gnatpp:: * Formatting Rules:: - File Name Krunching Using gnatkr * About gnatkr:: @@ -622,7 +615,6 @@ Microsoft Windows Topics * GNAT and COM/DCOM Objects:: @end ifset - * Index:: @end menu @end ifnottex @@ -649,8 +641,6 @@ For ease of exposition, ``GNAT Pro'' will be referred to simply as ``GNAT'' in the remainder of this document. @end ifset - - @menu * What This Guide Contains:: * What You Should Know before Reading This Guide:: @@ -729,7 +719,6 @@ way to navigate through sources. version of an Ada source file with control over casing, indentation, comment placement, and other elements of program presentation style. - @item @ref{File Name Krunching Using gnatkr}, describes the @code{gnatkr} file name krunching utility, used to handle shortened @@ -826,7 +815,6 @@ Microsoft Windows platform. @end ifset @end itemize - @c ************************************************* @node What You Should Know before Reading This Guide @c ************************************************* @@ -933,8 +921,6 @@ If you are using GNAT on a Windows platform, please note that the ``@code{\}'' character should be used instead. @end ifset - - @c **************************** @node Getting Started with GNAT @chapter Getting Started with GNAT @@ -991,7 +977,6 @@ All three steps are most commonly handled by using the @code{gnatmake} utility program that, given the name of the main program, automatically performs the necessary compilation, binding and linking steps. - @node Running a Simple Ada Program @section Running a Simple Ada Program @@ -1114,7 +1099,6 @@ Hello WORLD! @noindent appear in response to this command. - @c **************************************** @node Running a Program with Multiple Units @section Running a Program with Multiple Units @@ -1322,7 +1306,6 @@ startup menu). * Simple Debugging with GPS:: @end menu - @node Building a New Program with GPS @subsection Building a New Program with GPS @noindent @@ -1429,7 +1412,6 @@ Select @code{File}, then @code{Save As}, and enter the source file name The file will be saved in the same directory you specified as the location of the default project file. - @item @emph{Updating the project file} You need to add the new source file to the project. @@ -1463,8 +1445,6 @@ Close the GPS window (or select @code{File}, then @code{Exit}) to terminate this GPS session. @end enumerate - - @node Simple Debugging with GPS @subsection Simple Debugging with GPS @noindent @@ -1572,7 +1552,6 @@ Right click on @code{N}, select @code{Debug}, then select @code{Display N}. You will see information about @code{N} appear in the @code{Debugger Data} pane, showing the value as 5. - @item @emph{Assigning a new value to a variable} Right click on the @code{N} in the @code{Debugger Data} pane, and @@ -1608,7 +1587,6 @@ The console window will disappear. @end enumerate @end enumerate - @node Introduction to Glide and GVD @section Introduction to Glide and GVD @cindex Glide @@ -3483,7 +3461,6 @@ directory designated by the logical name @code{SYS$SCRATCH:} GNAT uses the current directory for temporary files. @end ifset - @c ************************* @node Compiling Using gcc @chapter Compiling Using @code{gcc} @@ -4122,7 +4099,6 @@ is equivalent to specifying the following sequence of switches: @end smallexample @end ifclear - @c NEED TO CHECK THIS FOR VMS @noindent @@ -4166,7 +4142,6 @@ as validity checking options (see description of @option{-gnatV}). @end ifclear @end itemize - @node Output and Error Message Control @subsection Output and Error Message Control @findex stderr @@ -4330,7 +4305,6 @@ List possible interpretations for ambiguous calls Additional details on incorrect parameters @end itemize - @item -gnatq @cindex @option{-gnatq} (@code{gcc}) @ifclear vms @@ -4374,7 +4348,6 @@ since ALI files are never generated if @option{-gnats} is set. @end table - @node Warning Message Control @subsection Warning Message Control @cindex Warning messages @@ -4467,7 +4440,6 @@ Mismatching bounds in an aggregate @item Attempt to return local value by reference - @item Premature instantiation of a generic body @@ -4528,7 +4500,6 @@ Useless exception handlers @item Accidental hiding of name by child unit - @item Access before elaboration detected at compile time @@ -4969,7 +4940,6 @@ When no switch @option{^-gnatw^/WARNINGS^} is used, this is equivalent to: @end table - @node Debugging and Assertion Control @subsection Debugging and Assertion Control @@ -5063,7 +5033,6 @@ indicate validity checks that are performed or not performed in addition to the default checks described above. @end ifset - @table @option @c !sort! @item -gnatVa @@ -5227,7 +5196,6 @@ See also the pragma @code{Validity_Checks} which allows modification of the validity checking mode at the program source level, and also allows for temporary disabling of validity checks. - @node Style Checking @subsection Style Checking @findex Style checking @@ -5781,7 +5749,6 @@ increase the amount of stack for the environment task, then this is an operating systems issue, and must be addressed with the appropriate operating systems commands. - @node Using gcc for Syntax Checking @subsection Using @code{gcc} for Syntax Checking @table @option @@ -5837,7 +5804,6 @@ together. This is primarily used by the @code{gnatchop} utility (@pxref{Renaming Files Using gnatchop}). @end table - @node Using gcc for Semantic Checking @subsection Using @code{gcc} for Semantic Checking @table @option @@ -6025,7 +5991,6 @@ to enable file name krunching. For the source file naming rules, @xref{File Naming Rules}. @end table - @node Subprogram Inlining Control @subsection Subprogram Inlining Control @@ -6415,7 +6380,6 @@ and communicates it to the compiler using this switch. @end table - @node Integrated Preprocessing @subsection Integrated Preprocessing @@ -6603,7 +6567,6 @@ are suitable for spawning with appropriate GNAT RTL routines. @end ifset - @node Search Paths and the Run-Time Library (RTL) @section Search Paths and the Run-Time Library (RTL) @@ -6717,7 +6680,6 @@ Besides simplifying access to the RTL, a major use of search paths is in compiling sources from multiple directories. This can make development environments much more flexible. - @node Order of Compilation Issues @section Order of Compilation Issues @@ -6827,7 +6789,6 @@ This information is output in the forms of comments in the generated program, to be read by the @code{gnatlink} utility used to link the Ada application. @end enumerate - @node Running gnatbind @section Running @code{gnatbind} @@ -6919,7 +6880,6 @@ The use of the @option{^-C^/BIND_FILE=C^} switch for both @code{gnatbind} and @code{gnatlink} will cause the program to be generated in C (and compiled using the gnu C compiler). - @node Switches for gnatbind @section Switches for @command{gnatbind} @@ -7173,7 +7133,6 @@ You may obtain this listing of switches by running @code{gnatbind} with no arguments. @end ifclear - @node Consistency-Checking Modes @subsection Consistency-Checking Modes @@ -7496,7 +7455,6 @@ a list of ALI files can be given, and the execution of the program consists of elaboration of these units in an appropriate order. @end table - @node Command-Line Access @section Command-Line Access @@ -7527,7 +7485,6 @@ required, your main program must set @code{gnat_argc} and @code{gnat_argv} from the @code{argc} and @code{argv} values passed to it. - @node Search Paths for gnatbind @section Search Paths for @code{gnatbind} @@ -7696,7 +7653,6 @@ the @code{adainit} and @code{adafinal} routines to be called before and after accessing the Ada units. @end table - @c ------------------------------------ @node Linking Using gnatlink @chapter Linking Using @code{gnatlink} @@ -8583,13 +8539,6 @@ if you want to specify library paths only. @item -@code{gnatmake} examines both an ALI file and its corresponding object file -for consistency. If an ALI is more recent than its corresponding object, -or if the object file is missing, the corresponding source will be recompiled. -Note that @code{gnatmake} expects an ALI and the corresponding object file -to be in the same directory. - -@item @code{gnatmake} will ignore any files whose ALI file is write-protected. This may conveniently be used to exclude standard libraries from consideration and in particular it means that the use of the @@ -8642,8 +8591,7 @@ approach and in particular to understand how it uses the results of previous compilations without incorrectly depending on them. First a definition: an object file is considered @dfn{up to date} if the -corresponding ALI file exists and its time stamp predates that of the -object file and if all the source files listed in the +corresponding ALI file exists and if all the source files listed in the dependency section of this ALI file have time stamps matching those in the ALI file. This means that neither the source file itself nor any files that it depends on have been modified, and hence there is no need @@ -8710,7 +8658,6 @@ listed by the binder. @code{gnatmake} will operate in quiet mode, not displaying commands it is executing. @end table - @c ************************* @node Improving Performance @chapter Improving Performance @@ -8730,7 +8677,6 @@ the size of program executables. @end menu @end ifnottex - @c ***************************** @node Performance Considerations @section Performance Considerations @@ -8935,7 +8881,6 @@ is generally discouraged with GNAT, since it often results in larger executables which run more slowly. See further discussion of this point in @pxref{Inlining of Subprograms}. - @node Debugging Optimized Code @subsection Debugging Optimized Code @cindex Debugging optimized code @@ -9064,7 +9009,6 @@ on the resulting executable, which removes both debugging information and global symbols. @end ifclear - @node Inlining of Subprograms @subsection Inlining of Subprograms @@ -9574,7 +9518,6 @@ the @file{gnat.adc} file. You should recompile your program from scratch after that, because you need a consistent @file{gnat.adc} file during the entire compilation. - @node Making Your Executables Smaller @subsection Making Your Executables Smaller @@ -9635,9 +9578,6 @@ $ gnatmake ^-f main_prog^/FORCE_COMPILE MAIN_PROG^ @end enumerate - - - @c ******************************** @node Renaming Files Using gnatchop @chapter Renaming Files Using @code{gnatchop} @@ -9682,7 +9622,6 @@ system, you can set up a procedure where you use @command{gnatchop} each time you compile, regarding the source files that it writes as temporary files that you throw away. - @node Operating gnatchop in Compilation Mode @section Operating gnatchop in Compilation Mode @@ -9997,6 +9936,7 @@ recognized by @code{GNAT}: Ada_95 C_Pass_By_Copy Component_Alignment + Detect_Blocking Discard_Names Elaboration_Checks Eliminate @@ -10333,7 +10273,6 @@ even in conjunction with one or several switches @option{^-D^/DIRS_FILE^}. Several Naming Patterns and one excluded pattern are used in this example. - @c ***************************************** @c * G N A T P r o j e c t M a n a g e r * @c ***************************************** @@ -10744,7 +10683,7 @@ invoking @command{gnatmake} (see @ref{gnatmake and Project Files}). @noindent By default, the executable file name corresponding to a main source is -deducted from the main source file name. Through the attributes +deduced from the main source file name. Through the attributes @code{Executable} and @code{Executable_Suffix} of package @code{Builder}, it is possible to change this default. In project @code{Debug} above, the executable file name @@ -12542,7 +12481,6 @@ 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. - @c ********************************************** @c * Using Third-Party Libraries through Projects @c ********************************************** @@ -13730,7 +13668,6 @@ simple_name ::= @end smallexample - @node The Cross-Referencing Tools gnatxref and gnatfind @chapter The Cross-Referencing Tools @code{gnatxref} and @code{gnatfind} @findex gnatxref @@ -14426,7 +14363,6 @@ point to any character in the middle of the identifier. @end table - @c ********************************* @node The GNAT Pretty-Printer gnatpp @chapter The GNAT Pretty-Printer @command{gnatpp} @@ -14478,7 +14414,6 @@ allowed. The file name may contain path information; it does not have to follow the GNAT file naming rules @end itemize - @menu * Switches for gnatpp:: * Formatting Rules:: @@ -14540,7 +14475,6 @@ indicate the effect. * Other gnatpp Switches:: @end menu - @node Alignment Control @subsection Alignment Control @cindex Alignment control in @command{gnatpp} @@ -14581,7 +14515,6 @@ Align @code{=>} in associations The @option{^-A^/ALIGN^} switches are mutually compatible; any combination is allowed. - @node Casing Control @subsection Casing Control @cindex Casing control in @command{gnatpp} @@ -14676,7 +14609,6 @@ The @option{^-D-^/SPECIFIC_CASING^} and @option{^-D@var{file}^/DICTIONARY=@var{file}^} switches are mutually compatible. - @node Construct Layout Control @subsection Construct Layout Control @cindex Layout control in @command{gnatpp} @@ -14771,7 +14703,6 @@ indentation is set to 1 (in which case the default value for continuation line indentation is also 1) @end table - @node Other Formatting Options @subsection Other Formatting Options @@ -14831,7 +14762,6 @@ The same as the corresponding gcc switch @end table - @node Output File Control @subsection Output File Control @@ -14913,7 +14843,6 @@ Warning mode; a required layout in the result source. @end table - @node Formatting Rules @section Formatting Rules @@ -14929,7 +14858,6 @@ They provide the detailed descriptions of the switches shown above. * Name Casing:: @end menu - @node White Space and Empty Lines @subsection White Space and Empty Lines @@ -14963,7 +14891,6 @@ In order to preserve a visual separation between comment blocks, use an Likewise, if for some reason you wish to have a sequence of empty lines, use a sequence of empty comments instead. - @node Formatting Comments @subsection Formatting Comments @@ -15107,7 +15034,6 @@ comments may be reformatted in typical word processor style (that is, moving words between lines and putting as many words in a line as possible). - @node Construct Layout @subsection Construct Layout @@ -15185,7 +15111,6 @@ type q is record type q is end record; b : integer; end record; - Block : declare Block : A : Integer := 3; declare begin A : Integer := 3; @@ -15206,7 +15131,6 @@ A further difference between GNAT style layout and compact layout is that GNAT style layout inserts empty lines as separation for compound statements, return statements and bodies. - @node Name Casing @subsection Name Casing @@ -15399,8 +15323,6 @@ end Test; @end cartouche @end smallexample - - @c *********************************** @node File Name Krunching Using gnatkr @chapter File Name Krunching Using @code{gnatkr} @@ -16578,7 +16500,6 @@ library, by reordering the lines in the configuration files. In general, a library must be installed before the GNAT library if it redefines any part of it. - @node Using the library @subsection Using the library @@ -16646,7 +16567,6 @@ pragma Linker_Options ("-lmy_lib"); @end smallexample @end itemize - @node Stand-alone Ada Libraries @section Stand-alone Ada Libraries @cindex Stand-alone library, building, using @@ -16926,7 +16846,6 @@ gnat library. This Makefile contains its own documentation and in particular the set of instructions needed to rebuild a new library and to use it. - @node Using the GNU make Utility @chapter Using the GNU @code{make} Utility @findex make @@ -17218,7 +17137,6 @@ all: @end smallexample @end ifclear - @node Finding Memory Problems @chapter Finding Memory Problems @@ -17238,7 +17156,6 @@ access values (including ``dangling references''). * The GNAT Debug Pool Facility:: @end menu - @ifclear vms @node The gnatmem Tool @section The @command{gnatmem} Tool @@ -17581,7 +17498,6 @@ and #3 thanks to the more precise associated backtrace. @end ifclear - @node The GNAT Debug Pool Facility @section The GNAT Debug Pool Facility @findex Debug Pool @@ -17726,7 +17642,6 @@ Debug Pool info: High Water Mark: 8 @end smallexample - @node Creating Sample Bodies Using gnatstub @chapter Creating Sample Bodies Using @command{gnatstub} @findex gnatstub @@ -17903,7 +17818,6 @@ Verbose mode: generate version information. @end table - @node Other Utility Programs @chapter Other Utility Programs @@ -18098,7 +18012,6 @@ For more information, please refer to the online documentation available in the @code{Glide} @result{} @code{Help} menu. @end ifclear - @node Converting Ada Files to html with gnathtml @section Converting Ada Files to HTML with @code{gnathtml} @@ -18389,7 +18302,6 @@ The simplest command is simply @code{run}, which causes the program to run exactly as if the debugger were not present. The following section describes some of the additional commands that can be given to @code{GDB}. - @c ******************************* @node Introduction to GDB Commands @section Introduction to GDB Commands @@ -19189,7 +19101,6 @@ You can then get further information by invoking the @code{addr2line} tool as described earlier (note that the hexadecimal addresses need to be specified in C format, with a leading ``0x''). - @node Symbolic Traceback @subsection Symbolic Traceback @cindex traceback, symbolic @@ -20893,7 +20804,6 @@ and GNAT systems. @end ifset - @c ************************************** @node Platform-Specific Information for the Run-Time Libraries @appendix Platform-Specific Information for the Run-Time Libraries @@ -20957,11 +20867,9 @@ information about several specific platforms. * AIX-Specific Considerations:: @end menu - @node Summary of Run-Time Configurations @section Summary of Run-Time Configurations - @multitable @columnfractions .30 .70 @item @b{alpha-openvms} @item @code{@ @ }@i{rts-native (default)} @@ -21021,8 +20929,6 @@ information about several specific platforms. @* @end multitable - - @node Specifying a Run-Time Library @section Specifying a Run-Time Library @@ -21196,7 +21102,6 @@ you find that the improved efficiency of FSU threads is significant to you. Note also that to take full advantage of Florist and Glade, it is highly recommended that you use native threads. - @node Choosing the Scheduling Policy @section Choosing the Scheduling Policy @@ -21235,8 +21140,6 @@ you should use @code{pragma Time_Slice} with a value greater than @code{0.0}, or else use the corresponding @option{-T} binder option. - - @node Solaris-Specific Considerations @section Solaris-Specific Considerations @cindex Solaris Sparc threads libraries @@ -21251,7 +21154,6 @@ debugging 64-bit applications. * Building and Debugging 64-bit Applications:: @end menu - @node Solaris Threads Issues @subsection Solaris Threads Issues @@ -21305,7 +21207,6 @@ Run the program on the specified processor. (where @code{_SC_NPROCESSORS_CONF} is a system variable). @end table - @node Building and Debugging 64-bit Applications @subsection Building and Debugging 64-bit Applications @@ -21329,8 +21230,6 @@ amounts to: $ gdb64 hello @end smallexample - - @node IRIX-Specific Considerations @section IRIX-Specific Considerations @cindex IRIX thread library @@ -21351,7 +21250,6 @@ See the @cite{GNAT Reference Manual} for further information. The @emph{n32 ABI} compiler comes with a run-time library based on the kernel POSIX threads and thus does not have the limitations mentioned above. - @node Linux-Specific Considerations @section Linux-Specific Considerations @cindex Linux threads libraries @@ -21395,7 +21293,6 @@ This Appendix displays the source code for @command{gnatbind}'s output file generated for a simple ``Hello World'' program. Comments have been added for clarification purposes. - @smallexample @c adanocomment @iftex @leftskip=0cm @@ -22111,7 +22008,6 @@ and trace the elaboration routine for this package to find out where the problem might be (more usually of course you would be debugging elaboration code in your own application). - @node Elaboration Order Handling in GNAT @appendix Elaboration Order Handling in GNAT @cindex Order of elaboration @@ -23967,7 +23863,6 @@ difference, by looking at the two elaboration orders that are chosen, and figuring out which is correct, and then adding the necessary @code{Elaborate_All} pragmas to ensure the desired order. - @node Inline Assembler @appendix Inline Assembler @@ -25578,8 +25473,6 @@ end Intel_CPU; @c END OF INLINE ASSEMBLER CHAPTER @c =============================== - - @c *********************************** @c * Compatibility and Porting Guide * @c *********************************** @@ -25784,7 +25677,6 @@ include @code{pragma Interface} and the floating point type attributes (@code{Emax}, @code{Mantissa}, etc.), among other items. @end table - @node Implementation-dependent characteristics @section Implementation-dependent characteristics @noindent @@ -25805,7 +25697,6 @@ transition from certain Ada 83 compilers. * Target-specific aspects:: @end menu - @node Implementation-defined pragmas @subsection Implementation-defined pragmas @@ -25903,7 +25794,6 @@ incompatible with typical Ada 83 compiler practices regarding implicit packing, the meaning of the Size attribute, and the size of access values. GNAT's approach to these issues is described in @ref{Representation Clauses}. - @node Compatibility with Other Ada 95 Systems @section Compatibility with Other Ada 95 Systems @@ -26104,8 +25994,6 @@ attributes are recognized, although only a subset of them can sensibly be implemented. The description of pragmas in this reference manual indicates whether or not they are applicable to non-VMS systems. - - @ifset unw @node Microsoft Windows Topics @appendix Microsoft Windows Topics @@ -27878,7 +27766,6 @@ This section is temporarily left blank. @end ifset - @c ********************************** @c * GNU Free Documentation License * @c ********************************** diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 6d5595e7264..48c23f07eb8 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -605,7 +605,7 @@ begin Error_Msg ("?may result in missing run-time elaboration checks"); Error_Msg - ("?use -gnatE, pragma Suppress (Elaboration_Checks) instead"); + ("?use -gnatE, pragma Suppress (Elaboration_Check) instead"); end if; -- Quit if some file needs compiling diff --git a/gcc/ada/gnatdll.adb b/gcc/ada/gnatdll.adb index 74c004b5958..10249b313dd 100644 --- a/gcc/ada/gnatdll.adb +++ b/gcc/ada/gnatdll.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- G N A T D L L -- +-- G N A T D L L -- -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -27,25 +27,20 @@ -- GNATDLL is a Windows specific tool for building a DLL. -- Both relocatable and non-relocatable DLL's are supported -with Ada.Text_IO; -with Ada.Strings.Unbounded; -with Ada.Exceptions; -with Ada.Command_Line; -with GNAT.OS_Lib; -with GNAT.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Command_Line; use Ada.Command_Line; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Command_Line; use GNAT.Command_Line; with Gnatvsn; -with MDLL.Fil; -with MDLL.Utl; +with MDLL.Fil; use MDLL.Fil; +with MDLL.Utl; use MDLL.Utl; procedure Gnatdll is - use GNAT; - use Ada; - use MDLL; - use Ada.Strings.Unbounded; - - use type OS_Lib.Argument_List; + use type GNAT.OS_Lib.Argument_List; procedure Syntax; -- Print out usage @@ -59,7 +54,7 @@ procedure Gnatdll is procedure Check_Context; -- Check the context before runing any commands to build the library - Syntax_Error : exception; + Syntax_Error : exception; -- Raised when a syntax error is detected, in this case a usage info will -- be displayed. @@ -76,31 +71,33 @@ procedure Gnatdll is Default_DLL_Address : constant String := "0x11000000"; -- Default address for non relocatable DLL (Win32) - Lib_Filename : Unbounded_String := Null_Unbounded_String; + Lib_Filename : Unbounded_String := Null_Unbounded_String; -- The DLL filename that will be created (.dll) - Def_Filename : Unbounded_String := Null_Unbounded_String; + Def_Filename : Unbounded_String := Null_Unbounded_String; -- The definition filename (.def) - List_Filename : Unbounded_String := Null_Unbounded_String; + List_Filename : Unbounded_String := Null_Unbounded_String; -- The name of the file containing the objects file to put into the DLL - DLL_Address : Unbounded_String := - To_Unbounded_String (Default_DLL_Address); + DLL_Address : Unbounded_String := To_Unbounded_String (Default_DLL_Address); -- The DLL's base address - Objects_Files : Argument_List_Access := Null_Argument_List_Access; + Gen_Map_File : Boolean := False; + -- Set to True if a map file is to be generated + + Objects_Files : Argument_List_Access := MDLL.Null_Argument_List_Access; -- List of objects to put inside the library - Ali_Files : Argument_List_Access := Null_Argument_List_Access; + Ali_Files : Argument_List_Access := MDLL.Null_Argument_List_Access; -- For each Ada file specified, we keep arecord of the corresponding -- ALI file. This list of SLI files is used to build the binder program. - Options : Argument_List_Access := Null_Argument_List_Access; - -- A list of options set in the command line. + Options : Argument_List_Access := MDLL.Null_Argument_List_Access; + -- A list of options set in the command line - Largs_Options : Argument_List_Access := Null_Argument_List_Access; - Bargs_Options : Argument_List_Access := Null_Argument_List_Access; + Largs_Options : Argument_List_Access := MDLL.Null_Argument_List_Access; + Bargs_Options : Argument_List_Access := MDLL.Null_Argument_List_Access; -- GNAT linker and binder args options type Build_Mode_State is (Import_Lib, Dynamic_Lib, Dynamic_Lib_Only, Nil); @@ -109,8 +106,8 @@ procedure Gnatdll is -- Dynamic_Lib_Only means that only the DLL will be created (no import -- library). - Build_Mode : Build_Mode_State := Nil; - -- Will be set when parsing the command line. + Build_Mode : Build_Mode_State := Nil; + -- Will be set when parsing the command line Must_Build_Relocatable : Boolean := True; -- True means build a relocatable DLL, will be set to False if a @@ -121,10 +118,7 @@ procedure Gnatdll is ------------ procedure Syntax is - use Text_IO; - - procedure P (Str : in String) renames Text_IO.Put_Line; - + procedure P (Str : String) renames Put_Line; begin P ("Usage : gnatdll [options] [list-of-files]"); New_Line; @@ -148,6 +142,7 @@ procedure Gnatdll is P (" -a[addr] Build non-relocatable DLL at address <addr>"); P (" if <addr> is not specified use " & Default_DLL_Address); + P (" -m Generate map file"); P (" -n No-import - do not create the import library"); P (" -bargs opts opts are passed to the binder"); P (" -largs opts opts are passed to the linker"); @@ -159,9 +154,9 @@ procedure Gnatdll is procedure Check (Filename : in String) is begin - if not OS_Lib.Is_Regular_File (Filename) then - Exceptions.Raise_Exception (Context_Error'Identity, - "Error: " & Filename & " not found."); + if not Is_Regular_File (Filename) then + Raise_Exception + (Context_Error'Identity, "Error: " & Filename & " not found."); end if; end Check; @@ -186,29 +181,29 @@ procedure Gnatdll is -- No, a better choice would be to use tables ??? -- Limits on what??? - Ofiles : OS_Lib.Argument_List (1 .. Max_Files); + Ofiles : Argument_List (1 .. Max_Files); O : Positive := Ofiles'First; -- List of object files to put in the library. O is the next entry -- to be used. - Afiles : OS_Lib.Argument_List (1 .. Max_Files); + Afiles : Argument_List (1 .. Max_Files); A : Positive := Afiles'First; - -- List of ALI files. A is the next entry to be used. + -- List of ALI files. A is the next entry to be used - Gopts : OS_Lib.Argument_List (1 .. Max_Options); + Gopts : Argument_List (1 .. Max_Options); G : Positive := Gopts'First; - -- List of gcc options. G is the next entry to be used. + -- List of gcc options. G is the next entry to be used - Lopts : OS_Lib.Argument_List (1 .. Max_Options); + Lopts : Argument_List (1 .. Max_Options); L : Positive := Lopts'First; -- A list of -largs options (L is next entry to be used) - Bopts : OS_Lib.Argument_List (1 .. Max_Options); + Bopts : Argument_List (1 .. Max_Options); B : Positive := Bopts'First; -- A list of -bargs options (B is next entry to be used) Build_Import : Boolean := True; - -- Set to Fals if option -n if specified (no-import). + -- Set to Fals if option -n if specified (no-import) -------------- -- Add_File -- @@ -216,7 +211,7 @@ procedure Gnatdll is procedure Add_File (Filename : in String) is begin - if Fil.Is_Ali (Filename) then + if Is_Ali (Filename) then Check (Filename); @@ -226,7 +221,7 @@ procedure Gnatdll is Afiles (A) := new String'(Filename); A := A + 1; - elsif Fil.Is_Obj (Filename) then + elsif Is_Obj (Filename) then Check (Filename); @@ -238,7 +233,7 @@ procedure Gnatdll is else -- Unknown file type - Exceptions.Raise_Exception + Raise_Exception (Syntax_Error'Identity, "don't know what to do with " & Filename & " !"); end if; @@ -249,19 +244,19 @@ procedure Gnatdll is ------------------------- procedure Add_Files_From_List (List_Filename : in String) is - File : Text_IO.File_Type; + File : File_Type; Buffer : String (1 .. 500); Last : Natural; begin - Text_IO.Open (File, Text_IO.In_File, List_Filename); + Open (File, In_File, List_Filename); - while not Text_IO.End_Of_File (File) loop - Text_IO.Get_Line (File, Buffer, Last); + while not End_Of_File (File) loop + Get_Line (File, Buffer, Last); Add_File (Buffer (1 .. Last)); end loop; - Text_IO.Close (File); + Close (File); end Add_Files_From_List; -- Start of processing for Parse_Command_Line @@ -272,7 +267,7 @@ procedure Gnatdll is -- scan gnatdll switches loop - case Getopt ("g h v q k a? b: d: e: l: n I:") is + case Getopt ("g h v q k a? b: d: e: l: n m I:") is when ASCII.Nul => exit; @@ -290,7 +285,7 @@ procedure Gnatdll is MDLL.Verbose := True; if MDLL.Quiet then - Exceptions.Raise_Exception + Raise_Exception (Syntax_Error'Identity, "impossible to use -q and -v together."); end if; @@ -301,7 +296,7 @@ procedure Gnatdll is MDLL.Quiet := True; if MDLL.Verbose then - Exceptions.Raise_Exception + Raise_Exception (Syntax_Error'Identity, "impossible to use -v and -q together."); end if; @@ -343,11 +338,15 @@ procedure Gnatdll is if Def_Filename = Null_Unbounded_String then Def_Filename := To_Unbounded_String - (Fil.Ext_To (Parameter, "def")); + (Ext_To (Parameter, "def")); end if; Build_Mode := Dynamic_Lib; + when 'm' => + + Gen_Map_File := True; + when 'n' => Build_Import := False; @@ -361,7 +360,6 @@ procedure Gnatdll is when others => raise Invalid_Switch; - end case; end loop; @@ -382,14 +380,12 @@ procedure Gnatdll is loop case Getopt ("*") is - when ASCII.Nul => exit; when others => Lopts (L) := new String'(Full_Switch); L := L + 1; - end case; end loop; @@ -416,12 +412,10 @@ procedure Gnatdll is Add_Files_From_List (To_String (List_Filename)); end if; - -- Check if the set of parameters are compatible. + -- Check if the set of parameters are compatible - if Build_Mode = Nil and then not Help and then not Verbose then - Exceptions.Raise_Exception - (Syntax_Error'Identity, - "nothing to do."); + if Build_Mode = Nil and then not Help and then not MDLL.Verbose then + Raise_Exception (Syntax_Error'Identity, "nothing to do."); end if; -- -n option but no file specified @@ -430,7 +424,7 @@ procedure Gnatdll is and then A = Afiles'First and then O = Ofiles'First then - Exceptions.Raise_Exception + Raise_Exception (Syntax_Error'Identity, "-n specified but there are no objects to build the library."); end if; @@ -445,41 +439,49 @@ procedure Gnatdll is Build_Mode := Import_Lib; end if; - -- Check if only a dynamic library must be built. + -- If map file is to be generated, add linker option here + + if Gen_Map_File and then Build_Mode = Import_Lib then + Raise_Exception + (Syntax_Error'Identity, + "Can't generate a map file for an import library."); + end if; + + -- Check if only a dynamic library must be built if Build_Mode = Dynamic_Lib and then not Build_Import then Build_Mode := Dynamic_Lib_Only; end if; if O /= Ofiles'First then - Objects_Files := new OS_Lib.Argument_List'(Ofiles (1 .. O - 1)); + Objects_Files := new Argument_List'(Ofiles (1 .. O - 1)); end if; if A /= Afiles'First then - Ali_Files := new OS_Lib.Argument_List'(Afiles (1 .. A - 1)); + Ali_Files := new Argument_List'(Afiles (1 .. A - 1)); end if; if G /= Gopts'First then - Options := new OS_Lib.Argument_List'(Gopts (1 .. G - 1)); + Options := new Argument_List'(Gopts (1 .. G - 1)); end if; if L /= Lopts'First then - Largs_Options := new OS_Lib.Argument_List'(Lopts (1 .. L - 1)); + Largs_Options := new Argument_List'(Lopts (1 .. L - 1)); end if; if B /= Bopts'First then - Bargs_Options := new OS_Lib.Argument_List'(Bopts (1 .. B - 1)); + Bargs_Options := new Argument_List'(Bopts (1 .. B - 1)); end if; exception when Invalid_Switch => - Exceptions.Raise_Exception + Raise_Exception (Syntax_Error'Identity, Message => "Invalid Switch " & Full_Switch); when Invalid_Parameter => - Exceptions.Raise_Exception + Raise_Exception (Syntax_Error'Identity, Message => "No parameter for " & Full_Switch); @@ -512,9 +514,9 @@ begin end if; if MDLL.Verbose or else Help then - Text_IO.New_Line; - Text_IO.Put_Line ("GNATDLL " & Version & " - Dynamic Libraries Builder"); - Text_IO.New_Line; + New_Line; + Put_Line ("GNATDLL " & Version & " - Dynamic Libraries Builder"); + New_Line; end if; MDLL.Utl.Locate; @@ -544,7 +546,8 @@ begin To_String (Def_Filename), To_String (DLL_Address), Build_Import => True, - Relocatable => Must_Build_Relocatable); + Relocatable => Must_Build_Relocatable, + Map_File => Gen_Map_File); when Dynamic_Lib_Only => MDLL.Build_Dynamic_Library @@ -557,31 +560,30 @@ begin To_String (Def_Filename), To_String (DLL_Address), Build_Import => False, - Relocatable => Must_Build_Relocatable); + Relocatable => Must_Build_Relocatable, + Map_File => Gen_Map_File); when Nil => null; - end case; - end if; - Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success); + Set_Exit_Status (Success); exception when SE : Syntax_Error => - Text_IO.Put_Line ("Syntax error : " & Exceptions.Exception_Message (SE)); - Text_IO.New_Line; + Put_Line ("Syntax error : " & Exception_Message (SE)); + New_Line; Syntax; - Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); + Set_Exit_Status (Failure); - when E : Tools_Error | Context_Error => - Text_IO.Put_Line (Exceptions.Exception_Message (E)); - Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); + when E : MDLL.Tools_Error | Context_Error => + Put_Line (Exception_Message (E)); + Set_Exit_Status (Failure); when others => - Text_IO.Put_Line ("gnatdll: INTERNAL ERROR. Please report"); - Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); + Put_Line ("gnatdll: INTERNAL ERROR. Please report"); + Set_Exit_Status (Failure); end Gnatdll; diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 5c269916371..cdc924cb418 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -98,6 +98,8 @@ procedure Gnatls is Dependable : Boolean := False; -- flag -d Also_Predef : Boolean := False; + Very_Verbose_Mode : Boolean := False; -- flag -V + Unit_Start : Integer; Unit_End : Integer; Source_Start : Integer; @@ -162,6 +164,20 @@ procedure Gnatls is function Image (Restriction : Restriction_Id) return String; -- Returns the capitalized image of Restriction + --------------------------------------- + -- GLADE specific output subprograms -- + --------------------------------------- + + package GLADE is + + -- Any modification to this subunit requires a synchronization + -- with the GLADE implementation. + + procedure Output_ALI (A : ALI_Id); + procedure Output_No_ALI (Afile : File_Name_Type); + + end GLADE; + ----------------- -- Add_Lib_Dir -- ----------------- @@ -355,6 +371,409 @@ procedure Gnatls is end Find_Status; ----------- + -- GLADE -- + ----------- + + package body GLADE is + + N_Flags : Natural; + N_Indents : Natural := 0; + + type Token_Type is + (T_No_ALI, + T_ALI, + T_Unit, + T_With, + T_Source, + T_Afile, + T_Ofile, + T_Sfile, + T_Name, + T_Main, + T_Kind, + T_Flags, + T_Preelaborated, + T_Pure, + T_Has_RACW, + T_Remote_Types, + T_Shared_Passive, + T_RCI, + T_Predefined, + T_Internal, + T_Is_Generic, + T_Procedure, + T_Function, + T_Package, + T_Subprogram, + T_Spec, + T_Body); + + Image : constant array (Token_Type) of String_Access := + (T_No_ALI => new String'("No_ALI"), + T_ALI => new String'("ALI"), + T_Unit => new String'("Unit"), + T_With => new String'("With"), + T_Source => new String'("Source"), + T_Afile => new String'("Afile"), + T_Ofile => new String'("Ofile"), + T_Sfile => new String'("Sfile"), + T_Name => new String'("Name"), + T_Main => new String'("Main"), + T_Kind => new String'("Kind"), + T_Flags => new String'("Flags"), + T_Preelaborated => new String'("Preelaborated"), + T_Pure => new String'("Pure"), + T_Has_RACW => new String'("Has_RACW"), + T_Remote_Types => new String'("Remote_Types"), + T_Shared_Passive => new String'("Shared_Passive"), + T_RCI => new String'("RCI"), + T_Predefined => new String'("Predefined"), + T_Internal => new String'("Internal"), + T_Is_Generic => new String'("Is_Generic"), + T_Procedure => new String'("procedure"), + T_Function => new String'("function"), + T_Package => new String'("package"), + T_Subprogram => new String'("subprogram"), + T_Spec => new String'("spec"), + T_Body => new String'("body")); + + procedure Output_Name (N : Name_Id); + -- Remove any encoding info (%b and %s) and output N + + procedure Output_Afile (A : File_Name_Type); + procedure Output_Ofile (O : File_Name_Type); + procedure Output_Sfile (S : File_Name_Type); + -- Output various names. Check that the name is different from + -- no name. Otherwise, skip the output. + + procedure Output_Token (T : Token_Type); + -- Output token using a specific format. That is several + -- indentations and: + -- + -- T_No_ALI .. T_With : <token> & " =>" & NL + -- T_Source .. T_Kind : <token> & " => " + -- T_Flags : <token> & " =>" + -- T_Preelab .. T_Body : " " & <token> + + procedure Output_Sdep (S : Sdep_Id); + procedure Output_Unit (U : Unit_Id); + procedure Output_With (W : With_Id); + -- Output this entry as a global section (like ALIs) + + ------------------ + -- Output_Afile -- + ------------------ + + procedure Output_Afile (A : File_Name_Type) is + begin + if A /= No_File then + Output_Token (T_Afile); + Write_Name (A); + Write_Eol; + end if; + end Output_Afile; + + ---------------- + -- Output_ALI -- + ---------------- + + procedure Output_ALI (A : ALI_Id) is + begin + Output_Token (T_ALI); + N_Indents := N_Indents + 1; + + Output_Afile (ALIs.Table (A).Afile); + Output_Ofile (ALIs.Table (A).Ofile_Full_Name); + Output_Sfile (ALIs.Table (A).Sfile); + + -- Output Main + + if ALIs.Table (A).Main_Program /= None then + Output_Token (T_Main); + + if ALIs.Table (A).Main_Program = Proc then + Output_Token (T_Procedure); + else + Output_Token (T_Function); + end if; + + Write_Eol; + end if; + + -- Output Units + + for U in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop + Output_Unit (U); + end loop; + + -- Output Sdeps + + for S in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop + Output_Sdep (S); + end loop; + + N_Indents := N_Indents - 1; + end Output_ALI; + + ------------------- + -- Output_No_ALI -- + ------------------- + + procedure Output_No_ALI (Afile : File_Name_Type) is + begin + Output_Token (T_No_ALI); + N_Indents := N_Indents + 1; + Output_Afile (Afile); + N_Indents := N_Indents - 1; + end Output_No_ALI; + + ----------------- + -- Output_Name -- + ----------------- + + procedure Output_Name (N : Name_Id) is + begin + -- Remove any encoding info (%s or %b) + + Get_Name_String (N); + if Name_Len > 2 + and then Name_Buffer (Name_Len - 1) = '%' + then + Name_Len := Name_Len - 2; + end if; + + Output_Token (T_Name); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Eol; + end Output_Name; + + ------------------ + -- Output_Ofile -- + ------------------ + + procedure Output_Ofile (O : File_Name_Type) is + begin + if O /= No_File then + Output_Token (T_Ofile); + Write_Name (O); + Write_Eol; + end if; + end Output_Ofile; + + ----------------- + -- Output_Sdep -- + ----------------- + + procedure Output_Sdep (S : Sdep_Id) is + begin + Output_Token (T_Source); + Write_Name (Sdep.Table (S).Sfile); + Write_Eol; + end Output_Sdep; + + ------------------ + -- Output_Sfile -- + ------------------ + + procedure Output_Sfile (S : File_Name_Type) is + FS : File_Name_Type := S; + + begin + if FS /= No_File then + + -- We want to output the full source name + + FS := Full_Source_Name (FS); + + -- There is no full source name. This occurs for instance when a + -- withed unit has a spec file but no body file. This situation + -- is not a problem for GLADE since the unit may be located on + -- a partition we do not want to build. However, we need to + -- locate the spec file and to find its full source name. + -- Replace the body file name with the spec file name used to + -- compile the current unit when possible. + + if FS = No_File then + Get_Name_String (S); + + if Name_Len > 4 + and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" + then + Name_Buffer (Name_Len) := 's'; + FS := Full_Source_Name (Name_Find); + end if; + end if; + end if; + + if FS /= No_File then + Output_Token (T_Sfile); + Write_Name (FS); + Write_Eol; + end if; + end Output_Sfile; + + ------------------ + -- Output_Token -- + ------------------ + + procedure Output_Token (T : Token_Type) is + begin + if T in T_No_ALI .. T_Flags then + for J in 1 .. N_Indents loop + Write_Str (" "); + end loop; + + Write_Str (Image (T).all); + + for J in Image (T)'Length .. 12 loop + Write_Char (' '); + end loop; + + Write_Str ("=>"); + + if T in T_No_ALI .. T_With then + Write_Eol; + elsif T in T_Source .. T_Name then + Write_Char (' '); + end if; + + elsif T in T_Preelaborated .. T_Body then + if T in T_Preelaborated .. T_Is_Generic then + if N_Flags = 0 then + Output_Token (T_Flags); + end if; + + N_Flags := N_Flags + 1; + end if; + + Write_Char (' '); + Write_Str (Image (T).all); + + else + Write_Str (Image (T).all); + end if; + end Output_Token; + + ----------------- + -- Output_Unit -- + ----------------- + + procedure Output_Unit (U : Unit_Id) is + begin + Output_Token (T_Unit); + N_Indents := N_Indents + 1; + + -- Output Name + + Output_Name (Units.Table (U).Uname); + + -- Output Kind + + Output_Token (T_Kind); + + if Units.Table (U).Unit_Kind = 'p' then + Output_Token (T_Package); + else + Output_Token (T_Subprogram); + end if; + + if Name_Buffer (Name_Len) = 's' then + Output_Token (T_Spec); + else + Output_Token (T_Body); + end if; + + Write_Eol; + + -- Output source file name + + Output_Sfile (Units.Table (U).Sfile); + + -- Output Flags + + N_Flags := 0; + + if Units.Table (U).Preelab then + Output_Token (T_Preelaborated); + end if; + + if Units.Table (U).Pure then + Output_Token (T_Pure); + end if; + + if Units.Table (U).Has_RACW then + Output_Token (T_Has_RACW); + end if; + + if Units.Table (U).Remote_Types then + Output_Token (T_Remote_Types); + end if; + + if Units.Table (U).Shared_Passive then + Output_Token (T_Shared_Passive); + end if; + + if Units.Table (U).RCI then + Output_Token (T_RCI); + end if; + + if Units.Table (U).Predefined then + Output_Token (T_Predefined); + end if; + + if Units.Table (U).Internal then + Output_Token (T_Internal); + end if; + + if Units.Table (U).Is_Generic then + Output_Token (T_Is_Generic); + end if; + + if N_Flags > 0 then + Write_Eol; + end if; + + -- Output Withs + + for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop + Output_With (W); + end loop; + + N_Indents := N_Indents - 1; + end Output_Unit; + + ----------------- + -- Output_With -- + ----------------- + + procedure Output_With (W : With_Id) is + begin + Output_Token (T_With); + N_Indents := N_Indents + 1; + + Output_Name (Withs.Table (W).Uname); + + -- Output Kind + + Output_Token (T_Kind); + + if Name_Buffer (Name_Len) = 's' then + Output_Token (T_Spec); + else + Output_Token (T_Body); + end if; + + Write_Eol; + + Output_Afile (Withs.Table (W).Afile); + Output_Sfile (Withs.Table (W).Sfile); + + N_Indents := N_Indents - 1; + end Output_With; + + end GLADE; + + ----------- -- Image -- ----------- @@ -629,6 +1048,7 @@ procedure Gnatls is declare Restrictions : constant Restrictions_Info := ALIs.Table (ALI).Restrictions; + begin -- If the source was compiled with pragmas Restrictions, -- Display these restrictions. @@ -721,6 +1141,7 @@ procedure Gnatls is procedure Scan_Ls_Arg (Argv : String) is FD : File_Descriptor; Len : Integer; + begin pragma Assert (Argv'First = 1); @@ -729,7 +1150,6 @@ procedure Gnatls is end if; if Argv (1) = '-' then - if Argv'Length = 1 then Fail ("switch character cannot be followed by a blank"); @@ -782,6 +1202,7 @@ procedure Gnatls is when 'o' => Reset_Print; Print_Object := True; when 'v' => Verbose_Mode := True; when 'd' => Dependable := True; + when 'V' => Very_Verbose_Mode := True; when others => null; end case; @@ -911,9 +1332,6 @@ procedure Gnatls is ----------- procedure Usage is - - -- Start of processing for Usage - begin -- Usage line @@ -1020,7 +1438,7 @@ procedure Gnatls is end Usage; - -- Start of processing for Gnatls +-- Start of processing for Gnatls begin -- Initialize standard packages @@ -1063,11 +1481,6 @@ begin if Verbose_Mode then Targparm.Get_Target_Parameters; - -- WARNING: the output of gnatls -v is used during the compilation - -- and installation of GLADE to recreate sdefault.adb and locate - -- the libgnat.a to use. Any change in the output of gnatls -v must - -- be synchronized with the GLADE Dist/config.sdefault shell script. - Write_Eol; Write_Str ("GNATLS "); Write_Str (Gnat_Version_String); @@ -1132,15 +1545,20 @@ begin while More_Lib_Files loop Main_File := Next_Main_Lib_File; - Ali_File := Full_Lib_File_Name (Lib_File_Name (Main_File)); + Ali_File := Full_Lib_File_Name (Lib_File_Name (Main_File)); if Ali_File = No_File then - Write_Str ("Can't find library info for "); - Get_Name_String (Main_File); - Write_Char ('"'); - Write_Str (Name_Buffer (1 .. Name_Len)); - Write_Char ('"'); - Write_Eol; + if Very_Verbose_Mode then + GLADE.Output_No_ALI (Lib_File_Name (Main_File)); + + else + Write_Str ("Can't find library info for "); + Get_Name_String (Main_File); + Write_Char ('"'); -- " + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Char ('"'); -- " + Write_Eol; + end if; else Ali_File := Strip_Directory (Ali_File); @@ -1166,6 +1584,14 @@ begin end if; end loop; + if Very_Verbose_Mode then + for A in ALIs.First .. ALIs.Last loop + GLADE.Output_ALI (A); + end loop; + + return; + end if; + Find_General_Layout; for Id in ALIs.First .. ALIs.Last loop diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 0dbe4795980..189ee917691 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -224,8 +224,7 @@ package body Impunit is "g-memdum", -- GNAT.Memory_Dump "g-moreex", -- GNAT.Most_Recent_Exception "g-os_lib", -- GNAT.Os_Lib - "g-pehage", -- GNAT.Perfect_Hash.Generators - "g-perhas", -- GNAT.Perfect_Hash + "g-pehage", -- GNAT.Perfect_Hash_Generators "g-regexp", -- GNAT.Regexp "g-regist", -- GNAT.Registry "g-regpat", -- GNAT.Regpat diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 9fe4aa13239..4a54affe477 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -111,6 +111,7 @@ int __gl_num_interrupt_states = 0; int __gl_unreserve_all_interrupts = 0; int __gl_exception_tracebacks = 0; int __gl_zero_cost_exceptions = 0; +int __gl_detect_blocking = 0; /* Indication of whether synchronous signal handler has already been installed by a previous call to adainit */ @@ -173,7 +174,8 @@ __gnat_set_globals (int main_priority, int num_interrupt_states, int unreserve_all_interrupts, int exception_tracebacks, - int zero_cost_exceptions) + int zero_cost_exceptions, + int detect_blocking) { static int already_called = 0; @@ -236,6 +238,7 @@ __gnat_set_globals (int main_priority, __gl_task_dispatching_policy = task_dispatching_policy; __gl_unreserve_all_interrupts = unreserve_all_interrupts; __gl_exception_tracebacks = exception_tracebacks; + __gl_detect_blocking = detect_blocking; /* ??? __gl_zero_cost_exceptions is new in 3.15 and is referenced from a-except.adb, which is also part of the compiler sources. Since the diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 89b4e23b210..36240549d04 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -856,6 +856,10 @@ package body Lib.Writ is Write_Info_Str (" CE"); end if; + if Opt.Detect_Blocking then + Write_Info_Str (" DB"); + end if; + if Opt.Float_Format /= ' ' then Write_Info_Str (" F"); diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index c6f185bf2fc..2cc6b568cb0 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -181,6 +181,9 @@ package Lib.Writ is -- format will be correct and complete. Note that NO is -- always present if CE is present. -- + -- DB Detect_Blocking pragma is in effect for all units in + -- this file. + -- -- FD Configuration pragmas apply to all the units in this -- file specifying a possibly non-standard floating point -- format (VAX float with Long_Float using D_Float) diff --git a/gcc/ada/link.c b/gcc/ada/link.c index bf98e903581..70b349f5482 100644 --- a/gcc/ada/link.c +++ b/gcc/ada/link.c @@ -157,9 +157,9 @@ const char *__gnat_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; +int __gnat_link_max = 8192; +unsigned char __gnat_objlist_file_supported = 1; +unsigned char __gnat_using_gnu_linker = 1; char *__gnat_object_library_extension = ".a"; #elif defined (linux) diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb index a6c9b23c366..be8ace85db8 100644 --- a/gcc/ada/mdll.adb +++ b/gcc/ada/mdll.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -52,7 +52,8 @@ package body MDLL is Def_Filename : String; Lib_Address : String := ""; Build_Import : Boolean := False; - Relocatable : Boolean := False) + Relocatable : Boolean := False; + Map_File : Boolean := False) is use type OS_Lib.Argument_List; @@ -70,6 +71,7 @@ package body MDLL is Lib_Opt : aliased String := "-mdll"; Out_Opt : aliased String := "-o"; Adr_Opt : aliased String := "-Wl,--image-base=" & Lib_Address; + Map_Opt : aliased String := "-Wl,-Map," & Lib_Filename & ".map"; L_Afiles : Argument_List := Afiles; -- Local afiles list. This list can be reordered to ensure that the @@ -97,12 +99,10 @@ package body MDLL is procedure Build_Reloc_DLL is -- Objects plus the export table (.exp) file - Objects_Exp_File : constant OS_Lib.Argument_List := Exp_File'Unchecked_Access & Ofiles; Success : Boolean; - begin if not Quiet then Text_IO.Put_Line ("building relocatable DLL..."); @@ -147,10 +147,20 @@ package body MDLL is -- 5) Build the dynamic library - Utl.Gcc (Output_File => Dll_File, - Files => Objects_Exp_File, - Options => Adr_Opt'Unchecked_Access & All_Options, - Build_Lib => True); + declare + Params : OS_Lib.Argument_List := + Adr_Opt'Unchecked_Access & All_Options; + begin + if Map_File then + Params := Map_Opt'Unchecked_Access & Params; + end if; + + Utl.Gcc + (Output_File => Dll_File, + Files => Objects_Exp_File, + Options => Params, + Build_Lib => True); + end; OS_Lib.Delete_File (Exp_File, Success); OS_Lib.Delete_File (Bas_File, Success); @@ -234,7 +244,7 @@ package body MDLL is Utl.Gnatbind (L_Afiles, Options & Bargs_Options); declare - Params : constant OS_Lib.Argument_List := + Params : OS_Lib.Argument_List := Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access & Lib_Opt'Unchecked_Access & @@ -243,6 +253,10 @@ package body MDLL is Ofiles & All_Options; begin + if Map_File then + Params := Map_Opt'Unchecked_Access & Params; + end if; + Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params); end; @@ -285,10 +299,19 @@ package body MDLL is -- Build the DLL - Utl.Gcc (Output_File => Dll_File, - Files => Exp_File'Unchecked_Access & Ofiles, - Options => Adr_Opt'Unchecked_Access & All_Options, - Build_Lib => True); + declare + Params : OS_Lib.Argument_List := + Adr_Opt'Unchecked_Access & All_Options; + begin + if Map_File then + Params := Map_Opt'Unchecked_Access & Params; + end if; + + Utl.Gcc (Output_File => Dll_File, + Files => Exp_File'Unchecked_Access & Ofiles, + Options => Params, + Build_Lib => True); + end; OS_Lib.Delete_File (Exp_File, Success); @@ -330,7 +353,7 @@ package body MDLL is Utl.Gnatbind (L_Afiles, Options & Bargs_Options); declare - Params : constant OS_Lib.Argument_List := + Params : OS_Lib.Argument_List := Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access & Lib_Opt'Unchecked_Access & @@ -339,6 +362,10 @@ package body MDLL is Ofiles & All_Options; begin + if Map_File then + Params := Map_Opt'Unchecked_Access & Params; + end if; + Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params); end; @@ -370,7 +397,6 @@ package body MDLL is end if; case Relocatable is - when True => if L_Afiles'Length = 0 then Build_Reloc_DLL; @@ -384,7 +410,6 @@ package body MDLL is else Ada_Build_Non_Reloc_DLL; end if; - end case; end Build_Dynamic_Library; @@ -408,13 +433,11 @@ package body MDLL is -------------------------- procedure Build_Import_Library (Def_Base_Filename : String) is - Def_File : String renames Def_Filename; Dll_File : constant String := Def_Base_Filename & ".dll"; Lib_File : constant String := "lib" & Base_Filename & ".a"; begin - if not Quiet then Text_IO.Put_Line ("Building import library..."); Text_IO.Put_Line ("make " & Lib_File & diff --git a/gcc/ada/mdll.ads b/gcc/ada/mdll.ads index 5ca9f01a70e..495e025aabb 100644 --- a/gcc/ada/mdll.ads +++ b/gcc/ada/mdll.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -28,6 +28,7 @@ -- to build Windows DLL with GNAT.OS_Lib; +-- Should have USE here ??? package MDLL is @@ -36,20 +37,21 @@ package MDLL is Null_Argument_List : constant Argument_List := (1 .. 0 => new String'("")); - Null_Argument_List_Access : Argument_List_Access - := new Argument_List (1 .. 0); + Null_Argument_List_Access : Argument_List_Access := + new Argument_List (1 .. 0); - Tools_Error : exception; + Tools_Error : exception; + -- Commment required - Verbose : Boolean := False; - Quiet : Boolean := False; + Verbose : Boolean := False; + Quiet : Boolean := False; + -- Comment required ??? + Kill_Suffix : Boolean := False; -- Kill_Suffix is used by dlltool to know whether or not the @nn suffix -- should be removed from the exported names. When Kill_Suffix is set to -- True then dlltool -k option is used. - Kill_Suffix : Boolean := False; - procedure Build_Dynamic_Library (Ofiles : Argument_List; Afiles : Argument_List; @@ -60,14 +62,16 @@ package MDLL is Def_Filename : String; Lib_Address : String := ""; Build_Import : Boolean := False; - Relocatable : Boolean := False); + Relocatable : Boolean := False; + Map_File : Boolean := False); -- Build a DLL and the import library to link against the DLL. -- this function handles relocatable and non relocatable DLL. -- If the Afiles argument list contains some Ada units then it will -- generate the right adainit and adafinal and integrate it in the DLL. -- If the Afiles argument list is empty (there is only some object files -- provided) then it will not try to build a binder file. This is ok to - -- build DLL containing no Ada code. + -- build DLL containing no Ada code. If Map_File is set to True, a map + -- file named Lib_Filename & ".map" will be created. procedure Build_Import_Library (Lib_Filename : String; diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 69798078f92..528cbffaf99 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -98,7 +98,7 @@ package body Opt is procedure Set_Opt_Config_Switches (Internal_Unit : Boolean) is begin if Internal_Unit then - Ada_Version := Ada_Version_Default; + Ada_Version := Ada_Version_Runtime; Dynamic_Elaboration_Checks := False; Extensions_Allowed := True; External_Name_Exp_Casing := As_Is; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 25223bcbf32..e710275b74a 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -72,6 +72,10 @@ package Opt is -- GNAT -- Current Ada version for compiler + Ada_Version_Runtime : Ada_Version_Type := Ada_05; + -- GNAT + -- Ada version used to compile the runtime + Ada_Final_Suffix : constant String := "final"; Ada_Final_Name : String_Ptr := new String'("ada" & Ada_Final_Suffix); -- GNATBIND diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 2127e35067c..324b7dcde30 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -24,8 +24,9 @@ -- -- ------------------------------------------------------------------------------ -with Namet; use Namet; -with Osint; use Osint; +with Namet; use Namet; +with Osint; +with Prj.Com; use Prj.Com; with Table; with System.Case_Util; use System.Case_Util; @@ -39,11 +40,13 @@ package body Prj.Attr is -- Package names are preceded by 'P' -- Attribute names are preceded by two letters: + -- The first letter is one of -- 'S' for Single -- 's' for Single with optional index -- 'L' for List -- 'l' for List of strings with optional indexes + -- The second letter is one of -- 'V' for single variable -- 'A' for associative array @@ -186,90 +189,9 @@ package body Prj.Attr is Initialized : Boolean := False; -- A flag to avoid multiple initialization - ---------------- - -- Attributes -- - ---------------- - - type Attribute_Record is record - Name : Name_Id; - Var_Kind : Variable_Kind; - Optional_Index : Boolean; - Attr_Kind : Attribute_Kind; - Next : Attr_Node_Id; - end record; - -- Data for an attribute - - package Attrs is - new Table.Table (Table_Component_Type => Attribute_Record, - Table_Index_Type => Attr_Node_Id, - Table_Low_Bound => First_Attribute, - Table_Initial => Attributes_Initial, - Table_Increment => Attributes_Increment, - Table_Name => "Prj.Attr.Attrs"); - -- The table of the attributes - - -------------- - -- Packages -- - -------------- - - type Package_Record is record - Name : Name_Id; - Known : Boolean := True; - First_Attribute : Attr_Node_Id; - end record; - -- Data for a package - - package Package_Attributes is - new Table.Table (Table_Component_Type => Package_Record, - Table_Index_Type => Pkg_Node_Id, - Table_Low_Bound => First_Package, - Table_Initial => Packages_Initial, - Table_Increment => Packages_Increment, - Table_Name => "Prj.Attr.Packages"); - -- The table of the packages - function Name_Id_Of (Name : String) return Name_Id; -- Returns the Name_Id for Name in lower case - ------------------- - -- Add_Attribute -- - ------------------- - - procedure Add_Attribute - (To_Package : Package_Node_Id; - Attribute_Name : Name_Id; - Attribute_Node : out Attribute_Node_Id) - is - begin - -- Only add the attribute if the package is already defined - - if To_Package /= Empty_Package then - Attrs.Increment_Last; - Attrs.Table (Attrs.Last) := - (Name => Attribute_Name, - Var_Kind => Undefined, - Optional_Index => False, - Attr_Kind => Unknown, - Next => - Package_Attributes.Table (To_Package.Value).First_Attribute); - Package_Attributes.Table (To_Package.Value).First_Attribute := - Attrs.Last; - Attribute_Node := (Value => Attrs.Last); - end if; - end Add_Attribute; - - ------------------------- - -- Add_Unknown_Package -- - ------------------------- - - procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id) is - begin - Package_Attributes.Increment_Last; - Id := (Value => Package_Attributes.Last); - Package_Attributes.Table (Id.Value) := - (Name => Name, Known => False, First_Attribute => Empty_Attr); - end Add_Unknown_Package; - ----------------------- -- Attribute_Kind_Of -- ----------------------- @@ -307,6 +229,7 @@ package body Prj.Attr is Starting_At : Attribute_Node_Id) return Attribute_Node_Id is Id : Attr_Node_Id := Starting_At.Value; + begin while Id /= Empty_Attr and then Attrs.Table (Id).Name /= Name @@ -386,7 +309,7 @@ package body Prj.Attr is for Index in First_Package .. Package_Attributes.Last loop if Package_Name = Package_Attributes.Table (Index).Name then - Fail ("duplicate name """, + Osint.Fail ("duplicate name """, Initialization_Data (Start .. Finish - 1), """ in predefined packages."); end if; @@ -438,14 +361,14 @@ package body Prj.Attr is Attr_Kind := Case_Insensitive_Associative_Array; when 'b' => - if File_Names_Case_Sensitive then + if Osint.File_Names_Case_Sensitive then Attr_Kind := Associative_Array; else Attr_Kind := Case_Insensitive_Associative_Array; end if; when 'c' => - if File_Names_Case_Sensitive then + if Osint.File_Names_Case_Sensitive then Attr_Kind := Optional_Index_Associative_Array; else Attr_Kind := @@ -480,7 +403,7 @@ package body Prj.Attr is for Index in First_Attribute .. Attrs.Last - 1 loop if Attribute_Name = Attrs.Table (Index).Name then - Fail ("duplicate attribute """, + Osint.Fail ("duplicate attribute """, Initialization_Data (Start .. Finish - 1), """ in " & Attribute_Location); end if; @@ -581,11 +504,13 @@ package body Prj.Attr is begin if Name'Length = 0 then Fail ("cannot register an attribute with no name"); + raise Project_Error; end if; if In_Package = Empty_Package then Fail ("attempt to add attribute """, Name, """ to an undefined package"); + raise Project_Error; end if; Attr_Name := Name_Id_Of (Name); @@ -603,7 +528,7 @@ package body Prj.Attr is Get_Name_String (Package_Attributes.Table (In_Package.Value).Name) & """"); - exit; + raise Project_Error; end if; Curr_Attr := Attrs.Table (Curr_Attr).Next; @@ -613,7 +538,7 @@ package body Prj.Attr is -- If Index_Is_File_Name, change the attribute kind if necessary - if Index_Is_File_Name and then not File_Names_Case_Sensitive then + if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then case Attr_Kind is when Associative_Array => Real_Attr_Kind := Case_Insensitive_Associative_Array; @@ -645,14 +570,26 @@ package body Prj.Attr is -------------------------- procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is - Pkg_Name : Name_Id; + Pkg_Name : Name_Id; begin if Name'Length = 0 then Fail ("cannot register a package with no name"); + Id := Empty_Package; + return; end if; Pkg_Name := Name_Id_Of (Name); + + for Index in Package_Attributes.First .. Package_Attributes.Last loop + if Package_Attributes.Table (Index).Name = Pkg_Name then + Fail ("cannot register a package with a non unique name""", + Name, """"); + Id := Empty_Package; + return; + end if; + end loop; + Package_Attributes.Increment_Last; Id := (Value => Package_Attributes.Last); Package_Attributes.Table (Package_Attributes.Last) := @@ -672,6 +609,7 @@ package body Prj.Attr is begin if Name'Length = 0 then Fail ("cannot register a package with no name"); + raise Project_Error; end if; Pkg_Name := Name_Id_Of (Name); @@ -680,7 +618,7 @@ package body Prj.Attr is if Package_Attributes.Table (Index).Name = Pkg_Name then Fail ("cannot register a package with a non unique name""", Name, """"); - exit; + raise Project_Error; end if; end loop; @@ -692,7 +630,7 @@ package body Prj.Attr is if Attrs.Table (Curr_Attr).Name = Attr_Name then Fail ("duplicate attribute name """, Attributes (Index).Name, """ in new package """ & Name & """"); - exit; + raise Project_Error; end if; Curr_Attr := Attrs.Table (Curr_Attr).Next; @@ -701,7 +639,7 @@ package body Prj.Attr is Attr_Kind := Attributes (Index).Attr_Kind; if Attributes (Index).Index_Is_File_Name - and then not File_Names_Case_Sensitive + and then not Osint.File_Names_Case_Sensitive then case Attr_Kind is when Associative_Array => diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads index 226d82440ed..4c096893426 100644 --- a/gcc/ada/prj-attr.ads +++ b/gcc/ada/prj-attr.ads @@ -86,6 +86,12 @@ package Prj.Attr is -- explicitly with Register_New_Package (see below). type Attribute_Data_Array is array (Positive range <>) of Attribute_Data; + -- A list of attribute name/characteristics to be used as parameter of + -- procedure Register_New_Package below. + + -- In the subprograms below, when it is specified that the subprogram + -- "fails", procedure Prj.Com.Fail is called. Unless it is specified + -- otherwise, if Prj.Com.Fail returns, exception Prj.Prj_Error is raised. procedure Register_New_Package (Name : String; @@ -93,11 +99,8 @@ package Prj.Attr is -- Add a new package with its attributes. -- This procedure can only be called after Initialize, but before any -- other call to a service of the Project Managers. - -- The name of the package must be unique. The names of the attributes - -- must be different. - - -- The following declarations are only for the Project Manager, that is - -- the packages of the Prj or MLib hierarchies. + -- Fail if the name of the package is empty or not unique, or if the names + -- of the attributes are not different. ---------------- -- Attributes -- @@ -168,9 +171,11 @@ package Prj.Attr is -- Default value of Package_Node_Id objects procedure Register_New_Package (Name : String; Id : out Package_Node_Id); - -- Add a new package. Fails if the package has a duplicate name. - -- Initially, the new package has no attributes. Id may be used to add - -- attributes using procedure Register_New_Attribute below. + -- Add a new package. Fails if Name (the package name) is empty or is + -- already the name of a package, and set Id to Empty_Package, + -- if Prj.Com.Fail returns. Initially, the new package has no attributes. + -- Id may be used to add attributes using procedure Register_New_Attribute + -- below. procedure Register_New_Attribute (Name : String; @@ -179,32 +184,21 @@ package Prj.Attr is Var_Kind : Defined_Variable_Kind; Index_Is_File_Name : Boolean := False; Opt_Index : Boolean := False); - -- Add a new attribute to registered package In_Package. Fails if the - -- attribute has a duplicate name. See definition of type Attribute_Data - -- above for the meaning of parameters Attr_Kind, Var_Kind, + -- Add a new attribute to registered package In_Package. Fails if Name + -- (the attribute name) is empty, if In_Package is Empty_Package or if + -- the attribute name has a duplicate name. See definition of type + -- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind, -- Index_Is_File_Name and Opt_Index. function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id; -- Returns the package node id of the package with name Name. Returns -- Empty_Package if there is no package with this name. - procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id); - -- Add a new package. The Name cannot be the name of a predefined or - -- already registered package. - function First_Attribute_Of (Pkg : Package_Node_Id) return Attribute_Node_Id; -- Returns the first attribute in the list of attributes of package Pkg. -- Returns Empty_Attribute if Pkg is Empty_Package. - procedure Add_Attribute - (To_Package : Package_Node_Id; - Attribute_Name : Name_Id; - Attribute_Node : out Attribute_Node_Id); - -- Add an attribute to the list for package To_Package. Attribute_Name - -- cannot be the name of an existing attribute of the package. - -- Does nothing if To_Package is Empty_Package. - private ---------------- -- Attributes -- @@ -266,4 +260,46 @@ private Package_First : constant Package_Node_Id := First_Package_Node_Id; + ---------------- + -- Attributes -- + ---------------- + + type Attribute_Record is record + Name : Name_Id; + Var_Kind : Variable_Kind; + Optional_Index : Boolean; + Attr_Kind : Attribute_Kind; + Next : Attr_Node_Id; + end record; + -- Data for an attribute + + package Attrs is + new Table.Table (Table_Component_Type => Attribute_Record, + Table_Index_Type => Attr_Node_Id, + Table_Low_Bound => First_Attribute, + Table_Initial => Attributes_Initial, + Table_Increment => Attributes_Increment, + Table_Name => "Prj.Attr.Attrs"); + -- The table of the attributes + + -------------- + -- Packages -- + -------------- + + type Package_Record is record + Name : Name_Id; + Known : Boolean := True; + First_Attribute : Attr_Node_Id; + end record; + -- Data for a package + + package Package_Attributes is + new Table.Table (Table_Component_Type => Package_Record, + Table_Index_Type => Pkg_Node_Id, + Table_Low_Bound => First_Package, + Table_Initial => Packages_Initial, + Table_Increment => Packages_Increment, + Table_Name => "Prj.Attr.Packages"); + -- The table of the packages + end Prj.Attr; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 8a9ebaaf90a..e030236afe8 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -24,17 +24,18 @@ -- -- ------------------------------------------------------------------------------ -with Err_Vars; use Err_Vars; -with Namet; use Namet; -with Opt; use Opt; -with Prj.Err; use Prj.Err; -with Prj.Strt; use Prj.Strt; -with Prj.Tree; use Prj.Tree; -with Scans; use Scans; +with Err_Vars; use Err_Vars; +with Namet; use Namet; +with Opt; use Opt; +with Prj.Err; use Prj.Err; +with Prj.Strt; use Prj.Strt; +with Prj.Tree; use Prj.Tree; +with Scans; use Scans; with Snames; -with Types; use Types; -with Prj.Attr; use Prj.Attr; -with Uintp; use Uintp; +with Types; use Types; +with Prj.Attr; use Prj.Attr; +with Prj.Attr.PM; use Prj.Attr.PM; +with Uintp; use Uintp; package body Prj.Dect is @@ -876,7 +877,6 @@ package body Prj.Dect is -- Scan past "package" Scan; - Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 1af7f598918..41ca8d9fbc1 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -699,6 +699,9 @@ package Prj is end record; + Project_Error : exception; + -- Raised by some subprograms in Prj.Attr. + function Empty_Project return Project_Data; -- Return the representation of an empty project diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h index f9eb02aff72..4a6ffbe2dbf 100644 --- a/gcc/ada/raise.h +++ b/gcc/ada/raise.h @@ -65,7 +65,7 @@ extern void set_gnat_exit_status (int); extern void __gnat_set_globals (int, int, char, char, char, char, char *, char *, - int, int, int, int); + int, int, int, int, int); extern void __gnat_initialize (void); extern void __gnat_init_float (void); extern void __gnat_install_handler (void); diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb index 1174d75e565..89ba39fc1b3 100644 --- a/gcc/ada/s-parint.adb +++ b/gcc/ada/s-parint.adb @@ -45,8 +45,10 @@ package body System.Partition_Interface is type Pkg_Node; type Pkg_List is access Pkg_Node; type Pkg_Node is record - Name : String_Access; - Next : Pkg_List; + Name : String_Access; + Subp_Info : System.Address; + Subp_Info_Len : Integer; + Next : Pkg_List; end record; Pkg_Head : Pkg_List; @@ -63,9 +65,9 @@ package body System.Partition_Interface is -- String prepended in top of shared passive packages procedure Check - (Name : in Unit_Name; - Version : in String; - RCI : in Boolean := True) + (Name : Unit_Name; + Version : String; + RCI : Boolean := True) is begin null; @@ -76,8 +78,7 @@ package body System.Partition_Interface is ----------------------------- function Get_Active_Partition_ID - (Name : Unit_Name) - return System.RPC.Partition_ID + (Name : Unit_Name) return System.RPC.Partition_ID is P : Pkg_List := Pkg_Head; N : String := Lower (Name); @@ -98,10 +99,7 @@ package body System.Partition_Interface is -- Get_Active_Version -- ------------------------ - function Get_Active_Version - (Name : Unit_Name) - return String - is + function Get_Active_Version (Name : Unit_Name) return String is begin return ""; end Get_Active_Version; @@ -120,8 +118,7 @@ package body System.Partition_Interface is ------------------------------ function Get_Passive_Partition_ID - (Name : Unit_Name) - return System.RPC.Partition_ID + (Name : Unit_Name) return System.RPC.Partition_ID is begin return Get_Local_Partition_ID; @@ -131,21 +128,50 @@ package body System.Partition_Interface is -- Get_Passive_Version -- ------------------------- - function Get_Passive_Version - (Name : Unit_Name) - return String - is + function Get_Passive_Version (Name : Unit_Name) return String is begin return ""; end Get_Passive_Version; + ------------------ + -- Get_RAS_Info -- + ------------------ + + procedure Get_RAS_Info + (Name : Unit_Name; + Subp_Id : Subprogram_Id; + Proxy_Address : out Interfaces.Unsigned_64) + is + LName : constant String := Lower (Name); + N : Pkg_List; + begin + N := Pkg_Head; + while N /= null loop + if N.Name.all = LName then + declare + subtype Subprogram_Array is RCI_Subp_Info_Array + (First_RCI_Subprogram_Id .. + First_RCI_Subprogram_Id + N.Subp_Info_Len - 1); + Subprograms : Subprogram_Array; + for Subprograms'Address use N.Subp_Info; + pragma Import (Ada, Subprograms); + begin + Proxy_Address := + Interfaces.Unsigned_64 (Subprograms (Integer (Subp_Id)).Addr); + return; + end; + end if; + N := N.Next; + end loop; + Proxy_Address := 0; + end Get_RAS_Info; + ------------------------------ -- Get_RCI_Package_Receiver -- ------------------------------ function Get_RCI_Package_Receiver - (Name : Unit_Name) - return Interfaces.Unsigned_64 + (Name : Unit_Name) return Interfaces.Unsigned_64 is begin return 0; @@ -186,7 +212,7 @@ package body System.Partition_Interface is ------------------------------------- procedure Raise_Program_Error_Unknown_Tag - (E : in Ada.Exceptions.Exception_Occurrence) + (E : Ada.Exceptions.Exception_Occurrence) is begin Ada.Exceptions.Raise_Exception @@ -235,11 +261,12 @@ package body System.Partition_Interface is ------------------------------ procedure Register_Passive_Package - (Name : in Unit_Name; - Version : in String := "") + (Name : Unit_Name; + Version : String := "") is begin - Register_Receiving_Stub (Passive_Prefix & Name, null, Version); + Register_Receiving_Stub + (Passive_Prefix & Name, null, Version, System.Null_Address, 0); end Register_Passive_Package; ----------------------------- @@ -247,19 +274,23 @@ package body System.Partition_Interface is ----------------------------- procedure Register_Receiving_Stub - (Name : in Unit_Name; - Receiver : in RPC.RPC_Receiver; - Version : in String := "") + (Name : Unit_Name; + Receiver : RPC.RPC_Receiver; + Version : String := ""; + Subp_Info : System.Address; + Subp_Info_Len : Integer) is + N : constant Pkg_List := + new Pkg_Node'(new String'(Lower (Name)), + Subp_Info, Subp_Info_Len, + Next => null); begin if Pkg_Tail = null then - Pkg_Head := new Pkg_Node'(new String'(Lower (Name)), null); - Pkg_Tail := Pkg_Head; - + Pkg_Head := N; else - Pkg_Tail.Next := new Pkg_Node'(new String'(Lower (Name)), null); - Pkg_Tail := Pkg_Tail.Next; + Pkg_Tail.Next := N; end if; + Pkg_Tail := N; end Register_Receiving_Stub; --------- @@ -267,7 +298,7 @@ package body System.Partition_Interface is --------- procedure Run - (Main : in Main_Subprogram_Type := null) + (Main : Main_Subprogram_Type := null) is begin if Main /= null then diff --git a/gcc/ada/s-parint.ads b/gcc/ada/s-parint.ads index cf0a8b396e5..a4ac13d0789 100644 --- a/gcc/ada/s-parint.ads +++ b/gcc/ada/s-parint.ads @@ -45,8 +45,20 @@ package System.Partition_Interface is type DSA_Implementation_Name is (No_DSA, GLADE_DSA, PolyORB_DSA); DSA_Implementation : constant DSA_Implementation_Name := No_DSA; + -- RCI receiving stubs contain a table of descriptors for + -- all user subprograms exported by the unit. + type Subprogram_Id is new Natural; - -- This type is used exclusively by stubs + First_RCI_Subprogram_Id : constant := 2; + + type RCI_Subp_Info is record + Addr : System.Address; + -- Local address of the proxy object + end record; + + type RCI_Subp_Info_Access is access all RCI_Subp_Info; + type RCI_Subp_Info_Array is array (Integer range <>) of + aliased RCI_Subp_Info; subtype Unit_Name is String; -- Name of Ada units @@ -59,42 +71,49 @@ package System.Partition_Interface is Addr : Interfaces.Unsigned_64; Asynchronous : Boolean; end record; + type RACW_Stub_Type_Access is access RACW_Stub_Type; -- This type is used by the expansion to implement distributed objects. -- Do not change its definition or its layout without updating -- exp_dist.adb. + type RAS_Proxy_Type is tagged limited record + All_Calls_Remote : Boolean; + Receiver : System.Address; + Subp_Id : Subprogram_Id; + end record; + + type RAS_Proxy_Type_Access is access RAS_Proxy_Type; + pragma No_Strict_Aliasing (RAS_Proxy_Type_Access); + -- This type is used by the expansion to implement distributed objects. + -- Do not change its definition or its layout without updating + -- Exp_Dist.Build_Remote_Supbrogram_Proxy_Type. + procedure Check - (Name : in Unit_Name; - Version : in String; - RCI : in Boolean := True); + (Name : Unit_Name; + Version : String; + RCI : Boolean := True); -- Use by the main subprogram to check that a remote receiver -- unit has has the same version than the caller's one. - function Get_Active_Partition_ID - (Name : Unit_Name) - return RPC.Partition_ID; + function Get_Active_Partition_ID (Name : Unit_Name) return RPC.Partition_ID; -- Similar in some respects to RCI_Info.Get_Active_Partition_ID - function Get_Active_Version - (Name : Unit_Name) - return String; + function Get_Active_Version (Name : Unit_Name) return String; -- Similar in some respects to Get_Active_Partition_ID function Get_Local_Partition_ID return RPC.Partition_ID; -- Return the Partition_ID of the current partition function Get_Passive_Partition_ID - (Name : Unit_Name) - return RPC.Partition_ID; + (Name : Unit_Name) return RPC.Partition_ID; -- Return the Partition_ID of the given shared passive partition function Get_Passive_Version (Name : Unit_Name) return String; -- Return the version corresponding to a shared passive unit function Get_RCI_Package_Receiver - (Name : Unit_Name) - return Interfaces.Unsigned_64; + (Name : Unit_Name) return Interfaces.Unsigned_64; -- Similar in some respects to RCI_Info.Get_RCI_Package_Receiver procedure Get_Unique_Remote_Pointer @@ -102,20 +121,30 @@ package System.Partition_Interface is -- Get a unique pointer on a remote object procedure Raise_Program_Error_Unknown_Tag - (E : in Ada.Exceptions.Exception_Occurrence); + (E : Ada.Exceptions.Exception_Occurrence); pragma No_Return (Raise_Program_Error_Unknown_Tag); -- Raise Program_Error with the same message as E one procedure Register_Receiving_Stub - (Name : in Unit_Name; - Receiver : in RPC.RPC_Receiver; - Version : in String := ""); + (Name : Unit_Name; + Receiver : RPC.RPC_Receiver; + Version : String := ""; + Subp_Info : System.Address; + Subp_Info_Len : Integer); -- Register the fact that the Name receiving stub is now elaborated. -- Register the access value to the package RPC_Receiver procedure. + procedure Get_RAS_Info + (Name : Unit_Name; + Subp_Id : Subprogram_Id; + Proxy_Address : out Interfaces.Unsigned_64); + -- Look up the address of the proxy object for the given subprogram + -- in the named unit, or Null_Address if not present on the local + -- partition. + procedure Register_Passive_Package - (Name : in Unit_Name; - Version : in String := ""); + (Name : Unit_Name; + Version : String := ""); -- Register a passive package generic @@ -126,7 +155,7 @@ package System.Partition_Interface is end RCI_Info; -- RCI package information caching - procedure Run (Main : in Main_Subprogram_Type := null); + procedure Run (Main : Main_Subprogram_Type := null); -- Run the main subprogram end System.Partition_Interface; diff --git a/gcc/ada/s-solita.adb b/gcc/ada/s-solita.adb index 79c1b36b78e..6fd13da6cf8 100644 --- a/gcc/ada/s-solita.adb +++ b/gcc/ada/s-solita.adb @@ -44,6 +44,12 @@ with System.Task_Primitives.Operations; -- Used for Self -- Timed_Delay +with System.Tasking; +-- Used for Task_Id + +with Ada.Exceptions; +-- Used for Raise_Exception + package body System.Soft_Links.Tasking is package STPO renames System.Task_Primitives.Operations; @@ -79,9 +85,9 @@ package body System.Soft_Links.Tasking is procedure Timed_Delay_T (Time : Duration; Mode : Integer); -- Task-safe version of SSL.Timed_Delay - ---------------------- - -- Soft-Link Bodies -- - ---------------------- + -------------------------- + -- Soft-Link Get Bodies -- + -------------------------- function Get_Current_Excep return SSL.EOA is begin @@ -103,6 +109,10 @@ package body System.Soft_Links.Tasking is return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr; end Get_Sec_Stack_Addr; + -------------------------- + -- Soft-Link Set Bodies -- + -------------------------- + procedure Set_Jmpbuf_Address (Addr : Address) is begin STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr; @@ -118,9 +128,27 @@ package body System.Soft_Links.Tasking is STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr; end Set_Sec_Stack_Addr; + ------------------- + -- Timed_Delay_T -- + ------------------- + procedure Timed_Delay_T (Time : Duration; Mode : Integer) is + Self_Id : constant System.Tasking.Task_Id := STPO.Self; + begin - STPO.Timed_Delay (STPO.Self, Time, Mode); + -- In case pragma Detect_Blocking is active then Program_Error + -- must be raised if this potentially blocking operation + -- is called from a protected operation. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + STPO.Timed_Delay (Self_Id, Time, Mode); + end if; + end Timed_Delay_T; ----------------------------- diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb index 4a5b6af4bfc..9852c4e376c 100644 --- a/gcc/ada/s-taprob.adb +++ b/gcc/ada/s-taprob.adb @@ -39,6 +39,7 @@ pragma Polling (Off); with System.Task_Primitives.Operations; -- used for Write_Lock -- Unlock +-- Self with System.Parameters; -- used for Runtime_Traces @@ -87,6 +88,7 @@ package body System.Tasking.Protected_Objects is procedure Lock (Object : Protection_Access) is Ceiling_Violation : Boolean; + begin -- The lock is made without defering abortion. @@ -107,6 +109,19 @@ package body System.Tasking.Protected_Objects is if Ceiling_Violation then raise Program_Error; end if; + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active). + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + begin + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; end Lock; -------------------- @@ -115,6 +130,7 @@ package body System.Tasking.Protected_Objects is procedure Lock_Read_Only (Object : Protection_Access) is Ceiling_Violation : Boolean; + begin Read_Lock (Object.L'Access, Ceiling_Violation); @@ -125,6 +141,19 @@ package body System.Tasking.Protected_Objects is if Ceiling_Violation then raise Program_Error; end if; + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active). + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + begin + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; end Lock_Read_Only; ------------ @@ -133,6 +162,25 @@ package body System.Tasking.Protected_Objects is procedure Unlock (Object : Protection_Access) is begin + -- We are exiting from a protected action, so that we decrease the + -- protected object nesting level (if pragma Detect_Blocking is + -- active). + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Cannot call this procedure without being within a protected + -- action. + + pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0); + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting - 1; + end; + end if; + Unlock (Object.L'Access); if Parameters.Runtime_Traces then diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index a79db6afb69..f667a313bf3 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -83,6 +83,7 @@ package body System.Tasking is T.Common.Parent := Parent; T.Common.Base_Priority := Base_Priority; T.Common.Current_Priority := 0; + T.Common.Protected_Action_Nesting := 0; T.Common.Call := null; T.Common.Task_Arg := Task_Arg; T.Common.Task_Entry_Point := Task_Entry_Point; diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 5fd2c22c4ef..1dd9e27d730 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -335,13 +335,18 @@ package System.Tasking is ------------------------------------ type Activation_Chain is limited private; + -- Comment required ??? type Activation_Chain_Access is access all Activation_Chain; + -- Comment required ??? type Task_Procedure_Access is access procedure (Arg : System.Address); type Access_Boolean is access all Boolean; + Detect_Blocking : constant Boolean; + -- Boolean constant set True iff Detect_Blocking is active + ---------------------------------------------- -- Ada_Task_Control_Block (ATCB) definition -- ---------------------------------------------- @@ -421,6 +426,14 @@ package System.Tasking is -- accepts an entry or when Created activates, at which points Self is -- suspended. + Protected_Action_Nesting : Natural; + pragma Atomic (Protected_Action_Nesting); + -- The dynamic level of protected action nesting for this task. + -- This field is needed for checking whether potentially + -- blocking operations are invoked from protected actions. + -- pragma Atomic is used because it can be read/written from + -- protected interrupt handlers. + Task_Image : String (1 .. 32); -- Hold a string that provides a readable id for task, -- built from the variable of which it is a value or component. @@ -969,6 +982,14 @@ package System.Tasking is private Null_Task : constant Task_Id := null; + GL_Detect_Blocking : Integer; + pragma Import (C, GL_Detect_Blocking, "__gl_detect_blocking"); + -- Global variable exported by the binder generated file. A value + -- equal to 1 indicates that pragma Detect_Blocking is active, + -- while 0 is used for the pragma not being present. + + Detect_Blocking : constant Boolean := GL_Detect_Blocking = 1; + type Activation_Chain is record T_ID : Task_Id; end record; diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 75eecc6755a..5763272ce24 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -102,6 +102,10 @@ package body System.Tasking.Rendezvous is Accept_Alternative_Open, No_Alternative_Open); + ---------------- + -- Local Data -- + ---------------- + Default_Treatment : constant array (Select_Modes) of Select_Treatment := (Simple_Mode => No_Alternative_Open, Else_Mode => Else_Selected, @@ -391,7 +395,19 @@ package body System.Tasking.Rendezvous is Uninterpreted_Data : System.Address) is Rendezvous_Successful : Boolean; + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then STPO.Self.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + Call_Synchronous (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful); end Call_Simple; @@ -1309,6 +1325,17 @@ package body System.Tasking.Rendezvous is Entry_Call : Entry_Call_Link; begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + if Parameters.Runtime_Traces then Send_Trace_Info (W_Call, Acceptor, Entry_Index (E)); end if; @@ -1668,6 +1695,17 @@ package body System.Tasking.Rendezvous is Yielded : Boolean; begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + Initialization.Defer_Abort (Self_Id); Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index bdd30be27f6..535add5afbd 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -226,6 +226,17 @@ package body System.Tasking.Stages is procedure Abort_Tasks (Tasks : Task_List) is begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then STPO.Self.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + Utilities.Abort_Tasks (Tasks); end Abort_Tasks; @@ -266,6 +277,17 @@ package body System.Tasking.Stages is All_Elaborated : Boolean := True; begin + -- If pragma Detect_Blocking is active must be checked whether + -- this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_ID.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + pragma Debug (Debug.Trace (Self_ID, "Activate_Tasks", 'C')); @@ -513,6 +535,17 @@ package body System.Tasking.Stages is Len : Natural; begin + -- If pragma Detect_Blocking is active must be checked whether + -- this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_ID.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C')); diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index a195828c9b2..c1d7d3ccae4 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -44,6 +44,7 @@ with Ada.Exceptions; -- used for Exception_Occurrence_Access +-- Raise_Exception with System.Task_Primitives.Operations; -- used for Initialize_Lock @@ -72,6 +73,10 @@ package body System.Tasking.Protected_Objects.Entries is use Task_Primitives.Operations; use Ada.Exceptions; + ---------------- + -- Local Data -- + ---------------- + Locking_Policy : Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); @@ -216,13 +221,36 @@ package body System.Tasking.Protected_Objects.Entries is ------------------ procedure Lock_Entries - (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is + (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) + is begin if Object.Finalized then Raise_Exception (Program_Error'Identity, "Protected Object is finalized"); end if; + -- If pragma Detect_Blocking is active then Program_Error must + -- be raised if this potentially blocking operation is called from + -- a protected action, and the protected object nesting level + -- must be increased. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := STPO.Self; + begin + if Self_Id.Common.Protected_Action_Nesting > 0 then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + -- We are entering in a protected action, so that we + -- increase the protected object nesting level. + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end if; + end; + end if; + -- The lock is made without defering abortion. -- Therefore the abortion has to be deferred before calling this @@ -239,14 +267,9 @@ package body System.Tasking.Protected_Objects.Entries is procedure Lock_Entries (Object : Protection_Entries_Access) is Ceiling_Violation : Boolean; - begin - if Object.Finalized then - Raise_Exception - (Program_Error'Identity, "Protected Object is finalized"); - end if; - pragma Assert (STPO.Self.Deferral_Level > 0); - Write_Lock (Object.L'Access, Ceiling_Violation); + begin + Lock_Entries (Object, Ceiling_Violation); if Ceiling_Violation then Raise_Exception (Program_Error'Identity, "Ceiling Violation"); @@ -259,12 +282,35 @@ package body System.Tasking.Protected_Objects.Entries is procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is Ceiling_Violation : Boolean; + begin if Object.Finalized then Raise_Exception (Program_Error'Identity, "Protected Object is finalized"); end if; + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action, and the protected object nesting level must + -- be increased. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := STPO.Self; + begin + if Self_Id.Common.Protected_Action_Nesting > 0 then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + -- We are entering in a protected action, so that we + -- increase the protected object nesting level. + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end if; + end; + end if; + Read_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then @@ -278,6 +324,24 @@ package body System.Tasking.Protected_Objects.Entries is procedure Unlock_Entries (Object : Protection_Entries_Access) is begin + -- We are exiting from a protected action, so that we decrease the + -- protected object nesting level (if pragma Detect_Blocking is + -- active). + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + begin + -- Cannot call this procedure without being within a protected + -- action. + + pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0); + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting - 1; + end; + end if; + Unlock (Object.L'Access); end Unlock_Entries; diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb index 25a8251b9dc..a992ed1df0f 100644 --- a/gcc/ada/s-tposen.adb +++ b/gcc/ada/s-tposen.adb @@ -67,7 +67,8 @@ with System.Task_Primitives.Operations; -- Unlock with Ada.Exceptions; --- used for Exception_Id; +-- used for Exception_Id +-- Raise_Exception with System.Parameters; -- used for Single_Lock @@ -347,7 +348,30 @@ package body System.Tasking.Protected_Objects.Single_Entry is procedure Lock_Entry (Object : Protection_Entry_Access) is Ceiling_Violation : Boolean; + begin + -- If pragma Detect_Blocking is active then Program_Error must + -- be raised if this potentially blocking operation is called from + -- a protected action, and the protected object nesting level + -- must be increased. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := STPO.Self; + begin + if Self_Id.Common.Protected_Action_Nesting > 0 then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + -- We are entering in a protected action, so that we + -- increase the protected object nesting level. + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end if; + end; + end if; + STPO.Write_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then @@ -364,7 +388,30 @@ package body System.Tasking.Protected_Objects.Single_Entry is procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is Ceiling_Violation : Boolean; + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action, and the protected object nesting level must + -- be increased. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := STPO.Self; + begin + if Self_Id.Common.Protected_Action_Nesting > 0 then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + -- We are entering in a protected action, so that we + -- increase the protected object nesting level. + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end if; + end; + end if; + STPO.Read_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then @@ -465,6 +512,17 @@ package body System.Tasking.Protected_Objects.Single_Entry is Ceiling_Violation : Boolean; begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + STPO.Write_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then @@ -579,6 +637,17 @@ package body System.Tasking.Protected_Objects.Single_Entry is Ceiling_Violation : Boolean; begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + STPO.Write_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then @@ -631,6 +700,23 @@ package body System.Tasking.Protected_Objects.Single_Entry is procedure Unlock_Entry (Object : Protection_Entry_Access) is begin + -- We are exiting from a protected action, so that we decrease the + -- protected object nesting level (if pragma Detect_Blocking is active). + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Cannot call Unlock_Entry without being within protected action + + pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0); + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting - 1; + end; + end if; + STPO.Unlock (Object.L'Access); end Unlock_Entry; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index dd2e183ef84..7f78060490b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5594,12 +5594,13 @@ package body Sem_Ch3 is elsif Private_Extension and then Is_Generic_Type (Derived_Type) then Record_Type_Definition (Empty, Derived_Type); - -- STEP 5c: Process the record extension for non private tagged types. + -- STEP 5c: Process the record extension for non private tagged types elsif not Private_Extension then - -- Add the _parent field in the derived type. - Expand_Derived_Record (Derived_Type, Type_Def); + -- Add the _parent field in the derived type + + Expand_Record_Extension (Derived_Type, Type_Def); -- Analyze the record extension diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 183118f3225..7ea68f85699 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -150,7 +150,8 @@ package body Sem_Disp is and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type then Error_Msg_N - ("Access parameter of a remote subprogram must be controlling", + ("access parameter of remote object primitive" + & " must be controlling", Formal); end if; diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index aee306dd1d6..8314e6ca32f 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -105,6 +105,55 @@ package body Sem_Dist is end if; end Add_Stub_Constructs; + --------------------------------------- + -- Build_RAS_Primitive_Specification -- + --------------------------------------- + + function Build_RAS_Primitive_Specification + (Subp_Spec : Node_Id; + Remote_Object_Type : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Subp_Spec); + + Primitive_Spec : constant Node_Id := + Copy_Specification (Loc, + Spec => Subp_Spec, + New_Name => Name_Call); + + Subtype_Mark_For_Self : Node_Id; + + begin + if No (Parameter_Specifications (Primitive_Spec)) then + Set_Parameter_Specifications (Primitive_Spec, New_List); + end if; + + if Nkind (Remote_Object_Type) in N_Entity then + Subtype_Mark_For_Self := + New_Occurrence_Of (Remote_Object_Type, Loc); + else + Subtype_Mark_For_Self := Remote_Object_Type; + end if; + + Prepend_To ( + Parameter_Specifications (Primitive_Spec), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Subtype_Mark_For_Self))); + + -- Trick later semantic analysis into considering this + -- operation as a primitive (dispatching) operation of + -- tagged type Obj_Type. + + Set_Comes_From_Source ( + Defining_Unit_Name (Primitive_Spec), True); + + return Primitive_Spec; + end Build_RAS_Primitive_Specification; + ------------------------- -- Full_Qualified_Name -- ------------------------- @@ -295,7 +344,6 @@ package body Sem_Dist is Async_E : Entity_Id; All_Calls_Remote_E : Entity_Id; Attribute_Subp : Entity_Id; - Local_Addr : Node_Id; begin -- Check if we have to expand the access attribute @@ -329,17 +377,11 @@ package body Sem_Dist is All_Calls_Remote_E := Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E)); - Local_Addr := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Remote_Subp, Loc), - Attribute_Name => Name_Address); - Tick_Access_Conv_Call := Make_Function_Call (Loc, Name => New_Occurrence_Of (Attribute_Subp, Loc), Parameter_Associations => New_List ( - Local_Addr, Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)), Build_Subprogram_Id (Loc, Remote_Subp), New_Occurrence_Of (Async_E, Loc), @@ -354,78 +396,165 @@ package body Sem_Dist is ------------------------------------ procedure Process_Remote_AST_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - User_Type : constant Node_Id := Defining_Identifier (N); - Fat_Type : constant Entity_Id := + Loc : constant Source_Ptr := Sloc (N); + User_Type : constant Node_Id := Defining_Identifier (N); + Scop : constant Entity_Id := Scope (User_Type); + Is_RCI : constant Boolean := + Is_Remote_Call_Interface (Scop); + Is_RT : constant Boolean := + Is_Remote_Types (Scop); + Type_Def : constant Node_Id := Type_Definition (N); + + Parameter : Node_Id; + Is_Degenerate : Boolean; + -- True iff this RAS has an access formal parameter (see + -- Exp_Dist.Add_RAS_Dereference_TSS for details). + + Subpkg : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Subpkg_Decl : Node_Id; + Vis_Decls : constant List_Id := New_List; + Priv_Decls : constant List_Id := New_List; + + Obj_Type : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_External_Name ( + Chars (User_Type), 'R')); + + + Full_Obj_Type : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars (Obj_Type)); + + RACW_Type : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_External_Name ( + Chars (User_Type), 'P')); + + Fat_Type : constant Entity_Id := Make_Defining_Identifier (Loc, Chars (User_Type)); - New_Type_Decl : Node_Id; + Fat_Type_Decl : Node_Id; begin - -- We add a record type declaration for the equivalent fat pointer type - New_Type_Decl := + -- The tagged private type, primitive operation and RACW + -- type associated with a RAS need to all be declared in + -- a subpackage of the one that contains the RAS declaration, + -- because the primitive of the object type, and the associated + -- primitive of the stub type, need to be dispatching operations + -- of these types, and the profile of the RAS might contain + -- tagged types declared in the same scope. + + Append_To (Vis_Decls, + Make_Private_Type_Declaration (Loc, + Defining_Identifier => Obj_Type, + Abstract_Present => True, + Tagged_Present => True, + Limited_Present => True)); + + Append_To (Priv_Decls, Make_Full_Type_Declaration (Loc, - Defining_Identifier => Fat_Type, - Type_Definition => + Defining_Identifier => + Full_Obj_Type, + Type_Definition => Make_Record_Definition (Loc, - Component_List => - Make_Component_List (Loc, - Component_Items => New_List ( - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_Ras), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_Origin), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (Standard_Integer, Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_Receiver), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (RTE (RE_Unsigned_64), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_Subp_Id), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (Standard_Natural, Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_Async), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Reference_To (Standard_Boolean, Loc))))))); - - Insert_After (N, New_Type_Decl); + Abstract_Present => True, + Tagged_Present => True, + Limited_Present => True, + Null_Present => True, + Component_List => Empty))); + + Is_Degenerate := False; + Parameter := First (Parameter_Specifications (Type_Def)); + Parameters : while Present (Parameter) loop + if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then + Error_Msg_N ("formal parameter& has anonymous access type?", + Defining_Identifier (Parameter)); + Is_Degenerate := True; + exit Parameters; + end if; + Next (Parameter); + end loop Parameters; + + if Is_Degenerate then + Error_Msg_NE ( + "remote access-to-subprogram type& can only be null?", + Defining_Identifier (Parameter), User_Type); + -- The only legal value for a RAS with a formal parameter of an + -- anonymous access type is null, because it cannot be + -- subtype-Conformant with any legal remote subprogram declaration. + -- In this case, we cannot generate a corresponding primitive + -- operation. + + else + Append_To (Vis_Decls, + Make_Abstract_Subprogram_Declaration (Loc, + Specification => Build_RAS_Primitive_Specification ( + Subp_Spec => Type_Def, + Remote_Object_Type => Obj_Type))); + end if; + + Append_To (Vis_Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => RACW_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Obj_Type, Loc), + Attribute_Name => + Name_Class)))); + Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); + Set_Is_Remote_Types (RACW_Type, Is_RT); + -- ??? Object RPC receiver generation should be bypassed for this + -- RACW type, since actually calls will be received by the package + -- RPC receiver for the designated RCI subprogram. + + Subpkg_Decl := + Make_Package_Declaration (Loc, + Make_Package_Specification (Loc, + Defining_Unit_Name => + Subpkg, + Visible_Declarations => + Vis_Decls, + Private_Declarations => + Priv_Decls, + End_Label => + New_Occurrence_Of (Subpkg, Loc))); + Set_Is_Remote_Call_Interface (Subpkg, Is_RCI); + Set_Is_Remote_Types (Subpkg, Is_RT); + Insert_After_And_Analyze (N, Subpkg_Decl); + + -- Many parts of the analyzer and expander expect + -- that the fat pointer type used to implement remote + -- access to subprogram types be a record. + -- Note: The structure of this type must be kept consistent + -- with the code generated by Remote_AST_Null_Value for the + -- corresponding 'null' expression. + + Fat_Type_Decl := Make_Full_Type_Declaration (Loc, + Defining_Identifier => Fat_Type, + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Ras), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => + False, + Subtype_Indication => + New_Occurrence_Of (RACW_Type, Loc))))))); Set_Equivalent_Type (User_Type, Fat_Type); Set_Corresponding_Remote_Type (Fat_Type, User_Type); + Insert_After_And_Analyze (Subpkg_Decl, Fat_Type_Decl); -- The reason we suppress the initialization procedure is that we know -- that no initialization is required (even if Initialize_Scalars mode @@ -506,8 +635,7 @@ package body Sem_Dist is -- Remote_AST_E_Dereference -- ------------------------------ - function Remote_AST_E_Dereference (P : Node_Id) return Boolean - is + function Remote_AST_E_Dereference (P : Node_Id) return Boolean is ET : constant Entity_Id := Etype (P); begin @@ -534,12 +662,11 @@ package body Sem_Dist is -- Remote_AST_I_Dereference -- ------------------------------ - function Remote_AST_I_Dereference (P : Node_Id) return Boolean - is + function Remote_AST_I_Dereference (P : Node_Id) return Boolean is ET : constant Entity_Id := Etype (P); Deref : Node_Id; - begin + begin if Comes_From_Source (P) and then (Is_Remote_Call_Interface (ET) or else Is_Remote_Types (ET)) @@ -563,9 +690,8 @@ package body Sem_Dist is --------------------------- function Remote_AST_Null_Value - (N : Node_Id; - Typ : Entity_Id) - return Boolean + (N : Node_Id; + Typ : Entity_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); Target_Type : Entity_Id; @@ -603,12 +729,12 @@ package body Sem_Dist is Rewrite (N, Make_Aggregate (Loc, - Expressions => New_List ( - Make_Integer_Literal (Loc, 0), -- Ras - Make_Integer_Literal (Loc, 0), -- Origin - Make_Integer_Literal (Loc, 0), -- Receiver - Make_Integer_Literal (Loc, 0), -- Subp_Id - New_Occurrence_Of (Standard_False, Loc)))); -- Asyn + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Ras)), + Expression => + Make_Null (Loc))))); Analyze_And_Resolve (N, Target_Type); return True; end Remote_AST_Null_Value; diff --git a/gcc/ada/sem_dist.ads b/gcc/ada/sem_dist.ads index efadbef6644..4acf872baf4 100644 --- a/gcc/ada/sem_dist.ads +++ b/gcc/ada/sem_dist.ads @@ -36,6 +36,13 @@ package Sem_Dist is -- caller stubs, expansion takes place directly in the specification and -- no additional compilation unit is created. + function Build_RAS_Primitive_Specification + (Subp_Spec : Node_Id; + Remote_Object_Type : Node_Id) return Node_Id; + -- Build a subprogram specification for the primitive operation of the + -- Remote_Object_Type used to implement a remote access-to-subprogram + -- type whose parameter profile is given by specification Subp_Spec. + function Is_All_Remote_Call (N : Node_Id) return Boolean; -- Check whether a function or procedure call should be expanded into -- a remote call, because the entity is declared in a package decl that @@ -75,9 +82,8 @@ package Sem_Dist is -- the previous function. function Remote_AST_Null_Value - (N : Node_Id; - Typ : Entity_Id) - return Boolean; + (N : Node_Id; + Typ : Entity_Id) return Boolean; -- If N is a null value and Typ a remote access to subprogram type, -- this function will check if null needs to be replaced with an -- aggregate and will return True in this case. Otherwise, it will diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 02b19473962..6fd97d8a269 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2929,7 +2929,6 @@ package body Sem_Prag is -- denoted entities in the same declarative part. Hom_Id := Def_Id; - while Present (Hom_Id) loop Def_Id := Get_Base_Subprogram (Hom_Id); @@ -4498,6 +4497,9 @@ package body Sem_Prag is elsif Ekind (Nm) = E_Record_Type and then Present (Corresponding_Remote_Type (Nm)) then + -- A record type that is the Equivalent_Type for + -- a remote access-to-subprogram type. + N := Declaration_Node (Corresponding_Remote_Type (Nm)); if Nkind (N) = N_Full_Type_Declaration @@ -4507,6 +4509,13 @@ package body Sem_Prag is L := Parameter_Specifications (Type_Definition (N)); Process_Async_Pragma; + if Is_Asynchronous (Nm) + and then Expander_Active + then + RACW_Type_Is_Asynchronous ( + Underlying_RACW_Type (Nm)); + end if; + else Error_Pragma_Arg ("pragma% cannot reference access-to-function type", diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 8f2ccad2350..8d0cf7577e0 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -141,7 +141,7 @@ package body Sem_Type is -- visibility of these user-defined operations must be special-cased -- to determine whether they hide or are hidden by predefined operators. -- The form P."+" (x, y) requires additional handling. - -- + -- Concatenation is treated more conventionally: for every one-dimensional -- array type we introduce a explicit concatenation operator. This is -- necessary to handle the case of (element & element => array) which @@ -154,7 +154,7 @@ package body Sem_Type is procedure All_Overloads; pragma Warnings (Off, All_Overloads); - -- Debugging procedure: list full contents of Overloads table. + -- Debugging procedure: list full contents of Overloads table procedure New_Interps (N : Node_Id); -- Initialize collection of interpretations for the given node, which is @@ -197,7 +197,6 @@ package body Sem_Type is begin Get_First_Interp (N, Index, It); - while Present (It.Nam) loop -- A user-defined subprogram hides another declared at an outer @@ -234,8 +233,8 @@ package body Sem_Type is exit; elsif not In_Open_Scopes (Scope (Name)) - or else Scope_Depth (Scope (Name)) - <= Scope_Depth (Scope (It.Nam)) + or else Scope_Depth (Scope (Name)) <= + Scope_Depth (Scope (It.Nam)) then -- If ambiguity within instance, and entity is not an -- implicit operation, save for later disambiguation. @@ -297,9 +296,7 @@ package body Sem_Type is elsif Nkind (N) = N_Function_Call then Arg := First_Actual (N); - while Present (Arg) loop - if No (Universal_Interpretation (Arg)) then return False; end if; @@ -338,7 +335,7 @@ package body Sem_Type is or else Is_Potentially_Use_Visible (Vis_Type) or else In_Use (Vis_Type) or else (In_Use (Scope (Vis_Type)) - and then not Is_Hidden (Vis_Type)) + and then not Is_Hidden (Vis_Type)) or else Nkind (N) = N_Expanded_Name or else (Nkind (N) in N_Op and then E = Entity (N)) or else In_Instance @@ -354,8 +351,8 @@ package body Sem_Type is elsif Nkind (N) = N_Function_Call and then Nkind (Name (N)) = N_Expanded_Name and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T)) - or else Entity (Prefix (Name (N))) = Scope (Vis_Type) - or else Scope (Vis_Type) = System_Aux_Id) + or else Entity (Prefix (Name (N))) = Scope (Vis_Type) + or else Scope (Vis_Type) = System_Aux_Id) then null; @@ -390,7 +387,7 @@ package body Sem_Type is Set_Etype (N, T); else - -- Record both the operator or subprogram name, and its type. + -- Record both the operator or subprogram name, and its type if Nkind (N) in N_Op or else Is_Entity_Name (N) then Set_Entity (N, E); @@ -504,12 +501,12 @@ package body Sem_Type is for J in First_Interp .. All_Interp.Last - 1 loop - -- Current homograph is not hidden. Add to overloads. + -- Current homograph is not hidden. Add to overloads if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then exit; - -- Homograph is hidden, unless it is a predefined operator. + -- Homograph is hidden, unless it is a predefined operator elsif Type_Conformant (H, All_Interp.Table (J).Nam) then @@ -547,7 +544,7 @@ package body Sem_Type is H := Homonym (H); end loop; - -- Scan list of homographs for use-visible entities only. + -- Scan list of homographs for use-visible entities only H := Current_Entity (Ent); @@ -576,7 +573,7 @@ package body Sem_Type is if All_Interp.Last = First_Interp + 1 then - -- The original interpretation is in fact not overloaded. + -- The original interpretation is in fact not overloaded Set_Is_Overloaded (N, False); end if; @@ -666,7 +663,7 @@ package body Sem_Type is then return True; - -- The context may be class wide. + -- The context may be class wide elsif Is_Class_Wide_Type (T1) and then Is_Ancestor (Root_Type (T1), T2) @@ -903,6 +900,10 @@ package body Sem_Type is Predef_Subp : Entity_Id; User_Subp : Entity_Id; + function Inherited_From_Actual (S : Entity_Id) return Boolean; + -- Determine whether one of the candidates is an operation inherited + -- by a type that is derived from an actual in an instantiation. + function Is_Actual_Subprogram (S : Entity_Id) return Boolean; -- Determine whether a subprogram is an actual in an enclosing -- instance. An overloading between such a subprogram and one @@ -914,6 +915,7 @@ package body Sem_Type is -- ambiguities when two formal types have the same actual. function Standard_Operator return Boolean; + -- Comment required ??? function Remove_Conversions return Interp; -- Last chance for pathological cases involving comparisons on @@ -932,6 +934,29 @@ package body Sem_Type is -- pathology in the other direction with calls whose multiple overloaded -- actuals make them truly unresolvable. + --------------------------- + -- Inherited_From_Actual -- + --------------------------- + + function Inherited_From_Actual (S : Entity_Id) return Boolean is + Par : constant Node_Id := Parent (S); + begin + if Nkind (Par) /= N_Full_Type_Declaration + or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition + then + return False; + else + return Is_Entity_Name (Subtype_Indication (Type_Definition (Par))) + and then + Is_Generic_Actual_Type ( + Entity (Subtype_Indication (Type_Definition (Par)))); + end if; + end Inherited_From_Actual; + + -------------------------- + -- Is_Actual_Subprogram -- + -------------------------- + function Is_Actual_Subprogram (S : Entity_Id) return Boolean is begin return In_Open_Scopes (Scope (S)) @@ -947,7 +972,6 @@ package body Sem_Type is function Matches (Actual, Formal : Node_Id) return Boolean is T1 : constant Entity_Id := Etype (Actual); T2 : constant Entity_Id := Etype (Formal); - begin return T1 = T2 or else @@ -969,9 +993,9 @@ package body Sem_Type is Act2 : Node_Id; begin - It1 := No_Interp; - Get_First_Interp (N, I, It); + It1 := No_Interp; + Get_First_Interp (N, I, It); while Present (It.Typ) loop if not Is_Overloadable (It.Nam) then @@ -1055,12 +1079,11 @@ package body Sem_Type is Get_Next_Interp (I, It); end loop; - if Serious_Errors_Detected > 0 then - - -- After some error, a formal may have Any_Type and yield - -- a spurious match. To avoid cascaded errors if possible, - -- check for such a formal in either candidate. + -- After some error, a formal may have Any_Type and yield + -- a spurious match. To avoid cascaded errors if possible, + -- check for such a formal in either candidate. + if Serious_Errors_Detected > 0 then declare Formal : Entity_Id; @@ -1115,17 +1138,15 @@ package body Sem_Type is -- Start of processing for Disambiguate begin - -- Recover the two legal interpretations. + -- Recover the two legal interpretations Get_First_Interp (N, I, It); - while I /= I1 loop Get_Next_Interp (I, It); end loop; It1 := It; Nam1 := It.Nam; - while I /= I2 loop Get_Next_Interp (I, It); end loop; @@ -1154,12 +1175,12 @@ package body Sem_Type is declare Candidate : Interp := No_Interp; + begin Get_First_Interp (N, I, It); - while Present (It.Typ) loop if (Covers (Typ, It.Typ) - or else Typ = Any_Type) + or else Typ = Any_Type) and then (It.Typ = Universal_Integer or else It.Typ = Universal_Real) @@ -1183,8 +1204,7 @@ package body Sem_Type is end; elsif Chars (Nam1) /= Name_Op_Not - and then (Typ = Standard_Boolean - or else Typ = Any_Boolean) + and then (Typ = Standard_Boolean or else Typ = Any_Boolean) then -- Equality or comparison operation. Choose predefined operator -- if arguments are universal. The node may be an operator, a @@ -1215,7 +1235,6 @@ package body Sem_Type is Universal_Interpretation (Arg1) then Get_First_Interp (N, I, It); - while Scope (It.Nam) /= Standard_Standard loop Get_Next_Interp (I, It); end loop; @@ -1273,6 +1292,11 @@ package body Sem_Type is -- node is overloaded, it did not resolve to the global entity in -- the generic, and we choose the formal subprogram. + -- Finally, the ambiguity can be between an explicit subprogram and + -- one inherited (with different defaults) from an actual. In this + -- case the resolution was to the explicit declaration in the + -- generic, and remains so in the instance. + elsif In_Instance then if Nkind (N) = N_Function_Call or else Nkind (N) = N_Procedure_Call_Statement @@ -1289,6 +1313,16 @@ package body Sem_Type is elsif Is_Act2 and then not Is_Act1 then return It2; + + elsif Inherited_From_Actual (Nam1) + and then Comes_From_Source (Nam2) + then + return It2; + + elsif Inherited_From_Actual (Nam2) + and then Comes_From_Source (Nam1) + then + return It1; end if; Actual := First_Actual (N); @@ -1306,7 +1340,6 @@ package body Sem_Type is end; elsif Nkind (N) in N_Binary_Op then - if Matches (Left_Opnd (N), First_Formal (Nam1)) and then Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1))) @@ -1317,7 +1350,6 @@ package body Sem_Type is end if; elsif Nkind (N) in N_Unary_Op then - if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then return It1; else @@ -1374,7 +1406,7 @@ package body Sem_Type is then if Is_Fixed_Point_Type (Typ) and then (Chars (Nam1) = Name_Op_Multiply - or else Chars (Nam1) = Name_Op_Divide) + or else Chars (Nam1) = Name_Op_Divide) and then Ada_Version = Ada_83 then if It2.Nam = Predef_Subp then @@ -1393,7 +1425,6 @@ package body Sem_Type is return It2; end if; end if; - end Disambiguate; --------------------- @@ -1449,7 +1480,6 @@ package body Sem_Type is begin if Is_Overloaded (R) then Get_First_Interp (R, I, It); - while Present (It.Typ) loop if Covers (T, It.Typ) or else Covers (It.Typ, T) then @@ -1474,8 +1504,7 @@ package body Sem_Type is Set_Etype (R, TR); - -- In the non-overloaded case, the Etype of R is already set - -- correctly. + -- In the non-overloaded case, the Etype of R is already set correctly else null; @@ -1542,7 +1571,6 @@ package body Sem_Type is end if; Map_Ptr := Headers (Hash (O_N)); - while Present (Interp_Map.Table (Map_Ptr).Node) loop if Interp_Map.Table (Map_Ptr).Node = O_N then Int_Ind := Interp_Map.Table (Map_Ptr).Index; @@ -1598,16 +1626,14 @@ package body Sem_Type is else Get_First_Interp (N, I, It); - while Present (It.Typ) loop if (Covers (Typ, It.Typ) - and then - (Scope (It.Nam) /= Standard_Standard - or else not Is_Invisible_Operator (N, Base_Type (Typ)))) - + and then + (Scope (It.Nam) /= Standard_Standard + or else not Is_Invisible_Operator (N, Base_Type (Typ)))) or else (not Is_Tagged_Type (Typ) - and then Ekind (Typ) /= E_Anonymous_Access_Type - and then Covers (It.Typ, Typ)) + and then Ekind (Typ) /= E_Anonymous_Access_Type + and then Covers (It.Typ, Typ)) then return True; end if; @@ -1685,7 +1711,6 @@ package body Sem_Type is else Get_First_Interp (R, Index, It); - loop T2 := Specific_Type (T, It.Typ); @@ -1714,7 +1739,6 @@ package body Sem_Type is else Typ := Any_Type; Get_First_Interp (L, Index, It); - while Present (It.Typ) loop Typ := Check_Right_Argument (It.Typ); exit when Typ /= Any_Type; @@ -1726,7 +1750,6 @@ package body Sem_Type is -- If Typ is Any_Type, it means no compatible pair of types was found if Typ = Any_Type then - if Nkind (Parent (L)) in N_Op then Error_Msg_N ("incompatible types for operator", Parent (L)); @@ -1947,7 +1970,6 @@ package body Sem_Type is New_F := First_Formal (New_S); Old_F := First_Formal (Op); Num := 0; - while Present (New_F) and then Present (Old_F) loop Num := Num + 1; Next_Formal (New_F); @@ -2095,7 +2117,6 @@ package body Sem_Type is -- Find end of Interp list and copy downward to erase the discarded one II := I + 1; - while Present (All_Interp.Table (II).Typ) loop II := II + 1; end loop; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0f1894aef82..762be69a9a4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -41,7 +41,6 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Output; use Output; with Opt; use Opt; -with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Scans; use Scans; with Scn; use Scn; @@ -869,33 +868,23 @@ package body Sem_Util is procedure Check_Potentially_Blocking_Operation (N : Node_Id) is S : Entity_Id; - Loc : constant Source_Ptr := Sloc (N); begin - -- N is one of the potentially blocking operations listed in - -- 9.5.1 (8). When using the Ravenscar profile, raise Program_Error - -- before N if the context is a protected action. Otherwise, only issue - -- a warning, since some users are relying on blocking operations - -- inside protected objects. - -- Indirect blocking through a subprogram call - -- cannot be diagnosed statically without interprocedural analysis, - -- so we do not attempt to do it here. + -- N is one of the potentially blocking operations listed in 9.5.1(8). + -- When pragma Detect_Blocking is active, the run time will raise + -- Program_Error. Here we only issue a warning, since we generally + -- support the use of potentially blocking operations in the absence + -- of the pragma. - S := Scope (Current_Scope); + -- Indirect blocking through a subprogram call cannot be diagnosed + -- statically without interprocedural analysis, so we do not attempt + -- to do it here. + S := Scope (Current_Scope); while Present (S) and then S /= Standard_Standard loop if Is_Protected_Type (S) then - if Restricted_Profile then - Insert_Before_And_Analyze (N, - Make_Raise_Program_Error (Loc, - Reason => PE_Potentially_Blocking_Operation)); - Error_Msg_N ("potentially blocking operation, " & - " Program Error will be raised at run time?", N); - - else - Error_Msg_N - ("potentially blocking operation in protected operation?", N); - end if; + Error_Msg_N + ("potentially blocking operation in protected operation?", N); return; end if; @@ -5781,10 +5770,9 @@ package body Sem_Util is -- scope because the back end otherwise tries to allocate a -- variable length temporary for the particular variant. - -- ??? With tree-ssa, the back-end does not (yet) support these - -- types either, so disable this optimization for now. - - if Has_Discriminants (Typ) then + if Opt.GCC_Version = 2 + and then Has_Discriminants (Typ) + then return True; -- For GCC 3, or for a non-discriminated record in GCC 2, we are diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 5212ffb49e3..4cc22f8b917 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -110,8 +110,7 @@ package Sem_Util is procedure Check_Potentially_Blocking_Operation (N : Node_Id); -- N is one of the statement forms that is a potentially blocking - -- operation. If it appears within a protected action, emit warning - -- and raise Program_Error. + -- operation. If it appears within a protected action, emit warning. procedure Check_VMS (Construct : Node_Id); -- Check that this the target is OpenVMS, and if so, return with diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index c22c192da08..eb25be383f9 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -779,8 +779,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) if (attribute == Attr_Max_Size_In_Storage_Elements) gnu_result = convert (sizetype, - fold (build (CEIL_DIV_EXPR, bitsizetype, - gnu_result, bitsize_unit_node))); + fold (build2 (CEIL_DIV_EXPR, bitsizetype, + gnu_result, bitsize_unit_node))); break; case Attr_Alignment: @@ -1101,8 +1101,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) example in AARM 11.6(5.e). */ if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix) && !Is_Entity_Name (Prefix (gnat_node))) - gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result), - gnu_prefix, gnu_result)); + gnu_result = fold (build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result), + gnu_prefix, gnu_result)); *gnu_result_type_p = gnu_result_type; return gnu_result; @@ -1197,9 +1197,9 @@ Case_Statement_to_gnu (Node_Id gnat_node) abort (); } - add_stmt_with_node (build (CASE_LABEL_EXPR, void_type_node, - gnu_low, gnu_high, - create_artificial_label ()), + add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node, + gnu_low, gnu_high, + create_artificial_label ()), gnat_choice); } @@ -1214,8 +1214,8 @@ Case_Statement_to_gnu (Node_Id gnat_node) /* Now emit a definition of the label all the cases branched to. */ add_stmt (build1 (LABEL_EXPR, void_type_node, TREE_VALUE (gnu_switch_label_stack))); - gnu_result = build (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, - end_stmt_group (), NULL_TREE); + gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, + end_stmt_group (), NULL_TREE); pop_stack (&gnu_switch_label_stack); return gnu_result; @@ -1279,10 +1279,10 @@ Loop_Statement_to_gnu (Node_Id gnat_node) || tree_int_cst_equal (gnu_last, gnu_limit)) { gnu_cond_expr - = build (COND_EXPR, void_type_node, - build_binary_op (LE_EXPR, integer_type_node, - gnu_low, gnu_high), - NULL_TREE, alloc_stmt_list ()); + = build3 (COND_EXPR, void_type_node, + build_binary_op (LE_EXPR, integer_type_node, + gnu_low, gnu_high), + NULL_TREE, alloc_stmt_list ()); annotate_with_node (gnu_cond_expr, gnat_loop_spec); } @@ -1485,8 +1485,8 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) add_stmt_with_node (build1 (RETURN_EXPR, void_type_node, - build (MODIFY_EXPR, TREE_TYPE (gnu_retval), - DECL_RESULT (current_function_decl), gnu_retval)), + build2 (MODIFY_EXPR, TREE_TYPE (gnu_retval), + DECL_RESULT (current_function_decl), gnu_retval)), gnat_node); gnat_poplevel (); gnu_result = end_stmt_group (); @@ -1520,10 +1520,12 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call or an N_Procedure_Call_Statement, to a GCC tree, which is returned. - GNU_RESULT_TYPE_P is a pointer to where we should place the result type. */ + GNU_RESULT_TYPE_P is a pointer to where we should place the result type. + If GNU_TARGET is non-null, this must be a function call and the result + of the call is to be placed into that object. */ static tree -call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) +call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) { tree gnu_result; /* The GCC node corresponding to the GNAT subprogram name. This can either @@ -1566,7 +1568,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) gnat_actual = Next_Actual (gnat_actual)) add_stmt (gnat_to_gnu (gnat_actual)); - if (Nkind (gnat_node) == N_Function_Call) + if (Nkind (gnat_node) == N_Function_Call && !gnu_target) { *gnu_result_type_p = TREE_TYPE (gnu_subprog_type); return build1 (NULL_EXPR, *gnu_result_type_p, @@ -1576,6 +1578,37 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) return build_call_raise (PE_Stubbed_Subprogram_Called); } + /* If we are calling by supplying a pointer to a target, set up that + pointer as the first argument. Use GNU_TARGET if one was passed; + otherwise, make a target by building a variable of the maximum size + of the type. */ + if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) + { + tree gnu_real_ret_type + = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type))); + + if (!gnu_target) + { + tree gnu_obj_type + = maybe_pad_type (gnu_real_ret_type, + max_size (TYPE_SIZE (gnu_real_ret_type), true), + 0, Etype (Name (gnat_node)), "PAD", false, + false, false); + + gnu_target = create_tmp_var_raw (gnu_obj_type, "LR"); + gnat_pushdecl (gnu_target, gnat_node); + } + + gnu_actual_list + = tree_cons (NULL_TREE, + build_unary_op (ADDR_EXPR, NULL_TREE, + unchecked_convert (gnu_real_ret_type, + gnu_target, + false)), + NULL_TREE); + + } + /* The only way we can be making a call via an access type is if Name is an explicit dereference. In that case, get the list of formal args from the type the access type is pointing to. Otherwise, get the formals from @@ -1660,8 +1693,8 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) } /* Set up to move the copy back to the original. */ - gnu_temp = build (MODIFY_EXPR, TREE_TYPE (gnu_copy), - gnu_copy, gnu_actual); + gnu_temp = build2 (MODIFY_EXPR, TREE_TYPE (gnu_copy), + gnu_copy, gnu_actual); annotate_with_node (gnu_temp, gnat_actual); append_to_statement_list (gnu_temp, &gnu_after_list); } @@ -1826,12 +1859,24 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list); } - gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type), - gnu_subprog_addr, nreverse (gnu_actual_list), - NULL_TREE); + gnu_subprog_call = build3 (CALL_EXPR, TREE_TYPE (gnu_subprog_type), + gnu_subprog_addr, nreverse (gnu_actual_list), + NULL_TREE); - /* If it is a function call, the result is the call expression. */ - if (Nkind (gnat_node) == N_Function_Call) + /* If we return by passing a target, we emit the call and return the target + as our result. */ + if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) + { + add_stmt_with_node (gnu_subprog_call, gnat_node); + *gnu_result_type_p + = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type))); + return unchecked_convert (*gnu_result_type_p, gnu_target, false); + } + + /* If it is a function call, the result is the call expression unless + a target is specified, in which case we copy the result into the target + and return the assignment statement. */ + else if (Nkind (gnat_node) == N_Function_Call) { gnu_result = gnu_subprog_call; @@ -1841,7 +1886,12 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) || TYPE_RETURNS_BY_REF_P (gnu_subprog_type)) gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); - *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); + if (gnu_target) + gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, + gnu_target, gnu_result); + else + *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); + return gnu_result; } @@ -2111,12 +2161,12 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) gnu_handler = end_stmt_group (); /* This block is now "if (setjmp) ... <handlers> else <block>". */ - gnu_result = build (COND_EXPR, void_type_node, - (build_call_1_expr - (setjmp_decl, - build_unary_op (ADDR_EXPR, NULL_TREE, - gnu_jmpbuf_decl))), - gnu_handler, gnu_inner_block); + gnu_result = build3 (COND_EXPR, void_type_node, + (build_call_1_expr + (setjmp_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_jmpbuf_decl))), + gnu_handler, gnu_inner_block); } else if (gcc_zcx) { @@ -2131,8 +2181,8 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) gnu_handlers = end_stmt_group (); /* Now make the TRY_CATCH_EXPR for the block. */ - gnu_result = build (TRY_CATCH_EXPR, void_type_node, - gnu_inner_block, gnu_handlers); + gnu_result = build2 (TRY_CATCH_EXPR, void_type_node, + gnu_inner_block, gnu_handlers); } else gnu_result = gnu_inner_block; @@ -2225,7 +2275,7 @@ Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) gnu_choice, this_choice); } - return build (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE); + return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE); } /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, @@ -2312,7 +2362,7 @@ Exception_Handler_to_gnu_zcx (Node_Id gnat_node) We use a local variable to retrieve the incoming value at handler entry time, and reuse it to feed the end_handler hook's argument at exit. */ - gnu_current_exc_ptr = build (EXC_PTR_EXPR, ptr_type_node); + gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node); gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE, ptr_type_node, gnu_current_exc_ptr, false, false, false, false, NULL, @@ -2325,8 +2375,8 @@ Exception_Handler_to_gnu_zcx (Node_Id gnat_node) add_stmt_list (Statements (gnat_node)); gnat_poplevel (); - return build (CATCH_EXPR, void_type_node, gnu_etypes_list, - end_stmt_group ()); + return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, + end_stmt_group ()); } /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */ @@ -2857,13 +2907,13 @@ gnat_to_gnu (Node_Id gnat_node) expression if the slice range is not null (max >= min) or returns the min if the slice range is null */ gnu_expr - = fold (build (COND_EXPR, gnu_expr_type, - build_binary_op (GE_EXPR, gnu_expr_type, - convert (gnu_expr_type, - gnu_max_expr), - convert (gnu_expr_type, - gnu_min_expr)), - gnu_expr, gnu_min_expr)); + = fold (build3 (COND_EXPR, gnu_expr_type, + build_binary_op (GE_EXPR, gnu_expr_type, + convert (gnu_expr_type, + gnu_max_expr), + convert (gnu_expr_type, + gnu_min_expr)), + gnu_expr, gnu_min_expr)); } else gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); @@ -3354,26 +3404,32 @@ gnat_to_gnu (Node_Id gnat_node) case N_Assignment_Statement: /* Get the LHS and RHS of the statement and convert any reference to an - unconstrained array into a reference to the underlying array. */ + unconstrained array into a reference to the underlying array. + If we are not to do range checking and the RHS is an N_Function_Call, + pass the LHS to the call function. */ gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node))); - gnu_rhs - = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node))); - - /* If range check is needed, emit code to generate it */ - if (Do_Range_Check (Expression (gnat_node))) - gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node))); - /* If either side's type has a size that overflows, convert this - into raise of Storage_Error: execution shouldn't have gotten - here anyway. */ - if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST + /* If the type has a size that overflows, convert this into raise of + Storage_Error: execution shouldn't have gotten here anyway. */ + if (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs)))) - || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs))) == INTEGER_CST - && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs))))) gnu_result = build_call_raise (SE_Object_Too_Large); + else if (Nkind (Expression (gnat_node)) == N_Function_Call + && !Do_Range_Check (Expression (gnat_node))) + gnu_result = call_to_gnu (Expression (gnat_node), + &gnu_result_type, gnu_lhs); else - gnu_result - = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs); + { + gnu_rhs + = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node))); + + /* If range check is needed, emit code to generate it */ + if (Do_Range_Check (Expression (gnat_node))) + gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node))); + + gnu_result + = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs); + } break; case N_If_Statement: @@ -3381,9 +3437,9 @@ gnat_to_gnu (Node_Id gnat_node) tree *gnu_else_ptr; /* Point to put next "else if" or "else". */ /* Make the outer COND_EXPR. Avoid non-determinism. */ - gnu_result = build (COND_EXPR, void_type_node, - gnat_to_gnu (Condition (gnat_node)), - NULL_TREE, NULL_TREE); + gnu_result = build3 (COND_EXPR, void_type_node, + gnat_to_gnu (Condition (gnat_node)), + NULL_TREE, NULL_TREE); COND_EXPR_THEN (gnu_result) = build_stmt_group (Then_Statements (gnat_node), false); TREE_SIDE_EFFECTS (gnu_result) = 1; @@ -3396,9 +3452,9 @@ gnat_to_gnu (Node_Id gnat_node) for (gnat_temp = First (Elsif_Parts (gnat_node)); Present (gnat_temp); gnat_temp = Next (gnat_temp)) { - gnu_expr = build (COND_EXPR, void_type_node, - gnat_to_gnu (Condition (gnat_temp)), - NULL_TREE, NULL_TREE); + gnu_expr = build3 (COND_EXPR, void_type_node, + gnat_to_gnu (Condition (gnat_temp)), + NULL_TREE, NULL_TREE); COND_EXPR_THEN (gnu_expr) = build_stmt_group (Then_Statements (gnat_temp), false); TREE_SIDE_EFFECTS (gnu_expr) = 1; @@ -3433,12 +3489,12 @@ gnat_to_gnu (Node_Id gnat_node) case N_Exit_Statement: gnu_result - = build (EXIT_STMT, void_type_node, - (Present (Condition (gnat_node)) - ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE), - (Present (Name (gnat_node)) - ? get_gnu_tree (Entity (Name (gnat_node))) - : TREE_VALUE (gnu_loop_label_stack))); + = build2 (EXIT_STMT, void_type_node, + (Present (Condition (gnat_node)) + ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE), + (Present (Name (gnat_node)) + ? get_gnu_tree (Entity (Name (gnat_node))) + : TREE_VALUE (gnu_loop_label_stack))); break; case N_Return_Statement: @@ -3446,7 +3502,13 @@ gnat_to_gnu (Node_Id gnat_node) /* The gnu function type of the subprogram currently processed. */ tree gnu_subprog_type = TREE_TYPE (current_function_decl); /* The return value from the subprogram. */ - tree gnu_ret_val = 0; + tree gnu_ret_val = NULL_TREE; + /* The place to put the return value. */ + tree gnu_lhs + = (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type) + ? build_unary_op (INDIRECT_REF, NULL_TREE, + DECL_ARGUMENTS (current_function_decl)) + : DECL_RESULT (current_function_decl)); /* If we are dealing with a "return;" from an Ada procedure with parameters passed by copy in copy out, we need to return a record @@ -3484,53 +3546,71 @@ gnat_to_gnu (Node_Id gnat_node) else if (Present (Expression (gnat_node))) { - gnu_ret_val = gnat_to_gnu (Expression (gnat_node)); - - /* Do not remove the padding from GNU_RET_VAL if the inner - type is self-referential since we want to allocate the fixed - size in that case. */ - if (TREE_CODE (gnu_ret_val) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))) - && (CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))) - gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0); - - if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type) - || By_Ref (gnat_node)) - gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val); - - else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)) + /* If the current function returns by target pointer and we + are doing a call, pass that target to the call. */ + if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type) + && Nkind (Expression (gnat_node)) == N_Function_Call) + gnu_result = call_to_gnu (Expression (gnat_node), + &gnu_result_type, gnu_lhs); + + else { - gnu_ret_val = maybe_unconstrained_array (gnu_ret_val); - - /* We have two cases: either the function returns with - depressed stack or not. If not, we allocate on the - secondary stack. If so, we allocate in the stack frame. - if no copy is needed, the front end will set By_Ref, - which we handle in the case above. */ - if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type)) - gnu_ret_val - = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val, - TREE_TYPE (gnu_subprog_type), 0, -1, - gnat_node); - else + gnu_ret_val = gnat_to_gnu (Expression (gnat_node)); + + /* Do not remove the padding from GNU_RET_VAL if the inner + type is self-referential since we want to allocate the fixed + size in that case. */ + if (TREE_CODE (gnu_ret_val) == COMPONENT_REF + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))) + && (CONTAINS_PLACEHOLDER_P + (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))) + gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0); + + if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type) + || By_Ref (gnat_node)) gnu_ret_val - = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val, - TREE_TYPE (gnu_subprog_type), - Procedure_To_Call (gnat_node), - Storage_Pool (gnat_node), gnat_node); + = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val); + + else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)) + { + gnu_ret_val = maybe_unconstrained_array (gnu_ret_val); + + /* We have two cases: either the function returns with + depressed stack or not. If not, we allocate on the + secondary stack. If so, we allocate in the stack frame. + if no copy is needed, the front end will set By_Ref, + which we handle in the case above. */ + if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type)) + gnu_ret_val + = build_allocator (TREE_TYPE (gnu_ret_val), + gnu_ret_val, + TREE_TYPE (gnu_subprog_type), + 0, -1, gnat_node); + else + gnu_ret_val + = build_allocator (TREE_TYPE (gnu_ret_val), + gnu_ret_val, + TREE_TYPE (gnu_subprog_type), + Procedure_To_Call (gnat_node), + Storage_Pool (gnat_node), + gnat_node); + } + } + + gnu_result = build2 (MODIFY_EXPR, TREE_TYPE (gnu_ret_val), + gnu_lhs, gnu_ret_val); + if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)) + { + add_stmt_with_node (gnu_result, gnat_node); + gnu_ret_val = NULL_TREE; } } gnu_result = build1 (RETURN_EXPR, void_type_node, - (gnu_ret_val - ? build (MODIFY_EXPR, TREE_TYPE (gnu_ret_val), - DECL_RESULT (current_function_decl), - gnu_ret_val) - : NULL_TREE)); + gnu_ret_val ? gnu_result : gnu_ret_val); } break; @@ -3584,7 +3664,7 @@ gnat_to_gnu (Node_Id gnat_node) case N_Function_Call: case N_Procedure_Call_Statement: - gnu_result = call_to_gnu (gnat_node, &gnu_result_type); + gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE); break; /*************************/ @@ -3788,9 +3868,9 @@ gnat_to_gnu (Node_Id gnat_node) gnu_input_list = nreverse (gnu_input_list); gnu_output_list = nreverse (gnu_output_list); - gnu_result = build (ASM_EXPR, void_type_node, - gnu_template, gnu_output_list, - gnu_input_list, gnu_clobber_list); + gnu_result = build4 (ASM_EXPR, void_type_node, + gnu_template, gnu_output_list, + gnu_input_list, gnu_clobber_list); ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node); } else @@ -3889,9 +3969,9 @@ gnat_to_gnu (Node_Id gnat_node) annotate_with_node (gnu_result, gnat_node); if (Present (Condition (gnat_node))) - gnu_result = build (COND_EXPR, void_type_node, - gnat_to_gnu (Condition (gnat_node)), - gnu_result, alloc_stmt_list ()); + gnu_result = build3 (COND_EXPR, void_type_node, + gnat_to_gnu (Condition (gnat_node)), + gnu_result, alloc_stmt_list ()); } else gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result); @@ -4079,7 +4159,7 @@ gnat_to_gnu (Node_Id gnat_node) static void record_code_position (Node_Id gnat_node) { - tree stmt_stmt = build (STMT_STMT, void_type_node, NULL_TREE); + tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE); add_stmt_with_node (stmt_stmt, gnat_node); save_gnu_tree (gnat_node, stmt_stmt, true); @@ -4157,7 +4237,7 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) this decl since we already have evaluated the expressions in the sizes and positions as globals and doing it again would be wrong. But we do have to mark everything as used. */ - gnu_stmt = build (DECL_EXPR, void_type_node, gnu_decl); + gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl); if (!global_bindings_p ()) add_stmt_with_node (gnu_stmt, gnat_entity); else @@ -4276,12 +4356,12 @@ end_stmt_group () gnu_retval = alloc_stmt_list (); if (group->cleanups) - gnu_retval = build (TRY_FINALLY_EXPR, void_type_node, gnu_retval, - group->cleanups); + gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval, + group->cleanups); if (current_stmt_group->block) - gnu_retval = build (BIND_EXPR, void_type_node, BLOCK_VARS (group->block), - gnu_retval, group->block); + gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block), + gnu_retval, group->block); /* Remove this group from the stack and add it to the free list. */ current_stmt_group = group->previous; @@ -4418,10 +4498,33 @@ gnat_gimplify_expr (tree *expr_p, tree *pre_p, tree *post_p ATTRIBUTE_UNUSED) *expr_p = TREE_OPERAND (*expr_p, 0); return GS_OK; + case ADDR_EXPR: + /* If we're taking the address of a constant CONSTRUCTOR, force it to + be put into static memory. We know it's going to be readonly given + the semantics we have and it's required to be static memory in + the case when the reference is in an elaboration procedure. */ + if (TREE_CODE (TREE_OPERAND (expr, 0)) == CONSTRUCTOR + && TREE_CONSTANT (TREE_OPERAND (expr, 0))) + { + tree new_var + = create_tmp_var (TREE_TYPE (TREE_OPERAND (expr, 0)), "C"); + + TREE_READONLY (new_var) = 1; + TREE_STATIC (new_var) = 1; + TREE_ADDRESSABLE (new_var) = 1; + + gimplify_and_add (build2 (MODIFY_EXPR, TREE_TYPE (new_var), + new_var, TREE_OPERAND (expr, 0)), + pre_p); + + TREE_OPERAND (expr, 0) = new_var; + return GS_ALL_DONE; + } + return GS_UNHANDLED; + case COMPONENT_REF: - /* We have a kludge here. If the FIELD_DECL is from a fat pointer - and is from an early dummy type, replace it with the proper - FIELD_DECL. */ + /* We have a kludge here. If the FIELD_DECL is from a fat pointer and is + from an early dummy type, replace it with the proper FIELD_DECL. */ if (TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (*expr_p, 0))) && DECL_ORIGINAL_FIELD (TREE_OPERAND (*expr_p, 1))) { @@ -4472,23 +4575,23 @@ gnat_gimplify_stmt (tree *stmt_p) stmt_p); if (LOOP_STMT_TOP_COND (stmt)) - append_to_statement_list (build (COND_EXPR, void_type_node, - LOOP_STMT_TOP_COND (stmt), - alloc_stmt_list (), - build1 (GOTO_EXPR, - void_type_node, - gnu_end_label)), + append_to_statement_list (build3 (COND_EXPR, void_type_node, + LOOP_STMT_TOP_COND (stmt), + alloc_stmt_list (), + build1 (GOTO_EXPR, + void_type_node, + gnu_end_label)), stmt_p); append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p); if (LOOP_STMT_BOT_COND (stmt)) - append_to_statement_list (build (COND_EXPR, void_type_node, - LOOP_STMT_BOT_COND (stmt), - alloc_stmt_list (), - build1 (GOTO_EXPR, - void_type_node, - gnu_end_label)), + append_to_statement_list (build3 (COND_EXPR, void_type_node, + LOOP_STMT_BOT_COND (stmt), + alloc_stmt_list (), + build1 (GOTO_EXPR, + void_type_node, + gnu_end_label)), stmt_p); if (LOOP_STMT_UPDATE (stmt)) @@ -4508,8 +4611,8 @@ gnat_gimplify_stmt (tree *stmt_p) see if it needs to be conditional. */ *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt)); if (EXIT_STMT_COND (stmt)) - *stmt_p = build (COND_EXPR, void_type_node, - EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ()); + *stmt_p = build3 (COND_EXPR, void_type_node, + EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ()); return GS_OK; default: @@ -4974,17 +5077,17 @@ emit_check (tree gnu_cond, tree gnu_expr, int reason) in front of the comparison in case it ends up being a SAVE_EXPR. Put the whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak out. */ - gnu_result = fold (build (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond, - build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), - gnu_call, gnu_expr), - gnu_expr)); + gnu_result = fold (build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond, + build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), + gnu_call, gnu_expr), + gnu_expr)); /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and protect it. Otherwise, show GNU_RESULT has no side effects: we don't need to evaluate it just for the check. */ if (TREE_SIDE_EFFECTS (gnu_expr)) gnu_result - = build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result); + = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result); else TREE_SIDE_EFFECTS (gnu_result) = 0; @@ -5107,13 +5210,13 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, tree gnu_minus_point_5 = build_real (gnu_in_basetype, dconstmp5); tree gnu_zero = convert (gnu_in_basetype, integer_zero_node); tree gnu_saved_result = save_expr (gnu_result); - tree gnu_comp = build (GE_EXPR, integer_type_node, - gnu_saved_result, gnu_zero); - tree gnu_adjust = build (COND_EXPR, gnu_in_basetype, gnu_comp, - gnu_point_5, gnu_minus_point_5); + tree gnu_comp = build2 (GE_EXPR, integer_type_node, + gnu_saved_result, gnu_zero); + tree gnu_adjust = build3 (COND_EXPR, gnu_in_basetype, gnu_comp, + gnu_point_5, gnu_minus_point_5); gnu_result - = build (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust); + = build2 (PLUS_EXPR, gnu_in_basetype, gnu_saved_result, gnu_adjust); } if (TREE_CODE (gnu_ada_base_type) == INTEGER_TYPE @@ -5531,36 +5634,36 @@ gnat_stabilize_reference (tree ref, bool force) break; case COMPONENT_REF: - result = build (COMPONENT_REF, type, - gnat_stabilize_reference (TREE_OPERAND (ref, 0), - force), - TREE_OPERAND (ref, 1), NULL_TREE); + result = build3 (COMPONENT_REF, type, + gnat_stabilize_reference (TREE_OPERAND (ref, 0), + force), + TREE_OPERAND (ref, 1), NULL_TREE); break; case BIT_FIELD_REF: - result = build (BIT_FIELD_REF, type, - gnat_stabilize_reference (TREE_OPERAND (ref, 0), force), - gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), - force), - gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2), - force)); + result = build3 (BIT_FIELD_REF, type, + gnat_stabilize_reference (TREE_OPERAND (ref, 0), force), + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), + force), + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2), + force)); break; case ARRAY_REF: case ARRAY_RANGE_REF: - result = build (code, type, - gnat_stabilize_reference (TREE_OPERAND (ref, 0), force), - gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), - force), - NULL_TREE, NULL_TREE); + result = build4 (code, type, + gnat_stabilize_reference (TREE_OPERAND (ref, 0), force), + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), + force), + NULL_TREE, NULL_TREE); break; case COMPOUND_EXPR: - result = build (COMPOUND_EXPR, type, - gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0), - force), - gnat_stabilize_reference (TREE_OPERAND (ref, 1), - force)); + result = build2 (COMPOUND_EXPR, type, + gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0), + force), + gnat_stabilize_reference (TREE_OPERAND (ref, 1), + force)); break; /* If arg isn't a kind of lvalue we recognize, make no change. @@ -5621,10 +5724,10 @@ gnat_stabilize_reference_1 (tree e, bool force) us to more easily find the match for the PLACEHOLDER_EXPR. */ if (code == COMPONENT_REF && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0)))) - result = build (COMPONENT_REF, type, - gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), - force), - TREE_OPERAND (e, 1), TREE_OPERAND (e, 2)); + result = build3 (COMPONENT_REF, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), + force), + TREE_OPERAND (e, 1), TREE_OPERAND (e, 2)); else if (TREE_SIDE_EFFECTS (e) || force) return save_expr (e); else @@ -5638,9 +5741,10 @@ gnat_stabilize_reference_1 (tree e, bool force) case '2': /* Recursively stabilize each operand. */ - result = build (code, type, - gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), - gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), force)); + result = build2 (code, type, + gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force), + gnat_stabilize_reference_1 (TREE_OPERAND (e, 1), + force)); break; case '1': diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index 9e848578690..2b5bad74092 100644 --- a/gcc/ada/utils.c +++ b/gcc/ada/utils.c @@ -832,12 +832,13 @@ finish_record_type (tree record_type, tree fieldlist, bool has_rep, case QUAL_UNION_TYPE: ada_size - = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), - this_ada_size, ada_size)); - size = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), - this_size, size)); - size_unit = fold (build (COND_EXPR, sizetype, DECL_QUALIFIER (field), - this_size_unit, size_unit)); + = fold (build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), + this_ada_size, ada_size)); + size = fold (build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), + this_size, size)); + size_unit = fold (build3 (COND_EXPR, sizetype, + DECL_QUALIFIER (field), + this_size_unit, size_unit)); break; case RECORD_TYPE: @@ -1073,15 +1074,15 @@ merge_sizes (tree last_size, tree first_bit, tree size, bool special, } else - new = fold (build (COND_EXPR, type, TREE_OPERAND (size, 0), - integer_zerop (TREE_OPERAND (size, 1)) - ? last_size : merge_sizes (last_size, first_bit, - TREE_OPERAND (size, 1), - 1, has_rep), - integer_zerop (TREE_OPERAND (size, 2)) - ? last_size : merge_sizes (last_size, first_bit, - TREE_OPERAND (size, 2), - 1, has_rep))); + new = fold (build3 (COND_EXPR, type, TREE_OPERAND (size, 0), + integer_zerop (TREE_OPERAND (size, 1)) + ? last_size : merge_sizes (last_size, first_bit, + TREE_OPERAND (size, 1), + 1, has_rep), + integer_zerop (TREE_OPERAND (size, 2)) + ? last_size : merge_sizes (last_size, first_bit, + TREE_OPERAND (size, 2), + 1, has_rep))); /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially when fed through substitute_in_expr) into thinking that a constant @@ -1157,12 +1158,14 @@ split_plus (tree in, tree *pvar) RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained object. RETURNS_BY_REF is nonzero if the function returns by reference. RETURNS_WITH_DSP is nonzero if the function is to return with a - depressed stack pointer. */ + depressed stack pointer. RETURNS_BY_TARGET_PTR is true if the function + is to be passed (as its first parameter) the address of the place to copy + its result. */ tree create_subprog_type (tree return_type, tree param_decl_list, tree cico_list, bool returns_unconstrained, bool returns_by_ref, - bool returns_with_dsp) + bool returns_with_dsp, bool returns_by_target_ptr) { /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of the subprogram formal parameters. This list is generated by traversing the @@ -1193,13 +1196,15 @@ create_subprog_type (tree return_type, tree param_decl_list, tree cico_list, RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */ if (TYPE_CI_CO_LIST (type) || cico_list || TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained - || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref) + || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref + || TYPE_RETURNS_BY_TARGET_PTR_P (type) != returns_by_target_ptr) type = copy_type (type); TYPE_CI_CO_LIST (type) = cico_list; TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained; TYPE_RETURNS_STACK_DEPRESSED (type) = returns_with_dsp; TYPE_RETURNS_BY_REF_P (type) = returns_by_ref; + TYPE_RETURNS_BY_TARGET_PTR_P (type) = returns_by_target_ptr; return type; } @@ -1342,10 +1347,12 @@ create_var_decl (tree var_name, tree asm_name, tree type, tree var_init, TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl) = TYPE_VOLATILE (type); - /* At the global binding level we need to allocate static storage for the - variable if and only if its not external. If we are not at the top level + /* If it's public and not external, always allocate storage for it. + At the global binding level we need to allocate static storage for the + variable if and only if it's not external. If we are not at the top level we allocate automatic storage unless requested not to. */ - TREE_STATIC (var_decl) = global_bindings_p () ? !extern_flag : static_flag; + TREE_STATIC (var_decl) + = public_flag || (global_bindings_p () ? !extern_flag : static_flag); if (asm_name) SET_DECL_ASSEMBLER_NAME (var_decl, asm_name); @@ -2066,19 +2073,19 @@ max_size (tree exp, bool max_p) && !TREE_CONSTANT (rhs)) return lhs; else - return fold (build (code, type, lhs, rhs)); + return fold (build2 (code, type, lhs, rhs)); } case 3: if (code == SAVE_EXPR) return exp; else if (code == COND_EXPR) - return fold (build (max_p ? MAX_EXPR : MIN_EXPR, type, - max_size (TREE_OPERAND (exp, 1), max_p), - max_size (TREE_OPERAND (exp, 2), max_p))); + return fold (build2 (max_p ? MAX_EXPR : MIN_EXPR, type, + max_size (TREE_OPERAND (exp, 1), max_p), + max_size (TREE_OPERAND (exp, 2), max_p))); else if (code == CALL_EXPR && TREE_OPERAND (exp, 1)) - return build (CALL_EXPR, type, TREE_OPERAND (exp, 0), - max_size (TREE_OPERAND (exp, 1), max_p), NULL); + return build3 (CALL_EXPR, type, TREE_OPERAND (exp, 0), + max_size (TREE_OPERAND (exp, 1), max_p), NULL); } } @@ -2307,7 +2314,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) build_pointer_type_for_mode (type, SImode, false), record_type, build1 (ADDR_EXPR, build_pointer_type_for_mode (type, SImode, false), - build (PLACEHOLDER_EXPR, type)))); + build0 (PLACEHOLDER_EXPR, type)))); switch (mech) { @@ -2368,12 +2375,12 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) size_in_bytes (type))); /* Now build a pointer to the 0,0,0... element. */ - tem = build (PLACEHOLDER_EXPR, type); + tem = build0 (PLACEHOLDER_EXPR, type); for (i = 0, inner_type = type; i < ndim; i++, inner_type = TREE_TYPE (inner_type)) - tem = build (ARRAY_REF, TREE_TYPE (inner_type), tem, - convert (TYPE_DOMAIN (inner_type), size_zero_node), - NULL_TREE, NULL_TREE); + tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem, + convert (TYPE_DOMAIN (inner_type), size_zero_node), + NULL_TREE, NULL_TREE); field_list = chainon (field_list, @@ -2596,9 +2603,9 @@ update_pointer_to (tree old_type, tree new_type) is now a very "heavy" routine to do this, so it should be replaced at some point. */ ptr_temp_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr))); - new_ref = build (COMPONENT_REF, ptr_temp_type, - build (PLACEHOLDER_EXPR, ptr), - TREE_CHAIN (TYPE_FIELDS (ptr)), NULL_TREE); + new_ref = build3 (COMPONENT_REF, ptr_temp_type, + build0 (PLACEHOLDER_EXPR, ptr), + TREE_CHAIN (TYPE_FIELDS (ptr)), NULL_TREE); update_pointer_to (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))), @@ -2801,10 +2808,11 @@ convert (tree type, tree expr) /* If the input is a biased type, adjust first. */ if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype)) - return convert (type, fold (build (PLUS_EXPR, TREE_TYPE (etype), - fold (build1 (NOP_EXPR, - TREE_TYPE (etype), expr)), - TYPE_MIN_VALUE (etype)))); + return convert (type, fold (build2 (PLUS_EXPR, TREE_TYPE (etype), + fold (build1 (NOP_EXPR, + TREE_TYPE (etype), + expr)), + TYPE_MIN_VALUE (etype)))); /* If the input is a left-justified modular type, we need to extract the actual object before converting it to any other type with the @@ -2936,9 +2944,9 @@ convert (tree type, tree expr) return unchecked_convert (type, expr, false); else if (TYPE_BIASED_REPRESENTATION_P (type)) return fold (build1 (CONVERT_EXPR, type, - fold (build (MINUS_EXPR, TREE_TYPE (type), - convert (TREE_TYPE (type), expr), - TYPE_MIN_VALUE (type))))); + fold (build2 (MINUS_EXPR, TREE_TYPE (type), + convert (TREE_TYPE (type), expr), + TYPE_MIN_VALUE (type))))); /* ... fall through ... */ diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c index 016356399c4..6341863f061 100644 --- a/gcc/ada/utils2.c +++ b/gcc/ada/utils2.c @@ -96,9 +96,9 @@ gnat_truthvalue_conversion (tree expr) case COND_EXPR: /* Distribute the conversion into the arms of a COND_EXPR. */ return fold - (build (COND_EXPR, type, TREE_OPERAND (expr, 0), - gnat_truthvalue_conversion (TREE_OPERAND (expr, 1)), - gnat_truthvalue_conversion (TREE_OPERAND (expr, 2)))); + (build3 (COND_EXPR, type, TREE_OPERAND (expr, 0), + gnat_truthvalue_conversion (TREE_OPERAND (expr, 1)), + gnat_truthvalue_conversion (TREE_OPERAND (expr, 2)))); default: return build_binary_op (NE_EXPR, type, expr, @@ -355,8 +355,8 @@ compare_arrays (tree result_type, tree a1, tree a2) tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2)); tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2)); tree bt = get_base_type (TREE_TYPE (lb1)); - tree length1 = fold (build (MINUS_EXPR, bt, ub1, lb1)); - tree length2 = fold (build (MINUS_EXPR, bt, ub2, lb2)); + tree length1 = fold (build2 (MINUS_EXPR, bt, ub1, lb1)); + tree length2 = fold (build2 (MINUS_EXPR, bt, ub2, lb2)); tree nbt; tree tem; tree comparison, this_a1_is_null, this_a2_is_null; @@ -365,8 +365,8 @@ compare_arrays (tree result_type, tree a1, tree a2) unless the length of the second array is the constant zero. Note that we have set the `length' values to the length - 1. */ if (TREE_CODE (length1) == INTEGER_CST - && !integer_zerop (fold (build (PLUS_EXPR, bt, length2, - convert (bt, integer_one_node))))) + && !integer_zerop (fold (build2 (PLUS_EXPR, bt, length2, + convert (bt, integer_one_node))))) { tem = a1, a1 = a2, a2 = tem; tem = t1, t1 = t2, t2 = tem; @@ -379,8 +379,8 @@ compare_arrays (tree result_type, tree a1, tree a2) /* If the length of this dimension in the second array is the constant zero, we can just go inside the original bounds for the first array and see if last < first. */ - if (integer_zerop (fold (build (PLUS_EXPR, bt, length2, - convert (bt, integer_one_node))))) + if (integer_zerop (fold (build2 (PLUS_EXPR, bt, length2, + convert (bt, integer_one_node))))) { tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); @@ -459,7 +459,7 @@ compare_arrays (tree result_type, tree a1, tree a2) a1 = convert (type, a1), a2 = convert (type, a2); result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result, - fold (build (EQ_EXPR, result_type, a1, a2))); + fold (build2 (EQ_EXPR, result_type, a1, a2))); } @@ -474,10 +474,10 @@ compare_arrays (tree result_type, tree a1, tree a2) evaluated would be wrong. */ if (contains_save_expr_p (a1)) - result = build (COMPOUND_EXPR, result_type, a1, result); + result = build2 (COMPOUND_EXPR, result_type, a1, result); if (contains_save_expr_p (a2)) - result = build (COMPOUND_EXPR, result_type, a2, result); + result = build2 (COMPOUND_EXPR, result_type, a2, result); return result; } @@ -500,7 +500,7 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs, /* If this is an addition of a constant, convert it to a subtraction of a constant since we can do that faster. */ if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST) - rhs = fold (build (MINUS_EXPR, type, modulus, rhs)), op_code = MINUS_EXPR; + rhs = fold (build2 (MINUS_EXPR, type, modulus, rhs)), op_code = MINUS_EXPR; /* For the logical operations, we only need PRECISION bits. For addition and subraction, we need one more and for multiplication we @@ -532,7 +532,7 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs, } /* Do the operation, then we'll fix it up. */ - result = fold (build (op_code, op_type, lhs, rhs)); + result = fold (build2 (op_code, op_type, lhs, rhs)); /* For multiplication, we have no choice but to do a full modulus operation. However, we want to do this in the narrowest @@ -544,32 +544,32 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs, SET_TYPE_MODULUS (div_type, modulus); TYPE_MODULAR_P (div_type) = 1; result = convert (op_type, - fold (build (TRUNC_MOD_EXPR, div_type, - convert (div_type, result), modulus))); + fold (build2 (TRUNC_MOD_EXPR, div_type, + convert (div_type, result), modulus))); } /* For subtraction, add the modulus back if we are negative. */ else if (op_code == MINUS_EXPR) { result = save_expr (result); - result = fold (build (COND_EXPR, op_type, - build (LT_EXPR, integer_type_node, result, - convert (op_type, integer_zero_node)), - fold (build (PLUS_EXPR, op_type, - result, modulus)), - result)); + result = fold (build3 (COND_EXPR, op_type, + build2 (LT_EXPR, integer_type_node, result, + convert (op_type, integer_zero_node)), + fold (build2 (PLUS_EXPR, op_type, + result, modulus)), + result)); } /* For the other operations, subtract the modulus if we are >= it. */ else { result = save_expr (result); - result = fold (build (COND_EXPR, op_type, - build (GE_EXPR, integer_type_node, - result, modulus), - fold (build (MINUS_EXPR, op_type, - result, modulus)), - result)); + result = fold (build3 (COND_EXPR, op_type, + build2 (GE_EXPR, integer_type_node, + result, modulus), + fold (build2 (MINUS_EXPR, op_type, + result, modulus)), + result)); } return convert (type, result); @@ -791,16 +791,16 @@ build_binary_op (enum tree_code op_code, tree result_type, case NE_EXPR: /* If either operand is a NULL_EXPR, just return a new one. */ if (TREE_CODE (left_operand) == NULL_EXPR) - return build (op_code, result_type, - build1 (NULL_EXPR, integer_type_node, - TREE_OPERAND (left_operand, 0)), - integer_zero_node); + return build2 (op_code, result_type, + build1 (NULL_EXPR, integer_type_node, + TREE_OPERAND (left_operand, 0)), + integer_zero_node); else if (TREE_CODE (right_operand) == NULL_EXPR) - return build (op_code, result_type, - build1 (NULL_EXPR, integer_type_node, - TREE_OPERAND (right_operand, 0)), - integer_zero_node); + return build2 (op_code, result_type, + build1 (NULL_EXPR, integer_type_node, + TREE_OPERAND (right_operand, 0)), + integer_zero_node); /* If either object is a left-justified modular types, get the fields from within. */ @@ -998,11 +998,11 @@ build_binary_op (enum tree_code op_code, tree result_type, else if (TREE_CODE (right_operand) == NULL_EXPR) return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0)); else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF) - result = fold (build (op_code, operation_type, left_operand, right_operand, - NULL_TREE, NULL_TREE)); + result = fold (build4 (op_code, operation_type, left_operand, + right_operand, NULL_TREE, NULL_TREE)); else result - = fold (build (op_code, operation_type, left_operand, right_operand)); + = fold (build2 (op_code, operation_type, left_operand, right_operand)); TREE_SIDE_EFFECTS (result) |= has_side_effects; TREE_CONSTANT (result) @@ -1016,8 +1016,8 @@ build_binary_op (enum tree_code op_code, tree result_type, /* If we are working with modular types, perform the MOD operation if something above hasn't eliminated the need for it. */ if (modulus) - result = fold (build (FLOOR_MOD_EXPR, operation_type, result, - convert (operation_type, modulus))); + result = fold (build2 (FLOOR_MOD_EXPR, operation_type, result, + convert (operation_type, modulus))); if (result_type && result_type != operation_type) result = convert (result_type, result); @@ -1260,10 +1260,10 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) the straightforward code; the TRUNC_MOD_EXPR below is an AND operation. */ if (op_code == NEGATE_EXPR && mod_pow2) - result = fold (build (TRUNC_MOD_EXPR, operation_type, - fold (build1 (NEGATE_EXPR, operation_type, - operand)), - modulus)); + result = fold (build2 (TRUNC_MOD_EXPR, operation_type, + fold (build1 (NEGATE_EXPR, operation_type, + operand)), + modulus)); /* For nonbinary negate case, return zero for zero operand, else return the modulus minus the operand. If the modulus @@ -1271,22 +1271,24 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) as an XOR since it is equivalent and faster on most machines. */ else if (op_code == NEGATE_EXPR && !mod_pow2) { - if (integer_pow2p (fold (build (PLUS_EXPR, operation_type, - modulus, - convert (operation_type, - integer_one_node))))) - result = fold (build (BIT_XOR_EXPR, operation_type, - operand, modulus)); + if (integer_pow2p (fold (build2 (PLUS_EXPR, operation_type, + modulus, + convert (operation_type, + integer_one_node))))) + result = fold (build2 (BIT_XOR_EXPR, operation_type, + operand, modulus)); else - result = fold (build (MINUS_EXPR, operation_type, + result = fold (build2 (MINUS_EXPR, operation_type, modulus, operand)); - result = fold (build (COND_EXPR, operation_type, - fold (build (NE_EXPR, integer_type_node, - operand, - convert (operation_type, - integer_zero_node))), - result, operand)); + result = fold (build3 (COND_EXPR, operation_type, + fold (build2 (NE_EXPR, + integer_type_node, + operand, + convert + (operation_type, + integer_zero_node))), + result, operand)); } else { @@ -1295,16 +1297,16 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) XOR against the constant and subtract the operand from that constant for nonbinary modulus. */ - tree cnst = fold (build (MINUS_EXPR, operation_type, modulus, - convert (operation_type, - integer_one_node))); + tree cnst = fold (build2 (MINUS_EXPR, operation_type, modulus, + convert (operation_type, + integer_one_node))); if (mod_pow2) - result = fold (build (BIT_XOR_EXPR, operation_type, - operand, cnst)); + result = fold (build2 (BIT_XOR_EXPR, operation_type, + operand, cnst)); else - result = fold (build (MINUS_EXPR, operation_type, - cnst, operand)); + result = fold (build2 (MINUS_EXPR, operation_type, + cnst, operand)); } break; @@ -1360,8 +1362,8 @@ build_cond_expr (tree result_type, tree condition_operand, false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand); } - result = fold (build (COND_EXPR, result_type, condition_operand, - true_operand, false_operand)); + result = fold (build3 (COND_EXPR, result_type, condition_operand, + true_operand, false_operand)); /* If either operand is a SAVE_EXPR (possibly surrounded by arithmetic, make sure it gets done. */ @@ -1369,10 +1371,10 @@ build_cond_expr (tree result_type, tree condition_operand, false_operand = skip_simple_arithmetic (false_operand); if (TREE_CODE (true_operand) == SAVE_EXPR) - result = build (COMPOUND_EXPR, result_type, true_operand, result); + result = build2 (COMPOUND_EXPR, result_type, true_operand, result); if (TREE_CODE (false_operand) == SAVE_EXPR) - result = build (COMPOUND_EXPR, result_type, false_operand, result); + result = build2 (COMPOUND_EXPR, result_type, false_operand, result); /* ??? Seems the code above is wrong, as it may move ahead of the COND SAVE_EXPRs with side effects and not shared by both arms. */ @@ -1390,10 +1392,10 @@ build_cond_expr (tree result_type, tree condition_operand, tree build_call_1_expr (tree fundecl, tree arg) { - tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)), - build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), - chainon (NULL_TREE, build_tree_list (NULL_TREE, arg)), - NULL_TREE); + tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), + chainon (NULL_TREE, build_tree_list (NULL_TREE, arg)), + NULL_TREE); TREE_SIDE_EFFECTS (call) = 1; @@ -1406,11 +1408,11 @@ build_call_1_expr (tree fundecl, tree arg) tree build_call_2_expr (tree fundecl, tree arg1, tree arg2) { - tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)), - build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), - chainon (chainon (NULL_TREE, - build_tree_list (NULL_TREE, arg1)), - build_tree_list (NULL_TREE, arg2)), + tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), + chainon (chainon (NULL_TREE, + build_tree_list (NULL_TREE, arg1)), + build_tree_list (NULL_TREE, arg2)), NULL_TREE); TREE_SIDE_EFFECTS (call) = 1; @@ -1423,9 +1425,9 @@ build_call_2_expr (tree fundecl, tree arg1, tree arg2) tree build_call_0_expr (tree fundecl) { - tree call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)), - build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), - NULL_TREE, NULL_TREE); + tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)), + build_unary_op (ADDR_EXPR, NULL_TREE, fundecl), + NULL_TREE, NULL_TREE); TREE_SIDE_EFFECTS (call) = 1; @@ -1510,11 +1512,10 @@ gnat_build_constructor (tree type, tree list) } result = build_constructor (type, list); - TREE_CONSTANT (result) = allconstant; - TREE_STATIC (result) = allconstant; + TREE_CONSTANT (result) = TREE_INVARIANT (result) + = TREE_STATIC (result) = allconstant; TREE_SIDE_EFFECTS (result) = side_effects; - TREE_READONLY (result) = TYPE_READONLY (type); - + TREE_READONLY (result) = TYPE_READONLY (type) || allconstant; return result; } @@ -1596,8 +1597,8 @@ build_simple_component_ref (tree record_variable, tree component, /* It would be nice to call "fold" here, but that can lose a type we need to tag a PLACEHOLDER_EXPR with, so we can't do it. */ - ref = build (COMPONENT_REF, TREE_TYPE (field), record_variable, field, - NULL_TREE); + ref = build3 (COMPONENT_REF, TREE_TYPE (field), record_variable, field, + NULL_TREE); if (TREE_READONLY (record_variable) || TREE_READONLY (field)) TREE_READONLY (ref) = 1; @@ -1688,8 +1689,8 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align, build_tree_list (NULL_TREE, convert (gnu_size_type, gnu_align))); - gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)), - gnu_proc_addr, gnu_args, NULL_TREE); + gnu_call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)), + gnu_proc_addr, gnu_args, NULL_TREE); TREE_SIDE_EFFECTS (gnu_call) = 1; return gnu_call; } @@ -1717,8 +1718,8 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align, build_tree_list (NULL_TREE, convert (gnu_size_type, gnu_size))); - gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)), - gnu_proc_addr, gnu_args, NULL_TREE); + gnu_call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)), + gnu_proc_addr, gnu_args, NULL_TREE); TREE_SIDE_EFFECTS (gnu_call) = 1; return gnu_call; } @@ -1750,7 +1751,7 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align, else abort (); #if 0 - return build (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align); + return build2 (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align); #endif } else @@ -1830,16 +1831,16 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, return convert (result_type, - build (COMPOUND_EXPR, storage_ptr_type, - build_binary_op - (MODIFY_EXPR, storage_type, - build_unary_op (INDIRECT_REF, NULL_TREE, - convert (storage_ptr_type, storage)), - gnat_build_constructor (storage_type, template_cons)), - convert (storage_ptr_type, storage))); + build2 (COMPOUND_EXPR, storage_ptr_type, + build_binary_op + (MODIFY_EXPR, storage_type, + build_unary_op (INDIRECT_REF, NULL_TREE, + convert (storage_ptr_type, storage)), + gnat_build_constructor (storage_type, template_cons)), + convert (storage_ptr_type, storage))); } else - return build + return build2 (COMPOUND_EXPR, result_type, build_binary_op (MODIFY_EXPR, template_type, @@ -1910,13 +1911,13 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, { result = save_expr (result); result - = build (COMPOUND_EXPR, TREE_TYPE (result), - build_binary_op - (MODIFY_EXPR, NULL_TREE, - build_unary_op (INDIRECT_REF, TREE_TYPE (TREE_TYPE (result)), - result), - init), - result); + = build2 (COMPOUND_EXPR, TREE_TYPE (result), + build_binary_op + (MODIFY_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, + TREE_TYPE (TREE_TYPE (result)), result), + init), + result); } return convert (result_type, result); |