aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2004-09-13 12:18:42 +0200
committerArnaud Charlet <charlet@gcc.gnu.org>2004-09-13 12:18:42 +0200
commitc885d7a17a4fa12b015adde15326b13303c348bd (patch)
treeb660d80503dd74c8b52af273fa1a7b3c2af763e6
parentc892972fa7c999bf2cb6379d19265be42a974692 (diff)
downloadgcc-c885d7a17a4fa12b015adde15326b13303c348bd.zip
gcc-c885d7a17a4fa12b015adde15326b13303c348bd.tar.gz
gcc-c885d7a17a4fa12b015adde15326b13303c348bd.tar.bz2
[multiple changes]
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. From-SVN: r87435
-rw-r--r--gcc/ada/ChangeLog319
-rw-r--r--gcc/ada/Makefile.in2
-rw-r--r--gcc/ada/Makefile.rtl2
-rw-r--r--gcc/ada/a-calend.adb2
-rw-r--r--gcc/ada/a-direct.adb81
-rw-r--r--gcc/ada/a-direct.ads5
-rw-r--r--gcc/ada/a-except.adb31
-rw-r--r--gcc/ada/a-retide.adb28
-rw-r--r--gcc/ada/ada-tree.h5
-rw-r--r--gcc/ada/ali.adb6
-rw-r--r--gcc/ada/atree.adb1
-rw-r--r--gcc/ada/bindgen.adb40
-rw-r--r--gcc/ada/checks.adb1
-rw-r--r--gcc/ada/cuintp.c20
-rw-r--r--gcc/ada/decl.c110
-rw-r--r--gcc/ada/exp_ch3.adb72
-rw-r--r--gcc/ada/exp_ch3.ads2
-rw-r--r--gcc/ada/exp_ch6.adb28
-rw-r--r--gcc/ada/exp_dist.adb1507
-rw-r--r--gcc/ada/exp_dist.ads17
-rw-r--r--gcc/ada/exp_pakd.ads8
-rw-r--r--gcc/ada/g-pehage.adb8
-rw-r--r--gcc/ada/g-pehage.ads58
-rw-r--r--gcc/ada/g-perhas.ads67
-rw-r--r--gcc/ada/g-trasym.ads4
-rw-r--r--gcc/ada/gigi.h22
-rw-r--r--gcc/ada/gnat_rm.texi27
-rw-r--r--gcc/ada/gnat_ugn.texi119
-rw-r--r--gcc/ada/gnatbind.adb2
-rw-r--r--gcc/ada/gnatdll.adb182
-rw-r--r--gcc/ada/gnatls.adb460
-rw-r--r--gcc/ada/impunit.adb3
-rw-r--r--gcc/ada/init.c5
-rw-r--r--gcc/ada/lib-writ.adb4
-rw-r--r--gcc/ada/lib-writ.ads3
-rw-r--r--gcc/ada/link.c6
-rw-r--r--gcc/ada/mdll.adb59
-rw-r--r--gcc/ada/mdll.ads24
-rw-r--r--gcc/ada/opt.adb2
-rw-r--r--gcc/ada/opt.ads4
-rw-r--r--gcc/ada/prj-attr.adb124
-rw-r--r--gcc/ada/prj-attr.ads82
-rw-r--r--gcc/ada/prj-dect.adb22
-rw-r--r--gcc/ada/prj.ads3
-rw-r--r--gcc/ada/raise.h2
-rw-r--r--gcc/ada/s-parint.adb95
-rw-r--r--gcc/ada/s-parint.ads71
-rw-r--r--gcc/ada/s-solita.adb36
-rw-r--r--gcc/ada/s-taprob.adb48
-rw-r--r--gcc/ada/s-taskin.adb1
-rw-r--r--gcc/ada/s-taskin.ads21
-rw-r--r--gcc/ada/s-tasren.adb38
-rw-r--r--gcc/ada/s-tassta.adb33
-rw-r--r--gcc/ada/s-tpoben.adb80
-rw-r--r--gcc/ada/s-tposen.adb88
-rw-r--r--gcc/ada/sem_ch3.adb7
-rw-r--r--gcc/ada/sem_disp.adb3
-rw-r--r--gcc/ada/sem_dist.adb294
-rw-r--r--gcc/ada/sem_dist.ads12
-rw-r--r--gcc/ada/sem_prag.adb11
-rw-r--r--gcc/ada/sem_type.adb125
-rw-r--r--gcc/ada/sem_util.adb40
-rw-r--r--gcc/ada/sem_util.ads3
-rw-r--r--gcc/ada/trans.c466
-rw-r--r--gcc/ada/utils.c92
-rw-r--r--gcc/ada/utils2.c215
66 files changed, 3658 insertions, 1700 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d170497..c824ae6 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 e3b9507..1dba674 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 10031f8..4c01553 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 fdab0cb..e5788a4 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 74757fe..db0a931 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 d71e493..4cd2340 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 3f57408..22331f3 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 ca747a1..325a6b3 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 7cbbac1..21f1caf 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 3326eca..c1e51b4 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 c03a183..daf0641 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 fe9192a..dca5bbe 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 3c78397..6f74101 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 a6ce488..ecd21ca 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 33bbbb1..604c471 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 39d704e..631900a 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 7fc124a..27cd7d8 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 0dd84ea..df976ad 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 e3c176a..7015079 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 10cbc60..7d11ce3 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 9c3044b..ac52ecb 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 91ec418..32eaf0d 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 3db2e70..c5c3666 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 92a899c..0000000
--- 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 aa899d9..dc7b6db 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 8d09174..233c22b 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 82c390ab..08a6683 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 b9617b4..c8da0d8 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 6d5595e..48c23f0 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 74c004b..10249b3 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 5c26991..cdc924c 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 0dbe479..189ee91 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 9fe4aa1..4a54aff 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 89b4e23..3624054 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 c6f185b..2cc6b56 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 bf98e90..70b349f 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 a6c9b23..be8ace8 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 5ca9f01..495e025 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 6979807..528cbff 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 25223bc..e710275 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 2127e35..324b7dc 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 226d824..4c09689 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 8a9ebaa..e030236 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 1af7f59..41ca8d9 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 f9eb02a..4a6ffbe 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 1174d75..89ba39f 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 cf0a8b3..a4ac13d 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 79c1b36..6fd13da 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 4a5b6af..9852c4e 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 a79db6a..f667a31 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 5fd2c22..1dd9e27 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 75eecc6..5763272 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 bdd30be..535add5 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 a195828..c1d7d3c 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 25a8251..a992ed1 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 dd2e183..7f78060 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 183118f..7ea68f8 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 aee306d..8314e6c 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 efadbef..4acf872 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 02b1947..6fd97d8 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 8f2ccad..8d0cf75 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 0f1894a..762be69 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 5212ffb..4cc22f8 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 c22c192..eb25be3 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 9e84857..2b5bad7 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 0163563..6341863 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);