2004-08-09 Thomas Quinot <quinot@act-europe.fr>
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 9 Aug 2004 12:24:25 +0000 (12:24 +0000)
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 9 Aug 2004 12:24:25 +0000 (12:24 +0000)
* g-socket.adb (Abort_Selector): Initialize Buf to prevent valgrind
from complaining on potential uninitialized reference.
Change calls to GNAT.Sockets.Thin.Is_Socket_In_Set to account for
new specification and test explicitly for non-zero return value.

* g-socthi.ads (Is_Socket_In_Set): Declare imported function as
returning C.int, to avoid using a derived boolean type.

* exp_ch5.adb (Make_Tag_Ctrl_Assignments): Use
Duplicate_Subexpr_No_Checks in preference to direct use of
Remove_Side_Effects and New_Copy_Tree.
Clear Comes_From_Source on prefix of 'Size attribute reference.

* g-socthi.adb, g-socthi-vms.adb, g-socthi-mingw.adb,
g-socthi-vxworks.adb: Change calls to
GNAT.Sockets.Thin.Is_Socket_In_Set to account for new specification
and test explicitly for non-zero return value.

* g-socthi-vms.ads, g-socthi-mingw.ads, g-socthi-vxworks.ads:
(Is_Socket_In_Set): Declare imported function as returning C.int, to
avoid using a derived boolean type.

2004-08-09  Albert Lee  <lee@gnat.com>

* system-irix-n32.ads: Refine tasking priority constants for IRIX.

2004-08-09  Pascal Obry  <obry@gnat.com>

* gnat_ugn.texi: Document new way to build DLLs on Windows using
GCC's -shared option.

* mlib-tgt-mingw.adb (Build_Dynamic_Library): Pass GCC's options into
Options_2 parameter (options put after object files).

2004-08-09  Olivier Hainque  <hainque@act-europe.fr>

* decl.c (gnat_to_gnu_entity) <E_Array_Subtype>: Adjust condition to
ignore overflows on low and high bounds of an index to also account for
differences in signedness between sizetype and gnu_index_subtype.
These are as legitimate as the ones caused by a lower TYPE_PRECISION
on sizetype.

2004-08-09  Robert Dewar  <dewar@gnat.com>

* s-solita.ads, s-solita.adb: Minor reformatting

* gnat_rm.texi: Add documentation for pragma Profile (Restricted)
Move pragma Restricted_Run_Time, No_Run_Time, Ravenscar to new
obsolescent section
Add note that No_Implicit_Conditionals does not suppress
run time constraint checks.

* vms_conv.ads: Minor reformatting

* s-secsta.adb: Use SS_Ptr instead of Mark_Id as stack pointer (cleanup
and necessary for following change).
(Mark): Return new format Mark_Id containing sec stack address
(Release): Use sec stack address from Mark_Id avoiding Self call

* s-secsta.ads: Define SS_Ptr to be used instead of Mark_Id as stack
pointer (cleanup and necessary for following change).
Define Mark_Id as record containing address of secondary stack, that way
Release does not need to find the stack again, decreasing the number of
calls to Self and improving efficiency.

* sem_util.ads: Add a ??? comment for Is_Local_Variable_Reference

* sem_ch5.adb (Analyze_Case_Statement): Add circuitry to track value of
case variable into the individual case branches when possible.

* sem_ch11.adb: Minor reformatting

* prj.ads: Correct spelling of suffixs

* prj-nmsc.adb: Minor reformatting
Correct spelling suffixs throughout (also in identifiers)

* freeze.adb: Minor spelling correction

* exp_ch2.adb: Cleanups to handling of Current_Value
(no functional effect).

* bld.adb: Correct spelling of suffixs

* einfo.adb (Enclosing_Dynamic_Scope): Defend against junk argument

2004-08-09  Ed Schonberg  <schonberg@gnat.com>

PR ada/15408

* sem_ch7.adb (Install_Private_Declarations): In the body of the
package or of a child, private entities are both immediately_visible
and not hidden.

2004-08-09  Ed Schonberg  <schonberg@gnat.com>

* sem_eval.adb (Eval_Integer_Literal): If the context is Any_Integer,
there are no range checks on the value of the literal.

* exp_ch7.adb (Insert_Actions_In_Scope_Around): If the node being
wrapped is the triggering alternative of an asynchronous select, action
statements mustbe inserted before the select itself.

* sem_attr.adb (Analyze_Attribute, case 'Size): Handle properly the
case where the prefix is a protected function call.
(Resolve_Attribute, case 'Access): The attribute reference on a
subprogram is legal in a generic body if the subprogram is declared
elsewhere.

2004-08-09  Vincent Celier  <celier@gnat.com>

* makegpr.adb (Build_Library): Link with g++ if C++ is one of the
languages, otherwise building the library may fail with unresolved
symbols.
(Compile_Sources): Do not build libraries if -c switch is used

* gnatlink.adb (Process_Args): New switches -M and -Mmap
(Write_Usage): If map file creation is supported, output new switches
-M and -Mmap.
(Gnatlink): When -M is specified, add the necessary switch(es) to the
gcc call, when supported.

* Makefile.in: Added indepsw.o to the object list for gnatlink
Specified the AIX, GNU/Linux and Windows versions of indepsw.adb

* indepsw-aix.adb, indepsw-linux.adb, indepsw-mingw.adb,
indepsw.adb, indepsw.ads: New files.

2004-08-09  Bernard Banner  <banner@gnat.com>

* system-vxworks-x86.ads, s-vxwork-x86.ads: New files.

* Makefile.in: add section for vxworks x86

2004-08-09  Hristian Kirtchev  <kirtchev@gnat.com>

* exp_ch3.adb (Build_Init_Statements): Add extra condition to deal with
per-object constrained components where the discriminant is of an
Access type.
(Build_Record_Init_Proc): Add condition to prevent the inheritance of
the parent initialization procedure for derived Unchecked_Unions.
Instead, derived Unchecked_Unions build their own initialization
procedure.
(Build_Variant_Record_Equality): Implement Unchecked_Union equality.
Check the body of the subprogram for details.
(Freeze_Record_Type): Prevent the inheritance of discriminant checking
functions for derived Unchecked_Union types by introducing a condition.
Allow the creation of TSS equality functions for Unchecked_Unions.
(Make_Eq_Case): Rename formal parameter Node to E in function signature.
Add formal parameter Discr to function signature. Discr is used to
control the generated case statement for Unchecked_Union types.
(Make_Eq_If): Rename formal parameter Node to E in function signature.

* exp_ch4.adb (Build_Equality_Call): Implement equality calls for
Unchecked_Unions.
Check the body of the subprogram for details.
(Expand_Composite_Equality): Augment composite type equality to include
correct handling of Unchecked_Union components.
(Expand_N_In): Add condition to detect illegal membership tests when the
subtype mark is a constrained Unchecked_Union and the expression lacks
inferable discriminants, and build a Raise_Program_Error node.
(Expand_N_Op_Eq): Add function Has_Unconstrained_UU_Component. Used
to detect types that contain components of unconstrained Unchecked_Union
subtype. Add condition to detect equality between types that have an
unconstrained Unchecked_Union component, and build a Raise_Program_Error
node. Add condition to detect equality between Unchecked_Union types
that lack inferable discriminants, and build a Raise_Program_Error node.
Otherwise build a TSS equality function call.
(Expand_N_Type_Conversion): Add condition to detect illegal conversions
from a derived Unchecked_Union to an unconstrained non-Unchecked_Union
with the operand lacking inferable discriminants, and build a Raise_
Program_Error node.
(Expand_Record_Equality): Remove guard that prevents Unchecked_Union
composite equality.
(Has_Inferable_Discriminants): Implement new predicate for objects and
expressions of Unchecked_Union type. Check the body of subprogram for
details.
(Has_Unconstrained_UU_Components): Add function
Component_Is_Unconstrained_UU. It is used to detect whether a single
component is of an unconstrained Unchecked_Union subtype. Add function
Variant_Is_Unconstrained_UU. It is used to detect whether a single
component inside a variant is of an unconstrained Unchecked_Union type.

* exp_ch5.adb (Expand_Assign_Record): Add condition to copy the
inferred discriminant values. Add condition to generate a case
statement with an inferred discriminant as the switch.
(Make_Component_List_Assign): Introduce a Boolean flag that determines
the behaviour of the subprogram in the presence of an Unchecked_Union.
Add condition to trigger the usage of the inferred discriminant value
as the generated case statement switch.
(Make_Field_Assign): Introduce a Boolean flag that determines the
behaviour of the subprogram in the presence of an Unchecked_Union. Add
condition to trigger the usage of the inferred discriminant value as
the right-hand side of the generated assignment.

* exp_ch6.adb (Expand_Call): Add condition to skip extra actual
parameter generation when dealing with Unchecked_Unions.

* checks.adb (Apply_Discriminant_Check): Do not apply discriminant
checks for Unchecked_Unions.

* einfo.ads: Update comment on usage of flag Has_Per_Object_Constraint

* exp_attr.adb (Expand_N_Attribute_Reference): Produce
Raise_Program_Error nodes for the execution of Read and Write
attributes of Unchecked_Union types and the execution of Input and
Output attributes of Unchecked_Union types that lack default
discriminant values.

* sem_prag.adb (Analyze_Pragma): Remodel the analysis of pragma
Unchecked_Union. Add procedure Check_Component. It is used to inspect
per-object constrained components of Unchecked_Unions for being
Unchecked_Unions themselves. Add procedure Check_Variant. It is used to
check individual components withing a variant.

* sem_res.adb (Resolve_Comparison_Op): Remove guard that prevents
comparison of Unchecked_Unions.
(Resolve_Equality_OP): Remove guard that prevents equality between
Unchecked_Unions.

* sem_util.adb (Build_Component_Subtype): Add guard to prevent creation
of component subtypes for Unchecked_Union components.
(Get_Actual_Subtype): Add condition that returs the Unchecked_Union type
since it is the actual subtype.

* sem_ch12.adb (Instantiate_Type): Add condition to detect the correct
pass of Unchecked_Union subtypes as generic actuals to formal types
that lack known_discriminant_parts or that are derived Unchecked_Union
types, and do nothing. In any other case, produce an error message.

* sem_ch3.adb (Analyze_Component_Declaration): Add function
Contains_POC. It determines whether a constraint uses the discriminant
of an enclosing record type.
Add condition to detect per-object constrained component and set the
appropriate flag.
(Derived_Type_Declaration): Remove guard that prevents derivation from
Unchecked_Union types.
(Process_Subtype): Remove quard that prevents the creation of Unchecked_
Union subtypes.

* sem_ch4.adb (Analyze_Selected_Component): Correct the detection of
references to Unchecked_Union discriminants.

* sem_ch6.adb (Create_Extra_Formals): Add condition to skip extra
formal generation when dealing with Unchecked_Unions.
(Set_Actual_Subtypes): Add condition to prevent generation of actual
subtypes for Unchecked_Unions.

* sem_ch7.adb (Analyze_Package_Specification): Add procedure
Inspect_Unchecked_Union_Completion. It is used to detect incorrect
completions of discriminated partial views by Unchecked_Unions and
produce an error message.

2004-08-09  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

* trans.c (struct stmt_group): New field, GLOBAL.
(global_stmt_group, gnu_elab_proc_decl, build_unit_elab): Deleted.
(struct elab_info): New struct.
(elab_info_list, gnu_elab_proc_stack): New variables.
(Compilation_Unit_to_gnu): New procedure.
(gigi): Call it and also handle elaboration procs we've saved.
(gnat_init_stmt_group): Don't set global_stmt_group; instead initialize
global field from parent.
(gnat_to_gnu): Get decl from gnu_elab_proc_stack.
(gnat_to_gnu, case N_Compilation_Unit): Call Compilation_Unit_to_gnu.
(start_stmt_group): Initialize global field from parent.
(add_decl_expr): Set to global for current statement group.
(gnat_gimplify_expr, case NULL_EXPR): Add operand 0 to pre list, not
post.

* utils.c (global_bindings_p): True when no current_function_decl; no
longer check current_binding_level.

2004-08-09  Ben Brosgol  <brosgol@gnat.com>

* xgnatugn.adb: Added logic to deal with @ifset/@ifclear for edition
choice.

* gnat_rm.texi, gnat_ugn.texi: Added edition conditionalization logic.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@85714 138bc75d-0d04-0410-961f-82ee72b054a4

60 files changed:
gcc/ada/ChangeLog
gcc/ada/Makefile.in
gcc/ada/bld.adb
gcc/ada/checks.adb
gcc/ada/decl.c
gcc/ada/einfo.adb
gcc/ada/einfo.ads
gcc/ada/exp_attr.adb
gcc/ada/exp_ch2.adb
gcc/ada/exp_ch3.adb
gcc/ada/exp_ch4.adb
gcc/ada/exp_ch5.adb
gcc/ada/exp_ch6.adb
gcc/ada/exp_ch7.adb
gcc/ada/freeze.adb
gcc/ada/g-socket.adb
gcc/ada/g-socthi-mingw.adb
gcc/ada/g-socthi-mingw.ads
gcc/ada/g-socthi-vms.adb
gcc/ada/g-socthi-vms.ads
gcc/ada/g-socthi-vxworks.adb
gcc/ada/g-socthi-vxworks.ads
gcc/ada/g-socthi.adb
gcc/ada/g-socthi.ads
gcc/ada/gnat_rm.texi
gcc/ada/gnat_ugn.texi
gcc/ada/gnatlink.adb
gcc/ada/indepsw-aix.adb [new file with mode: 0644]
gcc/ada/indepsw-linux.adb [new file with mode: 0644]
gcc/ada/indepsw-mingw.adb [new file with mode: 0644]
gcc/ada/indepsw.adb [new file with mode: 0644]
gcc/ada/indepsw.ads [new file with mode: 0644]
gcc/ada/makegpr.adb
gcc/ada/mlib-tgt-mingw.adb
gcc/ada/prj-nmsc.adb
gcc/ada/prj.ads
gcc/ada/s-secsta.adb
gcc/ada/s-secsta.ads
gcc/ada/s-solita.adb
gcc/ada/s-solita.ads
gcc/ada/s-vxwork-x86.ads [new file with mode: 0644]
gcc/ada/sem_attr.adb
gcc/ada/sem_ch11.adb
gcc/ada/sem_ch12.adb
gcc/ada/sem_ch3.adb
gcc/ada/sem_ch4.adb
gcc/ada/sem_ch5.adb
gcc/ada/sem_ch6.adb
gcc/ada/sem_ch7.adb
gcc/ada/sem_eval.adb
gcc/ada/sem_prag.adb
gcc/ada/sem_res.adb
gcc/ada/sem_util.adb
gcc/ada/sem_util.ads
gcc/ada/system-irix-n32.ads
gcc/ada/system-vxworks-x86.ads [new file with mode: 0644]
gcc/ada/trans.c
gcc/ada/utils.c
gcc/ada/vms_conv.ads
gcc/ada/xgnatugn.adb

index e2dc48f..daf1367 100644 (file)
@@ -1,3 +1,285 @@
+2004-08-09  Thomas Quinot  <quinot@act-europe.fr>
+
+       * g-socket.adb (Abort_Selector): Initialize Buf to prevent valgrind
+       from complaining on potential uninitialized reference.
+       Change calls to GNAT.Sockets.Thin.Is_Socket_In_Set to account for
+       new specification and test explicitly for non-zero return value.
+
+       * g-socthi.ads (Is_Socket_In_Set): Declare imported function as
+       returning C.int, to avoid using a derived boolean type.
+
+       * exp_ch5.adb (Make_Tag_Ctrl_Assignments): Use
+       Duplicate_Subexpr_No_Checks in preference to direct use of
+       Remove_Side_Effects and New_Copy_Tree.
+       Clear Comes_From_Source on prefix of 'Size attribute reference.
+
+       * g-socthi.adb, g-socthi-vms.adb, g-socthi-mingw.adb,
+       g-socthi-vxworks.adb: Change calls to
+       GNAT.Sockets.Thin.Is_Socket_In_Set to account for new specification
+       and test explicitly for non-zero return value.
+
+       * g-socthi-vms.ads, g-socthi-mingw.ads, g-socthi-vxworks.ads: 
+       (Is_Socket_In_Set): Declare imported function as returning C.int, to
+       avoid using a derived boolean type.
+
+2004-08-09  Albert Lee  <lee@gnat.com>
+
+       * system-irix-n32.ads: Refine tasking priority constants for IRIX.
+
+2004-08-09  Pascal Obry  <obry@gnat.com>
+
+       * gnat_ugn.texi: Document new way to build DLLs on Windows using
+       GCC's -shared option.
+
+       * mlib-tgt-mingw.adb (Build_Dynamic_Library): Pass GCC's options into
+       Options_2 parameter (options put after object files).
+
+2004-08-09  Olivier Hainque  <hainque@act-europe.fr>
+
+       * decl.c (gnat_to_gnu_entity) <E_Array_Subtype>: Adjust condition to
+       ignore overflows on low and high bounds of an index to also account for
+       differences in signedness between sizetype and gnu_index_subtype.
+       These are as legitimate as the ones caused by a lower TYPE_PRECISION
+       on sizetype.
+
+2004-08-09  Robert Dewar  <dewar@gnat.com>
+
+       * s-solita.ads, s-solita.adb: Minor reformatting
+
+       * gnat_rm.texi: Add documentation for pragma Profile (Restricted)
+       Move pragma Restricted_Run_Time, No_Run_Time, Ravenscar to new
+       obsolescent section
+       Add note that No_Implicit_Conditionals does not suppress
+       run time constraint checks.
+
+       * vms_conv.ads: Minor reformatting
+
+       * s-secsta.adb: Use SS_Ptr instead of Mark_Id as stack pointer (cleanup
+       and necessary for following change).
+       (Mark): Return new format Mark_Id containing sec stack address
+       (Release): Use sec stack address from Mark_Id avoiding Self call
+
+       * s-secsta.ads: Define SS_Ptr to be used instead of Mark_Id as stack
+       pointer (cleanup and necessary for following change).
+       Define Mark_Id as record containing address of secondary stack, that way
+       Release does not need to find the stack again, decreasing the number of
+       calls to Self and improving efficiency.
+
+       * sem_util.ads: Add a ??? comment for Is_Local_Variable_Reference
+
+       * sem_ch5.adb (Analyze_Case_Statement): Add circuitry to track value of
+       case variable into the individual case branches when possible.
+
+       * sem_ch11.adb: Minor reformatting
+
+       * prj.ads: Correct spelling of suffixs
+
+       * prj-nmsc.adb: Minor reformatting
+       Correct spelling suffixs throughout (also in identifiers)
+
+       * freeze.adb: Minor spelling correction
+
+       * exp_ch2.adb: Cleanups to handling of Current_Value
+       (no functional effect).
+
+       * bld.adb: Correct spelling of suffixs
+
+       * einfo.adb (Enclosing_Dynamic_Scope): Defend against junk argument
+
+2004-08-09  Ed Schonberg  <schonberg@gnat.com>
+
+       PR ada/15408
+
+       * sem_ch7.adb (Install_Private_Declarations): In the body of the
+       package or of a child, private entities are both immediately_visible
+       and not hidden.
+
+2004-08-09  Ed Schonberg  <schonberg@gnat.com>
+
+       * sem_eval.adb (Eval_Integer_Literal): If the context is Any_Integer,
+       there are no range checks on the value of the literal.
+
+       * exp_ch7.adb (Insert_Actions_In_Scope_Around): If the node being
+       wrapped is the triggering alternative of an asynchronous select, action
+       statements mustbe inserted before the select itself.
+
+       * sem_attr.adb (Analyze_Attribute, case 'Size): Handle properly the
+       case where the prefix is a protected function call.
+       (Resolve_Attribute, case 'Access): The attribute reference on a
+       subprogram is legal in a generic body if the subprogram is declared
+       elsewhere.
+
+2004-08-09  Vincent Celier  <celier@gnat.com>
+
+       * makegpr.adb (Build_Library): Link with g++ if C++ is one of the
+       languages, otherwise building the library may fail with unresolved
+       symbols.
+       (Compile_Sources): Do not build libraries if -c switch is used
+
+       * gnatlink.adb (Process_Args): New switches -M and -Mmap
+       (Write_Usage): If map file creation is supported, output new switches
+       -M and -Mmap.
+       (Gnatlink): When -M is specified, add the necessary switch(es) to the
+       gcc call, when supported.
+
+       * Makefile.in: Added indepsw.o to the object list for gnatlink
+       Specified the AIX, GNU/Linux and Windows versions of indepsw.adb
+
+       * indepsw-aix.adb, indepsw-linux.adb, indepsw-mingw.adb,
+       indepsw.adb, indepsw.ads: New files.
+
+2004-08-09  Bernard Banner  <banner@gnat.com>
+
+       * system-vxworks-x86.ads, s-vxwork-x86.ads: New files.
+
+       * Makefile.in: add section for vxworks x86
+
+2004-08-09  Hristian Kirtchev  <kirtchev@gnat.com>
+
+       * exp_ch3.adb (Build_Init_Statements): Add extra condition to deal with
+       per-object constrained components where the discriminant is of an
+       Access type.
+       (Build_Record_Init_Proc): Add condition to prevent the inheritance of
+       the parent initialization procedure for derived Unchecked_Unions.
+       Instead, derived Unchecked_Unions build their own initialization
+       procedure.
+       (Build_Variant_Record_Equality): Implement Unchecked_Union equality.
+       Check the body of the subprogram for details.
+       (Freeze_Record_Type): Prevent the inheritance of discriminant checking
+       functions for derived Unchecked_Union types by introducing a condition.
+       Allow the creation of TSS equality functions for Unchecked_Unions.
+       (Make_Eq_Case): Rename formal parameter Node to E in function signature.
+       Add formal parameter Discr to function signature. Discr is used to
+       control the generated case statement for Unchecked_Union types.
+       (Make_Eq_If): Rename formal parameter Node to E in function signature.
+
+       * exp_ch4.adb (Build_Equality_Call): Implement equality calls for
+       Unchecked_Unions.
+       Check the body of the subprogram for details.
+       (Expand_Composite_Equality): Augment composite type equality to include
+       correct handling of Unchecked_Union components.
+       (Expand_N_In): Add condition to detect illegal membership tests when the
+       subtype mark is a constrained Unchecked_Union and the expression lacks
+       inferable discriminants, and build a Raise_Program_Error node.
+       (Expand_N_Op_Eq): Add function Has_Unconstrained_UU_Component. Used
+       to detect types that contain components of unconstrained Unchecked_Union
+       subtype. Add condition to detect equality between types that have an
+       unconstrained Unchecked_Union component, and build a Raise_Program_Error
+       node. Add condition to detect equality between Unchecked_Union types
+       that lack inferable discriminants, and build a Raise_Program_Error node.
+       Otherwise build a TSS equality function call.
+       (Expand_N_Type_Conversion): Add condition to detect illegal conversions
+       from a derived Unchecked_Union to an unconstrained non-Unchecked_Union
+       with the operand lacking inferable discriminants, and build a Raise_
+       Program_Error node.
+       (Expand_Record_Equality): Remove guard that prevents Unchecked_Union
+       composite equality.
+       (Has_Inferable_Discriminants): Implement new predicate for objects and
+       expressions of Unchecked_Union type. Check the body of subprogram for
+       details.
+       (Has_Unconstrained_UU_Components): Add function
+       Component_Is_Unconstrained_UU. It is used to detect whether a single
+       component is of an unconstrained Unchecked_Union subtype. Add function
+       Variant_Is_Unconstrained_UU. It is used to detect whether a single
+       component inside a variant is of an unconstrained Unchecked_Union type.
+
+       * exp_ch5.adb (Expand_Assign_Record): Add condition to copy the
+       inferred discriminant values. Add condition to generate a case
+       statement with an inferred discriminant as the switch.
+       (Make_Component_List_Assign): Introduce a Boolean flag that determines
+       the behaviour of the subprogram in the presence of an Unchecked_Union.
+       Add condition to trigger the usage of the inferred discriminant value
+       as the generated case statement switch.
+       (Make_Field_Assign): Introduce a Boolean flag that determines the
+       behaviour of the subprogram in the presence of an Unchecked_Union. Add
+       condition to trigger the usage of the inferred discriminant value as
+       the right-hand side of the generated assignment.
+
+       * exp_ch6.adb (Expand_Call): Add condition to skip extra actual
+       parameter generation when dealing with Unchecked_Unions.
+
+       * checks.adb (Apply_Discriminant_Check): Do not apply discriminant
+       checks for Unchecked_Unions.
+
+       * einfo.ads: Update comment on usage of flag Has_Per_Object_Constraint
+
+       * exp_attr.adb (Expand_N_Attribute_Reference): Produce
+       Raise_Program_Error nodes for the execution of Read and Write
+       attributes of Unchecked_Union types and the execution of Input and
+       Output attributes of Unchecked_Union types that lack default
+       discriminant values.
+
+       * sem_prag.adb (Analyze_Pragma): Remodel the analysis of pragma
+       Unchecked_Union. Add procedure Check_Component. It is used to inspect
+       per-object constrained components of Unchecked_Unions for being
+       Unchecked_Unions themselves. Add procedure Check_Variant. It is used to
+       check individual components withing a variant.
+
+       * sem_res.adb (Resolve_Comparison_Op): Remove guard that prevents
+       comparison of Unchecked_Unions.
+       (Resolve_Equality_OP): Remove guard that prevents equality between
+       Unchecked_Unions.
+
+       * sem_util.adb (Build_Component_Subtype): Add guard to prevent creation
+       of component subtypes for Unchecked_Union components.
+       (Get_Actual_Subtype): Add condition that returs the Unchecked_Union type
+       since it is the actual subtype.
+
+       * sem_ch12.adb (Instantiate_Type): Add condition to detect the correct
+       pass of Unchecked_Union subtypes as generic actuals to formal types
+       that lack known_discriminant_parts or that are derived Unchecked_Union
+       types, and do nothing. In any other case, produce an error message.
+
+       * sem_ch3.adb (Analyze_Component_Declaration): Add function
+       Contains_POC. It determines whether a constraint uses the discriminant
+       of an enclosing record type.
+       Add condition to detect per-object constrained component and set the
+       appropriate flag.
+       (Derived_Type_Declaration): Remove guard that prevents derivation from
+       Unchecked_Union types.
+       (Process_Subtype): Remove quard that prevents the creation of Unchecked_
+       Union subtypes.
+
+       * sem_ch4.adb (Analyze_Selected_Component): Correct the detection of
+       references to Unchecked_Union discriminants.
+
+       * sem_ch6.adb (Create_Extra_Formals): Add condition to skip extra
+       formal generation when dealing with Unchecked_Unions.
+       (Set_Actual_Subtypes): Add condition to prevent generation of actual
+       subtypes for Unchecked_Unions.
+
+       * sem_ch7.adb (Analyze_Package_Specification): Add procedure
+       Inspect_Unchecked_Union_Completion. It is used to detect incorrect
+       completions of discriminated partial views by Unchecked_Unions and
+       produce an error message.
+
+2004-08-09  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>
+
+       * trans.c (struct stmt_group): New field, GLOBAL.
+       (global_stmt_group, gnu_elab_proc_decl, build_unit_elab): Deleted.
+       (struct elab_info): New struct.
+       (elab_info_list, gnu_elab_proc_stack): New variables.
+       (Compilation_Unit_to_gnu): New procedure.
+       (gigi): Call it and also handle elaboration procs we've saved.
+       (gnat_init_stmt_group): Don't set global_stmt_group; instead initialize
+       global field from parent.
+       (gnat_to_gnu): Get decl from gnu_elab_proc_stack.
+       (gnat_to_gnu, case N_Compilation_Unit): Call Compilation_Unit_to_gnu.
+       (start_stmt_group): Initialize global field from parent.
+       (add_decl_expr): Set to global for current statement group.
+       (gnat_gimplify_expr, case NULL_EXPR): Add operand 0 to pre list, not
+       post.
+
+       * utils.c (global_bindings_p): True when no current_function_decl; no
+       longer check current_binding_level.
+
+2004-08-09  Ben Brosgol  <brosgol@gnat.com>
+
+       * xgnatugn.adb: Added logic to deal with @ifset/@ifclear for edition
+       choice.
+
+       * gnat_rm.texi, gnat_ugn.texi: Added edition conditionalization logic.
+
 2004-08-06  Andreas Schwab  <schwab@suse.de>
 
        * utils.c (gnat_define_builtin): Remove second parameter of
index f7bcfe0..e3b9507 100644 (file)
@@ -298,7 +298,7 @@ Makefile: ../config.status $(srcdir)/Makefile.in $(srcdir)/../version.c
 
 GNATLINK_OBJS = gnatlink.o \
  a-except.o ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o gnatvsn.o \
- hostparm.o interfac.o i-c.o i-cstrin.o namet.o opt.o osint.o output.o rident.o \
+ hostparm.o indepsw.o interfac.o i-c.o i-cstrin.o namet.o opt.o osint.o output.o rident.o \
  s-exctab.o s-secsta.o s-stalib.o s-stoele.o sdefault.o stylesw.o switch.o system.o \
  table.o tree_io.o types.o validsw.o widechar.o
 
@@ -592,6 +592,46 @@ ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
   EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
 endif
 
+ifeq ($(strip $(filter-out %86 wrs vxworks,$(targ))),)
+  LIBGNAT_TARGET_PAIRS = \
+  a-sytaco.ads<a-sytaco-vxworks.ads \
+  a-sytaco.adb<a-sytaco-vxworks.adb \
+  a-intnam.ads<a-intnam-vxworks.ads \
+  s-inmaop.adb<s-inmaop-posix.adb \
+  s-interr.adb<s-interr-vxworks.adb \
+  s-intman.ads<s-intman-vxworks.ads \
+  s-intman.adb<s-intman-vxworks.adb \
+  a-numaux.adb<a-numaux-x86.adb \
+  a-numaux.ads<a-numaux-x86.ads \
+  s-osinte.adb<s-osinte-vxworks.adb \
+  s-osinte.ads<s-osinte-vxworks.ads \
+  s-osprim.adb<s-osprim-vxworks.adb \
+  s-parame.ads<s-parame-vxworks.ads \
+  s-stchop.adb<s-stchop-vxworks.adb \
+  s-taprop.adb<s-taprop-vxworks.adb \
+  s-taspri.ads<s-taspri-vxworks.ads \
+  s-tpopsp.adb<s-tpopsp-vxworks.adb \
+  s-vxwork.ads<s-vxwork-x86.ads \
+  g-soccon.ads<g-soccon-vxworks.ads \
+  g-socthi.ads<g-socthi-vxworks.ads \
+  g-socthi.adb<g-socthi-vxworks.adb \
+  system.ads<system-vxworks-x86.ads
+
+  TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
+
+  ifeq ($(strip $(filter-out yes,$(TRACE))),)
+    LIBGNAT_TARGET_PAIRS += \
+    s-traces.adb<s-traces-default.adb \
+    s-trafor.adb<s-trafor-default.adb \
+    s-trafor.ads<s-trafor-default.ads \
+    s-tratas.adb<s-tratas-default.adb \
+    s-tfsetr.adb<s-tfsetr-vxworks.adb
+  endif
+
+  EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
+  EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
+endif
+
 ifeq ($(strip $(filter-out xscale% coff wrs vx%,$(targ))),)
   LIBGNAT_TARGET_PAIRS = \
   a-sytaco.ads<a-sytaco-vxworks.ads \
@@ -784,7 +824,8 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
   system.ads<system-linux-x86.ads
 
   TOOLS_TARGET_PAIRS =  \
-    mlib-tgt.adb<mlib-tgt-linux.adb
+    mlib-tgt.adb<mlib-tgt-linux.adb \
+    indepsw.adb<indepsw-linux.adb
 
   SYMLIB = $(ADDR2LINE_SYMLIB)
   THREADSLIB = -lpthread
@@ -1033,7 +1074,10 @@ ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),)
     THREADSLIB = -lgthreads -lmalloc
   endif
 
-  TOOLS_TARGET_PAIRS = mlib-tgt.adb<mlib-tgt-aix.adb
+  TOOLS_TARGET_PAIRS = \
+  mlib-tgt.adb<mlib-tgt-aix.adb \
+  indepsw.adb<indepsw-aix.adb
+
   GMEM_LIB = gmemlib
   SYMLIB = $(ADDR2LINE_SYMLIB)
 
@@ -1253,7 +1297,10 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
   g-soliop.ads<g-soliop-mingw.ads \
   system.ads<system-mingw.ads
 
-  TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-mingw.adb
+  TOOLS_TARGET_PAIRS= \
+  mlib-tgt.adb<mlib-tgt-mingw.adb \
+  indepsw.adb<indepsw-mingw.adb
+
   MISCLIB = -lwsock32
   SYMLIB = $(ADDR2LINE_SYMLIB)
   GMEM_LIB = gmemlib
index a39076b..6d52e8b 100644 (file)
@@ -80,7 +80,7 @@ package body Bld is
    Expression_Value  : String_Access := new String (1 .. 10);
    Expression_Last   : Natural := 0;
 
-   --  The following variables indicates if the suffixs and the languages
+   --  The following variables indicates if the suffixes and the languages
    --  are statically specified and, if they are, their values.
 
    C_Suffix          : String_Access := new String (1 .. 10);
@@ -2803,7 +2803,7 @@ package body Bld is
 
                There_Are_Cases := Last_Case /= Last_Case_Construction;
 
-               --  If the suffixs and the languages have not been specified,
+               --  If the suffixes and the languages have not been specified,
                --  give them the default values.
 
                if C_Suffix_Static and then C_Suffix_Last = 0 then
@@ -2920,7 +2920,7 @@ package body Bld is
                         end if;
 
                         --  If we still don't know the language, and all
-                        --  suffixs are static, then it cannot any of the
+                        --  suffixes are static, then it cannot any of the
                         --  processed languages.
 
                         if Source_Kind = Unknown
index 82e286f..7ffa17d 100644 (file)
@@ -43,6 +43,7 @@ with Rident;   use Rident;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
 with Sem_Eval; use Sem_Eval;
+with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
@@ -1163,6 +1164,12 @@ package body Checks is
          return;
       end if;
 
+      --  Nothing to do if the type is an Unchecked_Union
+
+      if Is_Unchecked_Union (Base_Type (T_Typ)) then
+         return;
+      end if;
+
       --  Suppress checks if the subtypes are the same.
       --  the check must be preserved in an assignment to a formal, because
       --  the constraint is given by the actual.
@@ -2377,14 +2384,26 @@ package body Checks is
             Dval := Duplicate_Subexpr_No_Checks (Dval);
          end if;
 
-         Dref :=
-           Make_Selected_Component (Loc,
-             Prefix =>
-               Duplicate_Subexpr_No_Checks (N, Name_Req => True),
-             Selector_Name =>
-               Make_Identifier (Loc, Chars (Disc_Ent)));
+         --  If we have an Unchecked_Union node, we can infer the discriminants
+         --  of the node.
+
+         if Is_Unchecked_Union (Base_Type (T_Typ)) then
+            Dref := New_Copy (
+              Get_Discriminant_Value (
+                First_Discriminant (T_Typ),
+                T_Typ,
+                Stored_Constraint (T_Typ)));
+
+         else
+            Dref :=
+              Make_Selected_Component (Loc,
+                Prefix =>
+                  Duplicate_Subexpr_No_Checks (N, Name_Req => True),
+                Selector_Name =>
+                  Make_Identifier (Loc, Chars (Disc_Ent)));
 
-         Set_Is_In_Discriminant_Check (Dref);
+            Set_Is_In_Discriminant_Check (Dref);
+         end if;
 
          Evolve_Or_Else (Cond,
            Make_Op_Ne (Loc,
index 480ebad..702e348 100644 (file)
@@ -348,7 +348,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
         not a deferred constant but a constant whose value is built
         manually.  */
 
-      if (definition && !gnu_expr 
+      if (definition && !gnu_expr
          && !No_Initialization (Declaration_Node (gnat_entity))
          && No (Renamed_Object (gnat_entity)))
        {
@@ -1786,7 +1786,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
                 does not overflow in SIZETYPE, ignore the overflow
                 indications.  */
              if ((TYPE_PRECISION (gnu_index_subtype)
-                  > TYPE_PRECISION (sizetype))
+                  > TYPE_PRECISION (sizetype)
+                  || TYPE_UNSIGNED (gnu_index_subtype)
+                     != TYPE_UNSIGNED (sizetype))
                  && TREE_CODE (gnu_min) == INTEGER_CST
                  && TREE_CODE (gnu_max) == INTEGER_CST
                  && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
@@ -1801,7 +1803,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
              /* Similarly, if the range is null, use bounds of 1..0 for
                 the sizetype bounds.  */
              else if ((TYPE_PRECISION (gnu_index_subtype)
-                       > TYPE_PRECISION (sizetype))
+                       > TYPE_PRECISION (sizetype)
+                      || TYPE_UNSIGNED (gnu_index_subtype)
+                         != TYPE_UNSIGNED (sizetype))
                       && TREE_CODE (gnu_min) == INTEGER_CST
                       && TREE_CODE (gnu_max) == INTEGER_CST
                       && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
@@ -5450,7 +5454,7 @@ components_to_record (tree gnu_record_type, Node_Id component_list,
   else if (gnu_our_rep_list)
     {
       tree gnu_rep_type
-       = (gnu_field_list ? gnu_record_type : make_node (RECORD_TYPE));
+       = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
       int len = list_length (gnu_our_rep_list);
       tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
       int i;
index b45279f..5f613dc 100644 (file)
@@ -4678,6 +4678,15 @@ package body Einfo is
       S  : Entity_Id;
 
    begin
+      --  The following test is an error defense against some syntax
+      --  errors that can leave scopes very messed up.
+
+      if Id = Standard_Standard then
+         return Id;
+      end if;
+
+      --  Normal case, search enclosing scopes
+
       S := Scope (Id);
       while S /= Standard_Standard
         and then not Is_Dynamic_Scope (S)
index 86de4bc..5ebe8da 100644 (file)
@@ -1399,8 +1399,19 @@ package Einfo is
 
 --    Has_Per_Object_Constraint (Flag154)
 --       Present in E_Component entities, true if the subtype of the
---       component has a per object constraint, i.e. an actual discriminant
---       value of the form T'Access, where T is the enclosing type.
+--       component has a per object constraint. Per object constraints result
+--       from the following situations:
+--
+--       1. N_Attribute_Reference - when the prefix is the enclosing type and
+--          the attribute is Access.
+--       2. N_Discriminant_Association - when the expression uses the
+--          discriminant of the enclosing type.
+--       3. N_Index_Or_Discriminant_Constraint - when at least one of the
+--          individual constraints is a per object constraint.
+--       4. N_Range - when the lower or upper bound uses the discriminant of
+--          the enclosing type.
+--       5. N_Range_Constraint - when the range expression uses the
+--          discriminant of the enclosing type.
 
 --    Has_Pragma_Controlled (Flag27) [implementation base type only]
 --       Present in access type entities. It is set if a pragma Controlled
index defbdd0..f87d503 100644 (file)
@@ -27,6 +27,7 @@
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
+with Elists;   use Elists;
 with Exp_Ch2;  use Exp_Ch2;
 with Exp_Ch9;  use Exp_Ch9;
 with Exp_Imgv; use Exp_Imgv;
@@ -1883,6 +1884,21 @@ package body Exp_Attr is
                pragma Assert
                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
 
+               --  Ada 2005 (AI-216): Program_Error is raised when executing
+               --  the default implementation of the Input attribute of an
+               --  unchecked union type if the type lacks default discriminant
+               --  values.
+
+               if Is_Unchecked_Union (Base_Type (U_Type))
+                 and then not Present (Discriminant_Constraint (U_Type))
+               then
+                  Insert_Action (N,
+                    Make_Raise_Program_Error (Loc,
+                      Reason => PE_Unchecked_Union_Restriction));
+
+                  return;
+               end if;
+
                Build_Record_Or_Elementary_Input_Function
                  (Loc, Base_Type (U_Type), Decl, Fname);
                Insert_Action (N, Decl);
@@ -2393,6 +2409,21 @@ package body Exp_Attr is
                pragma Assert
                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
 
+               --  Ada 2005 (AI-216): Program_Error is raised when executing
+               --  the default implementation of the Output attribute of an
+               --  unchecked union type if the type lacks default discriminant
+               --  values.
+
+               if Is_Unchecked_Union (Base_Type (U_Type))
+                 and then not Present (Discriminant_Constraint (U_Type))
+               then
+                  Insert_Action (N,
+                    Make_Raise_Program_Error (Loc,
+                      Reason => PE_Unchecked_Union_Restriction));
+
+                  return;
+               end if;
+
                Build_Record_Or_Elementary_Output_Procedure
                  (Loc, Base_Type (U_Type), Decl, Pname);
                Insert_Action (N, Decl);
@@ -2779,13 +2810,22 @@ package body Exp_Attr is
                pragma Assert
                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
 
+               --  Ada 2005 (AI-216): Program_Error is raised when executing
+               --  the default implementation of the Read attribute of an
+               --  Unchecked_Union type.
+
+               if Is_Unchecked_Union (Base_Type (U_Type)) then
+                  Insert_Action (N,
+                    Make_Raise_Program_Error (Loc,
+                      Reason => PE_Unchecked_Union_Restriction));
+               end if;
+
                if Has_Discriminants (U_Type)
                  and then Present
                    (Discriminant_Default_Value (First_Discriminant (U_Type)))
                then
                   Build_Mutable_Record_Read_Procedure
                     (Loc, Base_Type (U_Type), Decl, Pname);
-
                else
                   Build_Record_Read_Procedure
                     (Loc, Base_Type (U_Type), Decl, Pname);
@@ -3960,13 +4000,22 @@ package body Exp_Attr is
                pragma Assert
                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
 
+               --  Ada 2005 (AI-216): Program_Error is raised when executing
+               --  the default implementation of the Write attribute of an
+               --  Unchecked_Union type.
+
+               if Is_Unchecked_Union (Base_Type (U_Type)) then
+                  Insert_Action (N,
+                    Make_Raise_Program_Error (Loc,
+                      Reason => PE_Unchecked_Union_Restriction));
+               end if;
+
                if Has_Discriminants (U_Type)
                  and then Present
                    (Discriminant_Default_Value (First_Discriminant (U_Type)))
                then
                   Build_Mutable_Record_Write_Procedure
                     (Loc, Base_Type (U_Type), Decl, Pname);
-
                else
                   Build_Record_Write_Procedure
                     (Loc, Base_Type (U_Type), Decl, Pname);
index 966670d..130d74d 100644 (file)
@@ -56,9 +56,9 @@ package body Exp_Ch2 is
    --  Given a node N for a variable whose Current_Value field is set.
    --  If the node is for a discrete type, replaces the node with a
    --  copy of the referenced value. This provides a limited form of
-   --  value propagation for variables which are initialized and have
-   --  not been modified at the time of reference. The call has no
-   --  effect if the Current_Value refers to a conditional with a
+   --  value propagation for variables which are initialized or assigned
+   --  not been further modified at the time of reference. The call has
+   --  no effect if the Current_Value refers to a conditional with a
    --  condition other than equality.
 
    procedure Expand_Discriminant (N : Node_Id);
@@ -159,11 +159,7 @@ package body Exp_Ch2 is
                CS := Scope (CS);
 
             --  Otherwise, the reference is dubious, and we cannot be
-            --  sure that it is safe to do the replacement. Note in
-            --  particular, in a loop (except for the special case
-            --  tested above), we cannot safely do a replacement since
-            --  there may be an assignment at the bottom of the loop
-            --  that will affect a reference at the top of the loop.
+            --  sure that it is safe to do the replacement.
 
             else
                exit;
@@ -178,6 +174,10 @@ package body Exp_Ch2 is
    begin
       if True
 
+         --  No replacement if value raises constraint error
+
+         and then Nkind (CV) /= N_Raise_Constraint_Error
+
          --  Do this only for discrete types
 
          and then Is_Discrete_Type (T)
@@ -419,7 +419,6 @@ package body Exp_Ch2 is
                or else
              Ekind (E) = E_Out_Parameter)
         and then Present (Current_Value (E))
-        and then Nkind (Current_Value (E)) /= N_Raise_Constraint_Error
       then
          Expand_Current_Value (N);
 
index 3fec8c1..39d704e 100644 (file)
@@ -179,21 +179,27 @@ package body Exp_Ch3 is
    --  Check if E is defined in the RTL (in a child of Ada or System). Used
    --  to avoid to bring in the overhead of _Input, _Output for tagged types.
 
-   function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id;
+   function Make_Eq_Case
+     (E     : Entity_Id;
+      CL    : Node_Id;
+      Discr : Entity_Id := Empty) return List_Id;
    --  Building block for variant record equality. Defined to share the
    --  code between the tagged and non-tagged case. Given a Component_List
    --  node CL, it generates an 'if' followed by a 'case' statement that
    --  compares all components of local temporaries named X and Y (that
-   --  are declared as formals at some upper level). Node provides the
-   --  Sloc to be used for the generated code.
+   --  are declared as formals at some upper level). E provides the Sloc to be
+   --  used for the generated code. Discr is used as the case statement switch
+   --  in the case of Unchecked_Union equality.
 
-   function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id;
+   function Make_Eq_If
+     (E : Entity_Id;
+      L : List_Id) return Node_Id;
    --  Building block for variant record equality. Defined to share the
    --  code between the tagged and non-tagged case. Given the list of
    --  components (or discriminants) L, it generates a return statement
    --  that compares all components of local temporaries named X and Y
-   --  (that are declared as formals at some upper level). Node provides
-   --  the Sloc to be used for the generated code.
+   --  (that are declared as formals at some upper level). E provides the Sloc
+   --  to be used for the generated code.
 
    procedure Make_Predefined_Primitive_Specs
      (Tag_Typ     : Entity_Id;
@@ -1920,6 +1926,39 @@ package body Exp_Ch3 is
          Id  : Entity_Id;
          Typ : Entity_Id;
 
+         function Has_Access_Constraint (E : Entity_Id) return Boolean;
+         --  Components with access discriminants that depend on the current
+         --  instance must be initialized after all other components.
+
+         ---------------------------
+         -- Has_Access_Constraint --
+         ---------------------------
+
+         function Has_Access_Constraint (E : Entity_Id) return Boolean is
+            Disc : Entity_Id;
+            T    : constant Entity_Id := Etype (E);
+
+         begin
+            if Has_Per_Object_Constraint (E)
+              and then Has_Discriminants (T)
+            then
+               Disc := First_Discriminant (T);
+               while Present (Disc) loop
+                  if Is_Access_Type (Etype (Disc)) then
+                     return True;
+                  end if;
+
+                  Next_Discriminant (Disc);
+               end loop;
+
+               return False;
+            else
+               return False;
+            end if;
+         end Has_Access_Constraint;
+
+      --  Start of processing for Build_Init_Statements
+
       begin
          if Null_Present (Comp_List) then
             return New_List (Make_Null_Statement (Loc));
@@ -1934,7 +1973,7 @@ package body Exp_Ch3 is
 
          Per_Object_Constraint_Components := False;
 
-         --  First step : regular components.
+         --  First step : regular components
 
          Decl := First_Non_Pragma (Component_Items (Comp_List));
          while Present (Decl) loop
@@ -1945,7 +1984,7 @@ package body Exp_Ch3 is
             Id := Defining_Identifier (Decl);
             Typ := Etype (Id);
 
-            if Has_Per_Object_Constraint (Id)
+            if Has_Access_Constraint (Id)
               and then No (Expression (Decl))
             then
                --  Skip processing for now and ask for a second pass
@@ -2025,7 +2064,7 @@ package body Exp_Ch3 is
                Id := Defining_Identifier (Decl);
                Typ := Etype (Id);
 
-               if Has_Per_Object_Constraint (Id)
+               if Has_Access_Constraint (Id)
                  and then No (Expression (Decl))
                then
                   if Has_Non_Null_Base_Init_Proc (Typ) then
@@ -2457,6 +2496,7 @@ package body Exp_Ch3 is
 
       if Is_Derived_Type (Rec_Type)
         and then not Is_Tagged_Type (Rec_Type)
+        and then not Is_Unchecked_Union (Rec_Type)
         and then not Has_New_Non_Standard_Rep (Rec_Type)
         and then not Parent_Subtype_Renaming_Discrims
         and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
@@ -2466,7 +2506,9 @@ package body Exp_Ch3 is
       --  Otherwise if we need an initialization procedure, then build one,
       --  mark it as public and inlinable and as having a completion.
 
-      elsif Requires_Init_Proc (Rec_Type) then
+      elsif Requires_Init_Proc (Rec_Type)
+        or else Is_Unchecked_Union (Rec_Type)
+      then
          Build_Init_Procedure;
          Set_Is_Public (Proc_Id, Is_Public (Pe));
 
@@ -2849,9 +2891,14 @@ package body Exp_Ch3 is
       Def   : constant Node_Id := Parent (Typ);
       Comps : constant Node_Id := Component_List (Type_Definition (Def));
       Stmts : constant List_Id := New_List;
+      Pspecs : constant List_Id := New_List;
 
    begin
+      --  Derived Unchecked_Union types no longer inherit the equality function
+      --  of their parent.
+
       if Is_Derived_Type (Typ)
+        and then not Is_Unchecked_Union (Typ)
         and then not Has_New_Non_Standard_Rep (Typ)
       then
          declare
@@ -2871,34 +2918,86 @@ package body Exp_Ch3 is
           Specification =>
             Make_Function_Specification (Loc,
               Defining_Unit_Name       => F,
-              Parameter_Specifications => New_List (
-                Make_Parameter_Specification (Loc,
-                  Defining_Identifier => X,
-                  Parameter_Type      => New_Reference_To (Typ, Loc)),
-
-                Make_Parameter_Specification (Loc,
-                  Defining_Identifier => Y,
-                  Parameter_Type      => New_Reference_To (Typ, Loc))),
-
+              Parameter_Specifications => Pspecs,
               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
-
           Declarations               => New_List,
           Handled_Statement_Sequence =>
             Make_Handled_Sequence_Of_Statements (Loc,
               Statements => Stmts)));
 
-      --  For unchecked union case, raise program error. This will only
-      --  happen in the case of dynamic dispatching for a tagged type,
-      --  since in the static cases it is a compile time error.
+      Append_To (Pspecs,
+        Make_Parameter_Specification (Loc,
+          Defining_Identifier => X,
+          Parameter_Type      => New_Reference_To (Typ, Loc)));
+
+      Append_To (Pspecs,
+        Make_Parameter_Specification (Loc,
+          Defining_Identifier => Y,
+          Parameter_Type      => New_Reference_To (Typ, Loc)));
+
+      --  Unchecked_Unions require additional machinery to support equality.
+      --  Two extra parameters (A and B) are added to the equality function
+      --  parameter list in order to capture the inferred values of the
+      --  discriminants in later calls.
+
+      if Is_Unchecked_Union (Typ) then
+         declare
+            Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ));
+
+            A : constant Node_Id :=
+                  Make_Defining_Identifier (Loc,
+                    Chars => Name_A);
+
+            B : constant Node_Id :=
+                  Make_Defining_Identifier (Loc,
+                    Chars => Name_B);
+
+         begin
+            --  Add A and B to the parameter list
+
+            Append_To (Pspecs,
+              Make_Parameter_Specification (Loc,
+                Defining_Identifier => A,
+                Parameter_Type => New_Reference_To (Discr_Type, Loc)));
+
+            Append_To (Pspecs,
+              Make_Parameter_Specification (Loc,
+                Defining_Identifier => B,
+                Parameter_Type => New_Reference_To (Discr_Type, Loc)));
+
+            --  Generate the following header code to compare the inferred
+            --  discriminants:
+
+            --  if a /= b then
+            --     return False;
+            --  end if;
+
+            Append_To (Stmts,
+              Make_If_Statement (Loc,
+                Condition =>
+                  Make_Op_Ne (Loc,
+                    Left_Opnd => New_Reference_To (A, Loc),
+                    Right_Opnd => New_Reference_To (B, Loc)),
+                Then_Statements => New_List (
+                  Make_Return_Statement (Loc,
+                    Expression => New_Occurrence_Of (Standard_False, Loc)))));
+
+            --  Generate component-by-component comparison. Note that we must
+            --  propagate one of the inferred discriminant formals to act as
+            --  the case statement switch.
+
+            Append_List_To (Stmts,
+              Make_Eq_Case (Typ, Comps, A));
+
+         end;
+
+      --  Normal case (not unchecked union)
 
-      if Has_Unchecked_Union (Typ) then
-         Append_To (Stmts,
-           Make_Raise_Program_Error (Loc,
-             Reason => PE_Unchecked_Union_Restriction));
       else
          Append_To (Stmts,
            Make_Eq_If (Typ,
              Discriminant_Specifications (Def)));
+
          Append_List_To (Stmts,
            Make_Eq_Case (Typ, Comps));
       end if;
@@ -4160,6 +4259,12 @@ package body Exp_Ch3 is
 
       elsif Is_Derived_Type (Def_Id)
         and then not Is_Tagged_Type (Def_Id)
+
+         --  If we have a derived Unchecked_Union, we do not inherit the
+         --  discriminant checking functions from the parent type since the
+         --  discriminants are non existent.
+
+        and then not Is_Unchecked_Union (Def_Id)
         and then Has_Discriminants (Def_Id)
       then
          declare
@@ -4329,7 +4434,6 @@ package body Exp_Ch3 is
          begin
             if Present (Comps)
               and then Present (Variant_Part (Comps))
-              and then not Is_Unchecked_Union (Def_Id)
             then
                Build_Variant_Record_Equality (Def_Id);
             end if;
@@ -5108,14 +5212,18 @@ package body Exp_Ch3 is
    --     when Vn => <Make_Eq_Case> on subcomponents
    --  end case;
 
-   function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id is
-      Loc      : constant Source_Ptr := Sloc (Node);
+   function Make_Eq_Case
+     (E     : Entity_Id;
+      CL    : Node_Id;
+      Discr : Entity_Id := Empty) return List_Id
+   is
+      Loc      : constant Source_Ptr := Sloc (E);
       Result   : constant List_Id    := New_List;
       Variant  : Node_Id;
       Alt_List : List_Id;
 
    begin
-      Append_To (Result, Make_Eq_If (Node, Component_Items (CL)));
+      Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
 
       if No (Variant_Part (CL)) then
          return Result;
@@ -5133,18 +5241,29 @@ package body Exp_Ch3 is
          Append_To (Alt_List,
            Make_Case_Statement_Alternative (Loc,
              Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
-             Statements => Make_Eq_Case (Node, Component_List (Variant))));
+             Statements => Make_Eq_Case (E, Component_List (Variant))));
 
          Next_Non_Pragma (Variant);
       end loop;
 
-      Append_To (Result,
-        Make_Case_Statement (Loc,
-          Expression =>
-            Make_Selected_Component (Loc,
-              Prefix => Make_Identifier (Loc, Name_X),
-              Selector_Name => New_Copy (Name (Variant_Part (CL)))),
-          Alternatives => Alt_List));
+      --  If we have an Unchecked_Union, use one of the parameters that
+      --  captures the discriminants.
+
+      if Is_Unchecked_Union (E) then
+         Append_To (Result,
+           Make_Case_Statement (Loc,
+             Expression => New_Reference_To (Discr, Loc),
+             Alternatives => Alt_List));
+
+      else
+         Append_To (Result,
+           Make_Case_Statement (Loc,
+             Expression =>
+               Make_Selected_Component (Loc,
+                 Prefix => Make_Identifier (Loc, Name_X),
+                 Selector_Name => New_Copy (Name (Variant_Part (CL)))),
+             Alternatives => Alt_List));
+      end if;
 
       return Result;
    end Make_Eq_Case;
@@ -5166,8 +5285,11 @@ package body Exp_Ch3 is
 
    --  or a null statement if the list L is empty
 
-   function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id is
-      Loc        : constant Source_Ptr := Sloc (Node);
+   function Make_Eq_If
+     (E : Entity_Id;
+      L : List_Id) return Node_Id
+   is
+      Loc        : constant Source_Ptr := Sloc (E);
       C          : Node_Id;
       Field_Name : Name_Id;
       Cond       : Node_Id;
@@ -5213,7 +5335,7 @@ package body Exp_Ch3 is
 
          else
             return
-              Make_Implicit_If_Statement (Node,
+              Make_Implicit_If_Statement (E,
                 Condition => Cond,
                 Then_Statements => New_List (
                   Make_Return_Statement (Loc,
index d1a7bbc..7f57b02 100644 (file)
@@ -47,6 +47,7 @@ with Opt;      use Opt;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
 with Sem_Cat;  use Sem_Cat;
+with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch13; use Sem_Ch13;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
@@ -154,6 +155,17 @@ package body Exp_Ch4 is
    --  for created object. If context is an access parameter, create a
    --  local access type to have a usable finalization list.
 
+   function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
+   --  Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
+   --  discriminants if it has a constrained nominal type, unless the object
+   --  is a component of an enclosing Unchecked_Union object that is subject
+   --  to a per-object constraint and the enclosing object lacks inferable
+   --  discriminants.
+   --
+   --  An expression of an Unchecked_Union type has inferable discriminants
+   --  if it is either a name of an object with inferable discriminants or a
+   --  qualified expression whose subtype mark denotes a constrained subtype.
+
    procedure Insert_Dereference_Action (N : Node_Id);
    --  N is an expression whose type is an access. When the type of the
    --  associated storage pool is derived from Checked_Pool, generate a
@@ -1581,6 +1593,123 @@ package body Exp_Ch4 is
                end;
 
             else
+               --  Comparison between Unchecked_Union components
+
+               if Is_Unchecked_Union (Full_Type) then
+                  declare
+                     Lhs_Type      : Node_Id := Full_Type;
+                     Rhs_Type      : Node_Id := Full_Type;
+                     Lhs_Discr_Val : Node_Id;
+                     Rhs_Discr_Val : Node_Id;
+
+                  begin
+                     --  Lhs subtype
+
+                     if Nkind (Lhs) = N_Selected_Component then
+                        Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
+                     end if;
+
+                     --  Rhs subtype
+
+                     if Nkind (Rhs) = N_Selected_Component then
+                        Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
+                     end if;
+
+                     --  Lhs of the composite equality
+
+                     if Is_Constrained (Lhs_Type) then
+
+                        --  Since the enclosing record can never be an
+                        --  Unchecked_Union (this code is executed for records
+                        --  that do not have variants), we may reference its
+                        --  discriminant(s).
+
+                        if Nkind (Lhs) = N_Selected_Component
+                          and then Has_Per_Object_Constraint (
+                                     Entity (Selector_Name (Lhs)))
+                        then
+                           Lhs_Discr_Val :=
+                             Make_Selected_Component (Loc,
+                               Prefix => Prefix (Lhs),
+                               Selector_Name =>
+                                 New_Copy (
+                                   Get_Discriminant_Value (
+                                     First_Discriminant (Lhs_Type),
+                                     Lhs_Type,
+                                     Stored_Constraint (Lhs_Type))));
+
+                        else
+                           Lhs_Discr_Val := New_Copy (
+                             Get_Discriminant_Value (
+                               First_Discriminant (Lhs_Type),
+                               Lhs_Type,
+                               Stored_Constraint (Lhs_Type)));
+
+                        end if;
+                     else
+                        --  It is not possible to infer the discriminant since
+                        --  the subtype is not constrained.
+
+                        Insert_Action (Nod,
+                          Make_Raise_Program_Error (Loc,
+                            Reason => PE_Unchecked_Union_Restriction));
+
+                        --  Prevent Gigi from generating illegal code, change
+                        --  the equality to a standard False.
+
+                        return New_Occurrence_Of (Standard_False, Loc);
+                     end if;
+
+                     --  Rhs of the composite equality
+
+                     if Is_Constrained (Rhs_Type) then
+                        if Nkind (Rhs) = N_Selected_Component
+                          and then Has_Per_Object_Constraint (
+                                     Entity (Selector_Name (Rhs)))
+                        then
+                           Rhs_Discr_Val :=
+                             Make_Selected_Component (Loc,
+                               Prefix => Prefix (Rhs),
+                               Selector_Name =>
+                                 New_Copy (
+                                   Get_Discriminant_Value (
+                                     First_Discriminant (Rhs_Type),
+                                     Rhs_Type,
+                                     Stored_Constraint (Rhs_Type))));
+
+                        else
+                           Rhs_Discr_Val := New_Copy (
+                             Get_Discriminant_Value (
+                               First_Discriminant (Rhs_Type),
+                               Rhs_Type,
+                               Stored_Constraint (Rhs_Type)));
+
+                        end if;
+                     else
+                        Insert_Action (Nod,
+                          Make_Raise_Program_Error (Loc,
+                            Reason => PE_Unchecked_Union_Restriction));
+
+                        return Empty;
+                     end if;
+
+                     --  Call the TSS equality function with the inferred
+                     --  discriminant values.
+
+                     return
+                       Make_Function_Call (Loc,
+                         Name => New_Reference_To (Eq_Op, Loc),
+                         Parameter_Associations => New_List (
+                           Lhs,
+                           Rhs,
+                           Lhs_Discr_Val,
+                           Rhs_Discr_Val));
+                  end;
+               end if;
+
+               --  Shouldn't this be an else, we can't fall through
+               --  the above IF, right???
+
                return
                  Make_Function_Call (Loc,
                    Name => New_Reference_To (Eq_Op, Loc),
@@ -2963,6 +3092,27 @@ package body Exp_Ch4 is
                        Prefix => New_Reference_To (Typ, Loc))));
                Analyze_And_Resolve (N, Rtyp);
                return;
+
+            --  Ada 2005 (AI-216): Program_Error is raised when evaluating
+            --  a membership test if the subtype mark denotes a constrained
+            --  Unchecked_Union subtype and the expression lacks inferable
+            --  discriminants.
+
+            elsif Is_Unchecked_Union (Base_Type (Typ))
+              and then Is_Constrained (Typ)
+              and then not Has_Inferable_Discriminants (Lop)
+            then
+               Insert_Action (N,
+                 Make_Raise_Program_Error (Loc,
+                   Reason => PE_Unchecked_Union_Restriction));
+
+               --  Prevent Gigi from generating incorrect code by rewriting
+               --  the test as a standard False.
+
+               Rewrite (N,
+                 New_Occurrence_Of (Standard_False, Loc));
+
+               return;
             end if;
 
             --  Here we have a non-scalar type
@@ -3714,6 +3864,10 @@ package body Exp_Ch4 is
       --  build and analyze call, adding conversions if the operation is
       --  inherited.
 
+      function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
+      --  Determines whether a type has a subcompoment of an unconstrained
+      --  Unchecked_Union subtype. Typ is a record type.
+
       -------------------------
       -- Build_Equality_Call --
       -------------------------
@@ -3731,14 +3885,315 @@ package body Exp_Ch4 is
             R_Exp := OK_Convert_To (Op_Type, R_Exp);
          end if;
 
-         Rewrite (N,
-           Make_Function_Call (Loc,
-             Name => New_Reference_To (Eq, Loc),
-             Parameter_Associations => New_List (L_Exp, R_Exp)));
+         --  If we have an Unchecked_Union, we need to add the inferred
+         --  discriminant values as actuals in the function call. At this
+         --  point, the expansion has determined that both operands have
+         --  inferable discriminants.
+
+         if Is_Unchecked_Union (Op_Type) then
+            declare
+               Lhs_Type      : constant Node_Id := Etype (L_Exp);
+               Rhs_Type      : constant Node_Id := Etype (R_Exp);
+               Lhs_Discr_Val : Node_Id;
+               Rhs_Discr_Val : Node_Id;
+
+            begin
+               --  Per-object constrained selected components require special
+               --  attention. If the enclosing scope of the component is an
+               --  Unchecked_Union, we can not reference its discriminants
+               --  directly. This is why we use the two extra parameters of
+               --  the equality function of the enclosing Unchecked_Union.
+
+               --  type UU_Type (Discr : Integer := 0) is
+               --     . . .
+               --  end record;
+               --  pragma Unchecked_Union (UU_Type);
+
+               --  1. Unchecked_Union enclosing record:
+
+               --     type Enclosing_UU_Type (Discr : Integer := 0) is record
+               --        . . .
+               --        Comp : UU_Type (Discr);
+               --        . . .
+               --     end Enclosing_UU_Type;
+               --     pragma Unchecked_Union (Enclosing_UU_Type);
+
+               --     Obj1 : Enclosing_UU_Type;
+               --     Obj2 : Enclosing_UU_Type (1);
+
+               --     . . . Obj1 = Obj2 . . .
+
+               --     Generated code:
+
+               --     if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
+
+               --  A and B are the formal parameters of the equality function
+               --  of Enclosing_UU_Type. The function always has two extra
+               --  formals to capture the inferred discriminant values.
+
+               --  2. Non-Unchecked_Union enclosing record:
+
+               --     type
+               --       Enclosing_Non_UU_Type (Discr : Integer := 0)
+               --     is record
+               --        . . .
+               --        Comp : UU_Type (Discr);
+               --        . . .
+               --     end Enclosing_Non_UU_Type;
+
+               --     Obj1 : Enclosing_Non_UU_Type;
+               --     Obj2 : Enclosing_Non_UU_Type (1);
+
+               --     . . . Obj1 = Obj2 . . .
+
+               --     Generated code:
+
+               --     if not (uu_typeEQ (obj1.comp, obj2.comp,
+               --                        obj1.discr, obj2.discr)) then
+
+               --  In this case we can directly reference the discriminants of
+               --  the enclosing record.
+
+               --  Lhs of equality
+
+               if Nkind (Lhs) = N_Selected_Component
+                 and then Has_Per_Object_Constraint (
+                            Entity (Selector_Name (Lhs)))
+               then
+                  --  Enclosing record is an Unchecked_Union, use formal A
+
+                  if Is_Unchecked_Union (Scope
+                       (Entity (Selector_Name (Lhs))))
+                  then
+                     Lhs_Discr_Val :=
+                       Make_Identifier (Loc,
+                         Chars => Name_A);
+
+                  --  Enclosing record is of a non-Unchecked_Union type, it is
+                  --  possible to reference the discriminant.
+
+                  else
+                     Lhs_Discr_Val :=
+                       Make_Selected_Component (Loc,
+                         Prefix => Prefix (Lhs),
+                         Selector_Name =>
+                           New_Copy (Get_Discriminant_Value (
+                             First_Discriminant (Lhs_Type),
+                             Lhs_Type,
+                             Stored_Constraint (Lhs_Type))));
+
+                  end if;
+
+               --  Comment needed here ???
+
+               else
+                  --  Infer the discriminant value
+
+                  Lhs_Discr_Val :=
+                    New_Copy (Get_Discriminant_Value (
+                      First_Discriminant (Lhs_Type),
+                      Lhs_Type,
+                      Stored_Constraint (Lhs_Type)));
+
+               end if;
+
+               --  Rhs of equality
+
+               if Nkind (Rhs) = N_Selected_Component
+                  and then Has_Per_Object_Constraint (
+                             Entity (Selector_Name (Rhs)))
+               then
+                  if Is_Unchecked_Union (Scope
+                       (Entity (Selector_Name (Rhs))))
+                  then
+                     Rhs_Discr_Val :=
+                       Make_Identifier (Loc,
+                         Chars => Name_B);
+
+                  else
+                     Rhs_Discr_Val :=
+                       Make_Selected_Component (Loc,
+                         Prefix => Prefix (Rhs),
+                         Selector_Name =>
+                           New_Copy (Get_Discriminant_Value (
+                             First_Discriminant (Rhs_Type),
+                             Rhs_Type,
+                             Stored_Constraint (Rhs_Type))));
+
+                  end if;
+               else
+                  Rhs_Discr_Val :=
+                    New_Copy (Get_Discriminant_Value (
+                      First_Discriminant (Rhs_Type),
+                      Rhs_Type,
+                      Stored_Constraint (Rhs_Type)));
+
+               end if;
+
+               Rewrite (N,
+                 Make_Function_Call (Loc,
+                   Name => New_Reference_To (Eq, Loc),
+                   Parameter_Associations => New_List (
+                     L_Exp,
+                     R_Exp,
+                     Lhs_Discr_Val,
+                     Rhs_Discr_Val)));
+            end;
+
+         --  Normal case, not an unchecked union
+
+         else
+            Rewrite (N,
+              Make_Function_Call (Loc,
+                Name => New_Reference_To (Eq, Loc),
+                Parameter_Associations => New_List (L_Exp, R_Exp)));
+         end if;
 
          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
       end Build_Equality_Call;
 
+      ------------------------------------
+      -- Has_Unconstrained_UU_Component --
+      ------------------------------------
+
+      function Has_Unconstrained_UU_Component
+        (Typ : Node_Id) return Boolean
+      is
+         Tdef  : constant Node_Id :=
+                   Type_Definition (Declaration_Node (Typ));
+         Clist : Node_Id;
+         Vpart : Node_Id;
+
+         function Component_Is_Unconstrained_UU
+           (Comp : Node_Id) return Boolean;
+         --  Determines whether the subtype of the component is an
+         --  unconstrained Unchecked_Union.
+
+         function Variant_Is_Unconstrained_UU
+           (Variant : Node_Id) return Boolean;
+         --  Determines whether a component of the variant has an unconstrained
+         --  Unchecked_Union subtype.
+
+         -----------------------------------
+         -- Component_Is_Unconstrained_UU --
+         -----------------------------------
+
+         function Component_Is_Unconstrained_UU
+           (Comp : Node_Id) return Boolean
+         is
+         begin
+            if Nkind (Comp) /= N_Component_Declaration then
+               return False;
+            end if;
+
+            declare
+               Sindic : constant Node_Id :=
+                          Subtype_Indication (Component_Definition (Comp));
+
+            begin
+               --  Unconstrained nominal type. In the case of a constraint
+               --  present, the node kind would have been N_Subtype_Indication.
+
+               if Nkind (Sindic) = N_Identifier then
+                  return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
+               end if;
+
+               return False;
+            end;
+         end Component_Is_Unconstrained_UU;
+
+         ---------------------------------
+         -- Variant_Is_Unconstrained_UU --
+         ---------------------------------
+
+         function Variant_Is_Unconstrained_UU
+           (Variant : Node_Id) return Boolean
+         is
+            Clist : constant Node_Id := Component_List (Variant);
+
+         begin
+            if Is_Empty_List (Component_Items (Clist)) then
+               return False;
+            end if;
+
+            declare
+               Comp : Node_Id := First (Component_Items (Clist));
+
+            begin
+               while Present (Comp) loop
+
+                  --  One component is sufficent
+
+                  if Component_Is_Unconstrained_UU (Comp) then
+                     return True;
+                  end if;
+
+                  Next (Comp);
+               end loop;
+            end;
+
+            --  None of the components withing the variant were of
+            --  unconstrained Unchecked_Union type.
+
+            return False;
+         end Variant_Is_Unconstrained_UU;
+
+      --  Start of processing for Has_Unconstrained_UU_Component
+
+      begin
+         if Null_Present (Tdef) then
+            return False;
+         end if;
+
+         Clist := Component_List (Tdef);
+         Vpart := Variant_Part (Clist);
+
+         --  Inspect available components
+
+         if Present (Component_Items (Clist)) then
+            declare
+               Comp : Node_Id := First (Component_Items (Clist));
+
+            begin
+               while Present (Comp) loop
+
+                  --  One component is sufficent
+
+                  if Component_Is_Unconstrained_UU (Comp) then
+                     return True;
+                  end if;
+
+                  Next (Comp);
+               end loop;
+            end;
+         end if;
+
+         --  Inspect available components withing variants
+
+         if Present (Vpart) then
+            declare
+               Variant : Node_Id := First (Variants (Vpart));
+
+            begin
+               while Present (Variant) loop
+
+                  --  One component within a variant is sufficent
+
+                  if Variant_Is_Unconstrained_UU (Variant) then
+                     return True;
+                  end if;
+
+                  Next (Variant);
+               end loop;
+            end;
+         end if;
+
+         --  Neither the available components, nor the components inside the
+         --  variant parts were of an unconstrained Unchecked_Union subtype.
+
+         return False;
+      end Has_Unconstrained_UU_Component;
+
    --  Start of processing for Expand_N_Op_Eq
 
    begin
@@ -3899,6 +4354,50 @@ package body Exp_Ch4 is
 
             Build_Equality_Call (Op_Name);
 
+         --  Ada 2005 (AI-216): Program_Error is raised when evaluating the
+         --  predefined equality operator for a type which has a subcomponent
+         --  of an Unchecked_Union type whose nominal subtype is unconstrained.
+
+         elsif Has_Unconstrained_UU_Component (Typl) then
+            Insert_Action (N,
+              Make_Raise_Program_Error (Loc,
+                Reason => PE_Unchecked_Union_Restriction));
+
+            --  Prevent Gigi from generating incorrect code by rewriting the
+            --  equality as a standard False.
+
+            Rewrite (N,
+              New_Occurrence_Of (Standard_False, Loc));
+
+         elsif Is_Unchecked_Union (Typl) then
+
+            --  If we can infer the discriminants of the operands, we make a
+            --  call to the TSS equality function.
+
+            if Has_Inferable_Discriminants (Lhs)
+                 and then
+               Has_Inferable_Discriminants (Rhs)
+            then
+               Build_Equality_Call
+                 (TSS (Root_Type (Typl), TSS_Composite_Equality));
+
+            else
+               --  Ada 2005 (AI-216): Program_Error is raised when evaluating
+               --  the predefined equality operator for an Unchecked_Union type
+               --  if either of the operands lack inferable discriminants.
+
+               Insert_Action (N,
+                 Make_Raise_Program_Error (Loc,
+                   Reason => PE_Unchecked_Union_Restriction));
+
+               --  Prevent Gigi from generating incorrect code by rewriting
+               --  the equality as a standard False.
+
+               Rewrite (N,
+                 New_Occurrence_Of (Standard_False, Loc));
+
+            end if;
+
          --  If a type support function is present (for complex cases), use it
 
          elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
@@ -6288,7 +6787,33 @@ package body Exp_Ch4 is
       --  assignment processing.
 
       elsif Is_Record_Type (Target_Type) then
-         Handle_Changed_Representation;
+
+         --  Ada 2005 (AI-216): Program_Error is raised when converting from
+         --  a derived Unchecked_Union type to an unconstrained non-Unchecked_
+         --  Union type if the operand lacks inferable discriminants.
+
+         if Is_Derived_Type (Operand_Type)
+           and then Is_Unchecked_Union (Base_Type (Operand_Type))
+           and then not Is_Constrained (Target_Type)
+           and then not Is_Unchecked_Union (Base_Type (Target_Type))
+           and then not Has_Inferable_Discriminants (Operand)
+         then
+            --  To prevent Gigi from generating illegal code, we make a
+            --  Program_Error node, but we give it the target type of the
+            --  conversion.
+
+            declare
+               PE : constant Node_Id := Make_Raise_Program_Error (Loc,
+                      Reason => PE_Unchecked_Union_Restriction);
+
+            begin
+               Set_Etype (PE, Target_Type);
+               Rewrite (N, PE);
+
+            end;
+         else
+            Handle_Changed_Representation;
+         end if;
 
       --  Case of conversions of enumeration types
 
@@ -6555,31 +7080,6 @@ package body Exp_Ch4 is
    --  Start of processing for Expand_Record_Equality
 
    begin
-      --  Special processing for the unchecked union case, which will occur
-      --  only in the context of tagged types and dynamic dispatching, since
-      --  other cases are handled statically. We return True, but insert a
-      --  raise Program_Error statement.
-
-      if Is_Unchecked_Union (Typ) then
-
-         --  If this is a component of an enclosing record, return the Raise
-         --  statement directly.
-
-         if No (Parent (Lhs)) then
-            Result :=
-              Make_Raise_Program_Error (Loc,
-                Reason => PE_Unchecked_Union_Restriction);
-            Set_Etype (Result, Standard_Boolean);
-            return Result;
-
-         else
-            Insert_Action (Lhs,
-              Make_Raise_Program_Error (Loc,
-                Reason => PE_Unchecked_Union_Restriction));
-            return New_Occurrence_Of (Standard_True, Loc);
-         end if;
-      end if;
-
       --  Generates the following code: (assuming that Typ has one Discr and
       --  component C2 is also a record)
 
@@ -6712,6 +7212,90 @@ package body Exp_Ch4 is
       return Find_Final_List (Owner);
    end Get_Allocator_Final_List;
 
+   ---------------------------------
+   -- Has_Inferable_Discriminants --
+   ---------------------------------
+
+   function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
+
+      function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
+      --  Determines whether the left-most prefix of a selected component is a
+      --  formal parameter in a subprogram. Assumes N is a selected component.
+
+      --------------------------------
+      -- Prefix_Is_Formal_Parameter --
+      --------------------------------
+
+      function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
+         Sel_Comp : Node_Id := N;
+
+      begin
+         --  Move to the left-most prefix by climbing up the tree
+
+         while Present (Parent (Sel_Comp))
+           and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
+         loop
+            Sel_Comp := Parent (Sel_Comp);
+         end loop;
+
+         return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
+      end Prefix_Is_Formal_Parameter;
+
+   --  Start of processing for Has_Inferable_Discriminants
+
+   begin
+      --  For identifiers and indexed components, it is sufficent to have a
+      --  constrained Unchecked_Union nominal subtype.
+
+      if Nkind (N) = N_Identifier
+           or else
+         Nkind (N) = N_Indexed_Component
+      then
+         return Is_Unchecked_Union (Base_Type (Etype (N)))
+                  and then
+                Is_Constrained (Etype (N));
+
+      --  For selected components, the subtype of the selector must be a
+      --  constrained Unchecked_Union. If the component is subject to a
+      --  per-object constraint, then the enclosing object must have inferable
+      --  discriminants.
+
+      elsif Nkind (N) = N_Selected_Component then
+         if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
+
+            --  A small hack. If we have a per-object constrained selected
+            --  component of a formal parameter, return True since we do not
+            --  know the actual parameter association yet.
+
+            if Prefix_Is_Formal_Parameter (N) then
+               return True;
+            end if;
+
+            --  Otherwise, check the enclosing object and the selector
+
+            return Has_Inferable_Discriminants (Prefix (N))
+                     and then
+                   Has_Inferable_Discriminants (Selector_Name (N));
+         end if;
+
+         --  The call to Has_Inferable_Discriminants will determine whether
+         --  the selector has a constrained Unchecked_Union nominal type.
+
+         return Has_Inferable_Discriminants (Selector_Name (N));
+
+      --  A qualified expression has inferable discriminants if its subtype
+      --  mark is a constrained Unchecked_Union subtype.
+
+      elsif Nkind (N) = N_Qualified_Expression then
+         return Is_Unchecked_Union (Subtype_Mark (N))
+                  and then
+                Is_Constrained (Subtype_Mark (N));
+
+      end if;
+
+      return False;
+   end Has_Inferable_Discriminants;
+
    -------------------------------
    -- Insert_Dereference_Action --
    -------------------------------
index 083c6c2..1d982ee 100644 (file)
@@ -43,6 +43,7 @@ with Rident;   use Rident;
 with Rtsfind;  use Rtsfind;
 with Sinfo;    use Sinfo;
 with Sem;      use Sem;
+with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Ch13; use Sem_Ch13;
 with Sem_Eval; use Sem_Eval;
@@ -1096,13 +1097,22 @@ package body Exp_Ch5 is
          --  the type may be private and resolution by identifier alone would
          --  fail.
 
-         function Make_Component_List_Assign (CL : Node_Id) return List_Id;
+         function Make_Component_List_Assign
+           (CL  : Node_Id;
+            U_U : Boolean := False) return List_Id;
          --  Returns a sequence of statements to assign the components that
-         --  are referenced in the given component list.
-
-         function Make_Field_Assign (C : Entity_Id) return Node_Id;
-         --  Given C, the entity for a discriminant or component, build
-         --  an assignment for the corresponding field values.
+         --  are referenced in the given component list. The flag U_U is
+         --  used to force the usage of the inferred value of the variant
+         --  part expression as the switch for the generated case statement.
+
+         function Make_Field_Assign
+           (C : Entity_Id;
+            U_U : Boolean := False) return Node_Id;
+         --  Given C, the entity for a discriminant or component, build an
+         --  assignment for the corresponding field values. The flag U_U
+         --  signals the presence of an Unchecked_Union and forces the usage
+         --  of the inferred discriminant value of C as the right hand side
+         --  of the assignment.
 
          function Make_Field_Assigns (CI : List_Id) return List_Id;
          --  Given CI, a component items list, construct series of statements
@@ -1136,15 +1146,19 @@ package body Exp_Ch5 is
          -- Make_Component_List_Assign --
          --------------------------------
 
-         function Make_Component_List_Assign (CL : Node_Id) return List_Id is
+         function Make_Component_List_Assign
+           (CL  : Node_Id;
+            U_U : Boolean := False) return List_Id
+         is
             CI : constant List_Id := Component_Items (CL);
             VP : constant Node_Id := Variant_Part (CL);
 
-            Result : List_Id;
             Alts   : List_Id;
-            V      : Node_Id;
             DC     : Node_Id;
             DCH    : List_Id;
+            Expr   : Node_Id;
+            Result : List_Id;
+            V      : Node_Id;
 
          begin
             Result := Make_Field_Assigns (CI);
@@ -1170,15 +1184,29 @@ package body Exp_Ch5 is
                   Next_Non_Pragma (V);
                end loop;
 
+               --  If we have an Unchecked_Union, use the value of the inferred
+               --  discriminant of the variant part expression as the switch
+               --  for the case statement. The case statement may later be
+               --  folded.
+
+               if U_U then
+                  Expr :=
+                    New_Copy (Get_Discriminant_Value (
+                      Entity (Name (VP)),
+                      Etype (Rhs),
+                      Discriminant_Constraint (Etype (Rhs))));
+               else
+                  Expr :=
+                    Make_Selected_Component (Loc,
+                      Prefix => Duplicate_Subexpr (Rhs),
+                      Selector_Name =>
+                        Make_Identifier (Loc, Chars (Name (VP))));
+               end if;
+
                Append_To (Result,
                  Make_Case_Statement (Loc,
-                   Expression =>
-                     Make_Selected_Component (Loc,
-                       Prefix => Duplicate_Subexpr (Rhs),
-                       Selector_Name =>
-                         Make_Identifier (Loc, Chars (Name (VP)))),
+                   Expression => Expr,
                    Alternatives => Alts));
-
             end if;
 
             return Result;
@@ -1188,10 +1216,29 @@ package body Exp_Ch5 is
          -- Make_Field_Assign --
          -----------------------
 
-         function Make_Field_Assign (C : Entity_Id) return Node_Id is
-            A : Node_Id;
+         function Make_Field_Assign
+           (C : Entity_Id;
+            U_U : Boolean := False) return Node_Id
+         is
+            A    : Node_Id;
+            Expr : Node_Id;
 
          begin
+            --  In the case of an Unchecked_Union, use the discriminant
+            --  constraint value as on the right hand side of the assignment.
+
+            if U_U then
+               Expr :=
+                 New_Copy (Get_Discriminant_Value (C,
+                   Etype (Rhs),
+                   Discriminant_Constraint (Etype (Rhs))));
+            else
+               Expr :=
+                 Make_Selected_Component (Loc,
+                   Prefix => Duplicate_Subexpr (Rhs),
+                   Selector_Name => New_Occurrence_Of (C, Loc));
+            end if;
+
             A :=
               Make_Assignment_Statement (Loc,
                 Name =>
@@ -1199,10 +1246,7 @@ package body Exp_Ch5 is
                     Prefix => Duplicate_Subexpr (Lhs),
                     Selector_Name =>
                       New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
-                Expression =>
-                  Make_Selected_Component (Loc,
-                    Prefix => Duplicate_Subexpr (Rhs),
-                    Selector_Name => New_Occurrence_Of (C, Loc)));
+                Expression => Expr);
 
             --  Set Assignment_OK, so discriminants can be assigned
 
@@ -1221,7 +1265,6 @@ package body Exp_Ch5 is
          begin
             Item := First (CI);
             Result := New_List;
-
             while Present (Item) loop
                if Nkind (Item) = N_Component_Declaration then
                   Append_To
@@ -1251,7 +1294,13 @@ package body Exp_Ch5 is
          if Has_Discriminants (L_Typ) then
             F := First_Discriminant (R_Typ);
             while Present (F) loop
-               Insert_Action (N, Make_Field_Assign (F));
+
+               if Is_Unchecked_Union (Base_Type (R_Typ)) then
+                  Insert_Action (N, Make_Field_Assign (F, True));
+               else
+                  Insert_Action (N, Make_Field_Assign (F));
+               end if;
+
                Next_Discriminant (F);
             end loop;
          end if;
@@ -1270,8 +1319,14 @@ package body Exp_Ch5 is
          if Nkind (RDef) = N_Record_Definition
            and then Present (Component_List (RDef))
          then
-            Insert_Actions
-              (N, Make_Component_List_Assign (Component_List (RDef)));
+
+            if Is_Unchecked_Union (R_Typ) then
+               Insert_Actions (N,
+                 Make_Component_List_Assign (Component_List (RDef), True));
+            else
+               Insert_Actions
+                 (N, Make_Component_List_Assign (Component_List (RDef)));
+            end if;
 
             Rewrite (N, Make_Null_Statement (Loc));
          end if;
@@ -3032,7 +3087,6 @@ package body Exp_Ch5 is
 
       Res       : List_Id;
       Tag_Tmp   : Entity_Id;
-      Original_Size, Range_Type, Opaque_Type : Entity_Id;
 
    begin
       Res := New_List;
@@ -3091,83 +3145,21 @@ package body Exp_Ch5 is
          Tag_Tmp := Empty;
       end if;
 
-      --  We really need a comment here ???
-
-      if Ctrl_Act then
-
-         --  subtype G is Storage_Offset range 1 .. Expr'Size
-
-         Original_Size :=
-           Make_Defining_Identifier (Loc,
-             New_Internal_Name ('S'));
-
-         Append_To (Res,
-           Make_Object_Declaration (Loc,
-             Defining_Identifier => Original_Size,
-             Constant_Present    => True,
-             Object_Definition   => New_Occurrence_Of (
-               RTE (RE_Storage_Offset), Loc),
-             Expression          =>
-               Make_Op_Divide (Loc,
-                 Left_Opnd =>
-                   Make_Attribute_Reference (Loc,
-                     Prefix =>
-                       Duplicate_Subexpr_No_Checks (L),
-                     Attribute_Name => Name_Size),
-                 Right_Opnd => Make_Integer_Literal (Loc,
-                     Intval => System_Storage_Unit))));
-
-         Range_Type :=
-           Make_Defining_Identifier (Loc,
-             New_Internal_Name ('G'));
+      --  Processing for controlled types and types with controlled components
 
-         Append_To (Res,
-           Make_Subtype_Declaration (Loc,
-             Defining_Identifier => Range_Type,
-             Subtype_Indication =>
-               Make_Subtype_Indication (Loc,
-                 Subtype_Mark =>
-                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
-                 Constraint   => Make_Range_Constraint (Loc,
-                   Range_Expression =>
-                     Make_Range (Loc,
-                       Low_Bound  => Make_Integer_Literal (Loc, 1),
-                       High_Bound => New_Occurrence_Of (
-                         Original_Size, Loc))))));
-
-         --  subtype S is Storage_Array (G)
+      --  Variables of such types contain pointers used to chain them in
+      --  finalization lists, in addition to user data. These pointers are
+      --  specific to each object of the type, not to the value being assigned.
+      --  Thus they need to be left intact during the assignment. We achieve
+      --  this by constructing a Storage_Array subtype, and by overlaying
+      --  objects of this type on the source and target of the assignment.
+      --  The assignment is then rewritten to assignments of slices of these
+      --  arrays, copying the user data, and leaving the pointers untouched.
 
-         Append_To (Res,
-           Make_Subtype_Declaration (Loc,
-             Defining_Identifier =>
-               Make_Defining_Identifier (Loc,
-                 New_Internal_Name ('S')),
-             Subtype_Indication  =>
-               Make_Subtype_Indication (Loc,
-                 Subtype_Mark =>
-                   New_Reference_To (RTE (RE_Storage_Array), Loc),
-                 Constraint =>
-                   Make_Index_Or_Discriminant_Constraint (Loc,
-                     Constraints =>
-                       New_List (New_Reference_To (Range_Type, Loc))))));
-
-         --  type A is access S
-
-         Opaque_Type := Make_Defining_Identifier (Loc,
-           New_Internal_Name ('A'));
-         Append_To (Res,
-           Make_Full_Type_Declaration (Loc,
-             Defining_Identifier => Opaque_Type,
-             Type_Definition     =>
-               Make_Access_To_Object_Definition (Loc,
-                 Subtype_Indication =>
-                   New_Occurrence_Of (
-                     Defining_Identifier (Last (Res)), Loc))));
-
-         --  Give a label name to this declare block, and add comments here???
-
-         declare
+      if Ctrl_Act then
+         Controlled_Actions : declare
             Prev_Ref : Node_Id;
+            --  A reference to the Prev component of the record controller
 
             First_After_Root : Node_Id := Empty;
             --  Index of first byte to be copied (used to skip
@@ -3184,31 +3176,44 @@ package body Exp_Ch5 is
             --  Index of first byte to be copied after outermost record
             --  controller data.
 
+            Expr, Source_Size      : Node_Id;
+            --  Used for computation of the size of the data to be copied
+
+            Range_Type  : Entity_Id;
+            Opaque_Type : Entity_Id;
+
             function Build_Slice
-              (Rec    : Entity_Id;
-               Lo, Hi : Node_Id) return Node_Id;
-            --  Function specs must have comments, saying what all the
-            --  parameters are and what the function does ???
+              (Rec : Entity_Id;
+               Lo  : Node_Id;
+               Hi  : Node_Id) return Node_Id;
+            --  Build and return a slice of an array of type S overlaid
+            --  on object Rec, with bounds specified by Lo and Hi. If either
+            --  bound is empty, a default of S'First (respectively S'Last)
+            --  is used.
 
             -----------------
             -- Build_Slice --
             -----------------
 
             function Build_Slice
-              (Rec    : Node_Id;
-               Lo, Hi : Node_Id) return Node_Id
+              (Rec : Node_Id;
+               Lo  : Node_Id;
+               Hi  : Node_Id) return Node_Id
             is
-               Lo_Bound, Hi_Bound : Node_Id;
+               Lo_Bound : Node_Id;
+               Hi_Bound : Node_Id;
 
                Opaque : constant Node_Id :=
                           Unchecked_Convert_To (Opaque_Type,
                             Make_Attribute_Reference (Loc,
                               Prefix         => Rec,
                               Attribute_Name => Name_Address));
-               --  Comment required, what is this???
+               --  Access value designating an opaque storage array of
+               --  type S overlaid on record Rec.
 
             begin
-               --  Comments required in this body ???
+               --  Compute slice bounds using S'First (1) and S'Last
+               --  as default values when not specified by the caller.
 
                if No (Lo) then
                   Lo_Bound := Make_Integer_Literal (Loc, 1);
@@ -3231,12 +3236,102 @@ package body Exp_Ch5 is
                    Lo_Bound, Hi_Bound));
             end Build_Slice;
 
-         --  Start of processing for ??? (name of block)
+         --  Start of processing for Controlled_Actions
 
          begin
+            --  Create a constrained subtype of Storage_Array whose size
+            --  corresponds to the value being assigned.
+
+            --  subtype G is Storage_Offset range
+            --    1 .. (Expr'Size + Storage_Unit - 1) / Storage_Unit
+
+            Expr := Duplicate_Subexpr_No_Checks (Expression (N));
+
+            if Nkind (Expr) = N_Qualified_Expression then
+               Expr := Expression (Expr);
+            end if;
+
+            Source_Size :=
+              Make_Op_Add (Loc,
+                Left_Opnd =>
+                  Make_Attribute_Reference (Loc,
+                    Prefix =>
+                      Expr,
+                    Attribute_Name =>
+                      Name_Size),
+                Right_Opnd =>
+                  Make_Integer_Literal (Loc,
+                  System_Storage_Unit - 1));
+
+            --  If Expr is a type conversion, standard Ada does not allow
+            --  'Size to be taken on it, but Gigi can handle this case,
+            --  and thus we can determine the amount of data to be copied.
+            --  The appropriate circuitry is enabled only for conversions
+            --  that do not Come_From_Source.
+
+            Set_Comes_From_Source (Prefix (Left_Opnd (Source_Size)), False);
+
+            Source_Size :=
+              Make_Op_Divide (Loc,
+                Left_Opnd => Source_Size,
+                Right_Opnd =>
+                  Make_Integer_Literal (Loc,
+                    Intval => System_Storage_Unit));
+
+            Range_Type :=
+              Make_Defining_Identifier (Loc,
+                New_Internal_Name ('G'));
+
+            Append_To (Res,
+              Make_Subtype_Declaration (Loc,
+                Defining_Identifier => Range_Type,
+                Subtype_Indication =>
+                  Make_Subtype_Indication (Loc,
+                    Subtype_Mark =>
+                      New_Reference_To (RTE (RE_Storage_Offset), Loc),
+                    Constraint   => Make_Range_Constraint (Loc,
+                      Range_Expression =>
+                        Make_Range (Loc,
+                          Low_Bound  => Make_Integer_Literal (Loc, 1),
+                          High_Bound => Source_Size)))));
+
+            --  subtype S is Storage_Array (G)
+
+            Append_To (Res,
+              Make_Subtype_Declaration (Loc,
+                Defining_Identifier =>
+                  Make_Defining_Identifier (Loc,
+                    New_Internal_Name ('S')),
+                Subtype_Indication  =>
+                  Make_Subtype_Indication (Loc,
+                    Subtype_Mark =>
+                      New_Reference_To (RTE (RE_Storage_Array), Loc),
+                    Constraint =>
+                      Make_Index_Or_Discriminant_Constraint (Loc,
+                        Constraints =>
+                          New_List (New_Reference_To (Range_Type, Loc))))));
+
+            --  type A is access S
+
+            Opaque_Type :=
+              Make_Defining_Identifier (Loc,
+                Chars => New_Internal_Name ('A'));
+
+            Append_To (Res,
+              Make_Full_Type_Declaration (Loc,
+                Defining_Identifier => Opaque_Type,
+                Type_Definition     =>
+                  Make_Access_To_Object_Definition (Loc,
+                    Subtype_Indication =>
+                      New_Occurrence_Of (
+                        Defining_Identifier (Last (Res)), Loc))));
+
+            --  Generate appropriate slice assignments
+
             First_After_Root := Make_Integer_Literal (Loc, 1);
 
-            --  Comment ???
+            --  For the case of a controlled object, skip the
+            --  Root_Controlled part.
 
             if Is_Controlled (T) then
                First_After_Root :=
@@ -3250,12 +3345,12 @@ package body Exp_Ch5 is
                      Make_Integer_Literal (Loc, System_Storage_Unit)));
             end if;
 
-            if Has_Controlled_Component (T) then
-
-               --  The record controller Prev and Next pointers must be left
-               --  intact in the target object, not copied. Compute the bounds
-               --  of the hole to be skipped in copying the objecct.
+            --  For the case of a record with controlled components, skip
+            --  the Prev and Next components of the record controller.
+            --  These components constitute a 'hole' in the middle of the
+            --  data to be copied.
 
+            if Has_Controlled_Component (T) then
                Prev_Ref :=
                  Make_Selected_Component (Loc,
                    Prefix =>
@@ -3265,7 +3360,8 @@ package body Exp_Ch5 is
                          New_Reference_To (Controller_Component (T), Loc)),
                    Selector_Name =>  Make_Identifier (Loc, Name_Prev));
 
-               --  Last index before hole
+               --  Last index before hole: determined by position of
+               --  the _Controller.Prev component.
 
                Last_Before_Hole :=
                  Make_Defining_Identifier (Loc,
@@ -3285,18 +3381,20 @@ package body Exp_Ch5 is
                          Prefix => New_Copy_Tree (Prefix (Prev_Ref)),
                          Attribute_Name => Name_Position))));
 
-               --  Hole length
+               --  Hole length: size of the Prev and Next components
 
                Hole_Length :=
                  Make_Op_Multiply (Loc,
-                   Make_Integer_Literal (Loc, Uint_2),
+                   Left_Opnd  => Make_Integer_Literal (Loc, Uint_2),
+                   Right_Opnd =>
                      Make_Op_Divide (Loc,
-                       Make_Attribute_Reference (Loc,
-                         Prefix =>
-                           New_Copy_Tree (Prev_Ref),
-                         Attribute_Name =>
-                           Name_Size),
-                     Make_Integer_Literal (Loc, System_Storage_Unit)));
+                       Left_Opnd =>
+                         Make_Attribute_Reference (Loc,
+                           Prefix         => New_Copy_Tree (Prev_Ref),
+                           Attribute_Name => Name_Size),
+                       Right_Opnd =>
+                         Make_Integer_Literal (Loc,
+                           Intval => System_Storage_Unit)));
 
                --  First index after hole
 
@@ -3312,44 +3410,55 @@ package body Exp_Ch5 is
                    Constant_Present    => True,
                    Expression          =>
                      Make_Op_Add (Loc,
-                       Make_Op_Add (Loc,
-                         New_Occurrence_Of (Last_Before_Hole, Loc),
-                         Hole_Length),
-                       Make_Integer_Literal (Loc, 1))));
+                       Left_Opnd  =>
+                         Make_Op_Add (Loc,
+                           Left_Opnd  =>
+                             New_Occurrence_Of (Last_Before_Hole, Loc),
+                           Right_Opnd => Hole_Length),
+                       Right_Opnd => Make_Integer_Literal (Loc, 1))));
 
                Last_Before_Hole := New_Occurrence_Of (Last_Before_Hole, Loc);
                First_After_Hole := New_Occurrence_Of (First_After_Hole, Loc);
             end if;
 
-            --  More comments needed everywhere ???
+            --  Assign the first slice (possibly skipping Root_Controlled,
+            --  up to the beginning of the record controller if present,
+            --  up to the end of the object if not).
 
             Append_To (Res, Make_Assignment_Statement (Loc,
-              Name       => Build_Slice (Duplicate_Subexpr_No_Checks (L),
-                                         First_After_Root,
-                                         Last_Before_Hole),
-
-              Expression => Build_Slice (Expression (N),
-                                         First_After_Root,
-                                         New_Copy_Tree (Last_Before_Hole))));
+              Name       => Build_Slice (
+                Rec => Duplicate_Subexpr_No_Checks (L),
+                Lo  => First_After_Root,
+                Hi  => Last_Before_Hole),
 
+              Expression => Build_Slice (
+                Rec => Expression (N),
+                Lo  => First_After_Root,
+                Hi  => New_Copy_Tree (Last_Before_Hole))));
 
             if Present (First_After_Hole) then
-               Remove_Side_Effects (Expression (N));
+
+               --  If a record controller is present, copy the second slice,
+               --  from right after the _Controller.Next component up to the
+               --  end of the object.
+
                Append_To (Res, Make_Assignment_Statement (Loc,
-                 Name       => Build_Slice (Duplicate_Subexpr_No_Checks (L),
-                                            First_After_Hole,
-                                            Empty),
-                 Expression => Build_Slice (New_Copy_Tree (Expression (N)),
-                                            New_Copy_Tree (First_After_Hole),
-                                            Empty)));
+                 Name       => Build_Slice (
+                   Rec => Duplicate_Subexpr_No_Checks (L),
+                   Lo  => First_After_Hole,
+                   Hi  => Empty),
+                 Expression => Build_Slice (
+                   Rec => Duplicate_Subexpr_No_Checks (Expression (N)),
+                   Lo  => New_Copy_Tree (First_After_Hole),
+                   Hi  => Empty)));
             end if;
-         end;
+         end Controlled_Actions;
 
       else
          Append_To (Res, Relocate_Node (N));
       end if;
 
-      --  Restore the Tag
+      --  Restore the tag
 
       if Save_Tag then
          Append_To (Res,
index 1842996..62de53a 100644 (file)
@@ -1376,6 +1376,12 @@ package body Exp_Ch6 is
                  New_Occurrence_Of (Standard_True, Loc),
                  Extra_Constrained (Formal));
 
+            --  Do not produce extra actuals for Unchecked_Union parameters.
+            --  Jump directly to the end of the loop.
+
+            elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
+               goto Skip_Extra_Actual_Generation;
+
             else
                --  If the actual is a type conversion, then the constrained
                --  test applies to the actual, not the target type.
@@ -1660,6 +1666,11 @@ package body Exp_Ch6 is
                     Reason => PE_Illegal_RACW_E_4_18))));
          end if;
 
+         --  This label is required when skipping extra actual generation for
+         --  Unchecked_Union parameters.
+
+         <<Skip_Extra_Actual_Generation>>
+
          Next_Actual (Actual);
          Next_Formal (Formal);
       end loop;
index a6567aa..eb6abd0 100644 (file)
@@ -1984,16 +1984,28 @@ package body Exp_Ch7 is
    ------------------------------------
 
    procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
-      SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+      SE     : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+      Target : Node_Id;
 
    begin
+      --  If the node to be wrapped is the triggering alternative of an
+      --  asynchronous select, it is not part of a statement list. The
+      --  actions must be inserted before the Select itself, which is
+      --  part of some list of statements.
+
+      if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative then
+         Target := Parent (Parent (Node_To_Be_Wrapped));
+      else
+         Target := N;
+      end if;
+
       if Present (SE.Actions_To_Be_Wrapped_Before) then
-         Insert_List_Before (N, SE.Actions_To_Be_Wrapped_Before);
+         Insert_List_Before (Target, SE.Actions_To_Be_Wrapped_Before);
          SE.Actions_To_Be_Wrapped_Before := No_List;
       end if;
 
       if Present (SE.Actions_To_Be_Wrapped_After) then
-         Insert_List_After (N, SE.Actions_To_Be_Wrapped_After);
+         Insert_List_After (Target, SE.Actions_To_Be_Wrapped_After);
          SE.Actions_To_Be_Wrapped_After := No_List;
       end if;
    end Insert_Actions_In_Scope_Around;
index c017d6d..cee69c4 100644 (file)
@@ -4275,7 +4275,7 @@ package body Freeze is
       Ensure_Type_Is_SA (Etype (E));
 
       --  Reset True_Constant flag, since something strange is going on
-      --  with the scoping here, and our simple value traceing may not
+      --  with the scoping here, and our simple value tracing may not
       --  be sufficient for this indication to be reliable. We kill the
       --  Constant_Value indication for the same reason.
 
index 75a1c30..b2d4f25 100644 (file)
@@ -44,7 +44,7 @@ with GNAT.Task_Lock;
 
 with GNAT.Sockets.Linker_Options;
 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
---  Need to include pragma Linker_Options which is platform dependent.
+--  Need to include pragma Linker_Options which is platform dependent
 
 with System; use System;
 
@@ -226,9 +226,9 @@ package body GNAT.Sockets is
    --------------------
 
    procedure Abort_Selector (Selector : Selector_Type) is
-      Buf     : Character;
+      Buf     : aliased Character := ASCII.NUL;
       Discard : C.int;
-      pragma Warnings (Off, Discard);
+      pragma Unreferenced (Discard);
 
    begin
       --  Send an empty array to unblock C select system call
@@ -1288,7 +1288,7 @@ package body GNAT.Sockets is
    begin
       return Item.Last /= No_Socket
         and then Socket <= Item.Last
-        and then Is_Socket_In_Set (Item.Set, C.int (Socket));
+        and then Is_Socket_In_Set (Item.Set, C.int (Socket)) /= 0;
    end Is_Set;
 
    -------------------
@@ -1865,22 +1865,23 @@ package body GNAT.Sockets is
       use type C.unsigned_short;
 
    begin
-      pragma Warnings (Off);
-
       --  Big-endian case. No conversion needed. On these platforms,
       --  htons() defaults to a null procedure.
 
+      pragma Warnings (Off);
+      --  Since the test can generate "always True/False" warning
+
       if Default_Bit_Order = High_Order_First then
          return S;
 
+         pragma Warnings (On);
+
       --  Little-endian case. We must swap the high and low bytes of this
       --  short to make the port number network compliant.
 
       else
          return (S / 256) + (S mod 256) * 256;
       end if;
-
-      pragma Warnings (On);
    end Short_To_Network;
 
    ---------------------
index a948bde..214e0f3 100644 (file)
@@ -385,7 +385,7 @@ package body GNAT.Sockets.Thin is
                   --  is not watching for it.
 
                   if WFSC /= No_Fd_Set
-                    and then Is_Socket_In_Set (WFSC, S)
+                    and then (Is_Socket_In_Set (WFSC, S) /= 0)
                   then
                      Insert_Socket_In_Set (WFS, S);
                   end if;
index 5ee990e..f13b907 100644 (file)
@@ -364,8 +364,9 @@ package GNAT.Sockets.Thin is
 
    function  Is_Socket_In_Set
      (Set    : Fd_Set_Access;
-      Socket : C.int) return Boolean;
-   --  Check whether Socket is in the socket set
+      Socket : C.int) return C.int;
+   --  Check whether Socket is in the socket set, return a non-zero
+   --  value if it is, zero if it is not.
 
    procedure Last_Socket_In_Set
      (Set  : Fd_Set_Access;
index 41b32d1..4d4a911 100644 (file)
@@ -403,7 +403,7 @@ package body GNAT.Sockets.Thin is
       R : Boolean;
    begin
       Task_Lock.Lock;
-      R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
+      R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
       Task_Lock.Unlock;
       return R;
    end Non_Blocking_Socket;
index a398552..47f2827 100644 (file)
@@ -385,9 +385,9 @@ package GNAT.Sockets.Thin is
 
    function  Is_Socket_In_Set
      (Set    : Fd_Set_Access;
-      Socket : C.int)
-     return Boolean;
-   --  Check whether Socket is in the socket set.
+      Socket : C.int) return C.int;
+   --  Check whether Socket is in the socket set, return a non-zero
+   --  value if it is, zero if it is not.
 
    procedure Last_Socket_In_Set
      (Set    : Fd_Set_Access;
index 28e2241..06a60ca 100644 (file)
@@ -518,7 +518,7 @@ package body GNAT.Sockets.Thin is
 
    begin
       Task_Lock.Lock;
-      R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
+      R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
       Task_Lock.Unlock;
       return R;
    end Non_Blocking_Socket;
index 3642a03..f389e9a 100644 (file)
@@ -387,9 +387,9 @@ package GNAT.Sockets.Thin is
 
    function  Is_Socket_In_Set
      (Set    : Fd_Set_Access;
-      Socket : C.int)
-     return Boolean;
-   --  Check whether Socket is in the socket set
+      Socket : C.int) return C.int;
+   --  Check whether Socket is in the socket set, return a non-zero
+   --  value if it is, zero if it is not.
 
    procedure Last_Socket_In_Set
      (Set    : Fd_Set_Access;
index 49f3c8d..9600cda 100644 (file)
@@ -407,7 +407,7 @@ package body GNAT.Sockets.Thin is
       R : Boolean;
    begin
       Task_Lock.Lock;
-      R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
+      R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
       Task_Lock.Unlock;
       return R;
    end Non_Blocking_Socket;
index f8b7aca..7a818d8 100644 (file)
@@ -360,8 +360,9 @@ package GNAT.Sockets.Thin is
 
    function  Is_Socket_In_Set
      (Set    : Fd_Set_Access;
-      Socket : C.int) return Boolean;
-   --  Check whether Socket is in the socket set
+      Socket : C.int) return C.int;
+   --  Check whether Socket is in the socket set, return a non-zero
+   --  value if it is, zero if it is not.
 
    procedure Last_Socket_In_Set
      (Set    : Fd_Set_Access;
index ea278f1..d3d2836 100644 (file)
 @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
 
 @setfilename gnat_rm.info
+
+@set FSFEDITION
+
 @settitle GNAT Reference Manual
+
 @setchapternewpage odd
 @syncodeindex fn cp
 
@@ -82,6 +86,7 @@ Ada Core Technologies, Inc.
 * Specialized Needs Annexes::
 * Implementation of Specific Ada Features::
 * Project File Reference::
+* Obsolescent Features::
 * GNU Free Documentation License::
 * Index::
 
@@ -152,10 +157,10 @@ Implementation Defined Pragmas
 * Pragma Passive::
 * Pragma Polling::
 * Pragma Profile (Ravenscar)::
+* Pragma Profile (Restricted)::
 * Pragma Propagate_Exceptions::
 * Pragma Psect_Object::
 * Pragma Pure_Function::
-* Pragma Restricted_Run_Time::
 * Pragma Restriction_Warnings::
 * Pragma Source_File_Name::
 * Pragma Source_File_Name_Project::
@@ -378,6 +383,8 @@ Implementation of Specific Ada Features
 
 Project File Reference
 
+Obsolescent Features
+
 GNU Free Documentation License
 
 Index
@@ -388,11 +395,21 @@ Index
 @node About This Guide
 @unnumbered About This Guide
 
+@ifclear PROEDITION
 @noindent
 This manual contains useful information in writing programs using the
 GNAT compiler.  It includes information on implementation dependent
 characteristics of GNAT, including all the information required by Annex
 M of the standard.
+@end ifclear
+
+@ifset PROEDITION
+@noindent
+This manual contains useful information in writing programs using the
+GNAT Pro compiler.  It includes information on implementation dependent
+characteristics of GNAT Pro, including all the information required by Annex
+M of the standard.
+@end ifset
 
 Ada 95 is designed to be highly portable.
 In general, a program will have the same effect even when compiled by
@@ -408,6 +425,11 @@ may be non-portable.  You should follow good programming practice and
 isolate and clearly document any sections of your program that make use
 of these features in a non-portable manner.
 
+@ifset PROEDITION
+For ease of exposition, ``GNAT Pro'' will be referred to simply as
+``GNAT'' in the remainder of this document.
+@end ifset
+
 @menu
 * What This Reference Manual Contains::
 * Conventions::
@@ -481,6 +503,12 @@ other features.
 @ref{Project File Reference}, presents the syntax and semantics
 of project files.
 
+@item
+@ref{Obsolescent Features} documents implementation dependent features,
+including pragmas and attributes, which are considered obsolescent, since
+there are other preferred ways of achieving the same results. These
+obsolescent forms are retained for backwards compatibilty.
+
 @end itemize
 
 @cindex Ada 95 ISO/ANSI Standard
@@ -643,10 +671,10 @@ consideration, the use of these pragmas should be minimized.
 * Pragma Passive::
 * Pragma Polling::
 * Pragma Profile (Ravenscar)::
+* Pragma Profile (Restricted)::
 * Pragma Propagate_Exceptions::
 * Pragma Psect_Object::
 * Pragma Pure_Function::
-* Pragma Restricted_Run_Time::
 * Pragma Restriction_Warnings::
 * Pragma Source_File_Name::
 * Pragma Source_File_Name_Project::
@@ -2945,14 +2973,51 @@ AI-305) available at
 respectively.
 
 The above set is a superset of the restrictions provided by pragma
-@code{Restricted_Run_Time}, it includes six additional restrictions
+@code{Profile (Restricted)}, it includes six additional restrictions
 (@code{Simple_Barriers}, @code{No_Select_Statements},
 @code{No_Calendar}, @code{No_Implicit_Heap_Allocations},
 @code{No_Relative_Delay} and @code{No_Task_Termination}).  This means
 that pragma @code{Profile (Ravenscar)}, like the pragma
-@code{Restricted_Run_Time}, automatically causes the use of a simplified,
+@code{Profile (Restricted)},
+automatically causes the use of a simplified,
 more efficient version of the tasking run-time system.
 
+@node Pragma Profile (Restricted)
+@unnumberedsec Pragma Profile (Restricted)
+@findex Restricted Run Time
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Profile (Restricted);
+@end smallexample
+
+@noindent
+A configuration pragma that establishes the following set of restrictions:
+
+@itemize @bullet
+@item No_Abort_Statements
+@item No_Entry_Queue
+@item No_Task_Hierarchy
+@item No_Task_Allocators
+@item No_Dynamic_Priorities
+@item No_Terminate_Alternatives
+@item No_Dynamic_Attachment
+@item No_Protected_Type_Allocators
+@item No_Local_Protected_Objects
+@item No_Requeue_Statements
+@item No_Task_Attributes_Package
+@item Max_Asynchronous_Select_Nesting =  0
+@item Max_Task_Entries =  0
+@item Max_Protected_Entries = 1
+@item Max_Select_Alternatives = 0
+@end itemize
+
+@noindent
+This set of restrictions causes the automatic selection of a simplified
+version of the run time that provides improved performance for the
+limited set of tasking functionality permitted by this set of restrictions.
+
 @node Pragma Propagate_Exceptions
 @unnumberedsec Pragma Propagate_Exceptions
 @findex Propagate_Exceptions
@@ -3063,42 +3128,6 @@ applies to the underlying renamed function.  This can be used to
 disambiguate cases of overloading where some but not all functions
 in a set of overloaded functions are to be designated as pure.
 
-@node Pragma Restricted_Run_Time
-@unnumberedsec Pragma Restricted_Run_Time
-@findex Restricted_Run_Time
-@noindent
-Syntax:
-
-@smallexample @c ada
-pragma Restricted_Run_Time;
-@end smallexample
-
-@noindent
-A configuration pragma that establishes the following set of restrictions:
-
-@itemize @bullet
-@item No_Abort_Statements
-@item No_Entry_Queue
-@item No_Task_Hierarchy
-@item No_Task_Allocators
-@item No_Dynamic_Priorities
-@item No_Terminate_Alternatives
-@item No_Dynamic_Attachment
-@item No_Protected_Type_Allocators
-@item No_Local_Protected_Objects
-@item No_Requeue_Statements
-@item No_Task_Attributes_Package
-@item Max_Asynchronous_Select_Nesting =  0
-@item Max_Task_Entries =  0
-@item Max_Protected_Entries = 1
-@item Max_Select_Alternatives = 0
-@end itemize
-
-@noindent
-This set of restrictions causes the automatic selection of a simplified
-version of the run time that provides improved performance for the
-limited set of tasking functionality permitted by this set of restrictions.
-
 @node Pragma Restriction_Warnings
 @unnumberedsec Pragma Restriction_Warnings
 @findex Restriction_Warnings
@@ -6031,7 +6060,7 @@ restrictions to produce a more efficient implementation.
 GNAT currently takes advantage of these restrictions by providing an optimized
 run time when the Ravenscar profile and the GNAT restricted run time set
 of restrictions are specified.  See pragma @code{Profile (Ravenscar)} and
-pragma @code{Restricted_Run_Time} for more details.
+pragma @code{Profile (Restricted)} for more details.
 
 @cindex Time, monotonic
 @unnumberedsec D.8(47-49): Monotonic Time
@@ -6975,7 +7004,10 @@ of exceptions when they are declared.
 This restriction ensures that the generated code does not contain any
 implicit conditionals, either by modifying the generated code where possible,
 or by rejecting any construct that would otherwise generate an implicit
-conditional.
+conditional. Note that this check does not include run time constraint
+checks, which on some targets may generate implicit conditionals as
+well. To control the latter, constraint checks can be suppressed in the
+normal manner.
 
 @item No_Implicit_Dynamic_Code
 @findex No_Implicit_Dynamic_Code
@@ -14196,6 +14228,47 @@ sequential elaboration of all its declarations. The computed values of
 attributes and variables in the project are then used to establish the
 environment in which the gnat tool will execute.
 
+@node Obsolescent Features
+@chapter Obsolescent Features
+
+@noindent
+This chapter describes features that are provided by GNAT, but are
+considered obsolescent since there are preferred ways of achieving
+the same effect. These features are provided solely for historical
+compatibility purposes.
+
+@menu
+* pragma No_Run_Time::
+* pragma Ravenscar::
+* pragma Restricted_Run_Time::
+@end menu
+
+@node pragma No_Run_Time
+@section pragma No_Run_Time
+
+The pragma @code{No_Run_Time} is used to achieve an affect similar
+to the use of the "Zero Foot Print" configurable run time, but without
+requiring a specially configured run time. The result of using this
+pragma, which must be used for all units in a partition, is to restrict
+the use of any language features requiring run-time support code. The
+preferred usage is to use an appropriately configured run-time that
+includes just those features that are to be made accessible.
+
+@node pragma Ravenscar
+@section pragma Ravenscar
+
+The pragma @code{Ravenscar} has exactly the same effect as pragma
+@code{Profile (Ravenscar)}. The latter usage is preferred since it
+is part of the new Ada 2005 standard.
+
+@node pragma Restricted_Run_Time
+@section pragma Restricted_Run_Time
+
+The pragma @code{Restricted_Run_Time} has exactly the same effect as
+pragma @code{Profile (Restricted)}. The latter usage is
+preferred since the Ada 2005 pragma @code{Profile} is intended for
+this kind of implementation dependent addition.
+
 @include fdl.texi
 @c GNU Free Documentation License
 
index 4162ea2..640f74d 100644 (file)
 @setfilename gnat_ugn_unw.info
 @end ifset
 
+@set FSFEDITION
+@set EDITION GNAT
+
+@ifset unw
+@set PLATFORM Unix and Windows
+@set FILE gnat_ugn_unw
+@end ifset
+
 @ifset vms
-@settitle GNAT User's Guide for Native Platforms / OpenVMS Alpha
-@dircategory GNU Ada tools
-@direntry
-* GNAT User's Guide (gnat_ugn_vms) for Native Platforms / OpenVMS Alpha
-@end direntry
+@set PLATFORM OpenVMS Alpha
+@set FILE gnat_ugn_vms
 @end ifset
 
-@ifset unw
-@settitle GNAT User's Guide for Native Platforms / Unix and Windows
+
+
+@settitle @value{EDITION} User's Guide for Native Platforms / @value{PLATFORM}
+@dircategory GNU Ada tools
 @direntry
-* GNAT User's Guide (gnat_ugn_unw) for Native Platforms / Unix and Windows
+* @value{EDITION} User's Guide (@value{FILE}) for Native Platforms / @value{PLATFORM}
 @end direntry
-@end ifset
 
 @include gcc-common.texi
 
@@ -114,12 +120,7 @@ under the terms of the GNU Free Documentation License, Version 1.2
 or any later version published by the Free Software Foundation;
 with the Invariant Sections being ``GNU Free Documentation License'', with the
 Front-Cover Texts being
-@ifset vms
-``GNAT User's Guide for Native Platforms / OpenVMS Alpha'',
-@end ifset
-@ifset unw
-``GNAT User's Guide for Native Platforms / Unix and Windows'',
-@end ifset
+``GNAT User's Guide for Native Platforms / @value{PLATFORM}'',
 and with no Back-Cover Texts.
 A copy of the license is included in the section entitled
 ``GNU Free Documentation License''.
@@ -127,17 +128,12 @@ A copy of the license is included in the section entitled
 
 @titlepage
 
-@title GNAT User's Guide
+@title @value{EDITION} User's Guide
 @center @titlefont{for Native Platforms}
 @sp 1
 
 @flushright
-@ifset unw
-@titlefont{@i{Unix and Windows}}
-@end ifset
-@ifset vms
-@titlefont{@i{OpenVMS Alpha}}
-@end ifset
+@titlefont{@i{@value{PLATFORM}}}
 @end flushright
 @sp 2
 
@@ -156,17 +152,10 @@ A copy of the license is included in the section entitled
 
 @ifnottex
 @node Top, About This Guide, (dir), (dir)
-@top GNAT User's Guide
-
-@ifset vms
-@noindent
-GNAT User's Guide for Native Platforms / OpenVMS Alpha
-@end ifset
+@top @value{EDITION} User's Guide
 
-@ifset unw
 @noindent
-GNAT User's Guide for Native Platforms / Unix and Windows
-@end ifset
+@value{EDITION} User's Guide for Native Platforms / @value{PLATFORM}
 
 @noindent
 GNAT, The GNU Ada 95 Compiler@*
@@ -643,16 +632,25 @@ Microsoft Windows Topics
 
 @noindent
 @ifset vms
-This guide describes the use of of GNAT, a full language compiler for the Ada
+This guide describes the use of of @value{EDITION},
+a full language compiler for the Ada
 95 programming language, implemented on HP OpenVMS Alpha platforms.
 @end ifset
 @ifclear vms
-This guide describes the use of GNAT, a compiler and software development
+This guide describes the use of @value{EDITION},
+a compiler and software development
 toolset for the full Ada 95 programming language.
 @end ifclear
 It describes the features of the compiler and tools, and details
 how to use them to build Ada 95 applications.
 
+@ifset PROEDITION
+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::
@@ -26123,6 +26121,8 @@ platforms (NT, 2000, and XP Professional).
 * Introduction to Dynamic Link Libraries (DLLs)::
 * Using DLLs with GNAT::
 * Building DLLs with GNAT::
+* Building DLLs with GNAT Project files::
+* Building DLLs with gnatdll::
 * GNAT and Windows Resources::
 * Debugging a DLL::
 * GNAT and COM/DCOM Objects::
@@ -26503,13 +26503,14 @@ slower since, as you will understand below, such calls are indirect.
 
 To illustrate the remainder of this section, suppose that an application
 wants to use the services of a DLL @file{API.dll}. To use the services
-provided by @file{API.dll} you must statically link against an import
-library which contains a jump table with an entry for each routine and
-variable exported by the DLL. In the Microsoft world this import library is
-called @file{API.lib}. When using GNAT this import library is called either
-@file{libAPI.a} or @file{libapi.a} (names are case insensitive).
-
-After you have statically linked your application with the import library
+provided by @file{API.dll} you must statically link against the DLL or
+an import library which contains a jump table with an entry for each
+routine and variable exported by the DLL. In the Microsoft world this
+import library is called @file{API.lib}. When using GNAT this import
+library is called either @file{libAPI.a} or @file{libapi.a} (names are
+case insensitive).
+
+After you have linked your application with the DLL or the import library
 and you run your application, here is what happens:
 
 @enumerate
@@ -26537,9 +26538,10 @@ routines and routines in the application using the DLL.
 @end itemize
 
 @item
-The entries in the @file{libAPI.a} or @file{API.lib} jump table which is
-part of your application are initialized with the addresses of the routines
-and variables in @file{API.dll}.
+The entries in the jump table (from the import library @file{libAPI.a}
+or @file{API.lib} or automatically created when linking against a DLL)
+which is part of your application are initialized with the addresses
+of the routines and variables in @file{API.dll}.
 
 @item
 If present in @file{API.dll}, routines @code{DllMain} or
@@ -26564,8 +26566,8 @@ still be relocated.
 As a side note, an interesting difference between Microsoft DLLs and
 Unix shared libraries, is the fact that on most Unix systems all public
 routines are exported by default in a Unix shared library, while under
-Windows the exported routines must be listed explicitly in a definition
-file (@pxref{The Definition File}).
+Windows it is possible (but not required) to list exported routines in
+a definition file (@pxref{The Definition File}).
 
 @node Using DLLs with GNAT
 @section Using DLLs with GNAT
@@ -26590,7 +26592,8 @@ The import library (@file{libAPI.a} or @file{API.lib}). As previously
 mentioned an import library is a statically linked library containing the
 import table which will be filled at load time to point to the actual
 @file{API.dll} routines. Sometimes you don't have an import library for the
-DLL you want to use. The following sections will explain how to build one.
+DLL you want to use. The following sections will explain how to build
+one. Note that this is optional.
 
 @item
 The actual DLL, @file{API.dll}.
@@ -26685,7 +26688,9 @@ subprograms, the @code{DLL} convention is a synonym of @code{Stdcall}
 @noindent
 If a Microsoft-style import library @file{API.lib} or a GNAT-style
 import library @file{libAPI.a} is available with @file{API.dll} you
-can skip this section. Otherwise read on.
+can skip this section. You can also skip this section if
+@file{API.dll} is built with GNU tools as in this case it is possible
+to link directly against the DLL. Otherwise read on.
 
 @node The Definition File
 @subsubsection The Definition File
@@ -26850,6 +26855,75 @@ See the Microsoft documentation for further details about the usage of
 @section Building DLLs with GNAT
 @cindex DLLs, building
 
+@noindent
+This section explain how to build DLLs using the GNAT built-in DLL
+support. With the following procedure it is straight forward to build
+and use DLLs with GNAT.
+
+@enumerate
+
+@item building object files
+
+The first step is to build all objects files that are to be included
+into the DLL. This is done by using the standard @code{gnatmake} tool.
+
+@item building the DLL
+
+To build the DLL you must use @code{gcc}'s @code{-shared}
+option. It is quite simple to use this method:
+
+@smallexample
+$ gcc -shared -o api.dll obj1.o obj2.o ...
+@end smallexample
+
+It is important to note that in this case all symbols found in the
+object files are automatically exported. It is possible to restrict
+the set of symbols to export by passing to @code{gcc} a definition
+file, @pxref{The Definition File}. For example:
+
+@smallexample
+$ gcc -shared -o api.dll api.def obj1.o obj2.o ...
+@end smallexample
+
+If you use a definition file you must export the elaboration procedures
+for every package that required one. Elaboration procedures are named
+using the package name followed by "_E".
+
+@item preparing DLL to be used
+
+For the DLL to be used by client programs the bodies must be hidden
+from it and the .ali set with read-only attribute. This is very important
+otherwise GNAT will recompile all packages and will not actually use
+the code in the DLL. For example:
+
+@smallexample
+$ mkdir apilib
+$ copy *.ads *.ali api.dll apilib
+$ attrib +R apilib\*.ali
+@end smallexample
+
+@end enumerate
+
+At this point it is possible to use the DLL by directly linking
+against it. Note that you must use the GNAT shared runtime when using
+GNAT shared libraries. This is achieved by using @code{-shared} binder's
+option.
+
+@smallexample
+$ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI
+@end smallexample
+
+@node Building DLLs with GNAT Project files
+@section Building DLLs with GNAT Project files
+@cindex DLLs, building
+
+@noindent
+There is nothing specific to Windows in this area. @pxref{Library Projects}.
+
+@node Building DLLs with gnatdll
+@section Building DLLs with gnatdll
+@cindex DLLs, building
+
 @menu
 * Limitations When Using Ada DLLs from Ada::
 * Exporting Ada Entities::
@@ -26861,8 +26935,13 @@ See the Microsoft documentation for further details about the usage of
 @end menu
 
 @noindent
-This section explains how to build DLLs containing Ada code. These DLLs
-will be referred to as Ada DLLs in the remainder of this section.
+Note that it is prefered to use the built-in GNAT DLL support
+(@pxref{Building DLLs with GNAT}) or GNAT Project files
+(@pxref{Building DLLs with GNAT Project files}) to build DLLs.
+
+This section explains how to build DLLs containing Ada code using
+@code{gnatdll}. These DLLs will be referred to as Ada DLLs in the
+remainder of this section.
 
 The steps required to build an Ada DLL that is to be used by Ada as well as
 non-Ada applications are as follows:
index fc1996f..5d30a57 100644 (file)
@@ -29,6 +29,7 @@
 with ALI;      use ALI;
 with Gnatvsn;  use Gnatvsn;
 with Hostparm;
+with Indepsw;  use Indepsw;
 with Namet;    use Namet;
 with Opt;
 with Osint;    use Osint;
@@ -157,6 +158,10 @@ procedure Gnatlink is
    Compile_Bind_File : Boolean := True;
    --  Set to False if bind file is not to be compiled
 
+   Create_Map_File : Boolean := False;
+   --  Set to True by switch -M. The map file name is derived from
+   --  the ALI file name (mainprog.ali => mainprog.map).
+
    Object_List_File_Supported : Boolean;
    pragma Import
      (C, Object_List_File_Supported, "__gnat_objlist_file_supported");
@@ -327,6 +332,21 @@ procedure Gnatlink is
                   Binder_Options.Table (Binder_Options.Last) :=
                     Linker_Options.Table (Linker_Options.Last);
 
+               elsif Arg'Length >= 3 and then Arg (2) = 'M' then
+                  declare
+                     Switches : String_List_Access;
+                  begin
+                     Convert (Map_File, Arg (3 .. Arg'Last), Switches);
+
+                     if Switches /= null then
+                        for J in Switches'Range loop
+                           Linker_Options.Increment_Last;
+                           Linker_Options.Table (Linker_Options.Last) :=
+                             Switches (J);
+                        end loop;
+                     end if;
+                  end;
+
                elsif Arg'Length = 2 then
                   case Arg (2) is
                      when 'A' =>
@@ -377,6 +397,9 @@ procedure Gnatlink is
                              ("Object list file not supported on this target");
                         end if;
 
+                     when 'M' =>
+                        Create_Map_File := True;
+
                      when 'n' =>
                         Compile_Bind_File := False;
 
@@ -1287,6 +1310,12 @@ procedure Gnatlink is
       Write_Line ("  -o nam     Use 'nam' as the name of the executable");
       Write_Line ("  -b target  Compile the binder source to run on target");
       Write_Line ("  -Bdir      Load compiler executables from dir");
+
+      if Is_Supported (Map_File) then
+         Write_Line ("  -Mmap      Create map file map");
+         Write_Line ("  -M         Create map file mainprog.map");
+      end if;
+
       Write_Line ("  --GCC=comp Use comp as the compiler");
       Write_Line ("  --LINK=nam Use 'nam' for the linking rather than 'gcc'");
       Write_Eol;
@@ -1492,6 +1521,25 @@ begin
                    & """ may conflict with shell command");
    end if;
 
+   --  If -M switch was specified, add the switches to create the map file
+
+   if Create_Map_File then
+      declare
+         Map_Name : constant String := Base_Name (Ali_File_Name.all) & ".map";
+         Switches : String_List_Access;
+
+      begin
+         Convert (Map_File, Map_Name, Switches);
+
+         if Switches /= null then
+            for J in Switches'Range loop
+               Linker_Options.Increment_Last;
+               Linker_Options.Table (Linker_Options.Last) := Switches (J);
+            end loop;
+         end if;
+      end;
+   end if;
+
    --  Perform consistency checks
 
    --  Transform the .ali file name into the binder output file name
diff --git a/gcc/ada/indepsw-aix.adb b/gcc/ada/indepsw-aix.adb
new file mode 100644 (file)
index 0000000..bdff971
--- /dev/null
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              I N D E P S W                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                              (AIX version)                               --
+--                                                                          --
+--            Copyright (C) 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- --
+-- 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.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the AIX version
+
+package body Indepsw is
+
+   Map_Switch : aliased constant String := "-Wl,-b,map:";
+
+   -------------
+   -- Convert --
+   -------------
+
+   procedure Convert
+     (Switch   : Switch_Kind;
+      Argument : String;
+      To       : out String_List_Access)
+   is
+   begin
+      case Switch is
+         when Map_File =>
+            To := new Argument_List'(1 => new String'(Map_Switch & Argument));
+      end case;
+   end Convert;
+
+   ------------------
+   -- Is_Supported --
+   ------------------
+
+   function Is_Supported (Switch : Switch_Kind) return Boolean is
+   begin
+      case Switch is
+         when Map_File =>
+            return True;
+      end case;
+   end Is_Supported;
+
+end Indepsw;
diff --git a/gcc/ada/indepsw-linux.adb b/gcc/ada/indepsw-linux.adb
new file mode 100644 (file)
index 0000000..74538a8
--- /dev/null
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              I N D E P S W                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                            (GNU/Linux version)                           --
+--                                                                          --
+--            Copyright (C) 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- --
+-- 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.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the GNU/Linux version
+
+package body Indepsw is
+
+   Map_Switch : aliased constant String := "-Wl,-Map,";
+
+   -------------
+   -- Convert --
+   -------------
+
+   procedure Convert
+     (Switch   : Switch_Kind;
+      Argument : String;
+      To       : out String_List_Access)
+   is
+   begin
+      case Switch is
+         when Map_File =>
+            To := new Argument_List'(1 => new String'(Map_Switch & Argument));
+      end case;
+   end Convert;
+
+   ------------------
+   -- Is_Supported --
+   ------------------
+
+   function Is_Supported (Switch : Switch_Kind) return Boolean is
+   begin
+      case Switch is
+         when Map_File =>
+            return True;
+      end case;
+   end Is_Supported;
+
+end Indepsw;
diff --git a/gcc/ada/indepsw-mingw.adb b/gcc/ada/indepsw-mingw.adb
new file mode 100644 (file)
index 0000000..bf59151
--- /dev/null
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              I N D E P S W                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                            (Windows version)                             --
+--                                                                          --
+--            Copyright (C) 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- --
+-- 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.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the Windows version
+
+package body Indepsw is
+
+   Map_Switch : aliased constant String := "-Wl,-Map,";
+
+   -------------
+   -- Convert --
+   -------------
+
+   procedure Convert
+     (Switch   : Switch_Kind;
+      Argument : String;
+      To       : out String_List_Access)
+   is
+   begin
+      case Switch is
+         when Map_File =>
+            To := new Argument_List'(1 => new String'(Map_Switch & Argument));
+      end case;
+   end Convert;
+
+   ------------------
+   -- Is_Supported --
+   ------------------
+
+   function Is_Supported (Switch : Switch_Kind) return Boolean is
+   begin
+      case Switch is
+         when Map_File =>
+            return True;
+      end case;
+   end Is_Supported;
+
+end Indepsw;
diff --git a/gcc/ada/indepsw.adb b/gcc/ada/indepsw.adb
new file mode 100644 (file)
index 0000000..ce86d2c
--- /dev/null
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              I N D E P S W                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--              Copyright (C) 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- --
+-- 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.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the default version: no switches are supported
+
+with Output; use Output;
+
+package body Indepsw is
+
+   -------------
+   -- Convert --
+   -------------
+
+   procedure Convert
+     (Switch   : Switch_Kind;
+      Argument : String;
+      To       : out String_List_Access)
+   is
+      pragma Unreferenced (Argument);
+   begin
+      case Switch is
+         when others =>
+            Write_Str ("warning: ");
+            Write_Line (No_Support_For (Switch).all);
+            To := null;
+      end case;
+   end Convert;
+
+   ------------------
+   -- Is_Supported --
+   ------------------
+
+   function Is_Supported (Switch : Switch_Kind) return Boolean is
+      pragma Unreferenced (Switch);
+   begin
+      return False;
+   end Is_Supported;
+
+end Indepsw;
diff --git a/gcc/ada/indepsw.ads b/gcc/ada/indepsw.ads
new file mode 100644 (file)
index 0000000..e206515
--- /dev/null
@@ -0,0 +1,84 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              I N D E P S W                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 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- --
+-- 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.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  GNATLINK platform-independent switches
+
+--  Used to convert GNAT switches to their platform-dependent switch
+--  equivalent for the underlying linker.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package Indepsw is
+
+   type Switch_Kind is
+   --  Independent switches currently supported
+
+     (Map_File);
+      --  Produce a map file. The path name of the map file to produce
+      --  is given as an argument.
+
+   procedure Convert
+     (Switch   : Switch_Kind;
+      Argument : String;
+      To       : out String_List_Access);
+   --  Convert Switch to the platform-dependent linker switch (with or without
+   --  additional arguments) To. Issue a warning if Switch is not supported
+   --  for the platform; in this case, To is set to null.
+
+   function Is_Supported (Switch : Switch_Kind) return Boolean;
+   --  Return True for each independent switch supported by the platform.
+
+private
+   --  Default warning messages when the switches are not supported by the
+   --  implementation. These are in the spec so that the platform specific
+   --  bodies do not need to redefine them.
+
+   Map_File_Not_Supported : aliased String :=
+     "the underlying linker does not allow the output of a map file";
+
+   No_Support_For : constant array (Switch_Kind) of String_Access :=
+                      (Map_File => Map_File_Not_Supported'Access);
+   --  All implementations of procedure Convert should include a case
+   --  statements with a "when others =>" choice that output the default
+   --  warning message:
+
+   --   case Switch is
+   --      when ... =>
+   --         ...
+   --      when others =>
+   --         Write_Str ("warning: ");
+   --         Write_Line (No_Support_For (Switch).all);
+   --         To := null;
+   --   end case;
+
+end Indepsw;
index 7f39b00..6b51b32 100644 (file)
@@ -1337,6 +1337,7 @@ package body Makegpr is
 
       Object_Name : Name_Id;
       Time_Stamp  : Time_Stamp_Type;
+      Driver_Name : Name_Id := No_Name;
 
    begin
       Check_Archive_Builder;
@@ -1527,61 +1528,76 @@ package body Makegpr is
 
          Last_Argument := 0;
 
-            --  If there are sources in Ada, then gnatmake will build the
-            --  library, so nothing to do.
+         --  If there are sources in Ada, then gnatmake will build the
+         --  library, so nothing to do.
 
-            if not Data.Languages (Lang_Ada) then
+         if not Data.Languages (Lang_Ada) then
 
-               --  Get all the object files of the project
+            --  Get all the object files of the project
 
-               Source_Id := Data.First_Other_Source;
+            Source_Id := Data.First_Other_Source;
 
-               while Source_Id /= No_Other_Source loop
-                  Source := Other_Sources.Table (Source_Id);
-                  Add_Argument
-                    (Get_Name_String (Source.Object_Name), Verbose_Mode);
-                  Source_Id := Source.Next;
-               end loop;
+            while Source_Id /= No_Other_Source loop
+               Source := Other_Sources.Table (Source_Id);
+               Add_Argument
+                 (Get_Name_String (Source.Object_Name), Verbose_Mode);
+               Source_Id := Source.Next;
+            end loop;
 
-               --  If it is a library, it need to be built it the same way
-               --  Ada libraries are built.
+            --  If it is a library, it need to be built it the same way
+            --  Ada libraries are built.
 
-               if Data.Library_Kind = Static then
-                  MLib.Build_Library
-                    (Ofiles => Arguments (1 .. Last_Argument),
-                     Afiles => No_Argument,
-                     Output_File => Get_Name_String (Data.Library_Name),
-                     Output_Dir  => Get_Name_String (Data.Library_Dir));
+            if Data.Library_Kind = Static then
+               MLib.Build_Library
+                 (Ofiles      => Arguments (1 .. Last_Argument),
+                  Afiles      => No_Argument,
+                  Output_File => Get_Name_String (Data.Library_Name),
+                  Output_Dir  => Get_Name_String (Data.Library_Dir));
 
-               else
-                  MLib.Tgt.Build_Dynamic_Library
-                    (Ofiles       => Arguments (1 .. Last_Argument),
-                     Foreign      => Arguments (1 .. Last_Argument),
-                     Afiles       => No_Argument,
-                     Options      => No_Argument,
-                     Interfaces   => No_Argument,
-                     Lib_Filename => Get_Name_String (Data.Library_Name),
-                     Lib_Dir      => Get_Name_String (Data.Library_Dir),
-                     Symbol_Data  => No_Symbols,
-                     Driver_Name  => No_Name,
-                     Lib_Version  => "",
-                     Auto_Init    => False);
+            else
+               --  Link with g++ if C++ is one of the languages, otherwise
+               --  building the library may fail with unresolved symbols.
+
+               if C_Plus_Plus_Is_Used then
+                  if Compiler_Names (Lang_C_Plus_Plus) = null then
+                     Get_Compiler (Lang_C_Plus_Plus);
+                  end if;
+
+                  if Compiler_Is_Gcc (Lang_C_Plus_Plus) then
+                     Name_Len := 0;
+                     Add_Str_To_Name_Buffer
+                       (Compiler_Names (Lang_C_Plus_Plus).all);
+                     Driver_Name := Name_Find;
+                  end if;
                end if;
-            end if;
 
-            --  Create fake empty archive, so we can check its time stamp later
+               MLib.Tgt.Build_Dynamic_Library
+                 (Ofiles       => Arguments (1 .. Last_Argument),
+                  Foreign      => Arguments (1 .. Last_Argument),
+                  Afiles       => No_Argument,
+                  Options      => No_Argument,
+                  Interfaces   => No_Argument,
+                  Lib_Filename => Get_Name_String (Data.Library_Name),
+                  Lib_Dir      => Get_Name_String (Data.Library_Dir),
+                  Symbol_Data  => No_Symbols,
+                  Driver_Name  => Driver_Name,
+                  Lib_Version  => "",
+                  Auto_Init    => False);
+            end if;
+         end if;
 
-            declare
-               Archive : Ada.Text_IO.File_Type;
-               use Ada.Text_IO;
-            begin
-               Create (Archive, Out_File, Archive_Name);
-               Close (Archive);
-            end;
+         --  Create fake empty archive, so we can check its time stamp later
 
-            Create_Archive_Dependency_File
-              (Archive_Dep_Name, Data.First_Other_Source);
+         declare
+            Archive : Ada.Text_IO.File_Type;
+            use Ada.Text_IO;
+         begin
+            Create (Archive, Out_File, Archive_Name);
+            Close (Archive);
+         end;
 
+         Create_Archive_Dependency_File
+           (Archive_Dep_Name, Data.First_Other_Source);
       end if;
    end Build_Library;
 
@@ -2539,12 +2555,13 @@ package body Makegpr is
                Need_To_Rebuild_Global_Archive := True;
             end if;
 
-            --  If there was no compilation error, build/rebuild the archive
-            --  if necessary.
+            --  If there was no compilation error and -c was not used,
+            --  build / rebuild the archive if necessary.
 
             if not Local_Errors
               and then Data.Library
               and then not Data.Languages (Lang_Ada)
+              and then not Compile_Only
             then
                Build_Library (Project, Need_To_Rebuild_Archive);
             end if;
@@ -2985,7 +3002,11 @@ package body Makegpr is
          end if;
 
       else
-         --  First compile sources and build archives for library project,
+         --  First check for C++, to link libraries with g++, rather than gcc
+
+         Check_For_C_Plus_Plus;
+
+         --  Compile sources and build archives for library project,
          --  if necessary.
 
          Compile_Sources;
@@ -3000,7 +3021,6 @@ package body Makegpr is
 
          if not Compile_Only then
             Build_Global_Archive;
-            Check_For_C_Plus_Plus;
             Link_Executables;
          end if;
 
index 77295cf..1efebfd 100644 (file)
@@ -121,7 +121,8 @@ package body MLib.Tgt is
       Tools.Gcc
         (Output_File => Lib_File,
          Objects     => Ofiles,
-         Options     => Options,
+         Options     => Tools.No_Argument_List,
+         Options_2   => Options,
          Driver_Name => Driver_Name);
    end Build_Dynamic_Library;
 
index c166baa..53e0853 100644 (file)
@@ -2526,11 +2526,12 @@ package body Prj.Nmsc is
       end if;
 
       if For_Language = Lang_Ada then
-         --  If we have looked for sources and found none, then
-         --  it is an error, except if it is an extending project.
-         --  If a non extending project is not supposed to contain
-         --  any source, then we never call Find_Sources.
-         --  No error either when setting up projects (gnat setup).
+
+         --  If we have looked for sources and found none, then it is an
+         --  error, except if it is an extending project. If a non-extending
+         --  project is not supposed to contain any source, then we never
+         --  Find_Sources. No error is signalled when setting up projects
+         --  using gnat setup.
 
          if Current_Source /= Nil_String then
             Data.Ada_Sources_Present := True;
@@ -3305,9 +3306,8 @@ package body Prj.Nmsc is
                   Object_Dir.Location);
 
             else
-               --  We check that the specified object directory
-               --  does exist, and attempt to create it if setting up projects
-               --  (gnat setup).
+               --  Check that the specified object directory does exist, and
+               --  attempt to create it if setting up projects (gnat setup).
 
                Locate_Directory
                  (Object_Dir.Value, Data.Display_Directory,
@@ -3319,6 +3319,7 @@ package body Prj.Nmsc is
                  and then Data.Object_Directory = No_Name
                then
                   --  The object directory does not exist, report an error
+
                   Err_Vars.Error_Msg_Name_1 := Object_Dir.Value;
                   Error_Msg
                     (Project,
@@ -3326,10 +3327,9 @@ package body Prj.Nmsc is
                      Data.Location);
 
                   --  Do not keep a nil Object_Directory. Set it to the
-                  --  specified (relative or absolute) path.
-                  --  This is for the benefit of tools that recover from
-                  --  errors; for example, these tools could create the
-                  --  non existent directory.
+                  --  specified (relative or absolute) path. This is for the
+                  --  benefit of tools that recover from errors. For example,
+                  --  these tools could create the non-existent directory.
 
                   Data.Display_Object_Dir := Object_Dir.Value;
                   Get_Name_String (Object_Dir.Value);
@@ -3447,10 +3447,10 @@ package body Prj.Nmsc is
 
          elsif Source_Dirs.Values = Nil_String then
 
-            --  If Source_Dirs is an empty string list, this means
-            --  that this project contains no source. For projects that
-            --  don't extend other projects, this also means that there is no
-            --  need for an object directory, if not specified.
+            --  If Source_Dirs is an empty string list, this means that this
+            --  contains no sources. For projects that do not extend other
+            --  projects, this also means that there is no need for an object
+            --  directory unless one is specified explicitly.
 
             if Data.Extends = No_Project
               and then  Data.Object_Directory = Data.Directory
@@ -3531,8 +3531,8 @@ package body Prj.Nmsc is
 
             begin
                --  If the project extended is a library project, we inherit
-               --  the library name, if it is not redefined; we check that
-               --  the library directory is specified; and we reset the
+               --  the library name, if it is not redefined, we check that
+               --  the library directory is specified, and we reset the
                --  library flag for the extended project.
 
                if Extended_Data.Library then
@@ -3773,26 +3773,26 @@ package body Prj.Nmsc is
             --  Check Spec_Suffix
 
             declare
-               Spec_Suffixs : Array_Element_Id :=
-                                Util.Value_Of
-                                  (Name_Spec_Suffix,
-                                   Naming.Decl.Arrays);
+               Spec_Suffixes : Array_Element_Id :=
+                                 Util.Value_Of
+                                   (Name_Spec_Suffix,
+                                    Naming.Decl.Arrays);
                Suffix  : Array_Element_Id;
                Element : Array_Element;
                Suffix2 : Array_Element_Id;
 
             begin
-               --  If some suffixs have been specified, we make sure that
+               --  If some suffixes have been specified, we make sure that
                --  for each language for which a default suffix has been
                --  specified, there is a suffix specified, either the one
                --  in the project file or if there were none, the default.
 
-               if Spec_Suffixs /= No_Array_Element then
+               if Spec_Suffixes /= No_Array_Element then
                   Suffix := Data.Naming.Spec_Suffix;
 
                   while Suffix /= No_Array_Element loop
                      Element := Array_Elements.Table (Suffix);
-                     Suffix2 := Spec_Suffixs;
+                     Suffix2 := Spec_Suffixes;
 
                      while Suffix2 /= No_Array_Element loop
                         exit when Array_Elements.Table (Suffix2).Index =
@@ -3800,9 +3800,8 @@ package body Prj.Nmsc is
                         Suffix2 := Array_Elements.Table (Suffix2).Next;
                      end loop;
 
-                     --  There is a registered default suffix, but no
-                     --  suffix specified in the project file.
-                     --  Add the default to the array.
+                     --  There is a registered default suffix, but no suffix is
+                     --  specified in the project file. Add default to array.
 
                      if Suffix2 = No_Array_Element then
                         Array_Elements.Increment_Last;
@@ -3811,16 +3810,16 @@ package body Prj.Nmsc is
                            Src_Index => Element.Src_Index,
                            Index_Case_Sensitive => False,
                            Value     => Element.Value,
-                           Next      => Spec_Suffixs);
-                        Spec_Suffixs := Array_Elements.Last;
+                           Next      => Spec_Suffixes);
+                        Spec_Suffixes := Array_Elements.Last;
                      end if;
 
                      Suffix := Element.Next;
                   end loop;
 
-                  --  Put the resulting array as the specification suffixs
+                  --  Put the resulting array as the specification suffixes
 
-                  Data.Naming.Spec_Suffix := Spec_Suffixs;
+                  Data.Naming.Spec_Suffix := Spec_Suffixes;
                end if;
             end;
 
@@ -3848,27 +3847,26 @@ package body Prj.Nmsc is
             --  Check Body_Suffix
 
             declare
-               Impl_Suffixs : Array_Element_Id :=
-                                Util.Value_Of
-                                  (Name_Body_Suffix,
-                                   Naming.Decl.Arrays);
+               Impl_Suffixes : Array_Element_Id :=
+                                 Util.Value_Of
+                                   (Name_Body_Suffix, Naming.Decl.Arrays);
 
                Suffix  : Array_Element_Id;
                Element : Array_Element;
                Suffix2 : Array_Element_Id;
 
             begin
-               --  If some suffixs have been specified, we make sure that
+               --  If some suffixes have been specified, we make sure that
                --  for each language for which a default suffix has been
                --  specified, there is a suffix specified, either the one
                --  in the project file or if there were noe, the default.
 
-               if Impl_Suffixs /= No_Array_Element then
+               if Impl_Suffixes /= No_Array_Element then
                   Suffix := Data.Naming.Body_Suffix;
 
                   while Suffix /= No_Array_Element loop
                      Element := Array_Elements.Table (Suffix);
-                     Suffix2 := Impl_Suffixs;
+                     Suffix2 := Impl_Suffixes;
 
                      while Suffix2 /= No_Array_Element loop
                         exit when Array_Elements.Table (Suffix2).Index =
@@ -3887,16 +3885,16 @@ package body Prj.Nmsc is
                            Src_Index => Element.Src_Index,
                            Index_Case_Sensitive => False,
                            Value => Element.Value,
-                           Next  => Impl_Suffixs);
-                        Impl_Suffixs := Array_Elements.Last;
+                           Next  => Impl_Suffixes);
+                        Impl_Suffixes := Array_Elements.Last;
                      end if;
 
                      Suffix := Element.Next;
                   end loop;
 
-                  --  Put the resulting array as the implementation suffixs
+                  --  Put the resulting array as the implementation suffixes
 
-                  Data.Naming.Body_Suffix := Impl_Suffixs;
+                  Data.Naming.Body_Suffix := Impl_Suffixes;
                end if;
             end;
 
index a67cb56..1af7f59 100644 (file)
@@ -675,7 +675,7 @@ package Prj is
       Language_Independent_Checked : Boolean := False;
       --  A flag that indicates that the project file has been checked
       --  for language independent features: Object_Directory,
-      --  Source_Directories, Library, non empty Naming Suffixs.
+      --  Source_Directories, Library, non empty Naming Suffixes.
 
       Checked : Boolean := False;
       --  A flag to avoid checking repetitively the naming scheme of
@@ -732,7 +732,7 @@ package Prj is
      (Language            : Name_Id;
       Default_Spec_Suffix : Name_Id;
       Default_Body_Suffix : Name_Id);
-   --  Register the default suffixs for a given language. These extensions
+   --  Register the default suffixes for a given language. These extensions
    --  will be ignored if the user has specified a new naming scheme in a
    --  project file.
    --
index f88589d..91e8278 100644 (file)
@@ -54,7 +54,7 @@ package body System.Secondary_Stack is
    --  then the secondary stack is allocated statically by grabbing a
    --  section of the primary stack and using it for this purpose.
 
-   type Memory is array (Mark_Id range <>) of SSE.Storage_Element;
+   type Memory is array (SS_Ptr range <>) of SSE.Storage_Element;
    for Memory'Alignment use Standard'Maximum_Alignment;
    --  This is the type used for actual allocation of secondary stack
    --  areas. We require maximum alignment for all such allocations.
@@ -98,16 +98,16 @@ package body System.Secondary_Stack is
    --    +-----------------+               +------------------+
    --
 
-   type Chunk_Id (First, Last : Mark_Id);
+   type Chunk_Id (First, Last : SS_Ptr);
    type Chunk_Ptr is access all Chunk_Id;
 
-   type Chunk_Id (First, Last : Mark_Id) is record
+   type Chunk_Id (First, Last : SS_Ptr) is record
       Prev, Next : Chunk_Ptr;
       Mem        : Memory (First .. Last);
    end record;
 
    type Stack_Id is record
-      Top           : Mark_Id;
+      Top           : SS_Ptr;
       Default_Size  : SSE.Storage_Count;
       Current_Chunk : Chunk_Ptr;
    end record;
@@ -134,16 +134,16 @@ package body System.Secondary_Stack is
    --  by the following data strcuture
 
    type Fixed_Stack_Id is record
-      Top : Mark_Id;
+      Top : SS_Ptr;
       --  Index of next available location in Mem. This is initialized to
       --  0, and then incremented on Allocate, and Decremented on Release.
 
-      Last : Mark_Id;
+      Last : SS_Ptr;
       --  Length of usable Mem array, which is thus the index past the
       --  last available location in Mem. Mem (Last-1) can be used. This
       --  is used to check that the stack does not overflow.
 
-      Max : Mark_Id;
+      Max : SS_Ptr;
       --  Maximum value of Top. Initialized to 0, and then may be incremented
       --  on Allocate, but is never Decremented. The last used location will
       --  be Mem (Max - 1), so Max is the maximum count of used stack space.
@@ -177,9 +177,9 @@ package body System.Secondary_Stack is
      (Addr         : out Address;
       Storage_Size : SSE.Storage_Count)
    is
-      Max_Align    : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
-      Max_Size     : constant Mark_Id :=
-                       ((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align)
+      Max_Align    : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
+      Max_Size     : constant SS_Ptr :=
+                       ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align)
                          * Max_Align;
 
    begin
@@ -256,7 +256,7 @@ package body System.Secondary_Stack is
                   Chunk.Next :=
                     new Chunk_Id
                       (First => Chunk.Last + 1,
-                       Last  => Chunk.Last + Mark_Id (Stack.Default_Size));
+                       Last  => Chunk.Last + SS_Ptr (Stack.Default_Size));
 
                   Chunk.Next.Prev := Chunk;
 
@@ -359,12 +359,12 @@ package body System.Secondary_Stack is
          begin
             Put_Line (
                       "  Total size              : "
-                      & Mark_Id'Image (Fixed_Stack.Last)
+                      & SS_Ptr'Image (Fixed_Stack.Last)
                       & " bytes");
 
             Put_Line (
                       "  Current allocated space : "
-                      & Mark_Id'Image (Fixed_Stack.Top - 1)
+                      & SS_Ptr'Image (Fixed_Stack.Top - 1)
                       & " bytes");
          end;
 
@@ -391,12 +391,12 @@ package body System.Secondary_Stack is
 
             Put_Line (
                       "  Total size              : "
-                      & Mark_Id'Image (Chunk.Last)
+                      & SS_Ptr'Image (Chunk.Last)
                       & " bytes");
 
             Put_Line (
                       "  Current allocated space : "
-                      & Mark_Id'Image (Stack.Top - 1)
+                      & SS_Ptr'Image (Stack.Top - 1)
                       & " bytes");
 
             Put_Line (
@@ -434,7 +434,7 @@ package body System.Secondary_Stack is
                Fixed_Stack.Last := 0;
             else
                Fixed_Stack.Last :=
-                 Mark_Id (Size) - Dummy_Fixed_Stack.Mem'Position;
+                 SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position;
             end if;
          end;
 
@@ -445,7 +445,7 @@ package body System.Secondary_Stack is
             Stack : Stack_Ptr;
          begin
             Stack               := new Stack_Id;
-            Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size));
+            Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size));
             Stack.Top           := 1;
             Stack.Default_Size  := SSE.Storage_Count (Size);
             Stk := To_Addr (Stack);
@@ -458,11 +458,12 @@ package body System.Secondary_Stack is
    -------------
 
    function SS_Mark return Mark_Id is
+      Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all;
    begin
       if SS_Ratio_Dynamic then
-         return To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top;
+         return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top);
       else
-         return To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top;
+         return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top);
       end if;
    end SS_Mark;
 
@@ -473,9 +474,9 @@ package body System.Secondary_Stack is
    procedure SS_Release (M : Mark_Id) is
    begin
       if SS_Ratio_Dynamic then
-         To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+         To_Stack_Ptr (M.Sstk).Top := M.Sptr;
       else
-         To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+         To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr;
       end if;
    end SS_Release;
 
@@ -491,7 +492,7 @@ package body System.Secondary_Stack is
    Stack : aliased Stack_Id;
    for Stack'Alignment use Standard'Maximum_Alignment;
 
-   Chunk : aliased Chunk_Id (1, Mark_Id (Default_Secondary_Stack_Size));
+   Chunk : aliased Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size));
    for Chunk'Alignment use Standard'Maximum_Alignment;
 
    Chunk_Address : Address;
index 12bcd65..ad2b34e 100644 (file)
@@ -73,7 +73,7 @@ package System.Secondary_Stack is
    --  to System.Null_Address.
 
    type Mark_Id is private;
-   --  Type used to mark the stack
+   --  Type used to mark the stack for mark/release processing
 
    function SS_Mark return Mark_Id;
    --  Return the Mark corresponding to the current state of the stack
@@ -102,6 +102,15 @@ private
    --  Unused entity that is just present to ease the sharing of the pool
    --  mechanism for specific allocation/deallocation in the compiler
 
-   type Mark_Id is new SSE.Integer_Address;
+   type SS_Ptr is new SSE.Integer_Address;
+   --  Stack pointer value for secondary stack
+
+   type Mark_Id is record
+      Sstk : System.Address;
+      Sptr : SS_Ptr;
+   end record;
+   --  A mark value contains the address of the secondary stack structure,
+   --  as returned by System.Soft_Links.Get_Sec_Stack_Addr, and a stack
+   --  pointer value corresponding to the point of the mark call.
 
 end System.Secondary_Stack;
index 4144acc..79c1b36 100644 (file)
@@ -31,8 +31,6 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
---  This package contains the tasking versions soft links.
-
 pragma Style_Checks (All_Checks);
 --  Turn off subprogram alpha ordering check, since we group soft link
 --  bodies and dummy soft link bodies together separately in this unit.
@@ -59,9 +57,9 @@ package body System.Soft_Links.Tasking is
    --  Boolean flag that indicates whether the tasking soft links have
    --  already been set.
 
-   ----------------------------------------------------------------------
-   -- Tasking versions of some services needed by non-tasking programs --
-   ----------------------------------------------------------------------
+   -----------------------------------------------------------------
+   -- Tasking Versions of Services Needed by Non-Tasking Programs --
+   -----------------------------------------------------------------
 
    function  Get_Jmpbuf_Address return  Address;
    procedure Set_Jmpbuf_Address (Addr : Address);
@@ -131,10 +129,10 @@ package body System.Soft_Links.Tasking is
 
    procedure Init_Tasking_Soft_Links is
    begin
-      --  If the tasking soft links have already been initialized do not
-      --  repeat it.
+      --  Set links only if not set already
 
       if not Initialized then
+
          --  Mark tasking soft links as initialized
 
          Initialized := True;
@@ -158,7 +156,6 @@ package body System.Soft_Links.Tasking is
          SSL.Set_Jmpbuf_Address     (SSL.Get_Jmpbuf_Address_NT);
          SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
       end if;
-
    end Init_Tasking_Soft_Links;
 
 end System.Soft_Links.Tasking;
index 1b9dae4..70252ca 100644 (file)
@@ -34,8 +34,7 @@
 --  This package contains the tasking versions soft links that are common
 --  to the full and the restricted run times. The rest of the required soft
 --  links are set by System.Tasking.Initialization and System.Tasking.Stages
---  (full run time) or System.Tasking.Restricted.Stages (restricted run
---  time).
+--  (full run time) or System.Tasking.Restricted.Stages (restricted run time).
 
 package System.Soft_Links.Tasking is
 
diff --git a/gcc/ada/s-vxwork-x86.ads b/gcc/ada/s-vxwork-x86.ads
new file mode 100644 (file)
index 0000000..11a3bce
--- /dev/null
@@ -0,0 +1,53 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                 GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS              --
+--                                                                          --
+--                        S Y S T E M . V X W O R K S                       --
+--                                                                          --
+--                                   S p e c                                --
+--                                                                          --
+--            Copyright (C) 1998-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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion. GNARL 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 GNARL; 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.                                      --
+--                                                                          --
+-- GNARL was developed by the GNARL team at Florida State University.       --
+-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the x86 VxWorks version of this package
+
+package System.VxWorks is
+   pragma Preelaborate (System.VxWorks);
+
+   --  Floating point context record. x86 version
+
+   --  For now this is a dummy implementation (more work needed ???)
+
+   type FP_CONTEXT is record
+      Dummy : Integer;
+   end record;
+
+   for FP_CONTEXT'Alignment use 4;
+   pragma Convention (C, FP_CONTEXT);
+
+   Num_HW_Interrupts : constant := 256;
+   --  Number of entries in hardware interrupt vector table
+
+end System.VxWorks;
index c1b018d..b69e967 100644 (file)
@@ -3306,10 +3306,23 @@ package body Sem_Attr is
       when Attribute_Size | Attribute_VADS_Size =>
          Check_E0;
 
-         if Is_Object_Reference (P)
-           or else (Is_Entity_Name (P)
-                     and then Ekind (Entity (P)) = E_Function)
+         --  If prefix is parameterless function call, rewrite and resolve
+         --  as such.
+
+         if Is_Entity_Name (P)
+           and then Ekind (Entity (P)) = E_Function
          then
+            Resolve (P);
+
+         --  Similar processing for a protected function call
+
+         elsif Nkind (P) = N_Selected_Component
+           and then Ekind (Entity (Selector_Name (P))) = E_Function
+         then
+            Resolve (P);
+         end if;
+
+         if Is_Object_Reference (P) then
             Check_Object_Reference (P);
 
          elsif Is_Entity_Name (P)
@@ -6566,15 +6579,16 @@ package body Sem_Attr is
                   --  outside a generic body when the subprogram is declared
                   --  within that generic body.
 
-                  elsif Enclosing_Generic_Body (Entity (P))
-                    /= Enclosing_Generic_Body (Btyp)
+                  elsif Present (Enclosing_Generic_Body (Entity (P)))
+                    and then Enclosing_Generic_Body (Entity (P)) /=
+                             Enclosing_Generic_Body (Btyp)
                   then
                      Error_Msg_N
                        ("access type must not be outside generic body", P);
                   end if;
                end if;
 
-               --  if this is a renaming, an inherited operation, or a
+               --  If this is a renaming, an inherited operation, or a
                --  subprogram instance, use the original entity.
 
                if Is_Entity_Name (P)
@@ -6603,7 +6617,8 @@ package body Sem_Attr is
 
             elsif Is_Overloaded (P) then
 
-               --  Use the designated type of the context  to disambiguate.
+               --  Use the designated type of the context  to disambiguate
+
                declare
                   Index : Interp_Index;
                   It    : Interp;
@@ -7263,7 +7278,6 @@ package body Sem_Attr is
       --  Finally perform static evaluation on the attribute reference
 
       Eval_Attribute (N);
-
    end Resolve_Attribute;
 
 end Sem_Attr;
index e2918ae..5eafc79 100644 (file)
@@ -479,7 +479,6 @@ package body Sem_Ch11 is
             Rewrite (N, Make_Null_Statement (Sloc (N)));
          end if;
       end if;
-
    end Analyze_Raise_xxx_Error;
 
    -----------------------------
index 4e05bd4..2e0534a 100644 (file)
@@ -8178,6 +8178,26 @@ package body Sem_Ch12 is
       else
          Act_T := Entity (Actual);
 
+         --  Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
+         --  as a generic actual parameter if the corresponding formal type
+         --  does not have a known_discriminant_part, or is a formal derived
+         --  type that is an Unchecked_Union type.
+
+         if Is_Unchecked_Union (Base_Type (Act_T)) then
+            if not Has_Discriminants (A_Gen_T)
+                     or else
+                   (Is_Derived_Type (A_Gen_T)
+                     and then
+                    Is_Unchecked_Union (A_Gen_T))
+            then
+               null;
+            else
+               Error_Msg_N ("Unchecked_Union cannot be the actual for a" &
+                 " discriminated formal type", Act_T);
+
+            end if;
+         end if;
+
          --  Deal with fixed/floating restrictions
 
          if Is_Floating_Point_Type (Act_T) then
index b7dc0a7..670ee76 100644 (file)
@@ -950,6 +950,63 @@ package body Sem_Ch3 is
       T  : Entity_Id;
       P  : Entity_Id;
 
+      function Contains_POC (Constr : Node_Id) return Boolean;
+      --  Determines whether a constraint uses the discriminant of a record
+      --  type thus becoming a per-object constraint (POC).
+
+      ------------------
+      -- Contains_POC --
+      ------------------
+
+      function Contains_POC (Constr : Node_Id) return Boolean is
+      begin
+         case Nkind (Constr) is
+
+            when N_Attribute_Reference =>
+               return Attribute_Name (Constr) = Name_Access
+                        and
+                      Prefix (Constr) = Scope (Entity (Prefix (Constr)));
+
+            when N_Discriminant_Association =>
+               return Denotes_Discriminant (Expression (Constr));
+
+            when N_Identifier =>
+               return Denotes_Discriminant (Constr);
+
+            when N_Index_Or_Discriminant_Constraint =>
+               declare
+                  IDC : Node_Id := First (Constraints (Constr));
+               begin
+                  while Present (IDC) loop
+
+                     --  One per-object constraint is sufficent
+
+                     if Contains_POC (IDC) then
+                        return True;
+                     end if;
+
+                     Next (IDC);
+                  end loop;
+
+                  return False;
+               end;
+
+            when N_Range =>
+               return Denotes_Discriminant (Low_Bound (Constr))
+                        or
+                      Denotes_Discriminant (High_Bound (Constr));
+
+            when N_Range_Constraint =>
+               return Denotes_Discriminant (Range_Expression (Constr));
+
+            when others =>
+               return False;
+
+         end case;
+      end Contains_POC;
+
+   --  Start of processing for Analyze_Component_Declaration
+
    begin
       Generate_Definition (Id);
       Enter_Name (Id);
@@ -1042,6 +1099,24 @@ package body Sem_Ch3 is
       Set_Etype (Id, T);
       Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N)));
 
+      --  The component declaration may have a per-object constraint, set the
+      --  appropriate flag in the defining identifier of the subtype.
+
+      if Present (Subtype_Indication (Component_Definition (N))) then
+         declare
+            Sindic : constant Node_Id :=
+               Subtype_Indication (Component_Definition (N));
+
+         begin
+            if Nkind (Sindic) = N_Subtype_Indication
+              and then Present (Constraint (Sindic))
+              and then Contains_POC (Constraint (Sindic))
+            then
+               Set_Has_Per_Object_Constraint (Id);
+            end if;
+         end;
+      end if;
+
       --  Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
       --  out some static checks
 
@@ -9492,9 +9567,6 @@ package body Sem_Ch3 is
 
          return;
 
-      elsif Is_Unchecked_Union (Parent_Type) then
-         Error_Msg_N ("cannot derive from Unchecked_Union type", N);
-
       --  Ada 2005 (AI-231): Static check
 
       elsif Is_Access_Type (Parent_Type)
@@ -12581,13 +12653,6 @@ package body Sem_Ch3 is
          P := Parent (S);
          Subtype_Mark_Id := Entity (Subtype_Mark (S));
 
-         if Is_Unchecked_Union (Subtype_Mark_Id)
-           and then Comes_From_Source (Related_Nod)
-         then
-            Error_Msg_N
-              ("cannot create subtype of Unchecked_Union", Related_Nod);
-         end if;
-
          --  Explicit subtype declaration case
 
          if Nkind (P) = N_Subtype_Declaration then
index 3831b67..e8cdf00 100644 (file)
@@ -2590,7 +2590,7 @@ package body Sem_Ch4 is
                Set_Etype (Sel, Etype (Comp));
 
                if Ekind (Comp) = E_Discriminant then
-                  if Is_Unchecked_Union (Prefix_Type) then
+                  if Is_Unchecked_Union (Base_Type (Prefix_Type)) then
                      Error_Msg_N
                        ("cannot reference discriminant of Unchecked_Union",
                         Sel);
@@ -4653,13 +4653,14 @@ package body Sem_Ch4 is
    --------------------------
 
    function Try_Object_Operation (N : Node_Id) return Boolean is
-      Obj        : constant Node_Id := Prefix (N);
-      Obj_Type   : Entity_Id;
-      Actual     : Node_Id;
-      Last_Node  : Node_Id;
-      --  Last_Node is used to free all the nodes generated while trying the
-      --  alternatives. NOTE: This must be removed because it is considered
-      --  too low level
+      Obj       : constant Node_Id := Prefix (N);
+      Obj_Type  : Entity_Id;
+      Actual    : Node_Id;
+
+      Last_Node : Node_Id;
+      --  Used to free all the nodes generated while trying the alternatives.
+      --  To me removed later, too low level ???
+
       use Atree_Private_Part;
 
       function Try_Replacement
@@ -4673,21 +4674,23 @@ package body Sem_Ch4 is
       --  Nam_Ent is the entity that provides the formals against which
       --  the actuals are checked. If the actuals are compatible with
       --  Ent_Nam, this function returns true.
+      --  Document other parameters, also what is Ent_Nam???
 
       function Try_Primitive_Operations
         (New_Prefix : Entity_Id;
          New_Subprg : Node_Id;
          Obj        : Node_Id;
          Obj_Type   : Entity_Id) return Boolean;
-      --  Traverse the list of primitive subprograms to look for the
+      --  Traverse list of primitive subprograms to look for the subprogram
+      --  Parameters should be documented ???
       --  subprogram.
 
       function Try_Class_Wide_Operation
         (New_Subprg : Node_Id;
          Obj        : Node_Id;
          Obj_Type   : Entity_Id) return Boolean;
-      --  Traverse all the ancestor types to look for a class-wide
-      --  subprogram
+      --  Traverse all the ancestor types to look for a class-wide subprogram
+      --  Parameters should be documented ???
 
       ------------------------------
       -- Try_Primitive_Operations --
@@ -4699,9 +4702,9 @@ package body Sem_Ch4 is
          Obj        : Node_Id;
          Obj_Type   : Entity_Id) return Boolean
       is
-         Deref      : Node_Id;
-         Elmt       : Elmt_Id;
-         Prim_Op    : Entity_Id;
+         Deref   : Node_Id;
+         Elmt    : Elmt_Id;
+         Prim_Op : Entity_Id;
 
       begin
          --  Look for the subprogram in the list of primitive operations.
@@ -4711,7 +4714,6 @@ package body Sem_Ch4 is
          --  analysis after the node replacement will resolve it.
 
          Elmt := First_Elmt (Primitive_Operations (Obj_Type));
-
          while Present (Elmt) loop
             Prim_Op := Node (Elmt);
 
@@ -4754,19 +4756,19 @@ package body Sem_Ch4 is
          Obj        : Node_Id;
          Obj_Type   : Entity_Id) return Boolean
       is
-         Deref      : Node_Id;
-         Hom        : Entity_Id;
-         Typ        : Entity_Id;
+         Deref : Node_Id;
+         Hom   : Entity_Id;
+         Typ   : Entity_Id;
 
       begin
-         Typ := Obj_Type;
+         --  Loop through ancestor types
 
+         Typ := Obj_Type;
          loop
             --  For each parent subtype we traverse all the homonym chain
             --  looking for a candidate class-wide subprogram
 
             Hom := Current_Entity (New_Subprg);
-
             while Present (Hom) loop
                if (Ekind (Hom) = E_Procedure
                      or else Ekind (Hom) = E_Function)
@@ -4801,9 +4803,10 @@ package body Sem_Ch4 is
                Hom := Homonym (Hom);
             end loop;
 
-            exit when Etype (Typ) = Typ;
+            --  Climb to ancestor type if there is one
 
-            Typ := Etype (Typ); --  Climb to the ancestor type
+            exit when Etype (Typ) = Typ;
+            Typ := Etype (Typ);
          end loop;
 
          return False;
@@ -4838,8 +4841,11 @@ package body Sem_Ch4 is
 
          if (Nkind (Parent (N)) = N_Procedure_Call_Statement
                or else Nkind (Parent (N)) = N_Function_Call)
-             and then N /= First (Parameter_Associations (Parent (N)))
-               --  Protect against recursive call; It occurs in "..:= F (O.P)"
+
+            --  Protect against recursive call; It occurs in "..:= F (O.P)"
+
+            and then N /= First (Parameter_Associations (Parent (N)))
+
          then
             Node_To_Replace := Parent (N);
 
@@ -4886,9 +4892,10 @@ package body Sem_Ch4 is
             --  Previous analysis transformed the node with the name
             --  and we have to reset it to properly re-analyze it.
 
-            New_Name := Make_Selected_Component (Loc,
-                          Prefix        => New_Reference_To (New_Prefix, Loc),
-                          Selector_Name => New_Copy_Tree (New_Subprg));
+            New_Name :=
+              Make_Selected_Component (Loc,
+                Prefix        => New_Reference_To (New_Prefix, Loc),
+                Selector_Name => New_Copy_Tree (New_Subprg));
             Set_Name (Call_Node, New_Name);
 
             Set_Analyzed (Call_Node, False);
@@ -4898,6 +4905,7 @@ package body Sem_Ch4 is
             return True;
 
          --  Free all the nodes used for this test and return
+
          else
             Nodes.Set_Last (Last_Node);
             return False;
@@ -4927,8 +4935,10 @@ package body Sem_Ch4 is
 
       if (Nkind (Parent (N)) = N_Procedure_Call_Statement
             or else Nkind (Parent (N)) = N_Function_Call)
-          and then N /= First (Parameter_Associations (Parent (N)))
-            --  Protects against recursive call in case of "..:= F (O.Proc)"
+
+         --  Protects against recursive call in case of "..:= F (O.Proc)"
+
+         and then N /= First (Parameter_Associations (Parent (N)))
       then
          Actual := First (Parameter_Associations (Parent (N)));
 
index 6b799ee..0077db2 100644 (file)
@@ -597,6 +597,12 @@ package body Sem_Ch5 is
    ----------------------------
 
    procedure Analyze_Case_Statement (N : Node_Id) is
+      Exp            : Node_Id;
+      Exp_Type       : Entity_Id;
+      Exp_Btype      : Entity_Id;
+      Last_Choice    : Nat;
+      Dont_Care      : Boolean;
+      Others_Present : Boolean;
 
       Statements_Analyzed : Boolean := False;
       --  Set True if at least some statement sequences get analyzed.
@@ -640,22 +646,61 @@ package body Sem_Ch5 is
       ------------------------
 
       procedure Process_Statements (Alternative : Node_Id) is
+         Choices : constant List_Id := Discrete_Choices (Alternative);
+         Ent     : Entity_Id;
+
       begin
          Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
          Statements_Analyzed := True;
+
+         --  An interesting optimization. If the case statement expression
+         --  is a simple entity, then we can set the current value within
+         --  an alternative if the alternative has one possible value.
+
+         --    case N is
+         --      when 1      => alpha
+         --      when 2 | 3  => beta
+         --      when others => gamma
+
+         --  Here we know that N is initially 1 within alpha, but for beta
+         --  and gamma, we do not know anything more about the initial value.
+
+         if Is_Entity_Name (Exp) then
+            Ent := Entity (Exp);
+
+            if Ekind (Ent) = E_Variable
+                 or else
+               Ekind (Ent) = E_In_Out_Parameter
+                 or else
+               Ekind (Ent) = E_Out_Parameter
+            then
+               if List_Length (Choices) = 1
+                 and then Nkind (First (Choices)) in N_Subexpr
+                 and then Compile_Time_Known_Value (First (Choices))
+               then
+                  Set_Current_Value (Entity (Exp), First (Choices));
+               end if;
+
+               Analyze_Statements (Statements (Alternative));
+
+               --  After analyzing the case, set the current value to empty
+               --  since we won't know what it is for the next alternative
+               --  (unless reset by this same circuit), or after the case.
+
+               Set_Current_Value (Entity (Exp), Empty);
+               return;
+            end if;
+         end if;
+
+         --  Case where expression is not an entity name of a variable
+
          Analyze_Statements (Statements (Alternative));
       end Process_Statements;
 
-      --  Variables local to Analyze_Case_Statement.
-
-      Exp       : Node_Id;
-      Exp_Type  : Entity_Id;
-      Exp_Btype : Entity_Id;
+      --  Table to record choices. Put after subprograms since we make
+      --  a call to Number_Of_Choices to get the right number of entries.
 
-      Case_Table     : Choice_Table_Type (1 .. Number_Of_Choices (N));
-      Last_Choice    : Nat;
-      Dont_Care      : Boolean;
-      Others_Present : Boolean;
+      Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
 
    --  Start of processing for Analyze_Case_Statement
 
index 3e4c4b3..9ed4bc4 100644 (file)
@@ -3285,6 +3285,13 @@ package body Sem_Ch6 is
                Formal_Type := Etype (Formal);
             end if;
 
+            --  Do not produce extra formals for Unchecked_Union parameters.
+            --  Jump directly to the end of the loop.
+
+            if Is_Unchecked_Union (Base_Type (Formal_Type)) then
+               goto Skip_Extra_Formal_Generation;
+            end if;
+
             if not Has_Discriminants (Formal_Type)
               and then Ekind (Formal_Type) in Private_Kind
               and then Present (Underlying_Type (Formal_Type))
@@ -3339,6 +3346,11 @@ package body Sem_Ch6 is
             Next_Formal (P_Formal);
          end if;
 
+         --  This label is required when skipping extra formal generation for
+         --  Unchecked_Union parameters.
+
+         <<Skip_Extra_Formal_Generation>>
+
          Next_Formal (Formal);
       end loop;
    end Create_Extra_Formals;
@@ -5225,6 +5237,7 @@ package body Sem_Ch6 is
          elsif Is_Record_Type (T)
            and then Ekind (Formal) = E_In_Parameter
            and then Chars (Formal) /= Name_uInit
+           and then not Is_Unchecked_Union (T)
            and then not Is_Discrim_SO_Function (Subp)
          then
             AS_Needed := True;
index 11be7c1..91d3067 100644 (file)
@@ -692,10 +692,15 @@ package body Sem_Ch7 is
       --  is a public child of Parent as defined in 10.1.1
 
       procedure Inspect_Deferred_Constant_Completion;
-      --  Examines the deferred constants in the private part of the
-      --  package specification. Emits the error "constant declaration
-      --  requires initialization expression " if not completed by an
-      --  import pragma.
+      --  Examines the deferred constants in the private part of the package
+      --  specification. Emits the error message "constant declaration requires
+      --  initialization expression " if not completed by an Import pragma.
+
+      procedure Inspect_Unchecked_Union_Completion (Decls : List_Id);
+      --  Detects all incomplete or private type declarations having a known
+      --  discriminant part that are completed by an Unchecked_Union. Emits
+      --  the error message "Unchecked_Union may not complete discriminated
+      --  partial view".
 
       ---------------------
       -- Clear_Constants --
@@ -834,6 +839,37 @@ package body Sem_Ch7 is
          end loop;
       end Inspect_Deferred_Constant_Completion;
 
+      ----------------------------------------
+      -- Inspect_Unchecked_Union_Completion --
+      ----------------------------------------
+
+      procedure Inspect_Unchecked_Union_Completion (Decls : List_Id) is
+         Decl : Node_Id := First (Decls);
+
+      begin
+         while Present (Decl) loop
+
+            --  We are looking at an incomplete or private type declaration
+            --  with a known_discriminant_part whose full view is an
+            --  Unchecked_Union.
+
+            if (Nkind (Decl) = N_Incomplete_Type_Declaration
+                  or else
+                Nkind (Decl) = N_Private_Type_Declaration)
+              and then Has_Discriminants (Defining_Identifier (Decl))
+              and then Present (Full_View (Defining_Identifier (Decl)))
+              and then Is_Unchecked_Union
+                (Full_View (Defining_Identifier (Decl)))
+            then
+               Error_Msg_N ("completion of discriminated partial view" &
+                 " cannot be an Unchecked_Union",
+                 Full_View (Defining_Identifier (Decl)));
+            end if;
+
+            Next (Decl);
+         end loop;
+      end Inspect_Unchecked_Union_Completion;
+
    --  Start of processing for Analyze_Package_Specification
 
    begin
@@ -982,6 +1018,18 @@ package body Sem_Ch7 is
          Next_Entity (E);
       end loop;
 
+      --  Ada 2005 (AI-216): The completion of an incomplete or private type
+      --  declaration having a known_discriminant_part shall not be an
+      --  Unchecked_Union type.
+
+      if Present (Vis_Decls) then
+         Inspect_Unchecked_Union_Completion (Vis_Decls);
+      end if;
+
+      if Present (Priv_Decls) then
+         Inspect_Unchecked_Union_Completion (Priv_Decls);
+      end if;
+
       if Ekind (Id) = E_Generic_Package
         and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
         and then Present (Priv_Decls)
@@ -1443,6 +1491,7 @@ package body Sem_Ch7 is
 
       while Present (Id) loop
          Install_Package_Entity (Id);
+         Set_Is_Hidden (Id, False);
          Next_Entity (Id);
       end loop;
 
index d248f07..5416e96 100644 (file)
@@ -1530,13 +1530,45 @@ package body Sem_Eval is
    procedure Eval_Integer_Literal (N : Node_Id) is
       T : constant Entity_Id := Etype (N);
 
+      function In_Any_Integer_Context return Boolean;
+      --  If the literal is resolved with a specific type in a context
+      --  where the expected type is Any_Integer, there are no range checks
+      --  on the literal. By the time the literal is evaluated, it carries
+      --  the type imposed by the enclosing expression, and we must recover
+      --  the context to determine that Any_Integer is meant.
+
+      ----------------------------
+      -- To_Any_Integer_Context --
+      ----------------------------
+
+      function In_Any_Integer_Context return Boolean is
+         Par : constant Node_Id   := Parent (N);
+         K   : constant Node_Kind := Nkind (Par);
+
+      begin
+         --  Any_Integer also appears in digits specifications for real types,
+         --  but those have bounds smaller that those of any integer base
+         --  type, so we can safely ignore these cases.
+
+         return    K = N_Number_Declaration
+           or else K = N_Attribute_Reference
+           or else K = N_Attribute_Definition_Clause
+           or else K = N_Modular_Type_Definition
+           or else K = N_Signed_Integer_Type_Definition;
+      end In_Any_Integer_Context;
+
+   --  Start of processing for Eval_Integer_Literal
+
    begin
+
       --  If the literal appears in a non-expression context, then it is
       --  certainly appearing in a non-static context, so check it. This
       --  is actually a redundant check, since Check_Non_Static_Context
       --  would check it, but it seems worth while avoiding the call.
 
-      if Nkind (Parent (N)) not in N_Subexpr then
+      if Nkind (Parent (N)) not in N_Subexpr
+        and then not In_Any_Integer_Context
+      then
          Check_Non_Static_Context (N);
       end if;
 
index 0ce7209..6edf69c 100644 (file)
@@ -329,6 +329,10 @@ package body Sem_Prag is
       procedure Check_At_Most_N_Arguments (N : Nat);
       --  Check there are no more than N arguments present
 
+      procedure Check_Component (Comp : Node_Id);
+      --  Examine Unchecked_Union component for correct use of per-object
+      --  constrained subtypes.
+
       procedure Check_Duplicated_Export_Name (Nam : Node_Id);
       --  Nam is an N_String_Literal node containing the external name set
       --  by an Import or Export pragma (or extended Import or Export pragma).
@@ -392,6 +396,10 @@ package body Sem_Prag is
       --  and to library level instantiations), and they are simply ignored,
       --  which is implemented by rewriting them as null statements.
 
+      procedure Check_Variant (Variant : Node_Id);
+      --  Check Unchecked_Union variant for lack of nested variants and
+      --  presence of at least one component.
+
       procedure Error_Pragma (Msg : String);
       pragma No_Return (Error_Pragma);
       --  Outputs error message for current pragma. The message contains an %
@@ -923,6 +931,36 @@ package body Sem_Prag is
          end if;
       end Check_At_Most_N_Arguments;
 
+      ---------------------
+      -- Check_Component --
+      ---------------------
+
+      procedure Check_Component (Comp : Node_Id) is
+      begin
+         if Nkind (Comp) = N_Component_Declaration then
+            declare
+               Sindic : constant Node_Id :=
+                          Subtype_Indication (Component_Definition (Comp));
+
+            begin
+               if Nkind (Sindic) = N_Subtype_Indication then
+
+                  --  Ada 2005 (AI-216): If a component subtype is subject to
+                  --  a per-object constraint, then the component type shall
+                  --  be an Unchecked_Union.
+
+                  if Has_Per_Object_Constraint (Defining_Identifier (Comp))
+                    and then
+                      not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
+                  then
+                     Error_Msg_N ("component subtype subject to per-object" &
+                       " constraint must be an Unchecked_Union", Comp);
+                  end if;
+               end if;
+            end;
+         end if;
+      end Check_Component;
+
       ----------------------------------
       -- Check_Duplicated_Export_Name --
       ----------------------------------
@@ -1417,6 +1455,37 @@ package body Sem_Prag is
          end if;
       end Check_Valid_Library_Unit_Pragma;
 
+      -------------------
+      -- Check_Variant --
+      -------------------
+
+      procedure Check_Variant (Variant : Node_Id) is
+         Clist : constant Node_Id := Component_List (Variant);
+         Comp  : Node_Id;
+
+      begin
+         if Present (Variant_Part (Clist)) then
+            Error_Msg_N
+              ("Unchecked_Union may not have nested variants",
+               Variant_Part (Clist));
+         end if;
+
+         if not Is_Non_Empty_List (Component_Items (Clist)) then
+            Error_Msg_N
+              ("Unchecked_Union may not have empty component list",
+               Variant);
+            return;
+         end if;
+
+         Comp := First (Component_Items (Clist));
+         while Present (Comp) loop
+
+            Check_Component (Comp);
+            Next (Comp);
+
+         end loop;
+      end Check_Variant;
+
       ------------------
       -- Error_Pragma --
       ------------------
@@ -9741,6 +9810,14 @@ package body Sem_Prag is
                Tdef  := Type_Definition (Declaration_Node (Typ));
                Clist := Component_List (Tdef);
 
+               Comp := First (Component_Items (Clist));
+               while Present (Comp) loop
+
+                  Check_Component (Comp);
+                  Next (Comp);
+
+               end loop;
+
                if No (Clist) or else No (Variant_Part (Clist)) then
                   Error_Msg_N
                     ("Unchecked_Union must have variant part",
@@ -9749,60 +9826,12 @@ package body Sem_Prag is
                end if;
 
                Vpart := Variant_Part (Clist);
-
-               if Is_Non_Empty_List (Component_Items (Clist)) then
-                  Error_Msg_N
-                    ("components before variant not allowed " &
-                     "in Unchecked_Union",
-                     First (Component_Items (Clist)));
-               end if;
-
                Variant := First (Variants (Vpart));
                while Present (Variant) loop
-                  Clist := Component_List (Variant);
-
-                  if Present (Variant_Part (Clist)) then
-                     Error_Msg_N
-                       ("Unchecked_Union may not have nested variants",
-                        Variant_Part (Clist));
-                  end if;
-
-                  if not Is_Non_Empty_List (Component_Items (Clist)) then
-                     Error_Msg_N
-                       ("Unchecked_Union may not have empty component list",
-                        Variant);
-                     return;
-                  end if;
-
-                  Comp := First (Component_Items (Clist));
-
-                  if Nkind (Comp) = N_Component_Declaration then
-
-                     if Present (Expression (Comp)) then
-                        Error_Msg_N
-                          ("default initialization not allowed " &
-                           "in Unchecked_Union",
-                           Expression (Comp));
-                     end if;
-
-                     declare
-                        Sindic : constant Node_Id :=
-                          Subtype_Indication (Component_Definition (Comp));
-
-                     begin
-                        if Nkind (Sindic) = N_Subtype_Indication then
-                           Check_Static_Constraint (Constraint (Sindic));
-                        end if;
-                     end;
-                  end if;
-
-                  if Present (Next (Comp)) then
-                     Error_Msg_N
-                       ("Unchecked_Union variant can have only one component",
-                        Next (Comp));
-                  end if;
 
+                  Check_Variant (Variant);
                   Next (Variant);
+
                end loop;
             end if;
 
index 9a7d711..863e96b 100644 (file)
@@ -4005,13 +4005,6 @@ package body Sem_Res is
             return;
 
          else
-            if Comes_From_Source (N)
-              and then Has_Unchecked_Union (T)
-            then
-               Error_Msg_N
-                ("cannot compare Unchecked_Union values", N);
-            end if;
-
             Resolve (L, T);
             Resolve (R, T);
             Check_Unset_Reference (L);
@@ -4748,13 +4741,6 @@ package body Sem_Res is
             end if;
          end if;
 
-         if Comes_From_Source (N)
-           and then Has_Unchecked_Union (T)
-         then
-            Error_Msg_N
-              ("cannot compare Unchecked_Union values", N);
-         end if;
-
          Resolve (L, T);
          Resolve (R, T);
 
index 3f9c7ee..0f1894a 100644 (file)
@@ -467,6 +467,12 @@ package body Sem_Util is
       Decl : Node_Id;
 
    begin
+      --  Unchecked_Union components do not require component subtypes
+
+      if Is_Unchecked_Union (T) then
+         return Empty;
+      end if;
+
       Subt :=
         Make_Defining_Identifier (Loc,
           Chars => New_Internal_Name ('S'));
@@ -2394,7 +2400,7 @@ package body Sem_Util is
       --  because the discriminant is not available. The restrictions on
       --  Unchecked_Union are designed to make sure that this is OK.
 
-      elsif Is_Unchecked_Union (Utyp) then
+      elsif Is_Unchecked_Union (Base_Type (Utyp)) then
          return Typ;
 
       --  Here for the unconstrained case, we must find actual subtype
index b9cd266..5212ffb 100644 (file)
@@ -503,6 +503,7 @@ package Sem_Util is
    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean;
    --  Determines whether Expr is a refeference to a variable or IN OUT
    --  mode parameter of the current enclosing subprogram.
+   --  Why are OUT parameters not considered here ???
 
    function Is_Object_Reference (N : Node_Id) return Boolean;
    --  Determines if the tree referenced by N represents an object. Both
index 398a355..0bdc08b 100644 (file)
@@ -90,14 +90,26 @@ pragma Pure (System);
 
    --  Priority-related Declarations (RM D.1)
 
-   Max_Priority           : constant Positive := 30;
-   Max_Interrupt_Priority : constant Positive := 31;
-
-   subtype Any_Priority       is Integer      range  0 .. 31;
-   subtype Priority           is Any_Priority range  0 .. 30;
-   subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
-   Default_Priority : constant Priority := 15;
+   --  IRIX priorities as defined by realtime(5):
+   --
+   --  255        is for system-level interrupts
+   --  240 - 254  are suggested for hard real-time threads
+   --  200 - 239  are used by system device driver interrupt threads
+   --  110 - 199  are suggested for interactive real-time applications
+   --   90 - 109  are used by system daemon threads
+   --    0 -  89  are suggested for soft real-time applications
+   --
+   --  We don't express the full range of IRIX priorities.  For now, we
+   --  handle only the subset for soft real-time applications.
+
+   Max_Priority           : constant Positive := 88;
+   Max_Interrupt_Priority : constant Positive := 89;
+
+   subtype Any_Priority       is Integer      range  0 .. 89;
+   subtype Priority           is Any_Priority range  0 .. 88;
+   subtype Interrupt_Priority is Any_Priority range 89 .. 89;
+
+   Default_Priority : constant Priority := 44;
 
 private
 
diff --git a/gcc/ada/system-vxworks-x86.ads b/gcc/ada/system-vxworks-x86.ads
new file mode 100644 (file)
index 0000000..1575fdf
--- /dev/null
@@ -0,0 +1,158 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                        GNAT RUN-TIME COMPONENTS                          --
+--                                                                          --
+--                               S Y S T E M                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                         (VxWorks Version x86)                            --
+--                                                                          --
+--          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
+--                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
+-- 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 System is
+pragma Pure (System);
+--  Note that we take advantage of the implementation permission to
+--  make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+   type Name is (SYSTEM_NAME_GNAT);
+   System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+   --  System-Dependent Named Numbers
+
+   Min_Int               : constant := Long_Long_Integer'First;
+   Max_Int               : constant := Long_Long_Integer'Last;
+
+   Max_Binary_Modulus    : constant := 2 ** Long_Long_Integer'Size;
+   Max_Nonbinary_Modulus : constant := Integer'Last;
+
+   Max_Base_Digits       : constant := Long_Long_Float'Digits;
+   Max_Digits            : constant := Long_Long_Float'Digits;
+
+   Max_Mantissa          : constant := 63;
+   Fine_Delta            : constant := 2.0 ** (-Max_Mantissa);
+
+   Tick                  : constant := 1.0 / 60.0;
+
+   --  Storage-related Declarations
+
+   type Address is private;
+   Null_Address : constant Address;
+
+   Storage_Unit : constant := 8;
+   Word_Size    : constant := 32;
+   Memory_Size  : constant := 2 ** 32;
+
+   --  Address comparison
+
+   function "<"  (Left, Right : Address) return Boolean;
+   function "<=" (Left, Right : Address) return Boolean;
+   function ">"  (Left, Right : Address) return Boolean;
+   function ">=" (Left, Right : Address) return Boolean;
+   function "="  (Left, Right : Address) return Boolean;
+
+   pragma Import (Intrinsic, "<");
+   pragma Import (Intrinsic, "<=");
+   pragma Import (Intrinsic, ">");
+   pragma Import (Intrinsic, ">=");
+   pragma Import (Intrinsic, "=");
+
+   --  Other System-Dependent Declarations
+
+   type Bit_Order is (High_Order_First, Low_Order_First);
+   Default_Bit_Order : constant Bit_Order := Low_Order_First;
+
+   --  Priority-related Declarations (RM D.1)
+
+   --  256        is reserved for the VxWorks kernel
+   --  248 - 255  correspond to hardware interrupt levels 0 .. 7
+   --  247        is a catchall default "interrupt" priority for signals,
+   --             allowing higher priority than normal tasks, but lower than
+   --             hardware priority levels.  Protected Object ceilings can
+   --             override these values.
+   --  246        is used by the Interrupt_Manager task
+
+   Max_Priority           : constant Positive := 245;
+   Max_Interrupt_Priority : constant Positive := 255;
+
+   subtype Any_Priority       is Integer      range   0 .. 255;
+   subtype Priority           is Any_Priority range   0 .. 245;
+   subtype Interrupt_Priority is Any_Priority range 246 .. 255;
+
+   Default_Priority : constant Priority := 122;
+
+private
+
+   type Address is mod Memory_Size;
+   Null_Address : constant Address := 0;
+
+   --------------------------------------
+   -- System Implementation Parameters --
+   --------------------------------------
+
+   --  These parameters provide information about the target that is used
+   --  by the compiler. They are in the private part of System, where they
+   --  can be accessed using the special circuitry in the Targparm unit
+   --  whose source should be consulted for more detailed descriptions
+   --  of the individual switch values.
+
+   AAMP                      : constant Boolean := False;
+   Backend_Divide_Checks     : constant Boolean := False;
+   Backend_Overflow_Checks   : constant Boolean := False;
+   Command_Line_Args         : constant Boolean := False;
+   Configurable_Run_Time     : constant Boolean := False;
+   Denorm                    : constant Boolean := True;
+   Duration_32_Bits          : constant Boolean := False;
+   Exit_Status_Supported     : constant Boolean := True;
+   Fractional_Fixed_Ops      : constant Boolean := False;
+   Frontend_Layout           : constant Boolean := False;
+   Functions_Return_By_DSP   : constant Boolean := False;
+   Machine_Overflows         : constant Boolean := False;
+   Machine_Rounds            : constant Boolean := True;
+   OpenVMS                   : constant Boolean := False;
+   Signed_Zeros              : constant Boolean := True;
+   Stack_Check_Default       : constant Boolean := False;
+   Stack_Check_Probes        : constant Boolean := False;
+   Support_64_Bit_Divides    : constant Boolean := True;
+   Support_Aggregates        : constant Boolean := True;
+   Support_Composite_Assign  : constant Boolean := True;
+   Support_Composite_Compare : constant Boolean := True;
+   Support_Long_Shifts       : constant Boolean := True;
+   Suppress_Standard_Library : constant Boolean := False;
+   Use_Ada_Main_Program_Name : constant Boolean := True;
+   ZCX_By_Default            : constant Boolean := False;
+   GCC_ZCX_Support           : constant Boolean := False;
+   Front_End_ZCX_Support     : constant Boolean := False;
+
+   --  Obsolete entries, to be removed eventually (bootstrap issues!)
+
+   High_Integrity_Mode       : constant Boolean := False;
+   Long_Shifts_Inlined       : constant Boolean := False;
+
+end System;
index f45783e..91b0518 100644 (file)
@@ -82,17 +82,30 @@ bool type_annotate_only;
 
 struct stmt_group GTY((chain_next ("%h.previous"))) {
   struct stmt_group *previous; /* Previous code group.  */
+  struct stmt_group *global;   /* Global code group from the level.  */
   tree stmt_list;              /* List of statements for this code group. */
   tree block;                  /* BLOCK for this code group, if any. */
   tree cleanups;               /* Cleanups for this code group, if any.  */
 };
 
 static GTY(()) struct stmt_group *current_stmt_group;
-static struct stmt_group *global_stmt_group;
 
 /* List of unused struct stmt_group nodes.  */
 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
 
+/* A structure used to record information on elaboration procedures
+   we've made and need to process.
+
+   ??? gnat_node should be Node_Id, but gengtype gets confused.  */
+
+struct elab_info GTY((chain_next ("%h.next"))) {
+  struct elab_info *next;      /* Pointer to next in chain. */
+  tree elab_proc;              /* Elaboration procedure.  */
+  int gnat_node;               /* The N_Compilation_Unit.  */
+};
+
+static GTY(()) struct elab_info *elab_info_list;
+
 /* Free list of TREE_LIST nodes used for stacks.  */
 static GTY((deletable)) tree gnu_stack_free_list;
 
@@ -102,6 +115,10 @@ static GTY((deletable)) tree gnu_stack_free_list;
    handler.  Not used in the zero-cost case.  */
 static GTY(()) tree gnu_except_ptr_stack;
 
+/* List of TREE_LIST nodes used to store the current elaboration procedure
+   decl.  TREE_VALUE is the decl.  */
+static GTY(()) tree gnu_elab_proc_stack;
+
 /* Variable that stores a list of labels to be used as a goto target instead of
    a return in some functions.  See processing for N_Subprogram_Body.  */
 static GTY(()) tree gnu_return_label_stack;
@@ -114,15 +131,13 @@ static GTY(()) tree gnu_loop_label_stack;
    TREE_VALUE of each entry is the label at the end of the switch.  */
 static GTY(()) tree gnu_switch_label_stack;
 
-/* The FUNCTION_DECL for the elaboration procedure for the main unit.  */
-static GTY(()) tree gnu_elab_proc_decl;
-
 /* Map GNAT tree codes to GCC tree codes for simple expressions.  */
 static enum tree_code gnu_codes[Number_Node_Kinds];
 
 /* Current node being treated, in case abort called.  */
 Node_Id error_gnat_node;
 
+static void Compilation_Unit_to_gnu (Node_Id);
 static void record_code_position (Node_Id);
 static void insert_code_for (Node_Id);
 static void start_stmt_group (void);
@@ -149,7 +164,6 @@ static tree extract_values (tree, tree);
 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
 static tree maybe_implicit_deref (tree);
 static tree gnat_stabilize_reference_1 (tree, bool);
-static bool build_unit_elab (void);
 static void annotate_with_node (tree, Node_Id);
 
 /* Constants for +0.5 and -0.5 for float-to-integer rounding.  */
@@ -169,10 +183,9 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
       Entity_Id standard_long_long_float, Entity_Id standard_exception_type,
       Int gigi_operating_mode)
 {
-  bool body_p;
-  Entity_Id gnat_unit_entity;
   tree gnu_standard_long_long_float;
   tree gnu_standard_exception_type;
+  struct elab_info *info;
 
   max_gnat_nodes = max_gnat_node;
   number_names = number_name;
@@ -226,53 +239,42 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
   if (Exception_Mechanism == GCC_ZCX)
     gnat_init_gcc_eh ();
 
-  /* Make the decl for the elaboration procedure.  */
-  body_p = (Defining_Entity (Unit (gnat_root)),
-           Nkind (Unit (gnat_root)) == N_Package_Body
-           || Nkind (Unit (gnat_root)) == N_Subprogram_Body);
-  gnat_unit_entity = Defining_Entity (Unit (gnat_root));
-
-  gnu_elab_proc_decl
-    = create_subprog_decl
-      (create_concat_name (gnat_unit_entity,
-                          body_p ? "elabb" : "elabs"),
-       NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
-       gnat_unit_entity);
-
-  DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
-  allocate_struct_function (gnu_elab_proc_decl);
-  Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
-  cfun = 0;
-
-      /* For a body, first process the spec if there is one. */
-  if (Nkind (Unit (gnat_root)) == N_Package_Body
-      || (Nkind (Unit (gnat_root)) == N_Subprogram_Body
-             && !Acts_As_Spec (gnat_root)))
-    add_stmt (gnat_to_gnu (Library_Unit (gnat_root)));
+  if (Nkind (gnat_root) != N_Compilation_Unit)
+    abort ();
 
-  process_inlined_subprograms (gnat_root);
+  Compilation_Unit_to_gnu (gnat_root);
 
-  if (type_annotate_only)
+  /* Now see if we have any elaboration procedures to deal with. */
+  for (info = elab_info_list; info; info = info->next)
     {
-      elaborate_all_entities (gnat_root);
-
-         if (Nkind (Unit (gnat_root)) == N_Subprogram_Declaration
-             || Nkind (Unit (gnat_root)) == N_Generic_Package_Declaration
-             || Nkind (Unit (gnat_root)) == N_Generic_Subprogram_Declaration)
-           return;
+      tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
+      tree gnu_stmts;
+
+      /* Mark everything we have as not visited.  */
+      walk_tree_without_duplicates (&gnu_body, mark_unvisited, NULL);
+
+      /* Set the current function to be the elaboration procedure and gimplify
+        what we have.  */
+      current_function_decl = info->elab_proc;
+      gimplify_body (&gnu_body, info->elab_proc);
+
+      /* We should have a BIND_EXPR, but it may or may not have any statements
+        in it.  If it doesn't have any, we have nothing to do.  */
+      gnu_stmts = gnu_body;
+      if (TREE_CODE (gnu_stmts) == BIND_EXPR)
+       gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
+
+      /* If there are no statements, there is no elaboration code.  */
+      if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
+       Set_Has_No_Elaboration_Code (info->gnat_node, 1);
+      else
+       {
+         /* Otherwise, compile the function.  Note that we'll be gimplifying
+            it twice, but that's fine for the nodes we use.  */
+         begin_subprog_body (info->elab_proc);
+         end_subprog_body (gnu_body);
+       }
     }
-
-  process_decls (Declarations (Aux_Decls_Node (gnat_root)), Empty, Empty,
-                true, true);
-  add_stmt (gnat_to_gnu (Unit (gnat_root)));
-
-  /* Process any pragmas and actions following the unit.  */
-  add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_root)));
-  add_stmt_list (Actions (Aux_Decls_Node (gnat_root)));
-
-  /* Generate elaboration code for this unit, if necessary, and say whether
-     we did or not.  */
-  Set_Has_No_Elaboration_Code (gnat_root, build_unit_elab ());
 }
 \f
 /* Perform initializations for this module.  */
@@ -284,7 +286,7 @@ gnat_init_stmt_group ()
   init_code_table ();
   start_stmt_group ();
 
-  global_stmt_group = current_stmt_group;
+  current_stmt_group->global = current_stmt_group;
 
   /* Enable GNAT stack checking method if needed */
   if (!Stack_Check_Probes_On_Target)
@@ -2331,6 +2333,73 @@ Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
                end_stmt_group ());
 }
 \f
+/* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit.  */
+
+static void
+Compilation_Unit_to_gnu (Node_Id gnat_node)
+{
+  /* Make the decl for the elaboration procedure.  */
+  bool body_p = (Defining_Entity (Unit (gnat_node)),
+           Nkind (Unit (gnat_node)) == N_Package_Body
+           || Nkind (Unit (gnat_node)) == N_Subprogram_Body);
+  Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
+  tree gnu_elab_proc_decl
+    = create_subprog_decl
+      (create_concat_name (gnat_unit_entity,
+                          body_p ? "elabb" : "elabs"),
+       NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
+       gnat_unit_entity);
+  struct elab_info *info;
+
+  push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
+
+  DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
+  allocate_struct_function (gnu_elab_proc_decl);
+  Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
+  cfun = 0;
+
+      /* For a body, first process the spec if there is one. */
+  if (Nkind (Unit (gnat_node)) == N_Package_Body
+      || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
+             && !Acts_As_Spec (gnat_node)))
+    add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
+
+  process_inlined_subprograms (gnat_node);
+
+  if (type_annotate_only)
+    {
+      elaborate_all_entities (gnat_node);
+
+      if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
+         || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
+         || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
+       return;
+    }
+
+  process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
+                true, true);
+  add_stmt (gnat_to_gnu (Unit (gnat_node)));
+
+  /* Process any pragmas and actions following the unit.  */
+  add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
+  add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
+
+  /* Save away what we've made so far and record this potential elaboration
+     procedure.  */
+  info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info));
+  set_current_block_context (gnu_elab_proc_decl);
+  gnat_poplevel ();
+  DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
+  info->next = elab_info_list;
+  info->elab_proc = gnu_elab_proc_decl;
+  info->gnat_node = gnat_node;
+  elab_info_list = info;
+
+  /* Generate elaboration code for this unit, if necessary, and say whether
+     we did or not.  */
+  pop_stack (&gnu_elab_proc_stack);
+}
+\f
 /* This function is the driver of the GNAT to GCC tree transformation
    process.  It is the entry point of the tree transformer.  GNAT_NODE is the
    root of some GNAT tree.  Return the root of the corresponding GCC tree.
@@ -2382,7 +2451,7 @@ gnat_to_gnu (Node_Id gnat_node)
               || Nkind (gnat_node) == N_Raise_Program_Error)
              && (Ekind (Etype (gnat_node)) == E_Void))))
     {
-      current_function_decl = gnu_elab_proc_decl;
+      current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
       start_stmt_group ();
       gnat_pushlevel ();
       went_into_elab_proc = true;
@@ -3587,24 +3656,11 @@ gnat_to_gnu (Node_Id gnat_node)
       /* This is not called for the main unit, which is handled in function
         gigi above.  */
       start_stmt_group ();
+      current_stmt_group->global = current_stmt_group;
+      gnat_pushlevel ();
 
-      /* For a body, first process the spec if there is one. */
-      if (Nkind (Unit (gnat_node)) == N_Package_Body
-         || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
-             && !Acts_As_Spec (gnat_node)))
-       add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
-
-      process_inlined_subprograms (gnat_node);
-      process_decls (Declarations (Aux_Decls_Node (gnat_node)),
-                    Empty, Empty, true, true);
-      add_stmt (gnat_to_gnu (Unit (gnat_node)));
-
-      /* Process any pragmas and actions following the unit.  */
-      add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
-      add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
-
-      Set_Has_No_Elaboration_Code (gnat_node, 1);
-      gnu_result = end_stmt_group ();
+      Compilation_Unit_to_gnu (gnat_node);
+      gnu_result = alloc_stmt_list ();
       break;
 
     case N_Subprogram_Body_Stub:
@@ -4057,6 +4113,7 @@ start_stmt_group ()
 
   group->previous = current_stmt_group;
   group->stmt_list = group->block = group->cleanups = NULL_TREE;
+  group->global = current_stmt_group ? current_stmt_group->global : NULL;
   current_stmt_group = group;
 }
 
@@ -4117,7 +4174,7 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
     return;
 
   if (global_bindings_p ())
-    current_stmt_group = global_stmt_group;
+    current_stmt_group = current_stmt_group->global;
 
   add_stmt_with_node (build (DECL_EXPR, void_type_node, gnu_decl),
                      gnat_entity);
@@ -4339,7 +4396,7 @@ gnat_expand_stmt (tree gnu_stmt)
 /* Generate GIMPLE in place for the expression at *EXPR_P.  */
 
 int
-gnat_gimplify_expr (tree *expr_p, tree *pre_p ATTRIBUTE_UNUSED, tree *post_p)
+gnat_gimplify_expr (tree *expr_p, tree *pre_p, tree *post_p ATTRIBUTE_UNUSED)
 {
   tree expr = *expr_p;
 
@@ -4362,7 +4419,7 @@ gnat_gimplify_expr (tree *expr_p, tree *pre_p ATTRIBUTE_UNUSED, tree *post_p)
          TREE_NO_WARNING (*expr_p) = 1;
        }
 
-      append_to_statement_list (TREE_OPERAND (expr, 0), post_p);
+      append_to_statement_list (TREE_OPERAND (expr, 0), pre_p);
       return GS_OK;
 
     case UNCONSTRAINED_ARRAY_REF:
@@ -5614,45 +5671,6 @@ gnat_stabilize_reference_1 (tree e, bool force)
   return result;
 }
 \f
-/* Take care of building the elaboration procedure for the main unit.
-
-   Return true if we didn't need an elaboration function, false otherwise.  */
-
-static bool
-build_unit_elab ()
-{
-  tree body, stmts;
-
-  /* Mark everything we have as not visited.  */
-  walk_tree_without_duplicates (&current_stmt_group->stmt_list,
-                               mark_unvisited, NULL);
-
-  /* Set the current function to be the elaboration procedure, pop our
-     binding level, end our statement group, and gimplify what we have.  */
-  set_current_block_context (gnu_elab_proc_decl);
-  gnat_poplevel ();
-  body = end_stmt_group ();
-  current_function_decl = gnu_elab_proc_decl;
-  gimplify_body (&body, gnu_elab_proc_decl);
-
-  /* We should have a BIND_EXPR, but it may or may not have any statements
-     in it.  If it doesn't have any, we have nothing to do.  */
-  stmts = body;
-  if (TREE_CODE (stmts) == BIND_EXPR)
-    stmts = BIND_EXPR_BODY (stmts);
-
-  /* If there are no statements, we have nothing to do.  */
-  if (!stmts || !STATEMENT_LIST_HEAD (stmts))
-    return true;
-
-  /* Otherwise, compile the function.  Note that we'll be gimplifying
-     it twice, but that's fine for the nodes we use.  */
-  begin_subprog_body (gnu_elab_proc_decl);
-  end_subprog_body (body);
-
-  return false;
-}
-\f
 extern char *__gnat_to_canonical_file_spec (char *);
 
 /* Convert Sloc into *LOCUS (a location_t).  Return true if this Sloc
index c52fcd0..46c5639 100644 (file)
@@ -193,8 +193,7 @@ present_gnu_tree (Entity_Id gnat_entity)
 int
 global_bindings_p (void)
 {
-  return (force_global || !current_binding_level
-         || !current_binding_level->chain ? -1 : 0);
+  return ((force_global || !current_function_decl) ? -1 : 0);
 }
 
 /* Enter a new binding level. */
@@ -365,7 +364,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
     TYPE_NAME (TREE_TYPE (decl)) = decl;
 
   if (TREE_CODE (decl) != CONST_DECL)
-    rest_of_decl_compilation (decl, NULL, global_bindings_p (), 0);
+    rest_of_decl_compilation (decl, global_bindings_p (), 0);
 }
 \f
 /* Do little here.  Set up the standard declarations later after the
index fb0e4dd..1682c87 100644 (file)
 --                                                                          --
 ------------------------------------------------------------------------------
 
---  This package is part of the GNAT driver. It contains a procedure
---  VMS_Conversion to convert the command line in VMS form to the equivalent
---  command line with switches for the GNAT tools that the GNAT driver will
---  invoke.
---
+--  This package is part of the GNAT driver. It contains the procedure
+--  VMS_Conversion to convert a VMS command line to the equivalent command
+--  line with switches for the GNAT tools that the GNAT driver will invoke.
 --  The qualifier declarations are contained in package VMS_Data.
 
 with Table;
@@ -61,7 +59,7 @@ package VMS_Conv is
    --  Set true if /? switch causes display of generated command (on VMS)
 
    -------------------
-   -- COMMAND TABLE --
+   -- Command Table --
    -------------------
 
    --  The command table contains an entry for each command recognized by
@@ -71,10 +69,10 @@ package VMS_Conv is
    --  A parameter is defined as a whitespace bounded string, not begining
    --   with a slash. (But see note under FILES_OR_WILDCARD).
      (File,
-      --  A required file or directory parameter.
+      --  A required file or directory parameter
 
       Optional_File,
-      --  An optional file or directory parameter.
+      --  An optional file or directory parameter
 
       Other_As_Is,
       --  A parameter that's passed through as is (not canonicalized)
@@ -96,12 +94,29 @@ package VMS_Conv is
    type Parameter_Ref is access all Parameter_Array;
 
    type Command_Type is
-     (Bind, Chop, Clean, Compile, Elim, Find, Krunch, Library, Link, List,
-      Make, Metric, Name, Preprocess, Pretty, Setup, Shared, Stub, Xref,
+     (Bind,
+      Chop,
+      Clean,
+      Compile,
+      Elim,
+      Find,
+      Krunch,
+      Library,
+      Link,
+      List,
+      Make,
+      Metric,
+      Name,
+      Preprocess,
+      Pretty,
+      Setup,
+      Shared,
+      Stub,
+      Xref,
       Undefined);
 
    type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
-   --  Alternate command libel for non VMS system
+   --  Alternate command label for non VMS system use
 
    Corresponding_To : constant array (Alternate_Command) of Command_Type :=
      (Comp  => Compile,
@@ -144,7 +159,7 @@ package VMS_Conv is
    end record;
 
    -------------------------
-   -- INTERNAL STRUCTURES --
+   -- Internal Structures --
    -------------------------
 
    --  The switches and commands are defined by strings in the previous
@@ -271,9 +286,9 @@ package VMS_Conv is
    subtype Switch_Item  is Item (Id_Switch);
    subtype Option_Item  is Item (Id_Option);
 
-   ------------------
-   -- SWITCH TABLE --
-   ------------------
+   -------------------
+   -- Switch Tables --
+   -------------------
 
    --  The switch tables contain an entry for each switch recognized by the
    --  command processor. It is initialized by procedure Initialize.
index 5a992f4..a995edb 100644 (file)
 --       output. A line containing this escape sequence may not also contain
 --       a ^alpha^beta^ sequence.
 
---       Recognize @ifset and @ifclear (this is because we have menu problems
---       if we let makeinfo handle the ifset/ifclear pairs
+--       Process @ifset and @ifclear for the target flags (unw, vms);
+--       this is because we have menu problems if we let makeinfo handle
+--       these ifset/ifclear pairs.
+--       Note: @ifset/@ifclear commands for the edition flags (FSFEDITION,
+--       PROEDITION, ACADEMICEDITION) are passed through unchanged
 
 with Ada.Command_Line;           use Ada.Command_Line;
 with Ada.Strings;                use Ada.Strings;
@@ -143,7 +146,7 @@ procedure Xgnatugn is
    procedure Warning
      (Input        : Input_File;
       Message      : String);
-   --  Like Error, but just print a warning message.
+   --  Like Error, but just print a warning message
 
    Dictionary_File : aliased Input_File;
    procedure Read_Dictionary_File;
@@ -158,11 +161,24 @@ procedure Xgnatugn is
    --  It contains the Texinfo source code. Process_Source_File
    --  performs the necessary replacements.
 
-   type Target_Type is (UNW, VMS);
+   type Flag_Type is (UNW, VMS, FSFEDITION, PROEDITION, ACADEMICEDITION);
+   --  The flags permitted in @ifset or @ifclear commands:
+   --
+   --  Targets for preprocessing
+   --    UNW (Unix and Windows) or VMS
+   --
+   --  Editions of the manual
+   --    FSFEDITION, PROEDITION, or ACADEMICEDITION
+   --
+   --  Conditional commands for target are processed by xgnatugn
+   --
+   --  Conditional commands for edition are passed through unchanged
+
+   subtype Target_Type is Flag_Type range UNW .. VMS;
+   subtype Edition_Type is Flag_Type range FSFEDITION .. ACADEMICEDITION;
+
    Target : Target_Type;
-   --  The target for which preprocessing is performed:
-   --  UNW (Unix and Windows) or VMS
-   --  The Target variable is initialized using the command line.
+   --  The Target variable is initialized using the command line
 
    Valid_Characters : constant Character_Set
      := To_Set (Span => (' ',  '~'));
@@ -191,7 +207,7 @@ procedure Xgnatugn is
    --  execution terminates with a Fatal_Line_Length exception.
 
    VMS_Escape_Character : constant Character := '^';
-   --  The character used to mark VMS alternatives (^alpha^beta^).
+   --  The character used to mark VMS alternatives (^alpha^beta^)
 
    Extensions : GNAT.Spitbol.Table_VString.Table (20);
    procedure Initialize_Extensions;
@@ -231,7 +247,7 @@ procedure Xgnatugn is
    --  Target.
 
    function In_VMS_Section return Boolean;
-   --  Returns True if in an "@ifset vms" section.
+   --  Returns True if in an "@ifset vms" section
 
    procedure Check_No_Pending_Conditional;
    --  Checks that all preprocessing directives have been properly matched by
@@ -244,7 +260,7 @@ procedure Xgnatugn is
    type Conditional_Context is record
       Starting_Line : Positive;
       Cond          : Conditional;
-      Flag          : Target_Type;
+      Flag          : Flag_Type;
       Excluding     : Boolean;
    end record;
 
@@ -254,7 +270,7 @@ procedure Xgnatugn is
      array (1 .. Conditional_Stack_Depth) of Conditional_Context;
 
    Conditional_TOS : Natural := 0;
-   --  Pointer to the Top Of Stack for Conditional_Stack.
+   --  Pointer to the Top Of Stack for Conditional_Stack
 
    -----------
    -- Usage --
@@ -263,7 +279,7 @@ procedure Xgnatugn is
    procedure Usage is
    begin
       Put_Line (Standard_Error,
-              "usage: xgnatug TARGET SOURCE DICTIONARY [OUTFILE [WARNINGS]]");
+            "usage: xgnatugn TARGET SOURCE DICTIONARY [OUTFILE [WARNINGS]]");
       New_Line;
       Put_Line (Standard_Error, "TARGET is one of:");
 
@@ -342,8 +358,8 @@ procedure Xgnatugn is
    -----------
 
    procedure Error
-     (Input        : Input_File;
-      Message      : String)
+     (Input   : Input_File;
+      Message : String)
    is
    begin
       Error (Input, 0, Message);
@@ -586,7 +602,7 @@ procedure Xgnatugn is
             return;
          end if;
 
-         --  ^alpha^beta^, the VMS_Alternative case.
+         --  ^alpha^beta^, the VMS_Alternative case
 
          if Remaining_Line (Remaining_Line'First) = VMS_Escape_Character then
             declare
@@ -786,8 +802,7 @@ procedure Xgnatugn is
                        (Line (Token.Span.First .. Token.Span.Last)));
                Next_Token;
             else
-               --  We already have: Word ".", followed by an unknown
-               --  token.
+               --  We already have: Word ".", followed by an unknown token
 
                Append (Rewritten_Line, First_Word & '.');
 
@@ -894,7 +909,7 @@ procedure Xgnatugn is
       Ifset       : constant String := "@ifset ";
       Ifclear     : constant String := "@ifclear ";
       Endsetclear : constant String := "@end ";
-      --  Strings to be recognized for conditional processing.
+      --  Strings to be recognized for conditional processing
 
    begin
       while not End_Of_File (Source_File.Data) loop
@@ -910,14 +925,14 @@ procedure Xgnatugn is
             --  directive.
 
             Cond : Conditional;
-            --  The kind of the directive.
+            --  The kind of the directive
 
-            Flag : Target_Type;
-            --  Its flag.
+            Flag : Flag_Type;
+            --  Its flag
 
          begin
             --  If the line starts with @ifset or @ifclear, we try to convert
-            --  the following flag to one of our target types. If we fail,
+            --  the following flag to one of our flag types. If we fail,
             --  Have_Conditional remains False.
 
             if Line'Length >= Ifset'Length
@@ -930,16 +945,21 @@ procedure Xgnatugn is
                           Trim (Line (Ifset'Length + 1 .. Line'Last), Both);
 
                begin
-                  Flag := Target_Type'Value (Arg);
-
-                  if Translate (Target_Type'Image (Flag), Lower_Case_Map)
-                                                                    /= Arg
-                  then
-                     Error (Source_File, "flag has to be lowercase");
-                  end if;
-
+                  Flag := Flag_Type'Value (Arg);
                   Have_Conditional := True;
 
+                  case Flag is
+                     when Target_Type =>
+                        if Translate (Target_Type'Image (Flag),
+                                      Lower_Case_Map)
+                                                      /= Arg
+                        then
+                           Error (Source_File, "flag has to be lowercase");
+                        end if;
+
+                     when Edition_Type =>
+                        null;
+                  end case;
                exception
                   when Constraint_Error =>
                      Error (Source_File, "unknown flag for '@ifset'");
@@ -955,22 +975,28 @@ procedure Xgnatugn is
                           Trim (Line (Ifclear'Length + 1 .. Line'Last), Both);
 
                begin
-                  Flag := Target_Type'Value (Arg);
-                  if Translate (Target_Type'Image (Flag), Lower_Case_Map)
-                                                                     /= Arg
-                  then
-                     Error (Source_File, "flag has to be lowercase");
-                  end if;
-
+                  Flag := Flag_Type'Value (Arg);
                   Have_Conditional := True;
 
+                  case Flag is
+                     when Target_Type =>
+                        if Translate (Target_Type'Image (Flag),
+                                      Lower_Case_Map)
+                                                      /= Arg
+                        then
+                           Error (Source_File, "flag has to be lowercase");
+                        end if;
+
+                     when Edition_Type =>
+                        null;
+                  end case;
                exception
                   when Constraint_Error =>
                      Error (Source_File, "unknown flag for '@ifclear'");
                end;
             end if;
 
-            if Have_Conditional then
+            if Have_Conditional and (Flag in Target_Type) then
 
                --  We create a new conditional context and suppress the
                --  directive in the output.
@@ -979,6 +1005,7 @@ procedure Xgnatugn is
 
             elsif Line'Length >= Endsetclear'Length
               and then Line (1 .. Endsetclear'Length) = Endsetclear
+              and then (Flag in Target_Type)
             then
                --  The '@end ifset'/'@end ifclear' case is handled here. We
                --  have to pop the conditional context.
@@ -1016,7 +1043,7 @@ procedure Xgnatugn is
                end;
             end if;                     --  Have_Conditional
 
-            if not Have_Conditional then
+            if (not Have_Conditional) or (Flag in Edition_Type) then
 
                --  The ordinary case.
 
@@ -1252,23 +1279,24 @@ procedure Xgnatugn is
       end loop;
    end Check_No_Pending_Conditional;
 
-   ------------------
-   -- Main Program --
-   ------------------
+--  Start of processing for Xgnatugn
 
    Valid_Command_Line : Boolean;
    Output_File_Name   : VString;
 
 begin
    Initialize_Extensions;
-
    Valid_Command_Line := Argument_Count in 3 .. 5;
 
-   --  First argument: Target.
+   --  First argument: Target
 
    if Valid_Command_Line then
       begin
-         Target := Target_Type'Value (Argument (1));
+         Target := Flag_Type'Value (Argument (1));
+
+         if Target not in Target_Type then
+            Valid_Command_Line := False;
+         end if;
 
       exception
          when Constraint_Error =>
@@ -1276,7 +1304,7 @@ begin
       end;
    end if;
 
-   --  Second argument: Source_File.
+   --  Second argument: Source_File
 
    if Valid_Command_Line then
       begin
@@ -1289,7 +1317,7 @@ begin
       end;
    end if;
 
-   --  Third argument: Dictionary_File.
+   --  Third argument: Dictionary_File
 
    if Valid_Command_Line then
       begin
@@ -1302,7 +1330,7 @@ begin
       end;
    end if;
 
-   --  Fourth argument: Output_File.
+   --  Fourth argument: Output_File
 
    if Valid_Command_Line then
       if Argument_Count in 4 .. 5 then
@@ -1335,7 +1363,7 @@ begin
       Read_Dictionary_File;
       Close (Dictionary_File.Data);
 
-      --  Main processing starts here.
+      --  Main processing starts here
 
       Process_Source_File;
       Close (Output_File);