diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-08-09 12:24:25 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-08-09 12:24:25 +0000 |
| commit | 00f91aef2e75977bb03a8091ce6b4d4e46ae8d8f (patch) | |
| tree | 395000c4629fbf7cd7f7141f5caa3a8080d5dd8e | |
| parent | 5dacbe5333f7a9a3ee0860f89f0ba1262470b278 (diff) | |
| download | gcc-00f91aef2e75977bb03a8091ce6b4d4e46ae8d8f.tar.gz | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@85714 138bc75d-0d04-0410-961f-82ee72b054a4
60 files changed, 3204 insertions, 806 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e2dc48f59b0..daf1367a866 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index f7bcfe0c5a6..e3b9507c1f6 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -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 diff --git a/gcc/ada/bld.adb b/gcc/ada/bld.adb index a39076be834..6d52e8b5011 100644 --- a/gcc/ada/bld.adb +++ b/gcc/ada/bld.adb @@ -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 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 82e286fbc6c..7ffa17dcdda 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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, diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 480ebad8ca7..702e348acdb 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -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; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index b45279f9cce..5f613dc3efd 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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) diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 86de4bc819d..5ebe8dad72b 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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 diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index defbdd05526..f87d503db62 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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); diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 966670d68c2..130d74d80db 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -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); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 3fec8c15780..39d704efab5 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d1a7bbcd803..7f57b02425c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 -- ------------------------------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 083c6c291a7..1d982eeea4b 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 1842996362e..62de53a77c8 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index a6567aa4cda..eb6abd02f34 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index c017d6d9929..cee69c47762 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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. diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 75a1c300fef..b2d4f259cc3 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -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; --------------------- diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb index a948bdeedfa..214e0f37740 100644 --- a/gcc/ada/g-socthi-mingw.adb +++ b/gcc/ada/g-socthi-mingw.adb @@ -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; diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads index 5ee990e8628..f13b907ecf0 100644 --- a/gcc/ada/g-socthi-mingw.ads +++ b/gcc/ada/g-socthi-mingw.ads @@ -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; diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index 41b32d16e9a..4d4a9110e5f 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -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; diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads index a3985525f7c..47f2827d761 100644 --- a/gcc/ada/g-socthi-vms.ads +++ b/gcc/ada/g-socthi-vms.ads @@ -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; diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb index 28e22418847..06a60cae2d9 100644 --- a/gcc/ada/g-socthi-vxworks.adb +++ b/gcc/ada/g-socthi-vxworks.adb @@ -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; diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads index 3642a038bec..f389e9a484d 100644 --- a/gcc/ada/g-socthi-vxworks.ads +++ b/gcc/ada/g-socthi-vxworks.ads @@ -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; diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb index 49f3c8d244b..9600cda6428 100644 --- a/gcc/ada/g-socthi.adb +++ b/gcc/ada/g-socthi.adb @@ -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; diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads index f8b7aca88c5..7a818d88a37 100644 --- a/gcc/ada/g-socthi.ads +++ b/gcc/ada/g-socthi.ads @@ -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; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index ea278f14cf9..d3d28367e88 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -16,7 +16,11 @@ @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 diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 4162ea2037e..640f74d3399 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -85,20 +85,26 @@ @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: diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index fc1996f41ab..5d30a57c709 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -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 index 00000000000..bdff9712e91 --- /dev/null +++ b/gcc/ada/indepsw-aix.adb @@ -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 index 00000000000..74538a8c693 --- /dev/null +++ b/gcc/ada/indepsw-linux.adb @@ -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 index 00000000000..bf591514e88 --- /dev/null +++ b/gcc/ada/indepsw-mingw.adb @@ -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 index 00000000000..ce86d2cda1a --- /dev/null +++ b/gcc/ada/indepsw.adb @@ -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 index 00000000000..e206515b88d --- /dev/null +++ b/gcc/ada/indepsw.ads @@ -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; diff --git a/gcc/ada/makegpr.adb b/gcc/ada/makegpr.adb index 7f39b00469f..6b51b328639 100644 --- a/gcc/ada/makegpr.adb +++ b/gcc/ada/makegpr.adb @@ -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; diff --git a/gcc/ada/mlib-tgt-mingw.adb b/gcc/ada/mlib-tgt-mingw.adb index 77295cf5b17..1efebfd5638 100644 --- a/gcc/ada/mlib-tgt-mingw.adb +++ b/gcc/ada/mlib-tgt-mingw.adb @@ -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; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index c166baafa3a..53e08531644 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -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; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index a67cb5685eb..1af7f598918 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -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. -- diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb index f88589d8324..91e8278d006 100644 --- a/gcc/ada/s-secsta.adb +++ b/gcc/ada/s-secsta.adb @@ -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; diff --git a/gcc/ada/s-secsta.ads b/gcc/ada/s-secsta.ads index 12bcd655953..ad2b34e3ab4 100644 --- a/gcc/ada/s-secsta.ads +++ b/gcc/ada/s-secsta.ads @@ -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; diff --git a/gcc/ada/s-solita.adb b/gcc/ada/s-solita.adb index 4144acc3407..79c1b36b78e 100644 --- a/gcc/ada/s-solita.adb +++ b/gcc/ada/s-solita.adb @@ -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; diff --git a/gcc/ada/s-solita.ads b/gcc/ada/s-solita.ads index 1b9dae4396b..70252ca0858 100644 --- a/gcc/ada/s-solita.ads +++ b/gcc/ada/s-solita.ads @@ -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 index 00000000000..11a3bcece35 --- /dev/null +++ b/gcc/ada/s-vxwork-x86.ads @@ -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; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index c1b018dc753..b69e9678a91 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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; diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index e2918ae2d2f..5eafc79d97e 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -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; ----------------------------- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 4e05bd4fb87..2e0534a16d4 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b7dc0a793ec..670ee7656a3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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 diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 3831b6735da..e8cdf002e5c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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))); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 6b799ee5979..0077db2677a 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 3e4c4b332ea..9ed4bc4d54a 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 11be7c1df51..91d3067ba95 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -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; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index d248f07c7d2..5416e969658 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -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; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0ce72096ca9..6edf69ccca6 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 9a7d711b5ec..863e96b5ab4 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3f9c7eeba1d..0f1894aef82 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b9cd266b0de..5212ffb49e3 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 diff --git a/gcc/ada/system-irix-n32.ads b/gcc/ada/system-irix-n32.ads index 398a355899f..0bdc08b1fcb 100644 --- a/gcc/ada/system-irix-n32.ads +++ b/gcc/ada/system-irix-n32.ads @@ -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 index 00000000000..1575fdfea90 --- /dev/null +++ b/gcc/ada/system-vxworks-x86.ads @@ -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; diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index f45783e9986..91b051882c6 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -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 ()); } /* 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 ()); } +/* 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); +} + /* 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; } -/* 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 (¤t_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; -} - extern char *__gnat_to_canonical_file_spec (char *); /* Convert Sloc into *LOCUS (a location_t). Return true if this Sloc diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index c52fcd0db21..46c5639480b 100644 --- a/gcc/ada/utils.c +++ b/gcc/ada/utils.c @@ -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); } /* Do little here. Set up the standard declarations later after the diff --git a/gcc/ada/vms_conv.ads b/gcc/ada/vms_conv.ads index fb0e4dd9c0d..1682c879142 100644 --- a/gcc/ada/vms_conv.ads +++ b/gcc/ada/vms_conv.ads @@ -24,11 +24,9 @@ -- -- ------------------------------------------------------------------------------ --- 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. diff --git a/gcc/ada/xgnatugn.adb b/gcc/ada/xgnatugn.adb index 5a992f4e8ed..a995edb81ce 100644 --- a/gcc/ada/xgnatugn.adb +++ b/gcc/ada/xgnatugn.adb @@ -86,8 +86,11 @@ -- 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); |