diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-08-29 12:37:05 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-08-29 12:37:05 +0000 |
| commit | 12cb78d1cca1387a092ec0bd49c250340bff4afc (patch) | |
| tree | 1eab97da96906e0a2786d51d9f25f20de02befcf /gcc/ada | |
| parent | 31879e18aea3222fe3e56f2c0319c9f230645ff3 (diff) | |
| download | gcc-12cb78d1cca1387a092ec0bd49c250340bff4afc.tar.gz | |
2012-08-29 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk rev 190745 using svnmerge, notably
C++ conversion.
[gcc/]
2012-08-29 Basile Starynkevitch <basile@starynkevitch.net>
{{merging with trunk, converted to C++}}
* melt-runtime.h (MELT_FLEXIBLE_DIM): Set when C++.
* melt-runtime.c (melt_tempdir_path): Don't use choose_tmpdir from
libiberty.
(meltgc_start_module_by_index): Use address-of & on VEC_index.
(melt_really_initialize): When printing builtin settings, handle
GCC 4.8 as with implicit ENABLE_BUILD_WITH_CXX.
(meltgc_out_edge): Provide additional flag TDF_DETAILS for dump_edge_info.
(melt_val2passflag): Handle PROP_referenced_vars only when defined.
* melt-module.mk: Use GCCMELT_COMPILER instead of GCCMELT_CC.
* melt-build-script.tpl: Transmit GCCMELT_COMPILER on every make
using melt-module.mk and improve the error message.
* melt-build-script.sh: Regenerate.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@190778 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
214 files changed, 10239 insertions, 7518 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 328e1857446..06259ebe1fc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,1640 @@ +2012-08-19 Eric Botcazou <ebotcazou@adacore.com> + + * layout.adb (Set_Elem_Alignment): Cap the alignment of access types + to that of a regular access type for non-strict-alignment platforms. + * gcc-interface/utils.c (finish_fat_pointer_type): Do not set the + alignment for non-strict-alignment platforms. + +2012-08-19 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: Use proper + dummy type for the temporary COMPONENT_REF built for a derived tagged + type with discriminant. + +2012-08-14 Diego Novillo <dnovillo@google.com> + + Merge from cxx-conversion branch. Re-implement VEC in C++. + + * gcc-interface/trans.c (finalize_nrv_unc_r): Adjust VEC_index usage. + * gcc-interface/utils.c (convert): Likewise. + (remove_conversions): Likewise. + * gcc-interface/utils2.c (compare_fat_pointers): Likewise. + (build_unary_op): Likewise. + (gnat_stabilize_reference): Likewise. + +2012-08-06 Jose Ruiz <ruiz@adacore.com> + + * gcc-interface/Makefile.in: Add support for 32-bit VxWorks for SPARC + in kernel mode. + +2012-08-06 Arnaud Charlet <charlet@adacore.com> + + * prj-attr.adb (Register_New_Package): Add missing blank. + +2012-08-06 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Is_Two_Dim_Packed_Array): New predicate, + used when computing maximum size allowable to construct static + aggregate. + +2012-08-06 Vincent Pucci <pucci@adacore.com> + + * freeze.adb (Freeze_Entity): Inherit_Aspects_At_Freeze_Point + calls added for derived types and subtypes. + * sem_aux.adb, sem_aux.ads (Get_Rep_Item, Get_Rep_Pragma, + Has_Rep_Pragma): New routines. + * sem_ch13.ads (Inherit_Aspects_At_Freeze_Point): New routine. + * sem_ch13.adb (Analyze_Aspect_Specifications): Error message + for aspect Lock_Free fixed. + (Inherits_Aspects_At_Freeze_Point): New routine. + * sem_ch3.adb: Several flag settings removed since inheritance + of aspects must be performed at freeze point. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c: Fix s-oscons.ads formatting on VxWorks. + +2012-08-06 Vincent Pucci <pucci@adacore.com> + + * sem_dim.adb (Analyze_Dimension_Binary_Op): Issue an error message + for unknown exponent at compile-time. + +2012-08-06 Gary Dismukes <dismukes@adacore.com> + + * sem_eval.ads (Compile_Time_Known_Value_Or_Aggr): Enhance + comment to make it clear that the aggregate's evaluation might + still involve run-time checks even though the aggregate is + considered known at compile time. + * sinfo.ads (Compile_Time_Known_Aggregate): Correct comment to + refer to Exp_Aggr instead of Sem_Aggr. + +2012-08-06 Robert Dewar <dewar@adacore.com> + + * xoscons.adb: Minor code reorganization (remove unused variable + E at line 331). + * g-sercom.ads, exp_attr.adb: Minor reformatting. + * sinfo.adb, sinfo.ads: Minor cleanup, remove unused flag + Static_Processing_OK. + +2012-08-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Build_Derived_Concurrent_Type): Copy discriminant + constraint when building a constrained subtype, to prevent + undesirable tree sharing betweeb geberated subtype and derived + type definition. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * g-sercom-mingw.adb, s-oscons-tmplt.c: Add missing constants + on Windows. + +2012-08-06 Sergey Rybin <rybin@adacore.com frybin> + + * tree_io.ads: Update ASIS_Version_Number because of the tree fix + for discriminant constraints for concurrent types. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * sem_ch4.adb: Minor reformatting. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c, xoscons.adb: Per the Single UNIX Specification, + types cc_t, speed_t, and tcflag_t defined in <termios.h> all are + unsigned types. Add required special handling to have their correct + unsigned values in s-oscons.ads. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * par-ch13.adb: Minor reformatting. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * g-sercom.adb, g-sercom.ads, g-sercom-mingw.adb, g-sercom-linux.adb + (Set): Add Local and Flow_Control settings. + +2012-08-06 Ed Schonberg <schonberg@adacore.com> + + * exp_attr.adb: Suppress saving of 'Old if assertions are not + enabled. + +2012-08-06 Yannick Moy <moy@adacore.com> + + * sem_ch4.adb (Analyze_Selected_Component): Issue an error in + Alfa mode for component not present. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * exp_ch7.adb (Insert_Actions_In_Scope_Around): Do not + use a renaming of Scope_Stack.Table (Scope_Stack.Last), as + Process_Transient_Object may introduce new scopes and cause + Scope_Stack.Table to be reallocated. + +2012-08-06 Robert Dewar <dewar@adacore.com> + + * exp_util.adb, switch-c.adb, inline.ads, sem_ch10.adb, types.ads, + checks.adb, sem_prag.adb, sem.adb, sem.ads, sem_res.adb, sem_attr.adb, + gnat1drv.adb, exp_ch4.adb, exp_ch6.adb, opt.ads, osint.adb: Implement + extended overflow checks (step 1). + (Overflow_Check_Type, Suppress_Record, Suppress_All): New types. + (Suppress_Array): Extended to include switches to control extended + overflow checking (and renamed to Suppress_Record). + Update all uses of Suppress_Array. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * makeutl.ads: Minor documentation fix. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * exp_ch7.adb: Minor reformatting. + +2012-08-06 Geert Bosch <bosch@adacore.com> + + * a-ngelfu.adb: Change obsolete comment that this is a non-strict + implementation. + +2012-08-06 Steve Baird <baird@adacore.com> + + * exp_ch7.adb (Build_Finalizer.Process_Object_Declaration): If + CodePeer_Mode = True then omit exception handlers for finalization calls + +2012-08-06 Robert Dewar <dewar@adacore.com> + + * exp_aggr.adb: Minor reformatting. + +2012-08-06 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb: Remove useless flag Body_Deleted. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * sinfo.ads (End_Span): Change default from No_Uint to Uint_0, + as this is what all usage occurrences of this attribute are + expecting. + * uintp.adb (UI_To_Int): Add assertion to guard against calling + with No_Uint. + +2012-08-06 Vincent Pucci <pucci@adacore.com> + + PR ada/54125 + * exp_attr.adb (Expand_N_Attribute_Reference): Expand new + Atomic_Always_Lock_Free attribute. + * sem_attr.adb (Analyze_Attribute): Analyze new + Atomic_Always_Lock_Free attribute. + (Eval_Attribute): Nothing to do with new Atomic_Always_Lock_Free + attribute. + * sem_ch9.adb (Allows_Lock_Free_Implementation): + Support_Atomic_Primitives check replaces previous erroneous + size check. + * sem_util.adb, sem_util.ads (Support_Atomic_Primitives): + New routine. + * snames.ads-tmpl: New name Name_Atomic_Always_Lock_Free and + new attribute Attribute_Atomic_Always_Lock_Free defined. + * s-atopri.adb: Support_Atomic_Primitives checks replaced by + Atomic_Always_Lock_Free queries. + * system-aix64.ads, system-aix.ads, system-darwin-ppc.ads, + system-hpux.ads, system-linux-alpha.ads, system-linux-hppa.ads, + system-linux-ppc.ads, system-linux-s390.ads, + system-linux-s390x.ads, system-linux-sh4.ads, + system-linux-sparc.ads, system-lynxos178-ppc.ads, + system-lynxos-ppc.ads, system-mingw.ads, + system-vxworks-arm.ads, system-solaris-sparc.ads, + system-solaris-sparcv9.ads, system-vms_64.ads, + system-vxworks-m68k.ads, system-vxworks-mips.ads, + system-vxworks-ppc.ads, system-vxworks-sparcv9.ads: Flag + Support_Atomic_Primitives removed. + +2012-08-06 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_mech.adb (Set_Mechanisms): OUT and IN OUT parameters are + now unconditionally passed by reference. IN parameters subject + to convention C_Pass_By_Copy are passed by copy, otherwise they + are passed by reference. + +2012-08-06 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): According to + AI95-0303, protected objects with interrupt handlers can be + declared in nested scopes. This is a binding interpretation, + and thus applies to all versions of the compiler. + +2012-08-06 Robert Dewar <dewar@adacore.com> + + * frontend.adb, exp_aggr.adb: Minor reformatting. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * par-endh.adb: Minor reformatting. + +2012-08-06 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Process_Transient_Objects): Remove obsolete loop + processing related to array initialization. The expansion of + loops already contains a mechanism to detect controlled objects + generated by expansion and introduce a block around the loop + statements for finalization purposes. + +2012-08-06 Vincent Pucci <pucci@adacore.com> + + * sem_ch13.adb: Current scope must be within + or same as the scope of the entity while analysing aspect + specifications at freeze point. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * par_sco.adb: Add note about dubious SCO for TERMINATE + alternative. + * sem_ch8.adb, exp_ch11.adb: Minor reformatting. + +2012-08-06 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Two_Dim_Packed_Array_Handled): New procedure to + transform an aggregate for a packed two-dimensional array into + a one-dimensional array of constant values, in order to avoid + the generation of component-by-component assignments. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * frontend.adb: Do not attempt to process deferred configuration + pragmas if the main unit failed to load, to avoid cascaded + inconsistencies that can lead to a compiler crash. + +2012-08-06 Vincent Pucci <pucci@adacore.com> + + * s-atopri.adb: Minor reformatting. + +2012-08-06 Arnaud Charlet <charlet@adacore.com> + + * gnat-style.texi: Clarify that all subprograms should be + documented. Minor rewording. + +2012-08-06 Robert Dewar <dewar@adacore.com> + + * aspects.ads: Define Aspect_Id_Exclude_No_Aspect. + * par-ch13.adb, restrict.adb: Use Aspect_Id_Exclude_No_Aspect to + simplify code. + +2012-08-06 Yannick Moy <moy@adacore.com> + + * gnat-style.texi: Update style guide for declarations. + +2012-08-06 Yannick Moy <moy@adacore.com> + + * sem_attr.adb (Analyze_Attribute): In the case for 'Old, + skip a special expansion which is not needed in Alfa mode. + +2012-08-06 Yannick Moy <moy@adacore.com> + + * sem_ch5.adb (Analyze_Iterator_Specification): Do not perform + an expansion of the iterator in Alfa mode. + +2012-08-06 Robert Dewar <dewar@adacore.com> + + * s-oscons-tmplt.c, sem_ch9.adb, osint.adb: Minor reformatting. + +2012-08-06 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Remove obsolete + Alfa-specific guard. The code is a leftover from an early + implementation of iterators which is no longer in use. + +2012-08-06 Vincent Celier <celier@adacore.com> + + * par-ch13.adb (Get_Aspect_Specifications): Do not consider + No_Aspect when checking for a mispelled aspect. + +2012-08-06 Robert Dewar <dewar@adacore.com> + + * s-htable.adb: Minor reformatting. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c, g-socket.adb (System.OS_Constants.Target_OS): + Suppress warnings so that we don't have to do it at each usage. + +2012-08-06 Vincent Pucci <pucci@adacore.com> + + * exp_ch9.adb (Build_Lock_Free_Unprotected_Subprogram_Body): + Use of Known_Static_Esize instead of Known_Esize and + Known_Static_RM_Size instead of Known_RM_Size in order to + properly call UI_To_Int. Don't check the size of the component + type in case of generic. + * sem_ch9.adb (Allows_Lock_Free_Implementation): + Use of Known_Static_Esize instead of Known_Esize and + Known_Static_RM_Size instead of Known_RM_Size in order to properly + call UI_To_Int. Don't check the size of the component type in + case of generic. + +2012-08-06 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Discrete_Range_Cond): Do not try to optimize on + the assumption that the type of an expression can always fit in + the target type of a conversion. + +2012-07-30 Robert Dewar <dewar@adacore.com> + + * bindusg.adb: Clarify file in -A lines. + +2012-07-30 Robert Dewar <dewar@adacore.com> + + * freeze.adb: Minor reformatting. + +2012-07-30 Robert Dewar <dewar@adacore.com> + + * gnatcmd.adb, makeutl.adb, makeutl.ads: Minor code reorganization. + +2012-07-30 Vincent Pucci <pucci@adacore.com> + + * exp_ch9.adb (Build_Lock_Free_Unprotected_Subprogram_Body): Minor + reformatting. + * sem_ch9.adb (Allows_Lock_Free_Implementation): Minor reformatting. + Capture the correct error message in case of a quantified expression. + +2012-07-30 Thomas Quinot <quinot@adacore.com> + + * g-socket.adb (Get_Socket_Option, Set_Socket_Option): On Windows, the + value is a milliseconds count in a DWORD, not a struct timeval. + +2012-07-30 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch12.adb (Earlier): Add local variables T1 and T2. Minor code + refactoring. + +2012-07-30 Thomas Quinot <quinot@adacore.com> + + * gnatcmd.adb, make.adb, makeutl.adb, makeutl.ads + (Test_If_Relative_Path): Rename to Ensure_Absolute_Path to better + reflect what this subprogram does. Rename argument Including_L_Switch + to For_Gnatbind, and also exempt -A from rewriting. + * bindusg.adb: Document optional =file argument to gnatbind -A. + +2012-07-30 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_Entity): Do no apply restriction check on + storage pools to access to subprogram types. + +2012-07-30 Robert Dewar <dewar@adacore.com> + + * par_sco.adb, a-cihama.adb, a-coinve.adb, exp_ch7.adb, a-ciorse.adb, + exp_ch9.adb, sem_dim.adb, par-ch13.adb, sem_ch9.adb, a-cidlli.adb, + a-cimutr.adb, freeze.adb, a-ciormu.adb, sem_res.adb, sem_attr.adb, + a-cihase.adb, exp_ch4.adb, sem_ch4.adb, a-ciorma.adb, + s-tasinf-linux.ads, sem_ch13.adb, a-coinho.adb: Minor reformatting. + Add comments. + +2012-07-30 Vincent Pucci <pucci@adacore.com> + + * sem_ch9.adb (Allows_Lock_Free_Implementation): Restrict implicit + dereferences of access values. + +2012-07-27 Iain Sandoe <iain@codesourcery.com> + + * system-darwin-ppc64.ads: Add Support_Atomic_Primitives, set to True. + +2012-07-25 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils2.c (gnat_stabilize_reference) <BIT_FIELD_REF>: Do + not stabilize operand #1 and #2. + +2012-07-23 Tristan Gingold <gingold@adacore.com> + + * gcc-interface/trans.c (Handled_Sequence_Of_Statements_to_gnu): Use + End_Label sloc when possible for sloc of the TRY_CATCH_EXPR node. + +2012-07-23 Olivier Hainque <hainque@adacore.com> + + * gcc-interface/Makefile.in: Adjust processing of Linker_Options for + VxWorks. + * gcc-interface/Make-lang.in: Update dependencies. + +2012-07-23 Arnaud Charlet <charlet@adacore.com> + + * s-tasinf-linux.ads: Fix typo. + +2012-07-23 Thomas Quinot <quinot@adacore.com> + + * exp_ch7.adb, switch-m.adb, exp_ch3.adb, freeze.adb: Minor reformatting + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): If original + loop carries an identifier, preserve it when rewriting it as a + standard loop to validate exit statements that may reference + that name in the body of the loop. + +2012-07-23 Thomas Quinot <quinot@adacore.com> + + * exp_ch9.adb: Minor code cleanup. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Analyze_Selected_Component): When checking for + potential ambiguities with class-wide operations on synchronized + types, attach the copied node properly to the tree, to prevent + errors during expansion. + +2012-07-23 Yannick Moy <moy@adacore.com> + + * sem_ch5.adb (Analyze_Loop_Statement): Make sure the loop body + is analyzed in Alfa mode. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb: Adjust previous change. + +2012-07-23 Vincent Pucci <pucci@adacore.com> + + * sem_ch9.adb (Allows_Lock_Free_Implementation): Flag + Lock_Free_Given renames previous flag Complain. Description + updated. Henceforth, catch every error messages issued by this + routine when Lock_Free_Given is True. Declaration restriction + updated: No non-elementary parameter instead (even in parameter) + New subprogram body restrictions implemented: No allocator, + no address, import or export rep items, no delay statement, + no goto statement, no quantified expression and no dereference + of access value. + +2012-07-23 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Determine_Range): Add local variable Btyp. Handle + the case where the base type of an enumeration subtype is + private. Replace all occurrences of Base_Type with Btyp. + * exp_attr.adb (Attribute_Valid): Handle the case where the + base type of an enumeration subtype is private. Replace all + occurrences of Base_Type with Btyp. + * sem_util.adb (Get_Enum_Lit_From_Pos): Add local variable + Btyp. Handle the case where the base type of an enumeration + subtype is private. Replace all occurrences of Base_Type with + Btyp. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * par-ch6.adb (P_Mode): in Ada 2005, a mode indicator can apply + to a formal object of an anonymous access type. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Try_Container_Indexing): A user-defined indexing + aspect can have more than one index, e.g. to describe indexing + of a multidimensional object. + +2012-07-23 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Apply_Accessibility_Check): Reimplemented. The check is + now more complex and contains optional finalization part and mandatory + deallocation part. + +2012-07-23 Gary Dismukes <dismukes@adacore.com> + + * a-cihama.adb, a-cihase.adb, a-cimutr.adb, a-ciorma.adb, a-ciormu.adb, + a-ciorse.adb, a-coinho.adb, a-coinve.adb, a-cidlli.adb: Unsuppress + Accessibility_Check for Element_Type allocators. + +2012-07-23 Vasiliy Fofanov <fofanov@adacore.com> + + * projects.texi: Fix typo. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Explicit_Derenference): If prefix is + overloaded, remove those interpretations whose designated type + does not match the context, to avoid spurious ambiguities that + may be caused by the Ada 2012 conversion rule for anonymous + access types. + +2012-07-23 Vincent Celier <celier@adacore.com> + + * g-spitbo.adb (Substr (String)): Return full string and do not + raise exception when Start is 1 and Len is exactly the length + of the string parameter. + * g-spitbo.ads: Fix spelling error in the name of exception + Index_Error. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * par.adb: new subprogram Get_Aspect_Specifications. + * par-ch6.adb (P_Subprogram): handle subprogram bodies with aspect + specifications. + * par-ch13.adb (Get_Aspect_Specifications): extracted from + P_Aspect_Specifications. Collect aspect specifications in some + legal context, but do not attach them to any declaration. Used + when parsing subprogram declarations or bodies that include + aspect specifications. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): If aspects are + present, analyze them, or reject them if the subprogram as a + previous spec. + +2012-07-23 Vasiliy Fofanov <fofanov@adacore.com> + + * gnat_ugn.texi: Omit section on other platforms/runtimes support + in gnattest for vms version. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): + Handle properly aspects that can be specified on a subprogram + body: CPU, Priority, and Interrupt_Priority. + +2012-07-23 Claire Dross <dross@adacore.com> + + * a-cfdlli.ads: Switch definition of Constant_Reference_Type + and Empty_List. + +2012-07-23 Thomas Quinot <quinot@adacore.com> + + * par_sco.adb (Process_Decisions.Output_Header): For the guard + on an alternative in a SELECT statement, use the First_Sloc + of the guard expression (not its topmost sloc) as the decision + location, because this is what is referenced by dominance markers. + +2012-07-23 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Requires_Hooking): Examine the original expression + of an object declaration node because a function call that + returns on the secondary stack may have been rewritten into + something else. + +2012-07-23 Vincent Pucci <pucci@adacore.com> + + * sem_dim.adb (Analyze_Dimension_Has_Etype): For identifier, propagate + dimension when entity is a non-dimensionless constant. + (Analyze_Dimension_Object_Declaration): Propagate + dimension from the expression to the entity when type is a + dimensioned type and object is a constant. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Analyze_Attribute, case 'Old): if the prefix + is not an entity name, expand at once so that code generated by + the expansion of the prefix is not generated before the constant + that captures the old value is properly inserted and analyzed. + +2012-07-23 Thomas Quinot <quinot@adacore.com> + + * exp_ch9.adb (Ensure_Statement_Present): Mark generated NULL + statement as Comes_From_Source so that GIGI does not eliminate it. + +2012-07-23 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch12.adb (Insert_Freeze_Node_For_Instance): Inst is now + a local variable. Retrieve the related instance when processing + a subprogram instantiation. Such instances appear as wrapper + packages. + +2012-07-23 Vincent Pucci <pucci@adacore.com> + + * system-aix64.ads, system-aix.ads, system-darwin-ppc.ads, + system-hpux.ads, system-linux-alpha.ads, + system-linux-hppa.ads, system-linux-ppc.ads, + system-linux-s390.ads, system-linux-s390x.ads, + system-linux-sh4.ads, system-linux-sparc.ads, + system-lynxos-ppc.ads, system-mingw.ads, + system-solaris-sparc.ads, system-solaris-sparcv9.ads, + system-vms_64.ads, * system-vxworks-arm.ads, system-vxworks-m68k.ads, + system-vxworks-mips.ads, system-vxworks-ppc.ads, + system-vxworks-sparcv9.ads: Support_Atomic_Primitives set to False. + * system-darwin-x86.ads, system-darwin-x86_64.ads, + system-freebsd-x86.ads, system-freebsd-x86_64.ads, + system-hpux-ia64.ads, system-linux-ia64.ads, system-linux-x86.ads, + system-linux-x86_64.ads, system-lynxos-x86.ads, + system-mingw-x86_64.ads, system-solaris-x86.ads, + system-solaris-x86_64.ads, system-vms-ia64.ads, + system-vxworks-x86.ads: Support_Atomic_Primitives set to True. + * s-atopri.adb (Lock_Free_Read_X): New body. + (Lock_Free_Try_Write_X): Support_Atomic_Primitives check added. + (Lock_Free_Try_Write_64): New body. + * s-atopri.ads: New type uint. + (Sync_Compare_And_Swap_64): __sync_val_compare_and_swap_8 intrinsic + import. + (Lock_Free_Read_X): Body moved to s-atopri.adb. + (Lock_Free_Try_Write_64): Similar to other Lock_Free_Try_Write_X + routines. + * targparm.adb: New enumeration literal SAP + (Support_Atomic_Primitives) for type Targparm_Tags. New constant + SAP_Str. New component SAP_Str'Access for array Targparm_Str. + (Get_Target_Parameters): Parse Support_Atomic_Primitives_On_Target + flag. + * targparm.ads: New back-end code generation flag + Support_Atomic_Primitives_On_Target + +2012-07-23 Vincent Pucci <pucci@adacore.com> + + * gnat_ugn.texi: Dimensionality checking documentation updated. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Make_Inline): If the pragma applies to a + subprogram renaming, set inline flags on both the renamed entity + and on the renaming, so that some ASIS queries can be handled + consistently in the absence of expansion. + +2012-07-23 Fedor Rybin <frybin@adacore.com> + + * gnat_ugn.texi: Removing obsolete limitation of gnattest + to support only ada05. Updating gnattest support for other + platforms/run-times section to reflect the usage of taget + prefix in gnattest calls. Fixing missed obsolete --stub-default + option name. + +2012-07-23 Robert Dewar <dewar@adacore.com> + + * uintp.adb: Minor reformatting. + +2012-07-23 Olivier Hainque <hainque@adacore.com> + + * system-vxworks-ppc.ads: Replace the default + Linker_Options requesting crtbe by a commented out request for + -nostartfiles. + +2012-07-23 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Check_Naming): Do not get the exceptions names + in a virtual project. + +2012-07-23 Robert Dewar <dewar@adacore.com> + + * layout.adb, sem_prag.adb, sem.ads, freeze.adb, + switch-m.adb, exp_disp.adb, system-vxworks-ppc.ads, exp_ch6.adb: Minor + reformatting. + +2012-07-23 Tristan Gingold <gingold@adacore.com> + + * gcc-interface/trans.c: (Handled_Sequence_Of_Statements_to_gnu): Set + location on TRY_CATCH_EXPR. + +2012-07-19 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <object>: Try to ensure + that an object of CW type initialized to a value is sufficiently + aligned for this value. + +2012-07-19 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: Do not + look up the REP part of the base type in advance. Deal with that of + the variant types. + (get_rep_part): Be prepared for record types with fields. + +2012-07-18 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (stmt_group_may_fallthru): New function. + (gnat_to_gnu) <N_Block_Statement>: Use it to find out whether the + block needs to be translated. + +2012-07-17 Tristan Gingold <gingold@adacore.com> + + * gnat_rm.texi: Adjust previous change. + +2012-07-17 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Process_Import_Or_Interface): If the pragma + comes from an aspect, it applies to the corresponding entity + without further check. + +2012-07-17 Olivier Hainque <hainque@adacore.com> + + * initialize.c (__gnat_initialize for VxWorks): Remove section with + call to __gnat_vxw_setup_for_eh. + * system-vxworks-ppc.ads: Add -auto-register to -crtbe, relying + on the VxWorks constructor mechanism for network loaded modules + by default. + +2012-07-17 Tristan Gingold <gingold@adacore.com> + + * adaint.c: Minor reformatting. + +2012-07-17 Pascal Obry <obry@adacore.com> + + * s-regexp.adb (Adjust): Fix access violation in Adjust. + +2012-07-17 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_Entity): Warn if an imported subprogram + has pre/post conditions, because these will not be enforced. + +2012-07-17 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch7.adb (Process_Transient_Objects): Put all the + finalization blocks and the final raise statement into a wrapper + block. + +2012-07-17 Vincent Pucci <pucci@adacore.com> + + * s-atopri.adb (Lock_Free_Try_Write_X): Atomic_Compare_Exchange_X + replaced by Sync_Compare_And_Swap_X. + (Lock_Free_Try_Write_64): Removed. + * s-atopri.ads (Sync_Compare_And_Swap_X): Replaces previous + routine Atomic_Compare_Exchange_X. + (Lock_Free_Read_64): Renaming of Atomic_Load_64. + (Lock_Free_Try_Write_64): Renaming of Sync_Compare_And_Swap_64. + +2012-07-17 Vincent Celier <celier@adacore.com> + + * switch-m.adb (Normalize_Compiler_Switches): Recognize new + switches -gnatn1 and -gnatn2. + +2012-07-17 Vincent Pucci <pucci@adacore.com> + + * gnat_ugn.texi: GNAT dimensionality checking + documentation updated with System.Dim.Mks modifications. + +2012-07-17 Ed Schonberg <schonberg@adacore.com> + + * exp_ch3.adb: sloc of array init_proc is sloc of type declaration. + +2012-07-17 Tristan Gingold <gingold@adacore.com> + + * raise-gcc.c (get_call_site_action_for): Remove useless init + expression for p. + (get_action_description_for): Do not overwrite action->kind. + +2012-07-17 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Add local variables Attr + and Conversion_Added. Add local constant Typ. + Retrieve the original attribute after the arithmetic check + machinery has modified the node. Add a conversion to the target + type when the prefix of attribute Max_Size_In_Storage_Elements + is a controlled type. + +2012-07-17 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb (Expand_Inlined_Call): For each actual parameter + of mode 'out' or 'in out' that denotes an entity, reset + Last_Assignment on the entity so that any assignments to the + corresponding formal in the inlining will not trigger spurious + warnings about overwriting assignments. + +2012-07-17 Robert Dewar <dewar@adacore.com> + + * s-assert.ads: Fix comments to make it clear that this is used + for all assertions, not just pragma Assert. + +2012-07-17 Jerome Guitton <guitton@adacore.com> + + * par_sco.ads: Minor typo fix. + +2012-07-17 Gary Dismukes <dismukes@adacore.com> + + * layout.adb (Layout_Type): In the case where the target is + AAMP, use 32 bits (a single pointer) rather than 64 bits for an + anonymous access-to-subprogram type if the type is library-level + and Is_Local_Anonymous_Access is True. + +2012-07-17 Jose Ruiz <ruiz@adacore.com> + + * s-tassta.adb, s-tarest.adb (Create_Task, Create_Restricted_Task, + Initialize): Add comments explaining that the CPU affinity value that + is passed to the run-time library can be either Unspecified_CPU, to + indicate that the task inherits the affinity of its activating task, + or a value in the range of CPU_Range but no greater than Number_Of_CPUs. + +2012-07-17 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb (Make_DT): Remove decoration of Ada.Tags entities. + (Make_Tags): Add decoration of Ada.Tags entities. + +2012-07-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Check_Statement_Sequence): When locating the + last significant statement in a sequence, ignore iserted nodes + that typically come from expansion of controlled operations. + +2012-07-17 Tristan Gingold <gingold@adacore.com> + + * gnat_rm.texi: Document foreign exceptions. + +2012-07-17 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb, treepr.ads: Minor reformatting. + +2012-07-17 Robert Dewar <dewar@adacore.com> + + * exp_ch9.adb: Minor code reorganization. + * exp_ch3.adb: Minor code improvement. + +2012-07-17 Tristan Gingold <gingold@adacore.com> + + * seh_init.c (__gnat_SEH_error_handler): Not compiled anymore + on Windows 64 (+ SEH), as it is unused. + +2012-07-17 Javier Miranda <miranda@adacore.com> + + * sem_prag.adb (CPP_Class): Transform obsolescent pragma CPP_Class into + CPP convention automatically. + +2012-07-16 Tristan Gingold <gingold@adacore.com> + + * gcc-interface/decl.c (intrin_return_compatible_p): Map Address to + void *. + +2012-07-16 Thomas Quinot <quinot@adacore.com> + + * exp_ch9.adb (Ensure_Statement_Present): New subprogram. + (Expand_N_Asynchronous_Select, + Expand_N_Selective_Accept.Process_Accept_Alternative, + Expand_N_Selective_Accept.Process_Delay_Alternative, + Expand_N_Timed_Entry_Call): For an alternative with no trailing + statements, introduce a null statement to carry the sloc of + the initial special statement (accept, delay, or entry call) + in the alternative, for coverage analysis purposes. + +2012-07-16 Thomas Quinot <quinot@adacore.com> + + * sem_eval.adb (In_Subrange_Of): Fix typo in test for scalar + arguments. + +2012-07-16 Robert Dewar <dewar@adacore.com> + + * a-exexpr.adb, freeze.adb, a-exexpr-gcc.adb, a-except-2005.adb, + sem_eval.adb, s-fileio.adb: Minor reformatting. + +2012-07-16 Javier Miranda <miranda@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Remove support for obsolescent + pragma CPP_Class. + * sem_ch13.adb (Analyze_Freeze_Entity): Add missing error on Ada + derivations of CPP types. Found updating the tests affected by + the removal of pragma CPP_Class. + +2012-07-16 Thomas Quinot <quinot@adacore.com> + + * back_end.adb: Minor reformatting. + +2012-07-16 Thomas Quinot <quinot@adacore.com> + + * exp_ch9.adb (Expand_N_Selective_Accept.Process_Accept_Alternative): + Remove junk test that was always true. For the case of no statements + following the ACCEPT, jump directly to End_Lab instead of + introducing an intermediate jump. + (Expand_N_Selective_Accept.Process_Delay_Alternative): Fix + predicate testing for presence of statements following the DELAY. + that was always true. For the case of no statements following + the ACCEPT, jump directly to End_Lab instead of introducing an + intermediate jump. + (Expand_N_Selective_Accept): Fix incorrect insertion point for + end label. + +2012-07-16 Thomas Quinot <quinot@adacore.com> + + * gnat_rm.texi: Minor documentation improvements. + +2012-07-16 Yannick Moy <moy@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Allow Pre + and Pre'Class aspects on the same declaration. + * sem_prag.adb (Chain_PPC): Allow Pre and Pre'Class aspects on the + same hierarchy of primitive operations. + +2012-07-16 Thomas Quinot <quinot@adacore.com> + + * freeze.adb (Check_Component_Storage_Order): Do not reject a + nested composite with different scalar storage order if it is + byte aligned. + +2012-07-16 Thomas Quinot <quinot@adacore.com> + + * gnat_rm.texi: Update documentation for Scalar_Storage_Order. + +2012-07-16 Tristan Gingold <gingold@adacore.com> + + * a-exexpr.adb (Propagate_Exception): Adjust call to + Exception_Traces procedures. + * a-exexpr-gcc.adb (Setup_Current_Excep): Now a + function that returns an access to the Ada occurrence. + (Propagate_GCC_Exception): Adjust calls. + * raise.h (struct Exception_Occurrence): Declare. + * a-exextr.adb: Remove useless pragma. (Notify_Handled_Exception, + Notify_Unhandled_Exception) (Unhandled_Exception_Terminate): + Add Excep parameter. + * a-except.adb (Notify_Handled_Exception, + Notify_Unhandled_Exception) (Unhandled_Exception_Terminate): + Add Excep parameter. + (Process_Raise_Exception): Adjust calls. + * a-except-2005.adb (Notify_Handled_Exception, + Notify_Unhandled_Exception) (Unhandled_Exception_Terminate): Add + Excep parameter. + (Raise_Exception): Calls Raise_Exception_Always. + * raise-gcc.c (__gnat_setup_current_excep, + __gnat_notify_handled_exception) + (__gnat_notify_unhandled_exception): Adjust declarations. + (PERSONALITY_FUNCTION): Adjust calls. + (__gnat_personality_seh0): Remove warning. + +2012-07-16 Javier Miranda <miranda@adacore.com> + + * sem_eval.adb (Test_Expression_Is_Foldable): Adding documentation. + (Eval_Relational_Op): Adding documentation. + +2012-07-16 Robert Dewar <dewar@adacore.com> + + * freeze.adb, g-debpoo.adb, exp_ch3.adb: Minor reformatting. + +2012-07-16 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c: Add definitions of E2BIG and EILSEQ. + +2012-07-16 Tristan Gingold <gingold@adacore.com> + + * a-exexpr.adb (Propagate_Continue): New function replacing + Raise_Current_Excep. + (Allocate_Occurrence): New function. + (Propagate_Exception): Add Excep parameter, remove call to Call_Chain. + * a-exexpr-gcc.adb (GNAT_GCC_Exception): Occurrence component + is now aliased. + (To_GCC_Exception): Convert from Address. + (Allocate_Occurrence): Allocate an Unwind exception occurrence. + (Setup_Current_Excep): Fill the machine occurrence in case of + foreign exception. + (Propagate_Exception): Add Excep parameter, remove call to Call_Chain. + * a-except.adb (Set_Exception_C_Msg, Set_Exception_Msg): add + Excep parameter. + (Raise_Exception, Raise_Exception_Always, + Raise_Exception_No_Defer): Adjust calls to the above procedures. + (Raise_From_Signal_Handler, Raise_With_Location_And_Msg) + (Rcheck_PE_Finalize_Raised_Exception): Likewise. + * a-except-2005.adb (Set_Exception_C_Msg, Set_Exception_Msg): + add Excep parameter. + (Propagate_Exception): Likewise. + (Allocate_Occurrence): New function. + (Raise_Current_Excep): Removed. + (Complete_Occurrence): New function to save the call chain. + (Complete_And_Propagate_Occurrence): New procedure. + (Create_Occurrence_From_Signal_Handler): New function to build an + occurrence without propagating it. + (Create_Machine_Occurrence_From_Signal_Handler): Likewise, but + return the machine occurrence. + (Raise_From_Signal_Handler): Use Create_Occurrence_From_Signal_Handler. + (Raise_Exception, Raise_Exception_Always, Raise_Exception_No_Defer): + Adjust calls to the above procedures. Allocate the occurrence at + the beginning. + (Raise_With_Location_And_Msg, Raise_With_Msg) + (Rcheck_PE_Finalize_Raised_Exceptionm Reraise): Likewise. + (Reraise_Occurrence): Use Reraise_Occurrence_Always. + (Reraise_Occurrence_Always): Use Reraise_Occurrence_No_Defer. + (Reraise_Occurrence_No_Defer): Preserve machine occurrence. + (Save_Occurrence): Do not save machine occurrence. + * a-except-2005.ads (Exception_Occurrence): Add Machine_Occurrence + component. + (Null_Occurrence): Consider it. + * a-exexda.adb (Set_Exception_C_Msg, Set_Exception_Msg): add + Excep parameter. + +2012-07-16 Tristan Gingold <gingold@adacore.com> + + * seh_init.c (__gnat_map_SEH): New function extracted from + __gnat_SEH_error_handler. + * raise-gcc.c: __gnat_personality_seh0: Directly transforms + Windows system exception into GCC one when possible, in order + to save stack room (particularly useful when Storage_Error will + be propagated). + +2012-07-16 Robert Dewar <dewar@adacore.com> + + * a-direct.adb, g-dirope.adb: Minor reformatting. + +2012-07-16 Tristan Gingold <gingold@adacore.com> + + * a-except.ads, a-except-2005.ads: Remove outdated comment. + +2012-07-16 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb (Subprogram_Name_Greater): Fix algorithm to + conform to documentation. + +2012-07-16 Ed Schonberg <schonberg@adacore.com> + + * gnat1drv.adb (Check_Library_Items): Removed, no longer used. + +2012-07-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Array_Type_Declaration): if component type has + invariants, the array type itself requires an invariant procedure. + * exp_ch3.ads, exp_ch3.adb (Build_Array_Invariant_Proc): new + procedure, to build a checking procedure that applies the + invariant check on some type T to each component of an array + of T's. Code is similar to the construction of the init_proc + for an array, and handles multidimensional arrays by recursing + over successive dimensions. + +2012-07-16 Hristian Kirtchev <kirtchev@adacore.com> + + * g-debpoo.adb: Revert previous change. + +2012-07-16 Hristian Kirtchev <kirtchev@adacore.com> + + * freeze.adb (Freeze_Entity): Insert the itype reference to a + library-level class-wide subtype after the freeze node of the + equivalent record type. + +2012-07-16 Pascal Obry <obry@adacore.com> + + * s-crtl.ads (mkdir): New routine, support encoding. + * adaint.h (__gnat_mkdir): Update spec to pass encoding. + * mkdir.c (__gnat_mkdir): Add encoding parameter. + * a-direct.adb (Create_Directory): Use CRTL.mkdir, parse encoding + in form parameter. + * g-dirope.adb (Make_Dir): Update to pass encoding parameter. + +2012-07-16 Pascal Obry <obry@adacore.com> + + * adaint.c: Minor reformatting. + +2012-07-16 Steven Bosscher <steven@gcc.gnu.org> + + * gcc-interface/utils.c: Include timevar.h. + * Make-lang.in: Fix dependencies. + +2012-07-16 Vasiliy Fofanov <fofanov@adacore.com> + + * ug_words, vms_data.ads: Document VMS qualifiers for -gnatn1/2 + switches. + +2012-07-16 Bob Duff <duff@adacore.com> + + * sinfo.ads: Minor comment fix. + +2012-07-16 Bob Duff <duff@adacore.com> + + * sem_elab.adb (Within_Elaborate_All): Walk the with clauses to + find pragmas Elaborate_All that may be found in the transitive + closure of the dependences. + +2012-07-16 Robert Dewar <dewar@adacore.com> + + * exp_pakd.adb, freeze.adb, sem_util.adb, vms_data.ads: Minor + reformatting. + +2012-07-12 Vasiliy Fofanov <fofanov@adacore.com> + + * vms_data.ads: Add VMS qualifiers for -gnatn1/2 switches. + +2012-07-12 Thomas Quinot <quinot@adacore.com> + + * exp_ch5.adb, exp_pakd.adb, rtsfind.ads, freeze.adb, sem_util.adb, + sem_util.ads, exp_aggr.adb + (Exp_Aggr.Packed_Array_Aggregate_Handled): Simplify processing + for reverse storage order aggregate. + (Exp_Pakd.Byte_Swap): New utility routine used by... + (Exp_Pakd.Expand_Bit_Packed_Element_Set, + Expand_Packed_Element_Reference): For the case of a free-standing + packed array with reverse storage order, perform byte swapping. + (Rtsfind): Make new entities RE_Bswap_{16,32,64} available. + (Freeze.Check_Component_Storage_Order): New utility routine + to enforce legality rules for nested composite types whose + enclosing composite has an explicitly defined Scalar_Storage_Order + attribute. + (Sem_Util.In_Reverse_Storage_Order_Object): Renamed from + Sem_Util.In_Reverse_Storage_Order_Record, as SSO now applies to + array types as well. + (Exp_Ch5.Expand_Assign_Array): Remove now unnecessary kludge + for change of scalar storage order in assignments. The Lhs and + Rhs now always have the same scalar storage order. + +2012-07-12 Hristian Kirtchev <kirtchev@adacore.com> + + * g-debpoo.adb (Allocate): Add local constant + No_Element. Initialize the allocated memory chunk to No_Element. + +2012-07-12 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly + the case of an instance of a child unit where a formal derived + type DT is an extension of a type T declared in a parent unit, + and the actual in the instance of the child is the type T declared + in the parent instance, and that actual is not a derived type. + +2012-07-12 Eric Botcazou <ebotcazou@adacore.com> + Tristan Gingold <gingold@adacore.com> + + * system-hpux-ia64.ads: Enable ZCX by default. + * gcc-interface/Makefile.in: Use alternate stack on ia64-hpux. + Change soext to .so. + +2012-07-12 Robert Dewar <dewar@adacore.com> + + * s-atopri.adb, s-atopri.ads: Minor reformatting. + +2012-07-12 Robert Dewar <dewar@adacore.com> + + * ali.adb: Add circuitry to read new named form of restrictions lines. + * debug.adb: Add doc for new -gnatd.R switch (used positional + notation for output of restrictions data in ali file). + * lib-writ.adb: Implement new named format for restrictions lines. + * lib-writ.ads: Add documentation for new named format for + restrictions in ali files. + * restrict.adb, restrict.ads, sem_prag.adb: Update comments. + * rident.ads: Go back to withing System.Rident + * s-rident.ads: Add extensive comment on dealing with consistency + checking. + +2012-07-12 Thomas Quinot <quinot@adacore.com> + + * par_sco.adb, scos.ads: Emit detailed SCOs for SELECT statements. + +2012-07-12 Robert Dewar <dewar@adacore.com> + + * sem_disp.adb: Minor reformatting + * s-bytswa.ads: Minor comment update. + +2012-07-12 Vincent Pucci <pucci@adacore.com> + + * exp_ch9.adb (Build_Lock_Free_Unprotected_Subprogram_Body): + Atomic_Load_N replaced by Lock_Free_Read_N. Atomic_Compare_Exchange_N + replaced by Lock_Free_Try_Write_N. + Renaming of several local variables. For + procedure, Expected_Comp declaration moved to the declaration + list of the procedure. + * rtsfind.ads: RE_Atomic_Compare_Exchange_8, + RE_Atomic_Compare_Exchange_16, RE_Atomic_Compare_Exchange_32, + RE_Atomic_Compare_Exchange_64, RE_Atomic_Load_8, + RE_Atomic_Load_16, RE_Atomic_Load_32, RE_Atomic_Load_64, + RE_Atomic_Synchronize, RE_Relaxed removed. RE_Lock_Free_Read_8, + RE_Lock_Free_Read_16, RE_Lock_Free_Read_32, RE_Lock_Free_Read_64, + RE_Lock_Free_Try_Write_8, RE_Lock_Free_Try_Write_16, + RE_Lock_Free_Try_Write_32, RE_Lock_Free_Try_Write_64 added. + * s-atopri.adb: New file. + * s-atopri.ads (Atomic_Compare_Exchange_8): Renaming of + parameters. Import primitive __sync_val_compare_and_swap_1. + (Atomic_Compare_Exchange_16): Renaming of parameters. + Import primitive __sync_val_compare_and_swap_2. + (Atomic_Compare_Exchange_32): Renaming of parameters. + Import primitive __sync_val_compare_and_swap_4. + (Atomic_Compare_Exchange_64): Renaming of parameters. Import + primitive __sync_val_compare_and_swap_8. + (Atomic_Load_8): Ptr renames parameter X. + (Atomic_Load_16): Ptr renames parameter X. + (Atomic_Load_32): Ptr renames parameter X. + (Atomic_Load_64): Ptr renames parameter X. + (Lock_Free_Read_8): New routine. + (Lock_Free_Read_16): New routine. + (Lock_Free_Read_32): New routine. + (Lock_Free_Read_64): New routine. + (Lock_Free_Try_Write_8): New routine. + (Lock_Free_Try_Write_16): New routine. + (Lock_Free_Try_Write_32): New routine. + (Lock_Free_Try_Write_64): New routine. + +2012-07-12 Robert Dewar <dewar@adacore.com> + + * exp_attr.adb, exp_ch9.adb, sem_ch9.adb, exp_aggr.adb: Minor + reformatting. + +2012-07-12 Vincent Pucci <pucci@adacore.com> + + * sem_dim.adb (Analyze_Dimension_Function_Call): Reformatting of error + msgs for elementary functions. + +2012-07-12 Vincent Pucci <pucci@adacore.com> + + * sem_attr.adb (Eval_Attribute): Minor reformatting. + +2012-07-12 Pascal Obry <obry@adacore.com> + + * prj-nmsc.adb (Check_Library_Attributes): Allow the same library + project in different project tree (different aggregated projects). + +2012-07-12 Thomas Quinot <quinot@adacore.com> + + * s-bytswa.adb, g-bytswa.adb, g-bytswa.ads, s-bytswa.ads: Further + reorganization of byte swapping routines. + +2012-07-12 Ed Schonberg <schonberg@adacore.com> + + * sem_disp.adb (Check_Dispatching_Context): Refine legality + checks on tagg indeterminate calls to abstract operations, + that appear in the context of other calls. + +2012-07-12 Thomas Quinot <quinot@adacore.com> + + * s-bytswa.adb (Swapped2.Bswap16): Remove local function, + no longer needed. + +2012-07-12 Javier Miranda <miranda@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): For + attributes 'access, 'unchecked_access and 'unrestricted_access, + iff the current instance reference is located in a protected + subprogram or entry then rewrite the access attribute to be the + name of the "_object" parameter. + +2012-07-12 Tristan Gingold <gingold@adacore.com> + + * raise.h: Revert previous patch: structure is used in init.c + by vms. + +2012-07-12 Vincent Celier <celier@adacore.com> + + * make.adb (Binding_Phase): If --subdirs was used, but not + -P, change the working directory to the specified subdirectory + before invoking gnatbind. + (Linking_Phase): If --subdirs was used, but not -P, change the working + directory to the specified subdirectory before invoking gnatlink. + +2012-07-12 Vincent Pucci <pucci@adacore.com> + + * exp_ch9.adb (Build_Lock_Free_Unprotected_Subprogram_Body): + For a procedure, instead of replacing each Comp reference by a + reference to Current_Comp, make a renaming Comp of Current_Comp + that rewrites the original renaming generated by the compiler + during the analysis. Move the declarations of the procedure + inside the generated block. + (Process_Stmts): Moved in the body + of Build_Lock_Free_Unprotected_Subprogram_Body. + (Process_Node): + Moved in the body of Build_Lock_Free_Unprotected_Subprogram_Body. + * sem_ch9.adb (Allows_Lock_Free_Implementation): Restrict any + non-elementary out parameters in protected procedures. + +2012-07-12 Thomas Quinot <quinot@adacore.com> + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case + Scalar_Storage_Order): Attribute applies to base type only. + +2012-07-12 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Convert_To_Positional): Increase acceptable size + of static aggregate when Static_Elaboration_Desired is requested. + Add a warning if the request cannot be satisfied either because + some components or some array bounds are non-static. + +2012-07-12 Thomas Quinot <quinot@adacore.com> + + * exp_pakd.adb: Minor reformatting. + +2012-07-12 Tristan Gingold <gingold@adacore.com> + + * tracebak.c: Fix warnings. + * raise-gcc.c (__gnat_adjust_context): New function + (__gnat_personality_seh0): Call __gnat_adjust_context to adjust + PC in machine frame for exceptions that occur in the current + function. + +2012-07-12 Thomas Quinot <quinot@adacore.com> + + * g-bytswa.adb, g-bytswa.ads, s-bytswa.adb, s-bytswa.ads, Makefile.rtl: + Move GNAT.Byte_Swapping to System (with a renaming under GNAT) + so that it is usable in expanded code. + +2012-07-12 Tristan Gingold <gingold@adacore.com> + + * s-osinte-hpux.ads: Increase alternate stack size on hpux. + +2012-07-12 Javier Miranda <miranda@adacore.com> + + * exp_ch3.adb (Make_Neq_Body): Fix typo in comment. + +2012-07-12 Eric Botcazou <ebotcazou@adacore.com> + + * tb-gcc.c (trace_callback): On IA-64/HP-UX, use workaround only + if USE_LIBUNWIND_EXCEPTIONS is defined. + * init.c: Further tweaks for IA-64/HP-UX. + +2012-07-12 Tristan Gingold <gingold@adacore.com> + + * raise-gcc.c: Do not include unwind-dw2-fde.h. Adjust comments. + (db_region_for): Second argument is ip. Do not recompute ip. + (action_kind): Remove typedef, add unhandler enum const. + (action_descriptor): Adjust type of kind field. + (db_action_for): Second argument is ip, do not recompute it. + (get_call_site_action_for): First argument is call_site, do not + recompute it. Remove useless return. + (is_handled_by): Now return enum action_kind. + Handle GNAT_ALL_OTHERS first. + Return unhandler for GNAT_UNHANDLED_OTHERS. + (get_action_description_for): First argument is now ip, do not + recompute it. Adjust code for call to is_handled_by. + (__gnat_notify_unhandled_exception): Add prototype. + (PERSONALITY_FUNCTION): Call get_ip_from_context. Adjust calls. + Handle unhandler case. + (__gnat_cleanupunwind_handler): Add comments, add + ATTRIBUTE_UNUSED on arguments. + (__gnat_Unwind_RaiseException, __gnat_Unwind_ForcedUnwind): Define + only once. + * raise.h: Makes struct Exception_Data opaque. + +2012-07-12 Robert Dewar <dewar@adacore.com> + + * make.adb, sem_ch9.adb, prj.adb, s-rident.ads, snames.ads-tmpl: Minor + reformatting. + +2012-07-12 Javier Miranda <miranda@adacore.com> + + * exp_ch3.adb (Is_User_Defined_Equality): New subprogram. + (Make_Neq_Body): New subprogram. + (Make_Predefined_Primitive_Specs): Adding local variable + Has_Predef_Eq_ Renaming to ensure that we enable the machinery + which handles renamings of predefined primitive operators. + +2012-07-09 Pascal Obry <obry@adacore.com> + + * prj.adb (For_Every_Project_Imported_Context): Make sure we + callback with the project having sources. + Minor reformatting. + +2012-07-09 Eric Botcazou <ebotcazou@adacore.com> + + * make.adb: Fix typo. + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * sem_ch9.adb (Check_Node): Allow attributes + that denote static function for lock-free implementation. + (Is_Static_Function): New routine. + +2012-07-09 Tristan Gingold <gingold@adacore.com> + + * tracebak.c: Adjust skip_frames on Win64. + +2012-07-09 Tristan Gingold <gingold@adacore.com> + + * init.c: Add __gnat_adjust_context_for_raise for ia64/hpux. + * raise-gcc.c: __gnat_cleanupunwind_handler: Do not call + _Unwind_GetGR on hpux when using libgcc unwinder. Part of + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * exp_attr.adb, sem_attr.adb: Minor reformatting. + * par-ch13.adb, par-ch4.adb, par-util.adb: Reformatting + considering that internal attribute names are not defined anymore + in the main attribute names list. + * snames.adb-tmpl (Get_Attribute_Id): Special processinf + for names CPU, Dispatching_Domain and Interrupt_Priority. + (Is_Internal_Attribute_Name): Minor reformatting. + * snames.ads-tmpl: New list of internal attribute names. Internal + attributes moved at the end of the attribute Id list. + +2012-07-09 Robert Dewar <dewar@adacore.com> + + * freeze.adb: Minor code reorganization (use Ekind_In). + * exp_attr.adb, sem_ch9.adb par-ch4.adb, s-taprop-mingw.adb, + sem_attr.adb, exp_ch8.adb, snames.adb-tmpl, par-util.adb, + sem_ch13.adb, snames.ads-tmpl: Minor reformatting. + +2012-07-09 Tristan Gingold <gingold@adacore.com> + + * raise-gcc.c: Adjust previous patch. + +2012-07-09 Vincent Celier <celier@adacore.com> + + * make.adb (Compilation_Phase): Do not build libraries in + Codepeer mode (do not call Library_Phase). + +2012-07-09 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb: Extend previous change to elementary types. + +2012-07-09 Javier Miranda <miranda@adacore.com> + + * exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): Reverse + previous patch since unconditionally handling as renaming_as_body + renamings of predefined dispatching equality and unequality operator + cause visibility problems with private overridings of the equality + operator (see ACATS C854001). + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * exp_attr.adb (Signal_Bad_Attribute): Raise Program_Error in + case of internal attribute names (already rejected by the parser). + * par-ch13.adb (P_Representation_Clause): Complain if an internal + attribute name that comes from source occurs. + * par-ch4.adb (P_Name): Complain if an internal attribute name + occurs in the context of an attribute reference. + * par-util.adb (Signal_Bad_Attribute): Don't complain about + mispelling attribute with internal attributes. + * sem_attr.adb (Analyze_Attribute): Raise Program_Error in case + of internal attribute names (already rejected by the parser). + * snames.adb-tmpl (Is_Internal_Attribute_Name): New routine. + * snames.ads-tmpl: Attributes CPU, Dispatching_Domain and + Interrupt_Priority are marked as INT attributes since they + don't denote real attribute and are only used internally in + the compiler. + (Is_Internal_Attribute_Name): New routine. + +2012-07-09 Thomas Quinot <quinot@adacore.com> + + * einfo.adb (Set_Reverse_Storage_Order): Update assertion, + flag is now valid for array types as well. + +2012-07-09 Tristan Gingold <gingold@adacore.com> + + * tracebak.c: Implement __gnat_backtrace for Win64 SEH. + +2012-07-09 Robert Dewar <dewar@adacore.com> + + * einfo.ads: Minor reformatting. + +2012-07-09 Javier Miranda <miranda@adacore.com> + + * exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): Handle as + renaming_as_body renamings of predefined dispatching equality + and unequality operators. + +2012-07-09 Robert Dewar <dewar@adacore.com> + + * rident.ads: Do not instantiate r-ident.ads, this is now an + independent unit. + +2012-07-09 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb (Write_DT): Avoid runtime crash of this debugging + routine. + * sem_disp.adb (Find_Dispatching_Time): Protect this routine + against partially decorated entities. + +2012-07-09 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Check_Size): Reject a size clause that specifies + a value greater than Int'Last for a scalar type. + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * sem_ch9.adb (Allows_Lock_Free_Implementation): type must support + atomic operation moved to the protected body case. No non-elementary + out parameter moved to the protected declaration case. Functions have + only one lock-free restriction. + (Analyze_Protected_Type_Declaration): Issue a warning when + Priority given with Lock_Free. + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * sem_dim.adb: Grammar of aspect Dimension fixed. + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * freeze.adb (Freeze_Record_Type): Code reorg in order to avoid + pushing and popping the scope stack whenever a delayed aspect occurs. + +2012-07-09 Gary Dismukes <dismukes@adacore.com> + + * s-os_lib.ads: Remove pragma Elaborate_Body, as + this is now unnecessary due to recently added pragma Preelaborate. + +2012-07-09 Jose Ruiz <ruiz@adacore.com> + + * s-taprop-mingw.adb (Set_Priority): Remove the code that was + previously in place to reorder the ready queue when a task drops + its priority due to the loss of inherited priority. + +2012-07-09 Robert Dewar <dewar@adacore.com> + + * layout.adb, i-cstrea.ads, a-ststio.ads, prj-util.ads, sem_cat.adb, + s-commun.ads, s-ficobl.ads, s-os_lib.ads, s-fileio.ads: Minor + reformatting. + +2012-07-09 Eric Botcazou <ebotcazou@adacore.com> + + * raise-gcc.c: Update comments. Fix typo. + +2012-07-09 Thomas Quinot <quinot@adacore.com> + + * einfo.adb, einfo.ads, sem_attr.adb, sem_ch13.adb: Attribute + Scalar_Storage_Order can be defined or queried for array types as well + as record types. + +2012-07-09 Tristan Gingold <gingold@adacore.com> + + * a-exexpr-gcc.adb (CleanupUnwind_Handler): Now imported from + raise-gcc.c + * raise-gcc.c (__gnat_cleanupunwind_handler): Defined. + Strictly follow the ABI convention on ia64. + +2012-07-09 Gary Dismukes <dismukes@adacore.com> + + * a-ststio.ads: Add pragma Preelaborate, per AI05-0283. + * i-cstrea.ads (max_path_len): Change from variable to deferred + constant to allow it to be used as a bound in string component + in type System.File_IO.Temp_File_Record. + * s-os_lib.ads, s-commun.ads, s-ficobl.ads, s-fileio.ads: Add pragma + Preelaborate. + * s-fileio.adb (Get_Case_Sensitive): Move function inside + procedure Open. + (File_Names_Case_Sensitive): Move variable inside + procedure Open, to avoid violation of Preelaborate restriction + (due to call to Get_Case_Sensitive). + +2012-07-09 Ed Schonberg <schonberg@adacore.com> + + * layout.adb (Set_Elem_Alignment): Protect against meaningless + size clause, to prevent overflow in internal computation of + alignment. + +2012-07-09 Robert Dewar <dewar@adacore.com> + + * freeze.adb, prj-util.adb, prj-util.ads, sem_ch13.adb: Minor + reformatting. + +2012-07-09 Gary Dismukes <dismukes@adacore.com> + + * sem_cat.adb (Check_Categorization_Dependencies): + Allow dependence of both Remote_Types and Remote_Call_Interface + declarations (not just Remote_Types units) on preelaborated + units, but require that the dependence be made via a private + with_clause. Issue a specialized error message. + +2012-07-09 Pascal Obry <obry@adacore.com> + + * prj-util.adb, prj-util.ads (For_Interface_Sources): New routine. + +2012-07-09 Tristan Gingold <gingold@adacore.com> + + * seh_init.c (__gnat_SEH_error_handler): On Win64 and SEH, + return for unknown exceptions. + * raise-gcc.c (__gnat_personality_seh0): Call __gnat_SEH_error_handler. + +2012-07-09 Joel Brobecker <brobecker@adacore.com brobecker> + + * exp_dbug.ads (No_Dollar_In_Label): Delete. + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * sem_ch13.adb (Check_Overloaded_Name): New routine. + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * freeze.adb (Freeze_Record_Type): Analyze the delayed aspects of the + components in a record type. + +2012-07-09 Pascal Obry <obry@adacore.com> + + * prj-util.ads: Minor reformatting. + +2012-07-09 Tristan Gingold <gingold@adacore.com> + + * raise-gcc.c (db_indent): Simplify style, improve comments. + Remove !IN_RTS part (dead). + +2012-07-09 Robert Dewar <dewar@adacore.com> + + * usage.adb: Minor change to format of -gnatn line. + +2012-07-09 Tristan Gingold <gingold@adacore.com> + + * a-exexpr-gcc.adb: Reorder routine. + +2012-07-09 Vincent Celier <celier@adacore.com> + + * lib-writ.ads: Add documentation for the Z lines (implicitly + withed units) and Y lines (limited withed units). + +2012-07-09 Robert Dewar <dewar@adacore.com> + + * lib.ads, exp_attr.adb, exp_ch9.adb, sem_dim.adb, sem_ch9.adb, + sem_prag.adb, sem_ch12.adb, mlib-utl.adb, freeze.adb, sem_res.adb, + sem_attr.adb, sem_case.adb, gnatlink.adb, exp_ch4.adb, sem_ch6.adb, + sem_elim.adb, s-dimmks.ads, sem_ch13.adb: Minor code clean ups. + +2012-07-09 Eric Botcazou <ebotcazou@adacore.com> + + * gnat_ugn.texi (Switches for gcc): Document -gnatn[12] only + lightly in the summary and more thoroughly in inlining section. + (Performance Considerations): Document -gnatn[12] in inlining + section. + +2012-07-09 Tristan Gingold <gingold@adacore.com> + + * a-exexpr-gcc.adb (Unhandled_Except_Handler): New procedure. + (Unhandled_Others_Value): New const. + * raise-gcc.c (GNAT_UNHANDLED_OTHERS): Define. + (action_descriptor): Remove ttype_entry. + (get_action_description_for): Do not assign ttype_entry. + (is_handled_by): Consider GNAT_UNHANDLED_OTHERS. + +2012-07-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Call_to_gnu): Robustify test for function case + if the CICO mechanism is used. + +2012-07-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils2.c (build_simple_component_ref): Do not look + through an extension if the type contains a placeholder. + +2012-07-03 Eric Botcazou <ebotcazou@adacore.com> + + * exp_disp.adb (Expand_Dispatching_Call): Propagate the convention on + the designated subprogram type and also set Is_Dispatch_Table_Entity. + (Expand_Interface_Thunk): Propagate the convention on the thunk. + (Set_CPP_Constructors_Old): Set Is_Constructor and Convention_CPP on + the internal view of the constructors. + (Set_CPP_Constructors): Likewise. + * sem_prag.adb (Analyze_Pragma) <Pragma_CPP_Constructor>: Set the + convention on the function. + * gcc-interface/gigi.h (is_cplusplus_method): Declare. + * gcc-interface/decl.c (Has_Thiscall_Convention): New macro. + (gnat_to_gnu_entity) <E_Subprogram_Type>: Test it to set the `thiscall' + calling convention + (get_minimal_subprog_decl): Likewise. + (is_cplusplus_method): New predicate. + * gcc-interface/trans.c (Attribute_to_gnu) <Attr_Access>: Issue an + error on access to C++ constructor or member function. + +2012-07-03 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.c (gnat_pushdecl): Set TYPE_CONTEXT for types + attached to a TYPE_DECL. + 2012-06-26 Vincent Pucci <pucci@adacore.com> * exp_ch3.adb (Build_Init_Statements): Don't check the parents diff --git a/gcc/ada/ChangeLog-2011 b/gcc/ada/ChangeLog-2011 index 37f011b3a3c..7f5f6f9aa5f 100644 --- a/gcc/ada/ChangeLog-2011 +++ b/gcc/ada/ChangeLog-2011 @@ -15259,3195 +15259,3 @@ Copyright (C) 2011 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright notice and this notice are preserved. - - * gnat_rm.texi: Ramification of pragma Eliminate documentation - - fix bugs in the description of Source_Trace; - - get rid of UNIT_NAME; - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * exp_ch9.adb - (Build_Dispatching_Requeue): Adding support for VM targets - since we cannot directly reference the Tag entity. - * exp_sel.adb (Build_K): Adding support for VM targets. - (Build_S_Assignment): Adding support for VM targets. - * exp_disp.adb - (Default_Prim_Op_Position): In VM targets do not restrict availability - of predefined interface primitives to compiling in Ada 2005 mode. - (Is_Predefined_Interface_Primitive): In VM targets this service is not - restricted to compiling in Ada 2005 mode. - (Make_VM_TSD): Generate code that declares and initializes the OSD - record. Needed to support dispatching calls through synchronized - interfaces. - * exp_ch3.adb - (Make_Predefined_Primitive_Specs): Enable generation of predefined - primitives associated with synchronized interfaces. - (Make_Predefined_Primitive_Bodies): Enable generation of predefined - primitives associated with synchronized interfaces. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * par-ch11.adb (P_Handled_Sequence_Of_Statements): mark a sequence of - statements hidden in SPARK if preceded by the HIDE directive - (Parse_Exception_Handlers): mark each exception handler in a sequence of - exception handlers as hidden in SPARK if preceded by the HIDE directive - * par-ch6.adb (P_Subprogram): mark a subprogram body hidden in SPARK - if starting with the HIDE directive - * par-ch7.adb (P_Package): mark a package body hidden in SPARK if - starting with the HIDE directive; mark the declarations in a private - part as hidden in SPARK if the private part starts with the HIDE - directive - * restrict.adb, restrict.ads - (Set_Hidden_Part_In_SPARK): record a range of slocs as hidden in SPARK - (Is_In_Hidden_Part_In_SPARK): new function which returns whether its - argument node belongs to a part which is hidden in SPARK - (Check_SPARK_Restriction): do not issue violations on nodes in hidden - parts in SPARK; protect the possibly costly call to - Is_In_Hidden_Part_In_SPARK by a check that the SPARK restriction is on - * scans.ads (Token_Type): new value Tok_SPARK_Hide in enumeration - * scng.adb (Accumulate_Token_Checksum_GNAT_6_3, - Accumulate_Token_Checksum_GNAT_5_03): add case for new token - Tok_SPARK_Hide. - (Scan): recognize special comment starting with '#' and followed by - SPARK keyword "hide" as a HIDE directive. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * types.ads, erroutc.ads: Minor reformatting. - -2011-08-02 Vincent Celier <celier@adacore.com> - - * link.c: Add response file support for cross platforms. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_aggr.adb (Resolve_Array_Aggregate): when copying the expression - in an association, set parent field of copy before partial analysis. - * sem_res.adb (Resolve_Slice): create reference to itype only when - expansion is enabled. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * einfo.adb, einfo.ads (Body_Is_In_ALFA, Set_Body_Is_In_ALFA): get/set - for new flag denoting which subprogram bodies are in ALFA - * restrict.adb, sem_ch7.adb: Update comment - * sem_ch11.adb, sem_ch2.adb, sem_ch3.adb, sem_ch4.adb, sem_ch5.adb, - sem_ch9.adb, sem_res.adb: Add calls to - Current_Subprogram_Body_Is_Not_In_ALFA on unsupported constructs. - * sem_ch6.adb (Analyze_Function_Return): add calls to - Current_Subprogram_Body_Is_Not_In_ALFA on return statement in the - middle of the body, and extended return. - (Check_Missing_Return): add calls to Set_Body_Is_In_ALFA with argument - False when missing return. - (Analyze_Subprogram_Body_Helper): initialize the flag Body_Is_In_ALFA - to True for subprograms whose spec is in ALFA. Remove later on the flag - on the entity used for a subprogram body when there exists a separate - declaration. - * sem_util.adb, sem_util.ads (Current_Subprogram_Body_Is_Not_In_ALFA): - if Current_Subprogram is not Empty, set its flag Body_Is_In_ALFA to - False, otherwise do nothing. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * inline.adb, stand.ads, sem_ch6.adb, sem_ch8.adb: Minor reformatting. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * sem_ch4.ads: minor formatting. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * sem_aggr.adb, err_vars.ads, sem_ch3.adb, sem_ch5.adb, sem_ch9.adb, - debug.adb, sem_util.adb, sem_res.adb, sem_attr.adb, gnat1drv.adb, - errout.adb, errout.ads, exp_ch6.adb, sem_ch4.adb, restrict.adb, - restrict.ads, sem_ch6.adb, sem_ch8.adb, sem_ch11.adb, - opt.ads: cleanup of SPARK mode - -2011-08-02 Yannick Moy <moy@adacore.com> - - * cstand.adb (Create_Standard): sets Is_In_ALFA component of standard - types. - * einfo.adb, einfo.ads (Is_In_ALFA): add flag for all entities - (Is_In_ALFA, Set_Is_In_ALFA): new subprograms to access flag Is_In_ALFA - * sem_ch3.adb - (Analyze_Object_Declaration): set Is_In_ALFA flag for objects - (Constrain_Enumeration): set Is_In_ALFA flag for enumeration subtypes - (Constrain_Integer): set Is_In_ALFA flag for integer subtypes - (Enumeration_Type_Declaration): set Is_In_ALFA flag for enumeration - types. - (Set_Scalar_Range_For_Subtype): unset Is_In_ALFA flag for subtypes with - non-static range. - * sem_ch6.adb (Analyze_Return_Type): unset Is_In_ALFA flag for - functions whose return type is not in ALFA. - (Analyze_Subprogram_Specification): set Is_In_ALFA flag for subprogram - specifications. - (Process_Formals): unset Is_In_ALFA flag for subprograms if a - parameter's type is not in ALFA. - * stand.ads (Standard_Type_Is_In_ALFA): array defines which standard - types are in ALFA. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch6 (Analyze_Expression_Function): treat the function as - Inline_Always, and introduce a subprogram declaration for it when it is - not a completion. - * inline.adb (Add_Inlined_Body): recognize bodies that come from - expression functions, so that the back-end can determine whether they - can in fact be inlined. - * sem_util.adb (Is_Expression_Function): predicate to determine whether - a function body comes from an expression function. - -2011-08-02 Gary Dismukes <dismukes@adacore.com> - - * sem_ch6.adb (Check_Conformance): Revise the check for nonconforming - null exclusions to test Can_Never_Be_Null on the anonymous access types - of the formals rather than testing the formals themselves. Exclude this - check in cases where the Old_Formal is marked as a controlling formal, - to avoid issuing spurious errors for bodies completing dispatching - operations (due to the flag not getting set on controlling access - formals in body specs). - (Find_Corresponding_Spec): When checking full and subtype conformance of - subprogram bodies in instances, pass Designated and E in that order, for - consistency with the expected order of the formals (New_Id followed by - Old_Id). - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch8.adb: Minor reformatting. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch8.adb (Analyze_Subprogram_Renaming): new procedure - Check_Class_Wide_Actual, to implement AI05-0071, on defaulted - primitive operations of class-wide actuals. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * exp_atag.ads, exp_atag.adb - (Build_Common_Dispatching_Select_Statements): Remove argument Loc - since its value is implicitly passed in argument Typ. - * exp_disp.adb (Make_Disp_Conditional_Select_Body, - Make_Disp_Timed_Select_Body): Remove Loc in calls to routine - Build_Common_Dispatching_Select_Statements. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch3.adb, exp_atag.ads, get_scos.adb, get_scos.ads, - exp_disp.adb, lib-xref.adb, lib-xref.ads: Update comments. - Minor reformatting. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_res.adb: Minor reformatting. - * sem_prag.adb: Minor reformatting. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * exp_atag.adb, exp_atags.ads - (Build_Common_Dispatching_Select_Statement): Replace argument DT_Ptr - by the tagged type Entity. Required to use this routine in the VM - targets since we do not have available the Tag entity in the VM - platforms. - * exp_ch6.adb - (Expand_N_Subprogram_Body): Do not invoke Build_VM_TSDs if package - Ada.Tags has not been previously loaded. - * exp_ch7.adb - (Expand_N_Package_Declaration, Expand_N_Package_Body): Do not invoke - Build_VM_TSDs if package Ada.Tags has not been previously loaded. - * sem_aux.adb - (Enclosing_Dynamic_Scope): Add missing support to handle the full - view of enclosing scopes. Required to handle enclosing scopes that - are synchronized types whose full view is a task type. - * exp_disp.adb - (Build_VM_TSDs): Minor code improvement to avoid generating and - analyzing lists with empty nodes. - (Make_Disp_Asynchronous_Select_Body): Add support for VM targets. - (Make_Disp_Conditional_Select_Body): Add support for VM targets. - (Make_Disp_Get_Prim_Op_Kind): Add support for VM targets. - (Make_Disp_Timed_Select_Body): Add support for VM targets. - (Make_Select_Specific_Data_Table): Add support for VM targets. - (Make_VM_TSD): Generate code to initialize the SSD structure of - the TSD. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * lib-writ.adb (Write_ALI): when ALFA mode is set, write local - cross-references section in ALI. - * lib-xref.adb, lib-xref.ads (Xref_Entry): add components Sub - (enclosing subprogram), Slc (location of Sub) and Sun (unit number of - Sub). - (Enclosing_Subprogram_Or_Package): new function to return the enclosing - subprogram or package entity of a node - (Is_Local_Reference_Type): new function returns True for references - selected in local cross-references. - (Lt): function extracted from Lt in Output_References - (Write_Entity_Name): function extracted from Output_References - (Generate_Definition): generate reference with type 'D' for definition - of objects (object declaration and parameter specification), with - appropriate locations and units, for use in local cross-references. - (Generate_Reference): update fields Sub, Slc and Sun. Keep newly created - references of type 'I' for initialization in object definition. - (Output_References): move part of function Lt and procedure - Write_Entity_Name outside of the body. Ignore references of types 'D' - and 'I' introduced for local cross-references. - (Output_Local_References): new procedure to output the local - cross-references sections. - (Lref_Entity_Status): new array defining whether an entity is a local - * sem_ch3.adb (Analyze_Object_Declaration): call Generate_Reference - with 'I' type when initialization expression is present. - * get_scos.adb, get_scos.ads: Correct comments and typos - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * exp_ch6.adb (Expand_N_Subprogram_Body): Enable generation of TSDs in - the JVM target. - * exp_ch7.adb (Expand_N_Package_Body): Enable generation of TSDs in - the JVM target. - * exp_disp.adb (Build_VM_TSDs): No action needed if the runtime has no - TSD support. - -2011-08-02 Vincent Celier <celier@adacore.com> - - * prj-nmsc.adb (File_Found): New components Excl_File and Excl_Line - (No_Space_Img): New function - (Find_Excluded_Sources): When reading from a file, record the file name - and the line number for each excluded source. - (Mark_Excluded_Sources): When reporting an error, if the excluded - sources were read from a file, include file name and line number in - the error message. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_res.adb (Resolve_Call): implement rule in RM 12.5.1 (23.3/2). - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * exp_ch7.adb exp_ch6.adb, exp_disp.adb: Minor reformatting - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * exp_ch6.adb (Expand_N_Subprogram_Body): Temporarily restrict the - generation of TSDs to the DOTNET compiler. - * exp_ch7.adb (Expand_N_Package_Body): Temporarily restrict the - generation of TSDs to the DOTNET compiler. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * exp_disp.ads (Build_VM_TSDs): Build the runtime Type Specific Data - record of all the tagged types declared inside library level package - declarations, library level package bodies or library level subprograms. - * exp_disp.adb (Make_VM_TSD): New subprogram that builds the TSD - associated with a given tagged type. - (Build_VM_TSDs): New subprogram. - * exp_ch6.adb (Expand_N_Subprogram_Body): Generate TSDs records of main - compilation units that are subprograms. - * exp_ch7.adb (Expand_N_Package_Body): Generate TSDs of main - compilation units that are package bodies. - (Expand_N_Package_Declaration): Generate TSDs of the main compilation - units that are a package declaration or a package instantiation. - * exp_intr.adb (Expand_Dispatching_Constructor_Call): Minor code - reorganization to improve the error generated by the frontend when the - function Ada.Tags.Secondary_Tag is not available. - * rtsfind.ads (RE_Register_TSD): New runtime entity. - * exp_ch4.adb (Expand_N_Type_Conversion): Minor code cleanup. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * exp_disp.adb (Make_DT): Generate call to Check_TSD in Ada 2005 mode. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * s-imenne.ads: Minor reformatting. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * a-stunau.ads: Add pragma Suppress_Initialization for Big_String - * freeze.adb (Warn_Overlay): Don't warn if initialization suppressed - * s-stalib.ads: Add pragma Suppress_Initialization for Big_String - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * einfo.ads (Materialize_Entity): Document this is only for renamings - * exp_ch3.adb (Expand_N_Object_Declaration): Make sure we generate - required debug information in the case where we transform the object - declaration into a renaming declaration. - * exp_ch4.adb (Expand_Concatenate): Generate debug info for result - object - * exp_dbug.ads (Debug_Renaming_Declaration): Document setting of - Materialize_Entity. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * einfo.ads, einfo.adb (Suppress_Initialization): Replaces - Suppress_Init_Procs. - * exp_ch3.adb, exp_disp.adb, freeze.adb: Use - Suppress_Initialization/Initialization_Suppressed. - * gnat_rm.texi: New documentation for pragma Suppress_Initialization - * sem_aux.ads, sem_aux.adb (Initialization_Suppressed): New function - * sem_dist.adb: Use Suppress_Initialization/Initialization_Suppressed - * sem_prag.adb: New processing for pragma Suppress_Initialization. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * gnat_rm.texi, a-tags.ads, sem_prag.adb, sem_ch12.adb, exp_disp.adb: - Minor reformatting. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_prag.adb (Chain_PPC): Implement AI04-0230: null procedures can - only have inheritable classwide pre/postconditions. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * a-tags.ads, a-tags.adb (Check_TSD): New subprogram. - * rtsfind.ads (RE_Check_TSD): New runtime entity. - * exp_disp.adb (Make_DT): Generate call to the new runtime routine that - checks if the external tag of a type is the same as the external tag - of some other declaration. - -2011-08-02 Thomas Quinot <quinot@adacore.com> - - * s-taskin.ads: Minor reformatting. - -2011-08-02 Emmanuel Briot <briot@adacore.com> - - * g-comlin.adb (Display_Help): swap the order in which it prints the - short help and the general usage. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): copy properly - the aspect declarations and attach them to the generic copy for - subsequent analysis. - (Analyze_Subprogram_Instantiation): copy explicitly the aspect - declarations of the generic tree to the new subprogram declarations. - * sem_attr.adb (Check_Precondition_Postcondition): recognize - conditions that apply to a subprogram instance. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * gnat_rm.texi: Clarify doc on pragma Source_File_Name[_Project]. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch3.adb (Derived_Type_Declaration): When checking that a untagged - private type with a tagged full view is not derived in the immediate - scope of the partial view, (RM 7.3 (7)) use the scope of the base type. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * exp_ch4.adb: Minor reformatting. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch5.adb (Analyze_Loop_Statement): If the iteration scheme is an - Ada2012 iterator, the loop will be rewritten during expansion into a - while loop with a cursor and an element declaration. Do not analyze the - body in this case, because if the container is for indefinite types the - actual subtype of the elements will only be determined when the cursor - declaration is analyzed. - -2011-08-02 Arnaud Charlet <charlet@adacore.com> - - * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Ignore - size/alignment related attributes in CodePeer_Mode. - -2011-08-02 Gary Dismukes <dismukes@adacore.com> - - * sem_ch3.adb (Check_Ops_From_Incomplete_Type): Remove call to - Prepend_Element, since this can result in the operation getting the - wrong slot in the full type's dispatch table if the full type has - inherited operations. The incomplete type's operation will get added - to the proper position in the full type's primitives - list later in Sem_Disp.Check_Operation_From_Incomplete_Type. - (Process_Incomplete_Dependents): Add Is_Primitive test when checking for - dispatching operations, since there are cases where nonprimitive - subprograms can get added to the list of incomplete dependents (such - as subprograms in nested packages). - * sem_ch6.adb (Process_Formals): First, remove test for being in a - private part when determining whether to add a primitive with a - parameter of a tagged incomplete type to the Private_Dependents list. - Such primitives can also occur in the visible part, and should not have - been excluded from being private dependents. - * sem_ch7.adb (Uninstall_Declarations): When checking the rule of - RM05-3.10.1(9.3/2), test that a subprogram in the Private_Dependents - list of a Taft-amendment incomplete type is a primitive before issuing - an error that the full type must appear in the same unit. There are - cases where nonprimitives can be in the list (such as subprograms in - nested packages). - * sem_disp.adb (Derives_From): Use correct condition for checking that - a formal's type is derived from the type of the corresponding formal in - the parent subprogram (the condition was completely wrong). Add - checking that was missing for controlling result types being derived - from the result type of the parent operation. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * errout.adb (First_Node): minor renaming - * restrict.adb (Check_Formal_Restriction): put restriction warning on - first node. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * sem_res.adb (Resolve_Logical_Op): ensure N is a binary operator - before accessing operands. - * sem_util.adb (Is_SPARK_Initialization_Expr): follow original nodes to - decide whether an initialization expression respects SPARK rules, as - the plain node is the expanded one. This allows for more valid warnings - to be issued. - * gnat_rm.texi: Minor update. - -2011-08-02 Arnaud Charlet <charlet@adacore.com> - - * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): Revert - previous change. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch3.adb, sem_ch4.adb: Minor reformatting. - -2011-08-02 Hristian Kirtchev <kirtchev@adacore.com> - - * exp_ch5.adb (Expand_Iterator_Loop): Reformatting. Wrap the original - loop statements and the element renaming declaration with a block when - the element type is controlled. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * sinfo.ads: Minor formatting. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_aggr.adb (Add_Association): if the association has a box and no - expression, use the Sloc of the aggregate itself for the new - association. - * errout.adb (First_Node): Exclude nodes with no Sloc, and always use - the Original_Node. - -2011-08-02 Hristian Kirtchev <kirtchev@adacore.com> - - * exp_ch5.adb (Expand_Iterator_Loop): Code cleanup and refactoring. - When a container is provided via a function call, generate a renaming - of the function result. This avoids the creation of a transient scope - and the premature finalization of the container. - * exp_ch7.adb (Is_Container_Cursor): Removed. - (Wrap_Transient_Declaration): Remove the supression of the finalization - of the list controller when the declaration denotes a container cursor, - it is not needed. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * restrict.adb (Check_Formal_Restriction): only issue a warning if the - node is from source, instead of the original node being from source. - * sem_aggr.adb - (Resolve_Array_Aggregate): refine the check for a static expression, to - recognize also static ranges - * sem_ch3.adb, sem_ch3.ads (Analyze_Component_Declaration, - Array_Type_Declaration): postpone the test for the type being a subtype - mark after the type has been resolved, so that component-selection and - expanded-name are discriminated. - (Make_Index, Process_Range_Expr_In_Decl): add a parameter In_Iter_Schm - to distinguish the case of an iteration scheme, so that an error is - issed on a non-static range in SPARK except in an iteration scheme. - * sem_ch5.adb (Analyze_Iteration_Scheme): call Make_Index with - In_Iter_Schm = True. - * sem_ch6.adb (Analyze_Subprogram_Specification): refine the check for - user-defined operators so that they are allowed in renaming - * sem_ch8.adb - (Find_Selected_Component): refine the check for prefixing of operators - so that they are allowed in renaming. Move the checks for restrictions - on selector name after analysis discriminated between - component-selection and expanded-name. - * sem_res.adb (Resolve_Op_Concat_Arg): do not issue a warning on - concatenation argument of string type if it is static. - * sem_util.adb, sem_util.ads - (Check_Later_Vs_Basic_Declarations): add a new function - Is_Later_Declarative_Item to decice which declarations are allowed as - later items, in the two different modes Ada 83 and SPARK. In the SPARK - mode, add that renamings are considered as later items. - (Enclosing_Package): new function to return the enclosing package - (Enter_Name): correct the rule for homonyms in SPARK - (Is_SPARK_Initialization_Expr): default to returning True on nodes not - from source (result of expansion) to avoid issuing wrong warnings. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * errout.adb: On anything but an expression First_Node returns its - argument. - -2011-08-02 Pascal Obry <obry@adacore.com> - - * prj-proc.adb, make.adb, makeutl.adb: Minor reformatting. - -2011-08-02 Hristian Kirtchev <kirtchev@adacore.com> - - * exp_ch5.adb (Expand_Iterator_Loop): Code cleanup and reorganization. - Set the associated loop as the related expression of internally - generated cursors. - * exp_ch7.adb (Is_Container_Cursor): New routine. - (Wrap_Transient_Declaration): Supress the finalization of the list - controller when the declaration denotes a container cursor. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * opt.ads (SPARK_Mode): update comment, SPARK_Mode only set through - command line now. - * par-ch3.adb (P_Delta_Constraint): remove check in SPARK mode that the - expression is a simple expression. This check cannot be performed in - the semantics, so just drop it. - (P_Index_Or_Discriminant_Constraint): move check that the index or - discriminant is a subtype mark to Analyze_Subtype_Declaration in the - semantics. Other cases were previously checked in the semantics. - * par-ch4.adb (P_Name): move checks that a selector name is not - character literal or an operator symbol to Find_Selected_Component in - the semantics - * par-ch5.adb (Parse_Decls_Begin_End): move check that basic - declarations are not placed after later declarations in a separate - procedure in Sem_Util (possibly not the best choice?), to be used both - during parsing, for Ada 83 mode, and during semantic analysis, for - SPARK mode. - * par-endh.adb (Check_End): move check that end label is not missing - to Process_End_Label in the semantics - * par-prag.adb (Process_Restrictions_Or_Restriction_Warnings): remove - the special case for SPARK restriction - * par.adb: use and with Sem_Util, for use in Parse_Decls_Begin_End - * restrict.adb, restrict.ads (Check_Formal_Restriction): add a - parameter Force to issue the error message even on internal node (used - for generated end label). Call Check_Restriction to check when an error - must be issued. In SPARK mode, issue an error message even if the - restriction is not set. - (Check_Restriction): new procedure with an additional out parameter to - inform the caller that a message has been issued - * sem_aggr.adb: Minor modification of message - * sem_attr.adb (Analyze_Attribute): call Check_Formal_Restriction - instead of issuing an error message directly - * sem_ch3.adb (Analyze_Declarations): move here the check that basic - declarations are not placed after later declarations, by calling - Check_Later_Vs_Basic_Declarations - (Analyze_Subtype_Declaration): move here the check that an index or - discriminant constraint must be a subtype mark. Change the check that - a subtype of String must start at one so that it works on subtype marks. - * sem_ch4.adb (Analyze_Call): move here the check that a named - association cannot follow a positional one in a call - * sem_ch5.adb (Check_Unreachable_Code): call Check_Formal_Restriction - instead of issuing an error message directly - * sem_ch8.adb (Find_Selected_Component): move here the check that a - selector name is not a character literal or an operator symbol. Move - here the check that the prefix of an expanded name cannot be a - subprogram or a loop statement. - * sem_util.adb, sem_util.ads (Check_Later_Vs_Basic_Declarations): new - procedure called from parsing and semantics to check that basic - declarations are not placed after later declarations - (Process_End_Label): move here the check that end label is not missing - -2011-08-02 Arnaud Charlet <charlet@adacore.com> - - * sem_ch13.adb (Analyze_Enumeration_Representation_Clause): Ignore enum - representation clause in codepeer mode, since it confuses CodePeer and - does not bring useful info. - -2011-08-02 Ed Falis <falis@adacore.com> - - * init.c: initialize fp hw on MILS. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * errout.adb (First_Node): for bodies, return the node itself (small - optimization). For other nodes, do not check source_unit if the node - comes from Standard. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * exp_ch3.adb: Minor comment additions. - * sem_ch13.adb: Minor reformatting. - -2011-08-02 Pascal Obry <obry@adacore.com> - - * make.adb, makeutl.adb: Removes some superfluous directory separator. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_attr.adb: Minor reformatting. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * einfo.adb (Has_Default_Aspect): Replaces Has_Default_Value - (Has_Default_Component_Value): Removed - * einfo.ads Comment updates - (Has_Default_Aspect): Replaces Has_Default_Value - (Has_Default_Component_Value): Removed - * exp_ch13.adb - (Expand_N_Freeze_Entity): Handle Default[_Component]_Value aspects - * exp_ch3.adb - (Build_Array_Init_Proc): Handle Default_[Component_]Value aspects - (Get_Simple_Init_Val): Handle Default_Value aspect - (Needs_Simple_Initialization): Handle Default_Value aspect - * exp_ch3.ads: Needs_Simple_Initialization - * freeze.adb (Freeze_Entity): Handle Default_[Component_]Value aspect - * par-prag.adb (Pragma_Default[_Component]Value) Removed - * sem_ch13.adb - (Analyze_Aspect_Specifications): Fix Default[_Component]_Value aspects - * sem_prag.adb (Pragma_Default[_Component]Value) Removed - * snames.ads-tmpl (Pragma_Default[_Component]Value) Removed - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch5.adb (Analyze_Iterator_Specification): use base type to locate - package containing iteration primitives. - exp_ch5.adb (Expand_Iterator_Loop): ditto. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch5.adb (Analyze_Iteration_Scheme): For an Ada2012 iterator with - "of", pre-analyze expression in case it is a function call with - finalization actions that must be placed ahead of the loop. - * exp_ch5.adb (Expand_Iterator_Loop): If condition_actions are present - on an Ada2012 iterator, insert them ahead of the rewritten loop. - -2011-08-02 Geert Bosch <bosch@adacore.com> - - * cstand.adb (Create_Float_Types): Only consider C's long double for - Long_Long_Float, in addition to double. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch3.adb, sem_ch5.adb, sem_type.adb, switch-c.adb, switch-c.ads, - sem_prag.adb, sem_util.adb, sem_util.ads, sem_res.adb, warnsw.ads, - prepcomp.ads, cstand.adb, stand.ads, a-calfor.adb, s-stusta.adb: - Minor reformatting. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_attr.adb: handle properly 'Result when it is a prefix of an - indexed component. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * einfo.ads, einfo.adb - (Original_Access_Type): Move this attribute to Node26 since there was - an undocumented use of Node21 in E_Access_Subprogram_Type entities - which causes conflicts and breaks the generation of the .NET compiler. - (Interface_Name): Add missing documentation on JGNAT only uses of - this attribute. - -2011-08-02 Geert Bosch <bosch@adacore.com> - - * cstand.adb (Back_End_Float_Types): Use Elist instead of Nlist - (Find_Back_End_Float_Type): Likewise - (Create_Back_End_Float_Types): Likewise - (Create_Float_Types): Likewise - (Register_Float_Type): Likewise - * sem_ch3.adb (Floating_Point_Type_Declaration): Use Elist instead of - Nlist and split out type selection in new local Find_Base_Type function. - * sem_prag.adb (Process_Import_Predefined_Type): Use Elist instead of - Nlist - * stand.ads (Predefined_Float_Types): Use Elist instead of Nlist - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * inline.adb: Minor code reorganization (put Get_Code_Unit_Entity in - alpha order). - * opt.ads: Minor comment change. - * sem_ch12.adb: Minor code reorganization. - -2011-08-02 Gary Dismukes <dismukes@adacore.com> - - * sem_ch3.adb (Complete_Private_Subtype): Don't append the private - subtype's list of rep items to the list on the full subtype in the case - where the lists are the same. - -2011-08-02 Geert Bosch <bosch@adacore.com> - - * switch-c.adb (Free): New deallocation procedure to avoid implicitly - using the one from System.Strings, which also deallocates all strings. - -2011-08-02 Geert Bosch <bosch@adacore.com> - - * gcc-interface/gigi.h, gcc-interface/misc.c (enumerate_modes): New - function. - * gcc-interface/Make-lang.in: Update dependencies. - -2011-08-02 Olivier Hainque <hainque@adacore.com> - - * gcc-interface/trans.c (Subprogram_Body_to_gnu): Set the function - end_locus. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * sem_ch3.adb (Check_Anonymous_Access_Components): Create extra formals - associated with anonymous access to subprograms. - -2011-08-02 Geert Bosch <bosch@adacore.com> - - * opt.ads - (Preprocessing_Symbol_Defs): Move from Prepcomp.Symbol_Definitions. - (Preprocessing_Symbol_Last): Move from Prepcomp.Last_Definition. - * prepcomp.adb (Symbol_Definitions, Last_Definition): Move to opt.ads - (Add_Symbol_Definition): Move to switch-c.adb - (Process_Command_Line_Symbol_Definitions): Adjust references to above. - * prepcomp.ads: Remove dependency on Ada.Unchecked_Deallocation. - (Add_Symbol_Definition): Move to switch-c.adb. - * sem_ch13.adb, sem_prag.adb: Add dependency on Warnsw. - * sem_warn.adb - (Set_Dot_Warning_Switch, Set_GNAT_Mode_Warnings, Set_Warning_Switch): - Move to warnsw.adb. - * sem_warn.ads (Warn_On_Record_Holes, Warn_On_Overridden_Size, - Set_Dot_Warning_Switch, Set_GNAT_Mode_Warnings, Set_Warning_Switch): - Move to warnsw.adb. - * switch-c.adb: Replace dependency on Prepcomp and Sem_Warn by Warnsw. - (Add_Symbol_Definition): Moved from Prepcomp. - * switch-c.ads: Update copyright notice. Use String_List instead of - Argument_List, removing dependency on System.OS_Lib. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * sem_ch3.adb (Analyze_Object_Declaration): issue an error in formal - mode on initialization expression which does not respect SPARK - restrictions. - * sem_util.adb, sem_util.ads (Is_SPARK_Initialization_Expr): determines - if the tree referenced by its argument represents an initialization - expression in SPARK, suitable for initializing an object in an object - declaration. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * exp_ch9.adb (Expand_Access_Protected_Subprogram_Type): Link the - internally generated access to subprogram with its associated protected - subprogram type. - * einfo.ads, einfo.adb (Original_Access_Type): New attribute. - -2011-08-02 Geert Bosch <bosch@adacore.com> - - * cstand.adb (Register_Float_Type): Print information about type to - register, if the Debug_Flag_Dot_B is set. - * debug.adb (Debug_Flag_Dot_B): Document d.b debug option. - * rtsfind.ads (RE_Max_Base_Digits): New run time entity. - * sem_ch3.adb (Floating_Point_Type_Declaration): Allow declarations - with a requested precision of more than Max_Digits digits and no more - than Max_Base_Digits digits, if a range specification is present and the - Predefined_Float_Types list has a suitable type to derive from. - * sem_ch3.adb (Rep_Item_Too_Early): Avoid generating error in the - case of type completion with pragma Import - * sem_prag.adb - (Process_Import_Predefined_Type): Processing to complete a type - with pragma Import. Currently supports floating point types only. - (Set_Convention_From_Pragma): Do nothing without underlying type. - (Process_Convention): Guard against absence of underlying type, - which may happen when importing incomplete types. - (Process_Import_Or_Interface): Handle case of importing predefined - types. Tweak error message. - -2011-08-02 Eric Botcazou <ebotcazou@adacore.com> - - * inline.adb (Add_Inlined_Body): Adjust check for library-level inlined - functions to previous change. Reorganize code slightly. - -2011-08-02 Geert Bosch <bosch@adacore.com> - - * back_end.ads (Register_Type_Proc): New call back procedure type for - allowing the back end to provide information about available types. - (Register_Back_End_Types): New procedure to register back end types. - * back_end.adb (Register_Back_End_Types): Call the back end to enumerate - available types. - * cstand.adb (Back_End_Float_Types): New list for floating point types - supported by the back end. - (Build_Float_Type): Add extra parameter for Float_Rep_Kind. - (Copy_Float_Type): New procedure to make new copies of predefined types. - (Register_Float_Type): New call back procedure to populate the BEFT list - (Find_Back_End_Float_Type): New procedure to find a BEFT by name - (Create_Back_End_Float_Types): New procedure to populate the BEFT list. - (Create_Float_Types): New procedure to create entities for floating - point types predefined in Standard, and put these and any remaining - BEFTs on the Predefined_Float_Types list. - * stand.ads (Predefined_Float_Types): New list for predefined floating - point types that do not have declarations in package Standard. - -2011-08-02 Eric Botcazou <ebotcazou@adacore.com> - - * inline.adb (Get_Code_Unit_Entity): New local function. Returns the - entity node for the unit containing the parameter. - (Add_Inlined_Body): Use it to find the unit containing the subprogram. - (Add_Inlined_Subprogram): Likewise. - * gcc-interface/Make-lang.in: Update dependencies. - -2011-08-02 Thomas Quinot <quinot@adacore.com> - - * s-stusta.adb (Print): Make sure Pos is always initialized to a - suitable value. - -2011-08-02 Geert Bosch <bosch@adacore.com> - - * a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image. - -2011-08-02 Eric Botcazou <ebotcazou@adacore.com> - - * sem_type.adb (Covers): Move trivial case to the top and reuse the - computed value of Base_Type. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * restrict.adb (Check_Restriction): issue an error for any use of - class-wide, even if the No_Dispatch restriction is not set. - * sem_aggr.adb: Correct typos in comments and messages in formal mode - * sem_ch3.adb (Process_Full_View): issue an error in formal mode is, - when completing a private extension, the type named in the private part - is not the same as that named in the visible part. - * sem_res.adb (Resolve_Call): issue an error in formal mode on the use - of an inherited primitive operations of a tagged type or type extension - that returns the tagged type. - * sem_util.adb, sem_util.ads (Is_Inherited_Operation_For_Type): new - function which returns True for an implicit operation inherited by the - derived type declaration for the argument type. - (Is_SPARK_Object_Reference): move to appropriate place in alphabetic - order. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch5.adb (Pre_Analyze_Range): new procedure extracted from - Process_Bounds, to perform analysis with expansion of a range or an - expression that is the iteration scheme for a loop. - (Analyze_Iterator_Specification): If domain of iteration is given by a - function call with a controlled result, as is the case if call returns - a predefined container, ensure that finalization actions are properly - generated. - * par-ch3.adb: accept Ada2012 iterator form in P_Discrete_Range. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * sem_ch5.adb (Analyze_Iteration_Scheme): Fix typo. - * gcc-interface/Make-lang.in: Update dependencies. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * sem_util.ads, sem_util.adb (Is_Variable): Add a new formal to - determine if the analysis is performed using N or Original_Node (N). - * exp_util.adb (Side_Effect_Free): Code cleanup since the new - functionality of routine Is_Variable avoids code duplication. - * checks.adb (Determine_Range): Handle temporaries generated by - Remove_Side_Effects. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * exp_ch4.adb (Expand_N_Quantified_Expression): Force reanalysis and - expansion of the condition. Required since the previous analysis was - done with expansion disabled (see Resolve_Quantified_Expression) and - hence checks were not inserted and record comparisons have not been - expanded. - -2011-08-02 Ed Falis <falis@adacore.com> - - * s-taprop-vxworks.adb, s-intman-vxworks.adb, s-intman-vxworks.ads: - Update header. - -2011-08-02 Bob Duff <duff@adacore.com> - - * opt.ads: Minor comment fix. - -2011-08-02 Bob Duff <duff@adacore.com> - - * sem_ch12.adb (Analyze_Package_Instantiation, - Analyze_Subprogram_Instantiation): Turn off style checking while - analyzing an instance. Whatever style checks that apply to the generic - unit should apply, so it makes no sense to apply them in an instance. - This was causing trouble when compiling an instance of a runtime - unit that violates the -gnatyO switch. - * stylesw.adb (Set_Style_Check_Options): "when 'O' =>" was missing from - one of the two case statements, causing spurious errors. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * uname.adb: Minor reformatting. - * gnatcmd.adb: Minor reformatting. - * exp_attr.adb: Minor reformatting. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * exp_ch5.adb (Expand_N_Assignment_Statement): under restriction - No_Dispatching_Calls, do not look for the Assign primitive, because - predefined primitives are not created in this case. - -2011-08-02 Bob Duff <duff@adacore.com> - - * stylesw.ads: Minor comment fixes. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * freeze.adb (Add_To_Result): New procedure. - -2011-08-02 Jose Ruiz <ruiz@adacore.com> - - * exp_attr.adb (Find_Stream_Subprogram): When using a configurable run - time, if the specific run-time routines for handling streams of strings - are not available, use the default mechanism. - -2011-08-02 Arnaud Charlet <charlet@adacore.com> - - * s-regpat.ads: Fix typo. - -2011-08-02 Vincent Celier <celier@adacore.com> - - * prj-conf.adb (Get_Or_Create_Configuration_File): If On_Load_Config is - not null, call it to create the in memory config project file without - parsing an existing default config project file. - -2011-08-02 Eric Botcazou <ebotcazou@adacore.com> - - * atree.adb (Allocate_Initialize_Node): Remove useless temporaries. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_elim.adb: an abstract subprogram does not need an eliminate - pragma for its descendant to be eliminable. - -2011-08-02 Ed Falis <falis@adacore.com> - - * init.c: revert to handling before previous checkin for VxWorks - * s-intman-vxworks.adb: delete unnecessary declarations related to - using Ada interrupt facilities for handling signals. - Delete Initialize_Interrupts. Use __gnat_install_handler instead. - * s-intman-vxworks.ads: Import __gnat_install_handler as - Initialize_Interrupts. - * s-taprop-vxworks.adb: Delete Signal_Mask. - (Abort_Handler): change construction of mask to unblock exception - signals. - -2011-08-02 Jerome Guitton <guitton@adacore.com> - - * a-except-2005.adb (Raise_From_Signal_Handler): Call - Debug_Raise_Exception before propagation starts. - -2011-08-02 Eric Botcazou <ebotcazou@adacore.com> - - * exp_ch6.adb (Expand_Call): Guard restriction checks with a call - to Restriction_Check_Required. - * sem_ch3.adb (Analyze_Object_Declaration): Likewise. - * sem_res.adb (Resolve_Call): Likewise. - * sem_attr.adb (Check_Stream_Attribute): Likewise. - -2011-08-02 Bob Duff <duff@adacore.com> - - * stylesw.ads: Update comment. - * style.adb: Minor: Use Error_Msg_NE instead of Error_Msg_N. - * errout.ads: Remove obsolete comment. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * einfo.ads, einfo.adb (Is_Safe_To_Reevaluate): new function. - (Set_Is_Safe_To_Reevaluate): new procedure. - * sem_ch5.adb (Analyze_Assignment): Add one assertion to ensure that no - assignment is allowed on safe-to-reevaluate variables. - (Analyze_Iteration_Schine.Process_Bounds.One_Bound): Decorate the - temporary created to remove side effects in expressions that use - the secondary stack as safe-to-reevaluate. - * exp_util.adb (Side_Effect_Free): Add missing code to handle well - variables that are not true constants. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch5.adb, sem_ch7.adb, einfo.ads, sem_util.adb, sem_util.ads, - sem_res.adb, sem_ch6.adb: Minor reformatting. - -2011-08-02 Jerome Guitton <guitton@adacore.com> - - * a-except-2005.adb (Raise_Current_Excep): Remove obsolete dead code. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch6.adb (New_Overloaded_Entity, Check_Overriding_Indicator): Do - not set Overridden_Operation if subprogram is an initialization - procedure. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * par-ch6.adb: Correct obsolete name in comments - * restrict.adb, restrict.ads (Check_Formal_Restriction): new function - which takes two message arguments (existing function takes one), with - second message used for continuation. - * sem_ch5.adb (Analyze_Block_Statement): in formal mode, only reject - block statements that originate from a source block statement, not - generated block statements - * sem_ch6.adb (Analyze_Function_Call): rename L into Actuals, for - symmetry with procedure case - * sem_ch7.adb (Check_One_Tagged_Type_Or_Extension_At_Most): new - function to issue an error in formal mode if a package specification - contains more than one tagged type or type extension. - * sem_res.adb (Resolve_Actuals): in formal mode, check that actual - parameters matching formals of tagged types are objects (or ancestor - type conversions of objects), not general expressions. Issue an error - on view conversions that are not involving ancestor conversion of an - extended type. - (Resolve_Type_Conversion): in formal mode, issue an error on the - operand of an ancestor type conversion which is not an object - * sem_util.adb, sem_util.ads (Find_Actual): extend the behavior of the - procedure so that it works also for actuals of function calls - (Is_Actual_Tagged_Parameter): new function which determines if its - argument is an actual parameter of a formal of tagged type in a - subprogram call - (Is_SPARK_Object_Reference): new function which determines if the tree - referenced by its argument represents an object in SPARK - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch3.adb: Minor reformatting - Minor comment addition - Minor error msg text change - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * sem_ch5.adb (Analyze_Iteration_Scheme.Uses_Secondary_Stack): New - function. Used to be more precise when we generate a variable plus one - assignment to remove side effects in the evaluation of the Bound - expressions. - (Analyze_Iteration_Scheme): Clean attribute analyzed in all the nodes - of the bound expression to force its re-analysis and thus expand the - associated transient scope (if required). Code cleanup replacing the - previous code that declared the constant entity by an invocation to - routine Force_Evaluation which centralizes this work in the frontend. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * einfo.adb (Is_Base_Type): Improve efficiency by using a flag table - (Base_Type): Now uses improved Is_Base_Type function - * einfo.ads (Base_Type): Inline this function - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_prag.adb (Analyze_Pragma): Defend against infinite recursion - (Analyze_Aspect_Specifications): Fix Sloc values for constructed pragmas - -2011-08-02 Arnaud Charlet <charlet@adacore.com> - - * gcc-interface/Make-lang.in: Update dependencies. - * gcc-interface/Makefile.in: Use s-inmapop-vxworks.adb for all VxWorks - targets. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * par-ch3.adb (P_Delta_Constraint): issue an error in formal mode on - non-simple expression used in delta constraint - (P_Index_Or_Discriminant_Constraint): issue an error in formal mode on - index constraint which is not a subtype mark - * par.adb: With and use Restrict - * sem_ch3.adb (Analyze_Component_Declaration): issue an error in formal - mode on component type which is not a subtype mark and default - expression on component - (Analyze_Subtype_Declaration): issue an error in formal mode on subtype - of string which does not have a lower index bound equal to 1 - (Array_Type_Declaration): issue an error in formal mode on index or - component type which is not a subtype mark, and on aliased keyword on - component - (Derived_Type_Declaration): issue an error in formal mode on interface, - limited or abstract type - (Record_Type_Declaration): issue an error in formal mode on interface - (Record_Type_Definition): issue an error in formal mode on tagged types - and type extensions not declared in the specification of a library unit - package; on null non-tagged record; on variant part - -2011-08-02 Vincent Celier <celier@adacore.com> - - * prj-nmsc.adb (Check_Library_Attributes): Do not report Library_Dir - not declared for qualified library project when Library_Name is not - declared, but Library_Dir is. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch13.adb (Analyze_Aspect_Specification): Fix slocs on generated - pragmas (affects aspects [Component_]Default_Value - (Check_Aspect_At_Freeze_Point): For Component_Default_Value, use - component type for the resolution - -2011-08-02 Eric Botcazou <ebotcazou@adacore.com> - - * einfo.adb (Base_Type): Tune implementation for speed. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * freeze.adb: Minor reformatting. - -2011-08-02 Thomas Quinot <quinot@adacore.com> - - * scos.ads: Update comments. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch3.adb (Build_Derived_Type): Inherit the convention from the - base type, because the parent may be a subtype of a private type whose - convention is established in a private part. - -2011-08-02 Hristian Kirtchev <kirtchev@adacore.com> - - * exp_ch6.adb (Expand_N_Extended_Return_Statement): Wrap the return - statement in a block when the expansion of the return expression has - created a finalization chain. - * freeze.adb (Freeze_Expression): Alphabetize all choices associated - with the parent node. - Add N_Extended_Return_Statement to handle the case where a transient - object declaration appears in the Return_Object_Declarations list of - an extended return statement. - -2011-08-02 Matthew Gingell <gingell@adacore.com> - - * adaint.c (__gnat_is_symbolic_link_attr): Supress warning on possibly - unused parameter 'name'. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_elim.adb (Set_Eliminated): If the overridden operation is an - inherited operation, check whether its alias, which is the source - operastion that it renames, has been marked eliminated. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * exp_util.adb (Safe_Prefixed_Reference): Do not consider safe an - in-mode parameter whose type is an access type since it can be used to - modify its designated object. Enforce code that handles as safe an - access type that is not access-to-constant but it is the result of a - previous removal of side-effects. - (Remove_Side_Effects): Minor code reorganization of cases which require - no action. Done to incorporate documentation on new cases uncovered - working in this ticket: no action needed if this routine was invoked - too early and the nodes are not yet decorated. - * sem_res.adb (Resolve_Slice): Minor code cleanup replacling two calls - to routine Remove_Side_Effects by calls to Force_Evaluation since they - were issued with actuals that are implicitly provided by - Force_Evaluation. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch3.adb, sem_res.adb: Minor reformatting. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * sem_attr.adb (Check_Formal_Restriction_On_Attribute): new procedure - to issue an error in formal mode on attribute not supported in this mode - (Analyze_Attribute): issue errors on standard attributes not supported - in formal mode. - * sem_ch3.adb (Modular_Type_Declaration): remove obsolete part of - comment, and issue error in formal mode on modulus which is not a power - of 2. - (Process_Range_Expr_In_Decl): issue error in formal mode on non-static - range. - * sem_ch8.adb (Find_Type): issue error in formal mode on 'Base in - subtype mark. - * sem_res.adb (Resolve_Unary_Op): issue error in formal mode on unary - operator on modular type (except 'not'). - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * gnat_rm.texi: Minor reformatting. - -2011-08-02 Arnaud Charlet <charlet@adacore.com> - - * s-osinte-linux.ads: Minor comment update and reformatting. - * i-cexten.ads: Make this unit pure, as for its parent. - Will allow its usage in more contexts if needed. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * s-utf_32.ads: Minor comment fix. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_res.adb (Resolve_Actuals): if the subprogram is a primitive - operation of a tagged synchronized type, handle the case where the - controlling argument is overloaded. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * gnat_rm.texi, opt.ads, sem_prag.adb, snames.ads-tmpl: - Replace pragma SPARK_95 with pragma Restrictions (SPARK) - * par-prag.adb (Process_Restrictions_Or_Restriction_Warnings): set - SPARK mode and formal verification mode on processing SPARK restriction - * s-rident.ads (Restriction_Id): add SPARK restriction in those not - requiring consistency checking. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_res.adb: Minor reformatting. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads, - a-cforse.ads: Remove unneeded with of Ada.Containers - Remove commented out pragma Inline's - Move specifications of new subprograms to the actual specs - -2011-08-02 Yannick Moy <moy@adacore.com> - - * a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads, - a-cforse.ads: Update comments. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_attr.adb: add attribute name when 'Result has the wrong prefix. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads, - a-cforse.ads, a-cofove.ads: Minor reformatting. - -2011-08-02 Claire Dross <dross@adacore.com> - - * a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads, a-cforse.ads, - a-cofove.ads: Add comments. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * gnat_rm.texi: Document formal containers. - -2011-08-02 Emmanuel Briot <briot@adacore.com> - - * g-comlin.adb (Goto_Section, Getopt): fix handling of "*" when there - are empty sections. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * mlib-prj.adb, restrict.ads, sem_aggr.adb, sem_ch12.adb: Minor - reformatting. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * aspects.adb: New aspects Default_Value and Default_Component_Value - New format of Aspect_Names table checks for omitted entries - * aspects.ads: Remove mention of Aspect_Cancel and add documentation on - handling of boolean aspects for derived types. - New aspects Default_Value and Default_Component_Value - New format of Aspect_Names table checks for omitted entries - * einfo.ads, einfo.adb (Has_Default_Component_Value): New flag - (Has_Default_Value): New flag - (Has_Default_Component_Value): New flag - (Has_Default_Value): New flag - * par-ch13.adb (P_Aspect_Specifications): New format of Aspect_Names - table. - * par-prag.adb: New pragmas Default_Value and Default_Component_Value - * sem_ch13.adb (Analyze_Aspect_Specifications): New aspects - Default_Value and Default_Component_Value - * sem_prag.adb: New pragmas Default_Value and Default_Component_Value - New aspects Default_Value and Default_Component_Value - * snames.ads-tmpl: New pragmas Default_Value and Default_Component_Value - * sprint.adb: Print N_Aspect_Specification node when called from gdb - -2011-08-02 Vincent Celier <celier@adacore.com> - - * prj-nmsc.adb (Check_Library_Attributes): For virtual library project, - inherit library kind. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_res.adb: Add guards in calls to Matching_Static_Array_Bounds. - Minor reformatting. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * i-cstrin.ads: Updates to make Interfaces.C.Strings match RM - -2011-08-02 Yannick Moy <moy@adacore.com> - - * sem_aggr.adb (Resolve_Aggregate): Fix thinko. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * impunit.adb: Add comment. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * sem_aggr.adb (Check_Qualified_Aggregate): new procedure which checks - qualification of aggregates in formal mode - (Is_Top_Level_Aggregate): returns True for an aggregate not contained in - another aggregate - (Resolve_Aggregate): complete the test that an aggregate is adequately - qualified in formal mode - -2011-08-02 Pascal Obry <obry@adacore.com> - - * make.adb, bindgen.adb, gnatbind.adb: Minor reformatting. - * mlib-prj.adb: Supress warning when compiling binder generated file. - (Build_Library): Supress all warnings when compiling the binder - generated file. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * errout.adb, errout.ads (Check_Formal_Restriction): move procedure - from here... - * restrict.adb, restrict.ads (Check_Formal_Restriction): ...to here - * sem_aggr.adb, sem_ch5.adb, sem_util.adb: - Add with/use clauses to make Check_Formal_Restriction visible - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch12.adb (Check_Generic_Actuals): handle properly actual - in-parameters when type of the generic formal is private in the generic - spec and non-private in the body. - -2011-08-02 Claire Dross <dross@adacore.com> - - * a-cfdlli.adb, a-cfdlli.ads, a-cfhase.adb, a-cfhase.ads, a-cfhama.adb, - a-cfhama.ads, a-cforse.adb, a-cforse.ads, a-cforma.adb, a-cforma.ads, - a-cofove.adb, a-cofove.ads: New files implementing formal containers. - * impunit.adb, Makefile.rtl: Take new files into account. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_aggr.adb, sem_ch3.adb, sem_ch5.adb, make.adb, sem_res.adb, - sem_attr.adb, sem_ch6.adb, sem_ch8.adb: Minor reformatting. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * sem_aggr.adb (Resolve_Aggregate): disable incorrectly placed check in - formal mode - * sem_util.adb (Matching_Static_Array_Bounds): proper detection of - matching static array bounds, taking into account the special case of - string literals - * sem_ch3.adb: Typo in comment. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * errout.adb, errout.ads (Check_Formal_Restriction): new procedure - which issues an error in formal mode if its argument node is originally - from source - * sem_ch3.adb (Analyze_Full_Type_Declaration): move test that a type - has a discriminant specification so that it does not include the case - of derived types - (Derived_Type_Declaration): move here the test that a derived type has a - discriminant specification - * sem_aggr.adb (Resolve_Record_Aggregate): test the presence of the - first element of a component association before accessing its choices - (presence of component association is not enough) - * exp_ch6.adb (Expand_N_Subprogram_Declaration): test if a subprogram - declaration is a library item before accessing the next element in a - list, as library items are not member of lists - * sem_attr.adb, sem_ch11.adb, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, - sem_ch8.adb, sem_ch9.adb, sem_res.adb, sem_util.adb: use - Check_Formal_Restriction whenever possible. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch3.adb (Find_Type_Of_Object): In ASIS mode, create an itype - reference when needed. - -2011-08-02 Bob Duff <duff@adacore.com> - - * gnat_ugn.texi: Fix typo. - -2011-08-02 Vincent Celier <celier@adacore.com> - - * make.adb (Gnatmake): Use MLib.Tgt.Archive_Ext as the extension of - archive file name. Do not use the full path name of archives for Open - VMS. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch12.adb, sem_ch11.adb: New calling sequence for - Analyze_Aspect_Specifications - * sem_ch13.adb - (Analyze_Aspect_Specifications): New handling for boolean aspects - * sem_ch13.ads (Analyze_Aspect_Specifications): New calling sequence - * sem_ch3.adb, sem_ch6.adb, sem_ch7.adb, sem_ch9.adb: New calling - sequence for Analyze_Aspect_Specifications - * sem_prag.adb (Analyze_Pragma): Remove use of Aspect_Cancel entirely - * sinfo.ads, sinfo.adb (Aspect_Cancel): Remove, no longer used - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * freeze.adb (Freeze_Entity): Remove handling of delayed boolean - aspects, since these no longer exist. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * par-ch13.adb (Aspect_Specifications_Present): Always return false on - semicolon, do not try to see if there are aspects following it. - * par-ch3.adb (P_Declarative_Items): Better message for unexpected - aspect spec. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch8.adb, aspects.ads: Minor reformatting. - -2011-08-02 Eric Botcazou <ebotcazou@adacore.com> - - * sem_ch13.ads (Analyze_Aspect_Specification): Add pragma Inline. - * sem_ch13.adb (Analyze_Non_Null_Aspect_Specifications): New procedure - extracted from... - (Analyze_Aspect_Specifications): ...here. Call above procedure. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * exp_ch6.adb (Expand_N_Subprogram_Declaration): issue error in formal - mode on subprogram declaration outside of package specification, unless - it is followed by a pragma Import - * sem_ch3.adb (Access_Definition, Access_Subprogram_Declaration, - Access_Type_Declaration): issue error in formal mode on access type - (Analyze_Incomplete_Type_Decl): issue error in formal mode on - incomplete type - (Analyze_Object_Declaration): issue error in formal mode on object - declaration which does not respect SPARK restrictions - (Analyze_Subtype_Declaration): issue error in formal mode on subtype - declaration which does not respect SPARK restrictions - (Constrain_Decimal, Constrain_Float, Constrain_Ordinary_Fixed): issue - error in formal mode on digits or delta constraint - (Decimal_Fixed_Point_Type_Declaration): issue error in formal mode on - decimal fixed point type - (Derived_Type_Declaration): issue error in formal mode on derived type - other than type extensions of tagged record types - * sem_ch6.adb (Process_Formals): remove check in formal mode, redundant - with check on access definition - * sem_ch9.adb (Analyze_Protected_Definition): issue error in formal - mode on protected definition. - (Analyze_Task_Definition): issue error in formal mode on task definition - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * make.adb, sem_ch8.adb, s-inmaop-vxworks.adb: Minor reformatting. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * sem_ch6.adb (Can_Override_Operator): New function. - (Verify_Overriding_Indicator): Add missing code to check overriding - indicator in operators. Fixes regression. - (Check_Overriding_Indicator): Minor reformating after replacing the - code that evaluates if the subprogram can override an operator by - invocations to the above new function. - * einfo.adb - (Write_Field26_Name): Add missing code to ensure that, following - the documentation in einfo.ads, this field is not shown as attribute - "Static_Initialization" on non-dispatching functions. - -2011-08-02 Jose Ruiz <ruiz@adacore.com> - - * sem_res.adb (Resolve_Call): A call to - Ada.Real_Time.Timing_Events.Set_Handler violates restriction - No_Relative_Delay (AI-0211) only when it sets a relative timing event, - i.e., when the second parameter is of type Time_Span. - -2011-08-02 Vincent Celier <celier@adacore.com> - - * make.adb (Gnatmake): use <library dir>/lib<library name>.a to link - with an archive instead of -L<library dir> -l<library name>. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch8.adb (Analyze_Use_Type): If the clause is being re-analyzed, - mark the base types In_Use in addition to making the operations - use_visible. - -2011-08-02 Ed Falis <falis@adacore.com> - - * init.c: add and setup __gnat_signal_mask for the exception signals - * s-inmaop-vxworks.adb: new file. - * s-intman-vxworks.adb: remove unnecessary initializations and - simplify remaining - * s-intman-vxworks.ads: remove unnecessary variable - * s-taprop-vxworks.adb: simplify signal initialization - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_ch8.adb: Minor code reorganization, comment updates. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * sem_res.adb (Matching_Static_Array_Bounds): Moved to Sem_Util - * sem_util.ads, sem_util.adb (Matching_Static_Array_Bounds): Moved - here from Sem_Res. - (Matching_Static_Array_Bounds): Use Is_Ok_Static_Expression - (Matching_Static_Array_Bounds): Moved here from Sem_Res - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * atree.h, atree.ads, atree.adb: New subprograms to manipulate Elist5. - * par_ch8.adb (P_Use_Type): initialize Used_Operations for node. - * sinfo.ads, sinfo.adb (Used_Operations): new attribute of - use_type_clauses, to handle more efficiently use_type and use_all_type - constructs. - * sem_ch8.adb: Rewrite Use_One_Type and End_Use_Type to handle the - Ada2012 Use_All_Type clause. - (Use_Class_Wide_Operations): new procedure. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * exp_util.adb, par-ch10.adb, par-ch6.adb, sem.adb, sem_ch6.adb, - sem_ch6.ads, sinfo.adb, sinfo.ads, sprint.adb: Change parameterized - expression to expression function. - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * sem_ch4.adb: transform simple Ada2012 membership into equality only - if types are compatible. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * sem_res.adb (Matching_Static_Array_Bounds): new function which - returns True if its argument array types have same dimension and same - static bounds at each index. - (Resolve_Actuals): issue an error in formal mode on actuals passed as - OUT or IN OUT paramaters which are not view conversions in SPARK. - (Resolve_Arithmetic_Op): issue an error in formal mode on - multiplication or division with operands of fixed point types which are - not qualified or explicitly converted. - (Resolve_Comparison_Op): issue an error in formal mode on comparisons of - Boolean or array type (except String) operands. - (Resolve_Equality_Op): issue an error in formal mode on equality - operators for array types other than String with non-matching static - bounds. - (Resolve_Logical_Op): issue an error in formal mode on logical operators - for array types with non-matching static bounds. Factorize the code in - Matching_Static_Array_Bounds. - (Resolve_Qualified_Expression): issue an error in formal mode on - qualified expressions for array types with non-matching static bounds. - (Resolve_Type_Conversion): issue an error in formal mode on type - conversion for array types with non-matching static bounds - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * par-ch10.adb: Minor code reorganization (use Nkind_In). - -2011-08-02 Ed Schonberg <schonberg@adacore.com> - - * par-ch9.adb: save location of entry for proper error message. - -2011-08-02 Javier Miranda <miranda@adacore.com> - - * sem_type.ads, sem_type.adb (Is_Ancestor): Addition of a new formal - (Use_Full_View) which permits this routine to climb through the - ancestors using the full-view of private parents. - * sem_util.adb (Collect_Interfaces_Info, Implements_Interface): Set - Use_Full_View to true in calls to Is_Ancestor. - * sem_disp.adb (Override_Dispatching_Operation): Set Use_Full_View to - true in call to Is_Ancestor. - * exp_ch3.adb (Build_Offset_To_Top_Functions, Initialize_Tag): Set - Use_Full_View to true in call to Is_Ancestor. - * exp_ch7.adb (Controller_Component): Set Use_Full_View to true in - call to Is_Ancestor. - * exp_ch4.adb (Expand_N_Type_Conversion, Tagged_Membership): Set - Use_Full_View to true in calls to Is_Ancestor. - * exp_disp.adb (Expand_Interface_Actuals, Make_Secondary_DT, Make_DT, - Make_Select_Specific_Data_Table, Register_Primitive, - Set_All_DT_Position): Set Use_Full_View to true in calls to Is_Ancestor. - * exp_intr.adb (Expand_Dispatching_Constructor_Call): Set Use_Full_View - to true in call to Is_Ancestor. - * exp_util.adb (Find_Interface_ADT, Find_Interface_Tag): Set - Use_Full_View to true in calls to Is_Ancestor. - * exp_cg.adb - (Write_Call_Info): Set Use_Full_View to true in call to Is_Ancestor. - (Write_Type_Info): Set Use_Full_View to true in call to Is_Ancestor. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * gnat_rm.texi: Minor reformatting. - * sem_prag.adb: Minor reformatting. - -2011-08-02 Tristan Gingold <gingold@adacore.com> - - * vms_data.ads: Add VMS qualifier for -gnateP. - -2011-08-02 Robert Dewar <dewar@adacore.com> - - * par-ch13.adb (P_Aspect_Specification): New meaning of Decl = Empty - * par-ch7.adb (P_Package): Proper placement of aspects for package - decl/instantiation. - * par-endh.adb (Check_End): Ad Is_Sloc parameter - (End_Statements): Add Is_Sloc parameterr - * par.adb (P_Aspect_Specification): New meaning of Decl = Empty - (Check_End): Ad Is_Sloc parameter - (End_Statements): Add Is_Sloc parameterr - -2011-08-02 Vincent Celier <celier@adacore.com> - - * ug_words: Add VMS qualifier equivalent to -gnateP: - /SYMBOL_PREPROCESSING. - -2011-08-02 Jose Ruiz <ruiz@adacore.com> - - * gnat-style.texi: For hexadecimal numeric literals the typical - grouping of digits is 4 to represent 2 bytes. - A procedure spec which is split into several lines is indented two - characters. - -2011-08-02 Yannick Moy <moy@adacore.com> - - * exp_aggr.adb (Is_Others_Aggregate): move function to other unit. - * sem_aggr.adb, sem_aggr.ads (Is_Others_Aggregate): move function here - (Resolve_Aggregate): issue errors in formal modes when aggregate is not - properly qualified - (Resolve_Array_Aggregate): issue errors in formal modes on non-static - choice in array aggregate - (Resolve_Extension_Aggregate): issue errors in formal modes on subtype - mark as ancestor - (Resolve_Record_Aggregate): issue errors in formal modes on mixed - positional and named aggregate for record, or others in record - aggregate, or multiple choice in record aggregate - * sem_res.adb (Resolve_Logical_Op): issue errors in formal mode when - array operands to logical operations AND, OR and XOR do not have the - same static lower and higher bounds - * sem_ch5.adb, sinfo.ads: Correct typos in comments - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * sem_util.ads, sem_util.adb, sem_ch6.adb (Last_Source_Statement): - Replaces Last_Source_Node_In_Sequence. - * err_vars.ads (Error_Msg_Lang): 16 is OK, don't need 4K - * errout.adb (Set_Error_Msg_Lang): Takes arg with no parens, but stores - parens and blank in string (this was inconsistently implemented). - * errout.ads - (Set_Error_Msg_Lang): Takes arg with no parens, but stores parens and - blank in string (this was inconsistently implemented). - * gnat1drv.adb - (Set_Global_Switches): Set formal mode switches appropriately - * opt.ads, opt.adb: Formal mode is now global switches, more consistent - * par-prag.adb - (Analyze_Pragma, case SPARK_95): Set opt switches appropriately and - call Set_Error_Msg_Lang to set "spark" as language name. - * par.adb: Remove unnecessary call to set formal language for errout - * sem_prag.adb (P_Pragma, case SPARK_95): Set opt switches - appropriately and call Set_Error_Msg_Lang to set "spark" as language - name. - * sem_ch4.adb (Analyze_Concatenation_Operand): remove procedure and - calls to it, moved after resolution so that types are known - * sem_res.adb (Resolve_Op_Concat): issue an error in formal mode if - result of concatenation is not of type String - (Resolve_Op_Concat_Arg): issue an error in formal mode if an operand of - concatenation is not properly restricted - * gnat_rm.texi: Add doc on pragma Spark_95. - * gcc-interface/Makefile.in: Remove obsolete target pairs for - Interfaces.C.* on VMS. Remove s-parame-vms-restrict.ads. - * gcc-interface/Make-lang.in: Update dependencies. - -2011-08-01 Javier Miranda <miranda@adacore.com> - - * sem_disp.adb (Override_Dispatching_Operation): Enforce strictness of - condition that detects if the overridden operation must replace an - existing entity. - -2011-08-01 Javier Miranda <miranda@adacore.com> - - * exp_ch4.adb (Expand_N_Case_Expression): Propagate to the expanded - code declarations inserted by Insert_Actions in each alternative of the - N_Case_Expression node. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * sem_ch6.adb: Minor code reorganization. - * sem_util.adb: Minor reformatting. - -2011-08-01 Pascal Obry <obry@adacore.com> - - * prj-env.adb: Remove <prefix>/lib/gpr/<target> project search path. - * gnat_ugn.texi: Add documentation for VERSIONINFO Windows resource. - -2011-08-01 Yannick Moy <moy@adacore.com> - - * par-ch4.adb (P_Name): issue a syntax error in SPARK mode on character - literal or operator symbol which is prefixed - * sem_attr.adb (Analyze_Access_Attribute): issue an error in formal - mode on access attributes. - * sem_ch4.adb (Analyze_Concatenation_Operand): new procedure to check - that concatenation operands are properly restricted in formal mode - (Analyze_Concatenation, Analyze_Concatenation_Rest): call new procedure - Analyze_Concatenation_Operand. Issue an error in formal mode if the - result of the concatenation has a type different from String. - (Analyze_Conditional_Expression, Analyze_Explicit_Dereference, - Analyze_Quantified_Expression, Analyze_Slice, - Analyze_Null): issue an error in formal mode on unsupported constructs - * sem_ch5.adb - (Analyze_Block_Statement): only issue error on source block statement - * sem_util.ads, sem_util.adb (Last_Source_Node_In_Sequence): new - function which returns the last node in a list of nodes for which - Comes_From_Source returns True, if any - * sem_ch6.adb (Check_Missing_Return): minor refactoring to use - Last_Source_Node_In_Sequence - * sem_ch8.adb (Analyze_Exception_Renaming, Analyze_Generic_Renaming, - Analyze_Object_Renaming, Analyze_Use_Package): issue an error in formal - mode on unsupported constructs - * sem_ch9.adb Do not return after issuing error in formal mode, as the - rest of the actions may be needed later on since the error is marked as - not serious. - * sinfo.ads: Typos in comments. - -2011-08-01 Pascal Obry <obry@adacore.com> - - * projects.texi: Minor editing. - -2011-08-01 Yannick Moy <moy@adacore.com> - - * err_vars.ads (Error_Msg_Lang, Error_Msg_Langlen): new variables for - insertion character ~~ - * errout.ads, errout.adb (Formal_Error_Msg_...): remove procedures - (Set_Error_Msg_Lang): new procedure which fixes the language for use - with insertion character ~~ - (Set_Msg_Text): treat insertion character ~~ - * par-ch4.adb, par-ch5.adb, par-endh.adb, sem_attr.adb, sem_ch11.adb, - sem_ch3.adb, sem_ch5.adb, sem_ch9.adb, sem_util.adb: Replace calls to - Formal_Error_Msg_... procedures by equivalent Error_Msg_... - procedures. Favor calls to Error_Msg_F(E) over Error_Msg_N(E). Make - errors related to the formal language restriction not serious - (insertion character |). - * par.adb (Par): set formal language for error messages if needed - * sem_ch6.adb (Check_Missing_Return): take into account possible - generated statements at the end of the function - * snames.ads-tmpl (Name_SPARK_95, Pragma_SPARK_95): new variable and - enumeration value to define a new pragma SPARK_95 - * opt.ads, opt.adb (SPARK_Version_Type, SPARK_Version_Default, - SPARK_Version): new type and variables to store the SPARK version - (none by default). - (SPARK_Mode): return True when SPARK_Version is set - * par-prag.adb: Correct indentation - (Prag): take Pragma_SPARK_95 into account - * sem_prag.adb (Set_Mechanism_Value, Sig_Flags): take Pragma_SPARK_95 - into account. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * sem_ch3.adb, sem_ch3.ads, sem_ch5.adb, prj-part.adb, par-ch4.adb, - sem_util.adb, sem_ch4.adb, sem_ch6.adb, sem_ch6.ads, sem_ch8.adb, - sem_ch8.ads, sem_ch13.ads, par-ch5.adb, prj-env.ads: Minor reformatting - -2011-08-01 Pascal Obry <obry@adacore.com> - - * prj-part.ads, prj-part.adb (Parse): Add Target_Name parameter. Pass - Target_Name to Get_Path call. - (Parse_Single_Project): Likewise. - (Post_Parse_Context_Clause): Likewise. - * prj-env.ads, prj-env.adb (Find_Project): Add Target_Name parameter. - Call Initialise_Project_Path with the proper Target_Name. - (Initialize_Project_Path): Add <gnat_root>/<target_name>/lib/gnat - search path. - (Get_Path): Add Target_Name parameter. Call Initialise_Project_Path - with the proper Target_Name. - * prj-conf.adb (Get_Or_Create_Configuration_File): Pass Target_Name to - Part.Parse routine. - (Parse_Project_And_Apply_Config): Likewise. - * prj-makr.adb (Initialize): Pass empty Target_Name to Parse routine. - This is fine as this part of the code is supporting only native - compilation. - * prj-pars.adb (Parse): Pass empty Target_Name to Parse routine. This - is fine as this part of the code is supporting only native compilation. - -2011-08-01 Yannick Moy <moy@adacore.com> - - * sem_util.adb (Enter_Name): issue error in formal mode on declaration - of homonym, unless the homonym is one of the cases allowed in SPARK - * par-ch5.adb (Parse_Decls_Begin_End): issue error in SPARK mode for - package declaration occurring after a body. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * checks.adb, exp_ch4.adb: Minor reformatting. - -2011-08-01 Javier Miranda <miranda@adacore.com> - - * einfo.ads (Access_Disp_Table): Fix documentation. - (Dispatch_Table_Wrappers): Fix documentation. - -2011-08-01 Pascal Obry <obry@adacore.com> - - * prj-env.adb, prj-env.ads: Minor reformatting. - -2011-08-01 Yannick Moy <moy@adacore.com> - - * sem_util.ads, sem_util.adb, par.adb, par_util.adb - (Formal_Error_Msg, Formal_Error_Msg_N, Formal_Error_Msg_SP): move - procedures out of these packages. - * errout.ads, errout.adb - (Formal_Error_Msg, Formal_Error_Msg_N, Formal_Error_Msg_SP): move - procedures in of this package - (Formal_Error_Msg_NE): new procedure for wrapper on Error_Msg_NE - * par-ch5.adb (Parse_Decls_Begin_End): issue syntax error in SPARK mode - on misplaced later vs initial declarations, like in Ada 83 - * sem_attr.adb (Processing for Analyze_Attribute): issue error in - formal mode on attribute of private type whose full type declaration - is not visible - * sem_ch3.adb (Analyze_Declarations): issue error in formal mode on a - package declaration inside a package specification - (Analyze_Full_Type_Declaration): issue error in formal mode on - controlled type or discriminant type - * sem_ch6.adb (Analyze_Subprogram_Specification): only issue error on - user-defined operator means that it should come from the source - (New_Overloaded_Entity): issue error in formal mode on overloaded - entity. - * sem_ch6.ads, sem_ch13.ads: typos in comments. - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * atree.adb: Minor reformatting. - * checks.adb: Minor reformatting. - -2011-08-01 Vincent Celier <celier@adacore.com> - - * s-parame-vms-ia64.ads: Fix typo in comment - Minor reformatting - * s-parame-vms-restrict.ads: Removed, unused. - -2011-08-01 Javier Miranda <miranda@adacore.com> - - * exp_ch3.adb - (Is_Variable_Size_Array): Remove local subprogram Is_Constant_Bound. - * sem_ch3.adb - (Constrain_Index): Remove side effects in the evaluation of the bounds. - * sem_ch3.ads, sem_ch3.adb - (Is_Constant_Bound): New extended version of the subprogram that was - previously located inside function Exp_Ch3.Is_Variable_Size_Array. - Moved here since it is shared by routines of sem_ch3 and exp_ch3. - * sem_aux.ads (Constant_Value): Fix typo in comment. - * checks.adb (Generate_Index_Checks): New implementation which, for - array objects with constant bounds, generates the runtime check - referencing the bounds of the array type. For other cases this routine - provides its previous behavior obtaining such values from the array - object. - * sem_res.adb (Set_Slice_Subtype): Link a copied range subtree with its - parent type. - * atree.adb (New_Copy): Reset flag Is_Overloaded in the new copy since - we cannot have semantic interpretations of the new node. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * sem_ch6.adb (Fully_Conformant_Expressions): handle quantified - expressions. - -2011-08-01 Arnaud Charlet <charlet@adacore.com> - - * sem_ch8.adb: Minor code editing. - * s-vxwext.adb: Remove trailing space. - * freeze.adb, freeze.ads, errout.ads, erroutc.adb: Fix GPLv3 header for - consistency with other files. - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * s-auxdec.ads, s-auxdec-vms_64.ads: Minor reformatting. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * par-ch10.adb: reject parameterized expressions as compilation unit. - * sem_ch4.adb: handle properly conditional expression with overloaded - then_clause and no else_clause. - -2011-08-01 Tristan Gingold <gingold@adacore.com> - - * s-parame-vms-alpha.ads, s-parame-vms-ia64.ads: Redeclare C_Address - like done by System.Aux_DEC. - * env.c (__gnat_setenv) [VMS]: Put logicals into LNM$PROCESS table. - -2011-08-01 Yannick Moy <moy@adacore.com> - - * par-endh.adb (Check_End): issue a syntax error in SPARK mode for - missing label at end of declaration (subprogram or package) - * par-ch4.adb (P_Name): issue a syntax error in SPARK mode for mixing - of positional and named parameter association - * par.adb, par-util.adb (Formal_Error_Msg_SP): new wrapper on - Error_Msg_SP which adds a prefix to the error message giving the name - of the formal language analyzed - * sem_ch6.adb (Analyze_Return_Type): issue an error in formal mode for - access result type in subprogram, unconstrained array as result type,. - (Analyze_Subprogram_Declaration): issue an error in formal mode for null - procedure - * sem_ch8.adb: Code clean up. - -2011-08-01 Javier Miranda <miranda@adacore.com> - - * sem_ch7.adb (Uninstall_Declarations): Remove useless code. - * einfo.ads (Access_Disp_Table): Fix documentation. - (Dispatch_Table_Wrappers): Fix documentation. - * einfo.adb (Access_Disp_Table, Dispatch_Table_Wrappers, - Set_Access_Disp_Table, Set_Dispatch_Table_Wrappers): Fix the assertions - to enforce the documentation of this attribute. - (Set_Is_Interface): Cleanup the assertion. - * exp_ch4.adb (Expand_Allocator_Expression, Tagged_Membership): Locate - the Underlying_Type entity before reading attribute Access_Disp_Table. - * exp_disp.adb (Expand_Dispatching_Call, Expand_Interface_Conversion): - Locate the Underlying_Type before reading attribute Access_Disp_Table. - * exp_aggr.adb (Build_Array_Aggr_Code, Build_Record_Aggr_Code): Locate - the Underlying_Type entity before reading attribute Access_Disp_Table. - * exp_ch3.adb (Build_Record_Init_Proc, Expand_N_Object_Declaration): - Locate the Underlying_Type entity before reading attribute - Access_Disp_Table. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * s-poosiz.ads: Additional overriding indicators. - -2011-08-01 Yannick Moy <moy@adacore.com> - - * sem_ch5.adb (Analyze_Exit_Statement): add return after error in - formal mode. - (Analyze_Iteration_Scheme): issue error in formal mode when loop - parameter specification does not include a subtype mark. - * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): issue error in - formal mode on abstract subprogram. - (Analyze_Subprogram_Specification): issue error in formal mode on - user-defined operator. - (Process_Formals): issue error in formal mode on access parameter and - default expression. - * sem_ch9.adb (Analyze_Abort_Statement, - Analyze_Accept_Statement, Analyze_Asynchronous_Select, - Analyze_Conditional_Entry_Call, Analyze_Delay_Relative, - Analyze_Delay_Until, Analyze_Entry_Call_Alternative, - Analyze_Requeue, Analyze_Selective_Accept, - Analyze_Timed_Entry_Call): issue error in formal mode on such constructs - * sem_ch11.adb (Analyze_Raise_Statement, Analyze_Raise_xxx_Error): - issue error in formal mode on user-defined raise statement. - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * sem_ch6.adb (Enter_Overloaded_Entity): Do not warn about a - declaration being hidden when overriding an implicit inherited - subprogram. - * par-ch10.adb (P_Compilation_Unit): In syntax check only mode - (-gnats), do not complain about a source file that contains only a - pragma No_Body. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * sem_ch5.adb (Analyze_Iterator_Scheme): Do not overwrite type of loop - variable if already set. - -2011-08-01 Arnaud Charlet <charlet@adacore.com> - - * g-socket-dummy.adb, s-osinte-linux.ads, g-socket-dummy.ads, - g-debuti.adb, g-tasloc.adb, g-debuti.ads, g-tasloc.ads, - s-osinte-hpux.ads, g-sercom.adb, g-soliop-solaris.ads, g-sercom.ads, - g-sptain.ads, g-curexc.ads, s-tasloc.adb, s-tasloc.ads, s-tataat.adb, - g-ctrl_c.adb, a-reatim.adb, s-tataat.ads, g-dirope.adb, g-ctrl_c.ads, - g-dirope.ads, g-boubuf.adb, g-calend.adb, g-boubuf.ads, g-souinf.ads, - g-table.adb, g-bytswa-x86.adb, g-wispch.adb, g-io.adb, g-table.ads, - g-wispch.ads, g-io.ads, g-memdum.adb, g-memdum.ads, g-busorg.adb, - g-busorg.ads, g-regpat.adb, g-sothco-dummy.adb, g-encstr.adb, - g-regpat.ads, g-sothco-dummy.ads, s-osinte-aix.ads, g-encstr.ads, - g-sercom-mingw.adb, s-mastop-vms.adb, g-diopit.adb, g-diopit.ads, - s-vxwext.adb, g-dyntab.adb, g-dyntab.ads, g-crc32.adb, - g-sercom-linux.adb, g-crc32.ads, s-regpat.adb, g-flocon.ads, - s-regpat.ads, g-stheme.adb, g-sestin.ads, s-taspri-posix-noaltstack.ads, - g-soliop.ads, s-inmaop-posix.adb, g-locfil.ads, g-enblsp-vms-alpha.adb, - g-socthi-dummy.adb, g-socthi-dummy.ads, gnat.ads, g-moreex.adb, - g-moreex.ads, g-dynhta.adb, g-dynhta.ads, g-deutst.ads, g-htable.adb, - g-cgicoo.adb, g-htable.ads, g-cgicoo.ads, a-interr.adb, - g-socthi-vms.adb, g-socthi-vms.ads, g-hesora.adb, g-bubsor.adb, - g-hesora.ads, g-bubsor.ads, g-md5.adb, g-md5.ads, s-intman-irix.adb, - s-htable.adb, s-osinte-vms.adb, s-htable.ads, s-osinte-vms.ads, - s-taprob.adb, g-bytswa.adb, g-bytswa.ads, s-osinte-solaris-posix.ads, - a-suenco.adb, g-comver.adb, g-comver.ads, g-exctra.adb, - s-osinte-solaris.adb, g-exctra.ads, s-osinte-irix.ads, - s-osinte-solaris.ads, a-caldel-vms.adb, g-socthi-vxworks.adb, - g-expect.adb, g-socthi-vxworks.ads, g-expect.ads, g-comlin.ads, - g-heasor.adb, g-heasor.ads, g-traceb.adb, g-traceb.ads, g-decstr.adb, - g-spipat.adb, g-decstr.ads, g-spipat.ads, s-mastop-tru64.adb, - g-except.ads, g-thread.adb, g-hesorg.adb, g-thread.ads, g-hesorg.ads, - g-expect-vms.adb, a-stuten.ads, g-spchge.adb, g-spchge.ads, - g-u3spch.adb, g-u3spch.ads, g-spitbo.adb, g-spitbo.ads, - s-osinte-dummy.ads, s-osinte-posix.adb, g-pehage.adb, g-pehage.ads, - s-gloloc-mingw.adb, g-sha1.ads, s-traceb-hpux.adb, - g-trasym-unimplemented.adb, g-trasym-unimplemented.ads, g-io_aux.adb, - g-regexp.adb, g-io_aux.ads, g-socthi-mingw.adb, g-regexp.ads, - s-osinte-hpux-dce.adb, g-socthi-mingw.ads, g-cgi.adb, - s-osinte-hpux-dce.ads, g-cgi.ads, g-byorma.adb, g-boumai.ads, - g-byorma.ads, a-caldel.adb, s-regexp.adb, s-regexp.ads, - g-soliop-mingw.ads, g-sptavs.ads, s-osinte-tru64.ads, g-speche.adb, - g-speche.ads, g-socthi.adb, g-stsifd-sockets.adb, g-socthi.ads, - s-osinte-darwin.ads, i-vxwork-x86.ads, g-awk.adb, i-vxwork.ads, - g-awk.ads, g-zspche.adb, g-zspche.ads, g-socket.adb, g-sptabo.ads, - g-socket.ads, g-semaph.adb, g-semaph.ads, s-taspri-posix.ads, - g-enblsp-vms-ia64.adb, g-cgideb.adb, g-cgideb.ads, g-sothco.adb, - s-osinte-freebsd.ads, g-sothco.ads, g-catiio.adb, g-casuti.adb, - g-catiio.ads, g-casuti.ads, g-trasym.adb, g-trasym.ads, s-casuti.adb, - g-os_lib.adb, s-traceb-mastop.adb, g-busora.adb, s-interr-dummy.adb, - g-busora.ads, g-enutst.ads, s-os_lib.adb, a-tasatt.adb, - s-osinte-mingw.ads: Update to GPLv3 run-time license. - Use GNAT instead of GNARL. - -2011-08-01 Bob Duff <duff@adacore.com> - - * a-cdlili.ads, a-cihama.ads, a-coinve.ads, a-ciorse.ads, a-coorma.ads, - a-cidlli.ads, a-ciormu.ads, a-cihase.ads, a-cohama.ads, a-coorse.ads, - a-ciorma.ads, a-coormu.ads, a-convec.ads, a-cohase.ads: Minor - reformatting. - -2011-08-01 Yannick Moy <moy@adacore.com> - - * debug.adb (d.D) reverve flag for the SPARK mode - (d.E) reverve flag for SPARK generation mode - (d.F) reverve flag for Why generation mode - * opt.ads, opt.adb (ALFA_Mode, ALFA_Through_SPARK_Mode, - ALFA_Through_Why_Mode, Formal_Verification_Mode, SPARK_Mode): New - functions which return True when the corresponding modes are set - (Formal_Language): return "spark" or "alfa" when in formal verification - mode. - * sem_util.ads, sem_util.adb (Formal_Error_Msg): new wrapper on - Error_Msg to prefix the error message with a tag giving the formal - language - (Formal_Error_Msg_N): new wrapper on Error_Msg_N to prefix the error - message with a tag giving the formal language - * sem_ch5.adb (Analyze_Block_Statement): issue error in formal mode on - block statement - (Analyze_Case_Statement): issue error in formal mode on case statement - with a single "others" case alternative - (Analyze_Exit_Statement): issue errors in formal mode on exit - statements which do not respect SPARK restrictions - (Analyze_Goto_Statement): issue error in formal mode on goto statement - (Check_Unreachable_Code): always issue an error (not a warning) in - formal mode on unreachable code (concerns both code after an infinite - loop and after an unconditional jump, both not allowed in SPARK) - * sem_ch6.adb (Analyze_Return_Statement): add call to - Set_Return_Present for a procedure containing a return statement - (already done for functions in Analyze_Function_Return) - (Analyze_Function_Return): issue error in formal mode on extended - return or if return is not last statement in function - (Check_Missing_Return): issue error in formal mode if function does - not end with return or if procedure contains a return - * sem_ch8.ads, sem_ch8.adb (Has_Loop_In_Inner_Open_Scopes): new - function to detect if there is an inner scope of its parameter S which - is a loop. - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * sem_ch6.ads: Minor reformatting. - -2011-08-01 Javier Miranda <miranda@adacore.com> - - * sem_util.adb (Abstract_Interface_List): Complete condition when - processing private type declarations to avoid reading unavailable - attribute. - (Is_Synchronized_Tagged_Type): Complete condition when processing - private extension declaration nodes to avoid reading unavailable - attribute. - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * sem_ch3.adb: Minor reformatting. - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * s-parame-ae653.ads, s-parame-vms-alpha.ads, s-parame-hpux.ads, - i-cpoint.adb, i-cstrin.adb, i-cpoint.ads, i-cstrin.ads, - s-parame-vms-ia64.ads, s-parame.ads, i-c.ads, s-parame-vxworks.ads, - s-parame-vms-restrict.ads: Remove duplicated Interfaces.C.* packages - for VMS, instead parametrize the common implementation with - System.Parameters declarations. - -2011-08-01 Eric Botcazou <ebotcazou@adacore.com> - - * gnat_rm.texi: Document limitation of Pragma No_Strict_Aliasing. - -2011-08-01 Tristan Gingold <gingold@adacore.com> - - * seh_init.c: Fix SEH handler installation on win64. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * sem_ch3.adb (Access_Subprogram_Declaration): in Asis mode, prevent - double analysis of an anonymous access to subprogram, because it can - lead to improper sharing of profiles and a back-end crash. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * make.adb, sem_ch4.adb: Minor reformatting. - * gcc-interface/Make-lang.in: Update dependencies. - * sem_util.adb, exp_ch5.adb: Minor reformatting. - -2011-08-01 Arnaud Charlet <charlet@adacore.com> - - * gnat_rm.texi: Fix definition of Long_Integer. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * exp_aggr.adb: check limit size of static aggregate unconditionally, - to prevent storage exhaustion. - * exp_ch7.adb (Clean_Simple_Protected_Objects): if the scope being - finalized is a function body, insert the cleanup code before the final - return statement, to prevent spurious warnings. - * s-pooglo.ads: add overriding indicator. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * sem_ch4.adb (Operator_Check): improve error message when both a - with_clause and a use_clause are needed to make operator usage legal. - * sem_util.ads, sem_util.adb (Unit_Is_Visible): new predicate to - determine whether a compilation unit is visible within an other, - either through a with_clause in the current unit, or a with_clause in - its library unit or one one of its parents. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * exp_ch5.adb (Expand_N_Iterator_Loop): handle properly an iterator - over an arbitrary expression of an array or container type. - * lib-xref.adb: clarify comment. - -2011-08-01 Bob Duff <duff@adacore.com> - - * einfo.ads: Minor reformatting. - * debug.adb: Minor comment improvement. - -2011-08-01 Javier Miranda <miranda@adacore.com> - - * sem_ch4.adb (Try_Object_Operation): For class-wide subprograms do not - consider hidden subprograms as valid candidates. - -2011-08-01 Arnaud Charlet <charlet@adacore.com> - - * make.adb (Compile): Strip -mxxx switches in CodePeer mode. - -2011-08-01 Vasiliy Fofanov <fofanov@adacore.com> - - * gnat_ugn.texi: Fix typo. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * i-cstrin.adb, sem_util.adb, exp_ch11.adb, sem_ch8.adb, - lib-xref.adb: Minor reformatting - -2011-08-01 Gary Dismukes <dismukes@adacore.com> - - * exp_ch6.adb (Expand_N_Extended_Return_Statement): Replace test of - when to generate a call to Move_Final_List. - (Has_Controlled_Parts): Remove this function. - -2011-08-01 Geert Bosch <bosch@adacore.com> - - * par-ch3.adb (P_Discrete_Choice_List): Improve error message for extra - "," in choice list. - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * exp_ch11.adb (Expand_N_Raise_Statement): Mark N_Raise_xxx_Error for - explicit raise of a predefined exception as Comes_From_Source if the - original N_Raise_Statement comes from source. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * sinfo.ads: Add comment. - * sem_ch6.adb: Minor reformatting. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * freeze.adb (Freeze_Entity): Refine check for bad component size - clause to avoid rejecting confirming clause when atomic/aliased present. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * sem_ch8.adb (Find_Direct_Name, Analyze_Expanded_Name): use Is_LHS to - better determine whether an entity reference is a write. - * sem_util.adb (Is_LHS): refine predicate to handle assignment to a - subcomponent. - * lib-xref.adb (Output_References): Do no suppress a read reference at - the same location as an immediately preceeding modify-reference, to - handle properly in-out actuals. - -2011-08-01 Tristan Gingold <gingold@adacore.com> - - * env.c (__gnat_setenv) [VMS]: Refine previous change. - -2011-08-01 Quentin Ochem <ochem@adacore.com> - - * i-cstrin.adb (New_String): Changed implementation, now uses only the - heap to compute the result. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * atree.ads: Minor reformatting. - -2011-08-01 Emmanuel Briot <briot@adacore.com> - - * g-expect.adb (Get_Command_Output): Fix memory leak. - -2011-08-01 Geert Bosch <bosch@adacore.com> - - * cstand.adb (P_Float_Type): New procedure to print the definition of - predefined fpt types. - (P_Mixed_Name): New procedure to print a name using mixed case - (Print_Standard): Use P_Float_Type for printing floating point types - * einfo.adb (Machine_Emax_Value): Add preliminary support for quad - precision IEEE float. - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * sem_ch3.adb: Minor reformatting. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * sem_ch6.adb (Analyze_Parameterized_Expression): If the expression is - the completion of a generic function, insert the new body rather than - rewriting the original. - -2011-08-01 Yannick Moy <moy@adacore.com> - - * sinfo.ads, errout.ads: Typos in comments. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * par-endh.adb: Minor reformatting. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * aspects.ads, aspects.adb: Add aspects for library unit pragmas - (Pre_Post_Aspects): New subtype. - * par-ch12.adb (P_Generic): New syntax for aspects in packages - * par-ch13.adb (P_Aspect_Specifications): Add Semicolon parameter - * par-ch7.adb (P_Package): Remove Decl parameter - (P_Package): Handle new syntax for aspects (before IS) - * par-ch9.adb (P_Protected_Definition): Remove Decl parameter, handle - new aspect syntax - (P_Task_Definition): Remove Decl parameter, handle new aspect syntax - * par.adb (P_Aspect_Specifications): Add Semicolon parameter - (P_Package): Remove Decl parameter - * sem_ch13.adb (Analyze_Aspect_Specifications): Handle library unit - aspects - * sem_ch7.adb (Analyze_Package_Declaration): Analyze new format aspect - specs - * sem_util.ads, sem_util.adb (Static_Boolean): New function - * sinfo.ads: Document new syntax for aspects in packages etc. - * sprint.adb: Handle new syntax of aspects before IS in package - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * atree.ads: Minor reformatting. - * sem_prag.adb: Minor reformatting. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * exp_util.adb (Insert_Actions): Fix error in handling Actions for - case expr alternative. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * sem_ch12.adb: Fix typo. - -2011-08-01 Geert Bosch <bosch@adacore.com> - - * sem_prag.adb (Check_No_Link_Name): New procedure. - (Process_Import_Or_Interface): Use Check_No_Link_Name. - * cstand.adb (Create_Standard): Use Esize (Standard_Long_Long_Float) - instead of Standard_Long_Long_Float_Size global. Preparation for - eventual removal of per type constants. - * exp_util.ads (Get_Stream_Size): New function returning the stream - size value of subtype E. - * exp_util.adb (Get_Stream_Size): Implement new function. - * exp_strm.adb (Build_Elementary_Input_Call): Use Get_Stream_Size - function. - * exp_attr.adb (Attribute_Stream_Size): Use Get_Stream_Size - * einfo.adb: - (Machine_Mantissa_Value): Handle 128-bit quad precision IEEE floats - -2011-08-01 Geert Bosch <bosch@adacore.com> - - * cstand.adb: Fix comments. - * sem_prag.adb (Analyze_Pragma): Use List_Length instead of explicit - count of arguments. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * exp_ch4.adb, sem_cat.adb: Minor reformatting. - -2011-08-01 Geert Bosch <bosch@adacore.com> - - * atree.ads: Fix comment. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * aspects.ads, aspects.adb (Aspect_Names): Moved from body to spec. - * par-ch13.adb (P_Aspect_Specifications): Check misspelled aspect name. - * par.adb: Add with for Namet.Sp. - * par-tchk.adb: Minor reformatting. - -2011-08-01 Vincent Celier <celier@adacore.com> - - * mlib-tgt-specific-vms-alpha.adb, mlib-tgt-specific-vms-ia64.adb - (Build_Dynamic_Library): Use new function Init_Proc_Name to get the name - of the init procedure of a SAL. - * mlib-tgt-vms_common.ads, mlib-tgt-vms_common.adb (Init_Proc_Name): - New procedure. - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * exp_ch4.adb, s-tasini.ads, sem_attr.adb, s-soflin.ads: Minor - reformatting. - -2011-08-01 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> - - * adaint.c (__gnat_file_time_name_attr): Get rid of warning. - -2011-08-01 Thomas Quinot <quinot@adacore.com> - - * sem_util.adb, sem_util.ads (Has_Overriding_Initialize): Make function - conformant with its spec (return True only for types that have - an overriding Initialize primitive operation that prevents them from - having preelaborable initialization). - * sem_cat.adb (Validate_Object_Declaration): Fix test for preelaborable - initialization for controlled types in Ada 2005 or later mode. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * aspects.ads, aspects.adb: Add aspect Type_Invariant, Precondition, - Postcondition. - (Same_Aspect): New function. - * sem_ch13.adb (Analyze_Aspect_Specifications): Add aspect - Type_Invariant, Precondition, Postcondition. - * snames.ads-tmpl: Add Name_Type_Invariant. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * freeze.adb (Freeze_Entity): Don't call Check_Aspect_At_Freeze_Point - here. - (Freeze_All_Ent): Fix error in handling inherited aspects. - * sem_ch13.adb (Analyze_Aspect_Specifications): Skip aspect that is - already analyzed, but don't skip entire processing of a declaration, - that's wrong in some cases of declarations being rewritten. - (Analyze_Aspect_Specification): Set Is_Delayed_Aspect in aspects. - Don't delay for integer, string literals - Treat predicates in usual manner for delay, remove special case code, - not needed. - (Analyze_Freeze_Entity): Make call to Check_Aspect_At_Freeze_Point - (Build_Predicate_Function): Update saved expression in aspect - (Build_Invariant_Procedure): Update saved expression in aspect - * exp_ch4.adb (Expand_N_Selected_Component): Only do the optimization - of replacement of discriminant references if the reference is simple. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * aspects.ads, aspects.adb: Add Static_Predicate and Dynamic_Predicate. - * sem_ch13.adb (Analyze_Aspect_Specification): Add processing for - Static_Predicate and Dynamic_Predicate. - (Build_Predicate_Function): Add processing for Static_Predicate - and Dynamic_Predicate. - * sinfo.ads, sinfo.adb (From_Dynamic_Predicate): New flag - (From_Static_Predicate): New flag - * snames.ads-tmpl: Add Name_Static_Predicate and Name_Dynamic_Predicate - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * usage.adb: Documentation cleanup for Ada version modes in usage. - * expander.adb: Minor reformatting. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * atree.ads: Minor comment fix. - * a-stwifi.adb, a-stzfix.adb, a-strfix.adb, a-ztexio.ads, a-textio.ads, - a-witeio.ads, sem_prag.adb: Minor reformatting. - -2011-08-01 Doug Rupp <rupp@adacore.com> - - * env.c (__gnat_setenv) [VMS]: Force 32bit on item list structure - pointers. Use descrip.h header file for convenience. Add some - comments. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * freeze.adb (Freeze_Entity): Call Check_Aspect_At_Freeze_Point - (Freeze_All): Call Check_Aspect_At_End_Of_Declarations - * sem_ch13.ads, sem_ch13.adb (Check_Aspect_At_Freeze_Point): - New procedure. - (Check_Aspect_At_End_Of_Declarations): New procedure - (Analye_Aspect_Specification): Minor changes for above procedures - * sinfo.ads, sinfo.adb (Is_Delayed_Aspect): Now set in aspect - specification node as well. - -2011-08-01 Pascal Obry <obry@adacore.com> - - * adaint.c (_gnat_stat): GetFilesAttributesEx() would fail on special - Windows files. Use GetFilesAttributes() in this case to check for file - existence instead of returning with an error code. - -2011-08-01 Vincent Celier <celier@adacore.com> - - * a-stzfix.adb, a-stwifi.adb (Replace_Slice): Fixed computation when - High is above Source length. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * a-ztexio.ads, a-textio.ads, a-witeio.ads: Fix comment. - -2011-08-01 Robert Dewar <dewar@adacore.com> - - * aspects.ads (Boolean_Aspects): New subtype. - * exp_ch13.adb (Expand_Freeze_Entity): Fix errors in handling aspects - for derived types in cases where the parent type and derived type have - aspects. - * freeze.adb (Freeze_Entity): Fix problems in handling derived type - with aspects when parent type also has aspects. - (Freeze_Entity): Deal with delay of boolean aspects (must evaluate - boolean expression at this point). - * sem_ch13.adb (Analyze_Aspect_Specifications): Delay all aspects in - accordance with final decision on the Ada 2012 feature. - * sinfo.ads, sinfo.adb (Is_Boolean_Aspect): New flag. - -2011-08-01 Matthew Heaney <heaney@adacore.com> - - * a-chtgbo.adb (Delete_Node_Sans_Free): Replace iterator with selector. - -2011-08-01 Pascal Obry <obry@adacore.com> - - * a-stzunb-shared.adb, a-strunb-shared.adb, a-stwiun-shared.adb: - Fix Replace_Slice when High is above current string size. - (Replace_Slice): Fix DL computation when High is above current - string length. - -2011-08-01 Gary Dismukes <dismukes@adacore.com> - - * gnat_rm.texi: Add documentation for pragma Static_Elaboration_Desired. - -2011-08-01 Matthew Heaney <heaney@adacore.com> - - * a-rbtgbo.adb (Delete_Node_Sans_Free): Fixed assignment to left child - of node. - -2011-08-01 Pascal Obry <obry@adacore.com> - - * a-stzunb-shared.adb, a-strunb-shared.adb, a-stwiun-shared.adb: Minor - reformatting. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * sem_attr.adb (Analyze_Attribute, case 'Access): Handle properly named - access to protected subprograms in generic bodies. - * sem_ch6.adb (Analyze_Subprogram_Declaration): If the context is a - protected type, indicate that the convention of the subprogram is - Convention_Protected, because it may be used in subsequent declarations - within the protected declaration. - -2011-08-01 Vincent Celier <celier@adacore.com> - - * mlib-prj.adb (Build_Library): Use "ada_" as the prefix for the "init" - and "final" procedures when the name of the library is "ada", to avoid - duplicate symbols "adainit" and "adafinal" in executables. - -2011-08-01 Ed Schonberg <schonberg@adacore.com> - - * sem_attr.adb (Analyze_Attribute, case 'Result): Handle properly a - quantified expression that appears within a postcondition and uses the - Ada2012 'Result attribute. - -2011-07-28 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> - - * init.c (__gnat_error_handler): Cast reason to int. - (__gnat_install_handler): Explain sa_sigaction use. - -2011-07-24 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Subprogram_Type>: If the - subprogram has copy-in copy-out parameters, try to promote the mode of - the return type if it is passed in registers. - -2011-07-24 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/utils2.c (build_binary_op) <ARRAY_REF>: Do not mark the - left operand as addressable. - -2011-07-24 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/gigi.h (build_function_stub): Remove. - (build_return_expr): Likewise. - (convert_vms_descriptor): Declare. - * gcc-interface/utils.c (convert_vms_descriptor): Make global. - (build_function_stub): Move to... - * gcc-interface/utils2.c (build_return_expr): Move to... - * gcc-interface/trans.c (build_function_stub): ...here. - (build_return_expr): ...here. - (Subprogram_Body_to_gnu): Add local variable for language_function. - Disconnect the parameter attributes cache, if any, once done with it. - Call end_subprog_body only after setting the end_locus. - Build the stub associated with the function, if any, at the very end. - (gnat_to_gnu) <N_Return_Statement>: Remove couple of useless local - variables and streamline control flow. - -2011-07-23 Arnaud Charlet <charlet@adacore.com> - - PR ada/49819 - * gcc-interface/Makefile.in (powerpc-linux): Remove reference to - g-trasym-dwarf.adb. - -2011-07-22 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> - - PR bootstrap/49794 - * init.c [sun && __SVR4 && !__vxworks] (__gnat_install_handler): - Assign to act.sa_sigaction. - * tracebak.c [USE_GENERIC_UNWINDER] (__gnat_backtrace): Cast - current->return_address to char * before arithmetic. - -2011-07-22 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> - - * init.c [sgi] (__gnat_error_handler): Update sigaction(2) citation. - Correct argument types. - Extract code from reason. - (__gnat_install_handler): Assign to act.sa_sigaction. - -2011-07-21 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/Make-lang.in (GNAT1_ADA_OBJS): Move ada/b_gnat1.o to... - (GNAT1_OBJS): ...here. - -2011-07-15 Eric Botcazou <ebotcazou@adacore.com> - - PR ada/48711 - * g-socthi-mingw.adb (Fill): Fix formatting. - - * gcc-interface/gigi.h: Move around comment. - -2011-07-14 John David Anglin <dave.anglin@nrc-cnrc.gc.ca> - - PR ada/46350 - * s-taprop-hpux-dce.adb (Abort_Task): Remove unnecessary cast. - -2011-07-14 Florian Weimer <fw@deneb.enyo.de> - - PR ada/48711 - * g-socthi-mingw.adb (Fill): Guard against invalid MSG_WAITALL. - -2011-07-13 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/utils.c (build_vms_descriptor32): Skip the 32-bit - range comparison if Pmode is SImode. - -2011-07-12 Laurent GUERBY <laurent@guerby.net> - Eric Botcazou <ebotcazou@adacore.com> - - * adadecode.c: Wrap up in extern "C" block. - * adadecode.h: Likewise. - * adaint.c: Likewise. Remove 'const' keyword. - * adaint.h: Likewise. - * argv.c: Likewise. - * atree.h: Likewise. - * cio.c: Likewise. - * cstreams.c: Likewise. - * env.c: Likewise. - * exit.c: Likewise. - * fe.h: Likewise. - * final.c: Likewise. - * init.c: Likewise. - * initialize.c: Likewise. - * link.c: Likewise. - * namet.h: Likewise. - * nlists.h: Likewise. - * raise.c: Likewise. - * raise.h: Likewise. - * repinfo.h: Likewise. - * seh_init.c: Likewise. - * targext.c: Likewise. - * tracebak.c: Likewise. - * uintp.h: Likewise. - * urealp.h: Likewise. - * xeinfo.adb: Wrap up generated C code in extern "C" block. - * xsinfo.adb: Likewise. - * xsnamest.adb: Likewise. - * gcc-interface/gadaint.h: Wrap up in extern "C" block. - * gcc-interface/gigi.h: Wrap up some prototypes in extern "C" block. - * gcc-interface/misc.c: Likewise. - * gcc-interface/Make-lang.in (GCC_LINK): Use LINKER. - (GNAT1_C_OBJS): Remove ada/b_gnat1.o. List ada/seh_init.o and - ada/targext.o here... - (GNAT_ADA_OBJS): ...and not here. - (GNAT1_ADA_OBJS): Add ada/b_gnat1.o. - (GNATBIND_OBJS): Reorder. - -2011-07-07 Richard Henderson <rth@redhat.com> - - * gcc-interface/misc.c (gnat_init_gcc_eh): Don't call - dwarf2out_frame_init. - -2011-07-07 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/misc.c (gnat_init): Tweak previous change. - -2011-07-07 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> - - PR target/39150 - * gcc-interface/Makefile.in: Handle x86_64-solaris2. - -2011-07-06 Richard Guenther <rguenther@suse.de> - - * gcc-interface/misc.c (gnat_init): Merge calls to - build_common_tree_nodes and build_common_tree_nodes_2. - Re-initialize boolean_false_node. - -2011-07-02 Eric Botcazou <ebotcazou@adacore.com> - Olivier Hainque <hainque@adacore.com> - Nicolas Setton <setton@adacore.com> - - * gcc-interface/utils.c (record_builtin_type): Set TYPE_ARTIFICIAL on - the type according to the ARTIFICIAL_P parameter. - (create_type_decl): Likewise. - (create_type_stub_decl): Set TYPE_ARTIFICIAL on the type to 1. - -2011-07-01 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/Make-lang.in (gnat1): Prepend '+' to the command. - (gnatbind): Likewise. - -2011-06-29 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> - - * gcc-interface/Makefile.in (TOOLS_LIBS): Add $(LIBINTL). - -2011-06-18 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (gnat_to_gnu_component_type): Use GNAT_TYPE - local variable throughout. Remove useless call to Base_Type. - (gnat_to_gnu_field): Use GNAT_FIELD_TYPE local variable throughout. - Take it also into account for the volatileness of the field. Set the - TREE_SIDE_EFFECTS flag as well in this case. Reorder some warnings. - -2011-06-18 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/trans.c (Identifier_to_gnu): Don't set TREE_THIS_NOTRAP - on a dereference built for a by-ref object if it has an address clause. - -2011-06-18 Eric Botcazou <ebotcazou@adacore.com> - - * einfo.ads (Address_Taken): Document use for the second argument of - Asm_Input and Asm_Output attributes. - * sem_attr.adb (Analyze_Attribute) <Attribute_Asm_Input>: If the second - argument is an entity name, then set Address_Taken on it. - <Attribute_Asm_Output>: Likewise. - * gcc-interface/trans.c (lvalue_required_for_attribute_p): Handle the - Attr_Asm_Input and Attr_Asm_Output attributes explicitly. - (gnat_to_gnu) <N_Code_Statement>: If an operand is going to end up in - memory and is a CONST_DECL, retrieve its corresponding VAR_DECL. - -2011-06-16 Joern Rennecke <joern.rennecke@embecosm.com> - - PR middle-end/46500 - * gcc-interface/decl.c (gnat_to_gnu_param): Use pack_cumulative_args. - -2011-06-14 Joseph Myers <joseph@codesourcery.com> - - * gcc-interface/Make-lang.in (gnatbind$(exeext)): Use ggc-none.o. - (ada/utils.o): Update dependencies. - * gcc-interface/Makefile.in (EXTRA_GNATTOOLS_OBJS): Add - ../../../libcpp/libcpp.a. - * gcc-interface/utils.c: Include common/common-target.h. - (process_attributes): Use targetm_common.have_named_sections. - -2011-06-07 Richard Guenther <rguenther@suse.de> - - * gcc-interface/misc.c (gnat_init): Do not set size_type_node or call - set_sizetype. - -2011-06-06 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/utils2.c (gnat_stabilize_reference): Propagate the - TREE_THIS_NOTRAP flag. - -2011-06-06 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/utils2.c (gnat_stabilize_reference) <COMPOUND_EXPR>: - Fix thinko. - -2011-06-06 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/trans.c (Identifier_to_gnu): Also handle deferred - constants whose full view has discriminants specially. - -2011-06-06 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/utils.c: Include diagnostic.h. - (gnat_write_global_declarations): Output debug information for all - global type declarations before finalizing the compilation unit. - * gcc-interface/Make-lang.in (ada/utils.o): Add dependency. - -2011-05-25 Jakub Jelinek <jakub@redhat.com> - - * gcc-interface/utils.c (def_fn_type): Remove extra va_end. - -2011-05-25 Kai Tietz <ktietz@redhat.com> - - * adaint.c (__gnat_to_canonical_file_list_next): Use array - initialization instead of const/none-const pointer assignment. - -2011-05-24 Joseph Myers <joseph@codesourcery.com> - - * gcc-interface/Make-lang.in (GNAT1_OBJS): Don't include - $(EXTRA_GNAT1_OBJS). - (GNATBIND_OBJS): Don't include $(EXTRA_GNATBIND_OBJS). - (EXTRA_GNAT1_OBJS, EXTRA_GNATBIND_OBJS): Remove. - (gnat1$(exeext), gnatbind$(exeext)): Use libcommon-target.a. - * gcc-interface/Makefile.in (EXTRA_GNATTOOLS_OBJS): Use - libcommon-target.a instead of prefix.o. - -2011-05-21 Joseph Myers <joseph@codesourcery.com> - - PR ada/49097 - * gcc-interface/Make-lang.in (gnatbind$(exeext)): Depend on $(LIBDEPS). - -2011-05-20 Joseph Myers <joseph@codesourcery.com> - - * gcc-interface/Make-lang.in (EXTRA_GNATBIND_OBJS): Remove version.o. - * gcc-interface/Makefile.in (EXTRA_GNATTOOLS_OBJS): Use libcommon.a - instead of version.o. - -2011-05-18 Kai Tietz <ktietz@redhat.com> - - * gcc-interface/trans.c (Exception_Handler_to_gnu_sjlj): Use - boolean_false_node instead of integer_zero_node. - (convert_with_check): Likewise. - * gcc-interface/decl.c (choices_to_gnu): Likewise. - -2011-05-12 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/trans.c (call_to_gnu): In the by-reference case, if the - type of the parameter is an unconstrained array, convert the actual to - the type of the formal in the In Out and Out cases as well. - -2011-05-11 Nathan Froyd <froydnj@codesourcery.com> - - * gcc-interface/utils.c (def_fn_type): Don't call build_function_type; - call build_function_type_array or build_varargs_function_type_array - instead. - (create_subprog_type): Don't call build_function_type; call - build_function_type_vec instead. - -2011-05-11 Nathan Froyd <froydnj@codesourcery.com> - - * gcc-interface/ada-tree.h (TYPE_OBJECT_RECORD_TYPE): Use TYPE_MINVAL. - (TYPE_GCC_MIN_VALUE): Use TYPE_MINVAL. - (TYPE_GCC_MAX_VALUE): Use TYPE_MAXVAL. - -2011-05-07 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (intrin_arglists_compatible_p): Remove spaces. - - * gcc-interface/gigi.h (global_bindings_p): Adjust prototype. - * gcc-interface/utils.c (global_bindings_p): Return bool and simplify. - -2011-05-05 Nathan Froyd <froydnj@codesourcery.com> - - * gcc-interface/trans.c (Case_Statement_to_gnu): Call build_case_label. - -2011-05-05 Nathan Froyd <froydnj@codesourcery.com> - - * gcc-interface/decl.c (intrin_arglists_compatible_p): Use iterators - instead of accessing TYPE_ARG_TYPES directly. - * gcc-interface/utils.c (handle_nonnull_attribute): Likewise. - -2011-05-05 Eric Botcazou <ebotcazou@adacore.com> - - PR ada/48844 - * gcc-interface/gigi.h (get_variant_part): Declare. - * gcc-interface/decl.c (get_variant_part): Make global. - * gcc-interface/utils2.c (find_common_type): Do not return T1 if the - types have the same constant size, are record types and T1 has a - variant part while T2 doesn't. - -2011-05-05 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/utils.c (begin_subprog_body): Do not call - get_pending_sizes. - (end_subprog_body): Likewise. - -2011-05-04 Richard Guenther <rguenther@suse.de> - - * gcc-interface/trans.c (gnat_to_gnu): Remove zero notrunc argument to - int_const_binop. - (pos_to_constructor): Likewise. - -2011-05-03 Nathan Froyd <froydnj@codesourcery.com> - Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/trans.c (gigi): Call build_function_type_list instead - of build_function_type. Adjust calls to... - (build_raise_check): ...this. Do not take a void_tree parameter. - Call build_function_type_list instead of build_function_type. - Fix head comment and swap couple of conditional blocks. - -2011-04-30 Eric Botcazou <ebotcazou@adacore.com> - - * gnatvsn.ads (Library_Version): Bump to 4.7. - (Current_Year): Bump to 2011. - -2011-04-29 Michael Matz <matz@suse.de> - - * gcc-interface/misc.c (gnat_handle_option): Set - warn_maybe_uninitialized. - -2011-04-23 Gerald Pfeifer <gerald@pfeifer.com> - - * gnat_ugn.texi (Complexity Metrics Control): Update link to - the Watson/McCabe paper. - -2011-04-23 Jim Meyering <meyering@redhat.com> - - * gnat_ugn.texi (Examples of gnatxref Usage): Fix typo: s/it it/it is/ - -2011-04-22 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (make_packable_type): Copy DECL_PARALLEL_TYPE - onto the new type. - -2011-04-22 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/gigi.h (create_subprog_decl): Add ARTIFICIAL_FLAG - parameter. - * gcc-interface/utils.c (create_subprog_decl): Likewise. Set - DECL_ARTIFICIAL and DECL_NO_INLINE_WARNING_P on the DECL accordingly. - * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Subprogram_Type>: Add - ARTIFICIAL_FLAG local variable and pass it to create_subprog_decl. - <all>: Do not set flags on the reused DECL node coming from an alias. - Set DECL_IGNORED_P on the DECL node built for subprograms if they - don't need debug info here... - * gcc-interface/trans.c (Subprogram_Body_to_gnu): ...and not here. - (gigi): Adjust calls to create_subprog_decl. - (build_raise_check): Likewise. - (establish_gnat_vms_condition_handler): Likewise. - (Compilation_Unit_to_gnu): Likewise. - (gnat_to_gnu): Likewise. - -2011-04-21 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/Makefile.in (NO_SIBLING_ADAFLAGS): Always define. - (NO_REORDER_ADAFLAGS): New variable. - (EXTRA_GNATTOOLS): Always define. - (../stamp-gnatlib1-$(RTSDIR): Copy tsystem.h. - Clean up and adjust list of files compiled with special options. - * gcc-interface/Make-lang.in: Likewise. - (ada/decl.o): Cosmetical change. - (ada/misc.o): Remove dependency on $(PLUGIN_H). - -2011-04-20 Jim Meyering <meyering@redhat.com> - - * initialize.c (__gnat_initialize): Remove useless if-before-free. - -2011-04-17 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/Make-lang.in (gnatbind): Replace $(ALL_CFLAGS) with - $(CFLAGS) on the link line. - -2011-04-17 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Function>: Declare the - padded type built for the return type if it is unconstrained. - -2011-04-14 Nathan Froyd <froydnj@codesourcery.com> - - * gcc-interface/utils.c (gnat_poplevel): Use block_chainon. - -2011-04-12 Nathan Froyd <froydnj@codesourcery.com> - - * gcc-interface/ada-tree.h (union lang_tree_node): Check for TS_COMMON - before calling TREE_CHAIN. - * gcc-interface/misc.c (gnat_init_ts): New function. - (LANG_HOOKS_INIT_TS): Define. - -2011-04-12 Martin Jambor <mjambor@suse.cz> - - * gcc-interface/utils.c (end_subprog_body): Call cgraph_get_create_node - instead of cgraph_node. - -2011-04-08 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Procedure>: Set minimum - alignment on fields of the RETURN type built for the Copy-In Copy-Out - mechanism. - -2011-04-08 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/trans.c (Identifier_to_gnu): Do not return initializers - of aggregate types that contain a placeholder. - -2011-04-08 Nathan Froyd <froydnj@codesourcery.com> - - * gcc-interface/utils.c (handle_sentinel_attribute): Don't use - TYPE_ARG_TYPES. - (handle_type_generic_attribute): Likewise. - -2011-04-04 Eric Botcazou <ebotcazou@adacore.com> - - PR ada/47163 - * s-oscons-tmplt.c (MSG_WAITALL): Fix thinko in previous change. - -2011-04-04 Kai Tietz <ktietz@redhat.com> - - PR ada/47163 - * s-oscons-tmplt.c (MSG_WAITALL): Define it for native windows targets - to flag value. - -2011-04-02 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/utils2.c (build_allocator): In the unconstrained array - type case, do not strip a padding type around the array type. - -2011-04-02 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/utils.c (update_pointer_to): Finalize named pointer - types. - -2011-04-02 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/lang.opt (feliminate-unused-debug-types): Delete. - * gcc-interface/misc.c (gnat_handle_option): Remove special handling - code for -feliminate-unused-debug-types. - (gnat_post_options): Likewise. - -2011-04-02 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/utils.c (gnat_pushdecl): If this is a non-artificial - declaration of a pointer type, then set DECL_ORIGINAL_TYPE to a - distinct copy. - -2011-04-02 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (gnat_to_gnu_entity): Do not force the - DECL_ARTIFICIAL flag on enumeration types. - -2011-04-02 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Type>: Do not make - fat pointer types artificial unconditionally. - <E_Array_Subtype>: Attach the base array type as a parallel type if it - isn't artificial. - -2011-04-02 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/gigi.h (get_dummy_type): Declare. - (build_dummy_unc_pointer_types): Likewise. - (finish_fat_pointer_type): Likewise. - * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Array_Type>: If a dummy - fat pointer type has been built, complete it in place. - <E_Access_Type>: Call build_dummy_unc_pointer_types to build dummy fat - and thin pointers. Remove useless variable. - (finish_fat_pointer_type): Make global and move to... - * gcc-interface/utils.c (finish_fat_pointer_type): ...here. - (get_dummy_type): New function. - (build_dummy_unc_pointer_types): Likewise. - (gnat_pushdecl): Propage the name to the anonymous variants only. - (update_pointer_to): Only adjust the pointer types in the unconstrained - array case. - -2011-04-02 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/ada-tree.h (DECL_TAFT_TYPE_P): New flag. - * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Incomplete_Type>: Set it - if this is a Taft amendment type and the full declaration is available. - * gcc-interface/trans.c (process_type): Likewise. - If there is an old type, mark the new one as used if DECL_TAFT_TYPE_P. - (process_freeze_entity): Likewise. - * gcc-interface/utils.c (dummy_global): New static variable. - (gnat_write_global_declarations): If there are types declared as used - at the global level, insert them in the global hash table. - -2011-04-02 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/gigi.h (record_builtin_type): Add ARTIFICIAL_P param. - * gcc-interface/utils.c (gnat_pushdecl): If this is a non-artificial - declaration of an array type, then set DECL_ORIGINAL_TYPE to a distinct - copy. - (record_builtin_type): Add ARTIFICIAL_P parameter. Set DECL_ARTIFICIAL - flag of the type accordingly. - * gcc-interface/trans.c (gigi): Adjust calls to record_builtin_type. - -2011-04-02 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Access_Type>: Defer - finalizing types when updating the pointers to the designated type. - <all>: Finalize the deferred types even if we didn't defer processing - of incomplete types in this invocation. - -2011-04-01 Olivier Hainque <hainque@adacore.com> - Nicolas Setton <setton@adacore.com> - Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/misc.c (gnat_descriptive_type): New function. - (LANG_HOOKS_DESCRIPTIVE_TYPE): Redefine to gnat_descriptive_type. - -2011-03-28 Kai Tietz <ktietz@redhat.com> - - * gcc-interface/Makefile.in (SO_LIB): Handle multilib build for native - Windows targets. - (EH_MECHANISM): Use GCC exception mechanism for native Windows targets. - * system-mingw.ads (System): Change ZCX_By_Default default to True. - - * raise-gcc.c (PERSONALITY_FUNCTION): Add prototype. - -2011-03-28 Tristan Gingold <gingold@adacore.com> - - PR ada/44431 - * gcc-interface/Make-lang.in (ada/b_gnat1.adb): Replace ada/b_gnat1.c. - Use ada output of gnatbind. - (ada/b_gnatb.adb): Ditto. - (ada/b_gnat1.o, ada/b_gnatb.o): New rules. - (ada.mostlyclean, ada.stage1) - (ada.stage2, ada.stage3, ada.stage4, ada.stageprofile) - (ada.stagefeedback): Adjust. - * gcc-interface/Makefile.in (b_gnatl.adb): Replace b_gnatl.c. - Use ada output of gnatbind. - (b_gnatm.adb): Ditto. - (b_gnatl.o, b_gnatm.o): New rules. - -2011-03-26 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (gnat_to_gnu_entity) <object>: Create TYPE_DECL - for the padded type built to support a specified size or alignment. - -2011-03-26 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/gigi.h (finalize_from_with_types): Adjust comment. - * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Access_Type>: Defer - unconditionally to the end of the unit when the designated type is - limited_with'ed. - <all>: Rename local variable. Attempt to un-defer types only and do it - for limited_with'ed types as well. - (finalize_from_with_types): Adjust comment. Rename variable and tidy. - * gcc-interface/trans.c (Compilation_Unit_to_gnu): Use GNAT_UNIT - consistently and remove redundant call to finalize_from_with_types. - -2011-03-26 Eric Botcazou <ebotcazou@adacore.com> - - * inline.adb (Back_End_Cannot_Inline): Lift restriction on calls to - subprograms without a previous spec declared in the same unit. - * gcc-interface/trans.c (Compilation_Unit_to_gnu): Process inlined - subprograms at the end of the unit instead of at the beginning. - * gcc-interface/utils.c (create_subprog_decl): Check that the entity - isn't public for the special handling of non-inline functions nested - inside inline external functions. - -2011-03-25 Jeff Law <law@redhat.com> - - * gcc-interface/utils.c (def_fn_type): Add missing va_end. - -2011-03-24 Eric Botcazou <ebotcazou@adacore.com> - - * einfo.ads (Size_Depends_On_Discriminant): Adjust description. - * layout.adb (Compute_Size_Depends_On_Discriminant): New procedure - to compute Set_Size_Depends_On_Discriminant. - (Layout_Type): Call it on array types in back-end layout mode. - * sem_util.adb (Requires_Transient_Scope): Return true for array - types only if the size depends on the value of discriminants. - * gcc-interface/utils2.c (build_binary_op) <MODIFY_EXPR>: Use the RHS - type if the RHS is a call to a function that returns an unconstrained - type with default discriminant. - -2011-03-24 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/trans.c (gnat_to_gnu): Remove obsolete case of - non-conversion to the nominal result type at the end. - -2011-03-23 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/trans.c (create_temporary): New function taken from... - (create_init_temporary): ...here. Call it. - (call_to_gnu): Create the temporary for the return value early, if any. - Create it for a function with copy-in/copy-out parameters if there is - no target; in other cases of copy-in/copy-out, use another temporary. - Push the new binding level lazily. Add and rename local variables. - -2011-03-23 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (validate_size): Improve comments and tweak - error message. - (set_rm_size): Likewise. - -2011-03-23 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (gnat_to_gnu_entity) <object>: Create TYPE_DECL - for the padded type built in order to support a specified alignment. - Fix incorrect formatting. - -2011-03-21 Eric Botcazou <ebotcazou@adacore.com> - - PR bootstrap/48216 - * gcc-interface/decl.c (elaborate_expression_1): Localize GNU_DECL. - -2011-03-21 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (components_to_record): Add REORDER parameter, - rename DEBUG_INFO_P into DEBUG_INFO and move P_GNU_REP_LIST parameter - to the end of the list. Adjust recursive call. Rename local variable. - If REORDER is true, reorder components of the record type. - (gnat_to_gnu_entity): Pass OK_To_Reorder_Components flag as argument to - components_to_record and adjust the parameter list. - -2011-03-21 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (elaborate_expression_1): When optimization is - disabled, use the variable for bounds of loop iteration scheme. - -2011-03-21 Kai Tietz <ktietz@redhat.com> - - PR target/12171 - * gcc-interface/utils.c (gnat_internal_attribute_table): Add column. - -2011-03-17 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c (elaborate_expression_1): Try harder to find - out whether the expression is read-only. Short-circuit placeholder - case and rename a couple of local variables. - -2011-03-17 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/gigi.h (smaller_form_type_p): Declare. - * gcc-interface/trans.c (smaller_form_type_p): Make global and move... - * gcc-interface/utils.c (smaller_form_type_p): ...to here. - (convert): Deal with conversions from a smaller form type specially. - -2011-02-14 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/misc.c (gnat_init_options): Do not concatenate -I and - its argument, except for the special -I- switch. - -2011-02-12 Gerald Pfeifer <gerald@pfeifer.com> - - * gnat_ugn.texi (Compiling Different Versions of Ada): Update link to - "Ada Issues". - -2011-02-08 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/Makefile.in (x86-64 darwin): Handle multilibs. - -2011-02-03 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/gigi.h (fill_vms_descriptor): Take GNU_TYPE instead of - GNAT_FORMAL. - * gcc-interface/utils2.c (fill_vms_descriptor): Move from here to... - * gcc-interface/utils.c (fill_vms_descriptor): ...here. Take GNU_TYPE - instead of GNAT_FORMAL. Protect the expression against multiple uses. - Do not generate the check directly, instead instantiate the template - check present in the descriptor. - (make_descriptor_field): Move around. - (build_vms_descriptor32): Build a template check in the POINTER field. - (build_vms_descriptor): Remove useless suffixes. - * gcc-interface/trans.c (call_to_gnu): Adjust fill_vms_descriptor call. - -2011-01-26 Eric Botcazou <ebotcazou@adacore.com> - - PR bootstrap/47467 - * targext.c: Include target files if IN_RTS is defined. - -2011-01-26 Richard Guenther <rguenther@suse.de> - - PR bootstrap/47467 - * targext.c: Include config.h. - * gcc-interface/Make-lang.in (ada/targext.o): Add $(CONFIG_H) - dependency. - -2011-01-04 Pascal Obry <obry@adacore.com> - Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/decl.c: Disable Stdcall convention handling for 64-bit. - -2011-01-04 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/trans.c (Case_Statement_to_gnu): Put the SLOC of the - end-of-case on the end label and its associated gotos, if any. - -2011-01-04 Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/trans.c (Subprogram_Body_to_gnu): Evaluate the - expressions of the parameter cache within the statement group of - the CICO mechanism. - -2011-01-04 Olivier Hainque <hainque@adacore.com> - Eric Botcazou <ebotcazou@adacore.com> - - * gcc-interface/trans.c (BLOCK_SOURCE_END_LOCATION): Provide default. - (set_end_locus_from_node): New function. - (Subprogram_Body_to_gnu): Use it to mark both the inner BIND_EXPR we - make and the function end_locus. - (Compilation_Unit_to_gnu): Call it instead of a straight Sloc_to_locus - for the elaboration subprogram. - (set_gnu_expr_location_from_node) <default case>: Use it to attempt to - set the end_locus of the expression as well. - -2011-01-04 Eric Botcazou <ebotcazou@adacore.com> - - PR ada/47131 - * gcc-interface/trans.c (Identifier_to_gnu): In SJLJ mode, do not make - variables that are referenced in exception handlers volatile. - - - -Copyright (C) 2011 Free Software Foundation, Inc. - -Copying and distribution of this file, with or without modification, -are permitted in any medium without royalty provided the copyright -notice and this notice are preserved. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index d3212b20559..144e91469d4 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -483,6 +483,7 @@ GNATRTL_NONTASKING_OBJS= \ s-auxdec$(objext) \ s-bitops$(objext) \ s-boarop$(objext) \ + s-bytswa$(objext) \ s-carsi8$(objext) \ s-carun8$(objext) \ s-casi16$(objext) \ diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads index 8bf8a3d61a3..67ff3af8f48 100644 --- a/gcc/ada/a-cfdlli.ads +++ b/gcc/ada/a-cfdlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, 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 -- @@ -307,6 +307,9 @@ private Node : Count_Type := 0; end record; + type Constant_Reference_Type + (Element : not null access constant Element_Type) is null record; + procedure Read (Stream : not null access Root_Stream_Type'Class; Item : out Cursor); @@ -323,7 +326,4 @@ private No_Element : constant Cursor := (Node => 0); - type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; - end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index cc93b4c2fc0..fafe6719170 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -888,9 +888,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + + pragma Unsuppress (Accessibility_Check); + Element : Element_Access := new Element_Type'(New_Item); + begin New_Node := new Node_Type'(Element, null, null); + exception when others => Free (Element); @@ -1461,6 +1471,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Replace_Element"); declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + X : Element_Access := Position.Node.Element; begin diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 1d30d0443e4..2ea73b9f960 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -694,8 +694,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Position.Node.Key := new Key_Type'(Key); + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Position.Node.Element := new Element_Type'(New_Item); + exception when others => Free_Key (K); @@ -731,9 +739,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is K : Key_Access := new Key_Type'(Key); E : Element_Access; + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin E := new Element_Type'(New_Item); return new Node_Type'(K, E, Next); + exception when others => Free_Key (K); @@ -1166,8 +1181,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Node.Key := new Key_Type'(Key); + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Node.Element := new Element_Type'(New_Item); + exception when others => Free_Key (K); @@ -1215,6 +1238,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare X : Element_Access := Position.Node.Element; + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Position.Node.Element := new Element_Type'(New_Item); Free_Element (X); diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 735179415c1..9d96b6c6452 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -185,6 +185,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Assign (Node : Node_Access; Item : Element_Type) is X : Element_Access := Node.Element; + + -- The element allocator may need an accessibility check in the case the + -- actual type is class-wide or has access discriminants (RM 4.8(10.1) + -- and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Node.Element := new Element_Type'(Item); Free_Element (X); @@ -194,10 +201,10 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin if Target'Address = Source'Address then return; + else + Target.Clear; + Target.Union (Source); end if; - - Target.Clear; - Target.Union (Source); end Assign; -------------- @@ -807,7 +814,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is X := Position.Node.Element; - Position.Node.Element := new Element_Type'(New_Item); + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Position.Node.Element := new Element_Type'(New_Item); + end; Free_Element (X); end if; @@ -863,9 +879,18 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -------------- function New_Node (Next : Node_Access) return Node_Access is + + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + Element : Element_Access := new Element_Type'(New_Item); + begin return new Node_Type'(Element, Next); + exception when others => Free_Element (Element); @@ -881,9 +906,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Local_Insert (HT, New_Item, Node, Inserted); - if Inserted - and then HT.Length > HT_Ops.Capacity (HT) - then + if Inserted and then HT.Length > HT_Ops.Capacity (HT) then HT_Ops.Reserve_Capacity (HT, HT.Length); end if; end Insert; @@ -1317,7 +1340,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is X := Node.Element; - Node.Element := new Element_Type'(New_Item); + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(New_Item); + end; Free_Element (X); end Replace; diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index 050c0395dee..e249c6a68d6 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -291,7 +291,19 @@ package body Ada.Containers.Indefinite_Multiway_Trees is with "attempt to tamper with cursors (tree is busy)"; end if; - Element := new Element_Type'(New_Item); + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + + pragma Unsuppress (Accessibility_Check); + + begin + Element := new Element_Type'(New_Item); + end; + First := new Tree_Node_Type'(Parent => Parent.Node, Element => Element, others => <>); @@ -1240,7 +1252,19 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position.Container := Parent.Container; - Element := new Element_Type'(New_Item); + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + + pragma Unsuppress (Accessibility_Check); + + begin + Element := new Element_Type'(New_Item); + end; + Position.Node := new Tree_Node_Type'(Parent => Parent.Node, Element => Element, others => <>); @@ -1805,7 +1829,19 @@ package body Ada.Containers.Indefinite_Multiway_Trees is with "attempt to tamper with cursors (tree is busy)"; end if; - Element := new Element_Type'(New_Item); + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + + pragma Unsuppress (Accessibility_Check); + + begin + Element := new Element_Type'(New_Item); + end; + First := new Tree_Node_Type'(Parent => Parent.Node, Element => Element, others => <>); @@ -2163,7 +2199,16 @@ package body Ada.Containers.Indefinite_Multiway_Trees is with "attempt to tamper with elements (tree is locked)"; end if; - E := new Element_Type'(New_Item); + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + E := new Element_Type'(New_Item); + end; X := Position.Node.Element; Position.Node.Element := E; diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index e955dec8915..472c912d27b 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -812,8 +812,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position.Node.Key := new Key_Type'(Key); + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Position.Node.Element := new Element_Type'(New_Item); + exception when others => Free_Key (K); @@ -852,6 +860,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function New_Node return Node_Access is Node : Node_Access := new Node_Type; + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Node.Key := new Key_Type'(Key); Node.Element := new Element_Type'(New_Item); @@ -860,9 +874,10 @@ package body Ada.Containers.Indefinite_Ordered_Maps is exception when others => - -- On exception, deallocate key and elem + -- On exception, deallocate key and elem. Note that free + -- deallocates both the key and the elem. - Free (Node); -- Note that Free deallocates key and elem too + Free (Node); raise; end New_Node; @@ -1492,8 +1507,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Node.Key := new Key_Type'(Key); + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Node.Element := new Element_Type'(New_Item); + exception when others => Free_Key (K); @@ -1542,6 +1565,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is declare X : Element_Access := Position.Node.Element; + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Position.Node.Element := new Element_Type'(New_Item); Free_Element (X); diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb index 928ba9924c4..7bd1aa1e557 100644 --- a/gcc/ada/a-ciormu.adb +++ b/gcc/ada/a-ciormu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, 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- -- @@ -1167,6 +1167,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -------------- function New_Node return Node_Access is + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + Element : Element_Access := new Element_Type'(New_Item); begin @@ -1175,6 +1181,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is Right => null, Color => Red_Black_Trees.Red, Element => Element); + exception when others => Free_Element (Element); @@ -1768,6 +1775,13 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is declare X : Element_Access := Node.Element; + + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Node.Element := new Element_Type'(Item); Free_Element (X); @@ -1793,6 +1807,13 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -------------- function New_Node return Node_Access is + + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Node.Element := new Element_Type'(Item); -- OK if fails Node.Color := Red_Black_Trees.Red; diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 7b919494a17..885c6b6568b 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -1173,9 +1173,18 @@ package body Ada.Containers.Indefinite_Ordered_Sets is "attempt to tamper with elements (set is locked)"; end if; - X := Position.Node.Element; - Position.Node.Element := new Element_Type'(New_Item); - Free_Element (X); + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + X := Position.Node.Element; + Position.Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end; end if; end Include; @@ -1238,6 +1247,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -------------- function New_Node return Node_Access is + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + Element : Element_Access := new Element_Type'(New_Item); begin @@ -1246,6 +1261,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Right => null, Color => Red_Black_Trees.Red, Element => Element); + exception when others => Free_Element (Element); @@ -1818,9 +1834,18 @@ package body Ada.Containers.Indefinite_Ordered_Sets is "attempt to tamper with elements (set is locked)"; end if; - X := Node.Element; - Node.Element := new Element_Type'(New_Item); - Free_Element (X); + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + X := Node.Element; + Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end; end Replace; --------------------- @@ -1854,6 +1879,13 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -------------- function New_Node return Node_Access is + + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Node.Element := new Element_Type'(Item); -- OK if fails Node.Color := Red; @@ -1872,9 +1904,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Start of processing for Replace_Element begin - if Item < Node.Element.all - or else Node.Element.all < Item - then + if Item < Node.Element.all or else Node.Element.all < Item then null; else @@ -1883,8 +1913,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is "attempt to tamper with elements (set is locked)"; end if; - Node.Element := new Element_Type'(Item); - Free_Element (X); + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end; return; end if; @@ -1901,8 +1940,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is "attempt to tamper with elements (set is locked)"; end if; - Node.Element := new Element_Type'(Item); - Free_Element (X); + declare + -- The element allocator may need an accessibility check in the + -- case actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end; return; end if; diff --git a/gcc/ada/a-coinho.adb b/gcc/ada/a-coinho.adb index b6c38b098b6..0d0d40064e9 100644 --- a/gcc/ada/a-coinho.adb +++ b/gcc/ada/a-coinho.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2012, 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- -- @@ -220,8 +220,19 @@ package body Ada.Containers.Indefinite_Holders is raise Program_Error with "attempt to tamper with elements"; end if; - Free (Container.Element); - Container.Element := new Element_Type'(New_Item); + declare + X : Element_Access := Container.Element; + + -- Element allocator may need an accessibility check in case actual + -- type is class-wide or has access discriminants (RM 4.8(10.1) and + -- AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Container.Element := new Element_Type'(New_Item); + Free (X); + end; end Replace_Element; --------------- @@ -229,6 +240,12 @@ package body Ada.Containers.Indefinite_Holders is --------------- function To_Holder (New_Item : Element_Type) return Holder is + -- The element allocator may need an accessibility check in the case the + -- actual type is class-wide or has access discriminants (RM 4.8(10.1) + -- and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin return (AF.Controlled with new Element_Type'(New_Item), 0); end To_Holder; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 0627af1b94e..e615ad17efd 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -1698,7 +1698,16 @@ package body Ada.Containers.Indefinite_Vectors is -- value, in case the allocation fails (either because there is no -- storage available, or because element initialization fails). - Container.Elements.EA (Idx) := new Element_Type'(New_Item); + declare + -- The element allocator may need an accessibility check in the + -- case actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Container.Elements.EA (Idx) := new Element_Type'(New_Item); + end; -- The allocation of the element succeeded, so it is now safe to -- update the Last index, restoring container invariants. @@ -1744,7 +1753,16 @@ package body Ada.Containers.Indefinite_Vectors is -- because there is no storage available, or because element -- initialization fails). - E (Idx) := new Element_Type'(New_Item); + declare + -- The element allocator may need an accessibility check + -- in case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + E (Idx) := new Element_Type'(New_Item); + end; -- The allocation of the element succeeded, so it is now -- safe to update the Last index, restoring container @@ -1780,6 +1798,14 @@ package body Ada.Containers.Indefinite_Vectors is -- K always has a value if the exception handler triggers. K := Before; + + declare + -- The element allocator may need an accessibility check in + -- the case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin while K < Index loop E (K) := new Element_Type'(New_Item); @@ -1885,7 +1911,16 @@ package body Ada.Containers.Indefinite_Vectors is -- because there is no storage available, or because element -- initialization fails). - Dst.EA (Idx) := new Element_Type'(New_Item); + declare + -- The element allocator may need an accessibility check in + -- the case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Dst.EA (Idx) := new Element_Type'(New_Item); + end; -- The allocation of the element succeeded, so it is now safe -- to update the Last index, restoring container invariants. @@ -1925,7 +1960,16 @@ package body Ada.Containers.Indefinite_Vectors is -- already been updated), so if this allocation fails we simply -- let it propagate. - Dst.EA (Idx) := new Element_Type'(New_Item); + declare + -- The element allocator may need an accessibility check in + -- the case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Dst.EA (Idx) := new Element_Type'(New_Item); + end; end loop; end if; end; @@ -3174,6 +3218,13 @@ package body Ada.Containers.Indefinite_Vectors is declare X : Element_Access := Container.Elements.EA (Index); + + -- The element allocator may need an accessibility check in the case + -- where the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Container.Elements.EA (Index) := new Element_Type'(New_Item); Free (X); @@ -3205,6 +3256,13 @@ package body Ada.Containers.Indefinite_Vectors is declare X : Element_Access := Container.Elements.EA (Position.Index); + + -- The element allocator may need an accessibility check in the case + -- where the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin Container.Elements.EA (Position.Index) := new Element_Type'(New_Item); Free (X); @@ -3949,6 +4007,13 @@ package body Ada.Containers.Indefinite_Vectors is Last := Index_Type'First; + declare + -- The element allocator may need an accessibility check in the case + -- where the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin loop Elements.EA (Last) := new Element_Type'(New_Item); diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb index cac87afcbfe..e166c9f8f32 100644 --- a/gcc/ada/a-direct.adb +++ b/gcc/ada/a-direct.adb @@ -395,13 +395,8 @@ package body Ada.Directories is (New_Directory : String; Form : String := "") is - pragma Unreferenced (Form); - C_Dir_Name : constant String := New_Directory & ASCII.NUL; - function mkdir (Dir_Name : String) return Integer; - pragma Import (C, mkdir, "__gnat_mkdir"); - begin -- First, the invalid case @@ -410,10 +405,34 @@ package body Ada.Directories is "invalid new directory path name """ & New_Directory & '"'; else - if mkdir (C_Dir_Name) /= 0 then - raise Use_Error with - "creation of new directory """ & New_Directory & """ failed"; - end if; + -- Acquire setting of encoding parameter + + declare + Formstr : constant String := To_Lower (Form); + + Encoding : CRTL.Filename_Encoding; + -- Filename encoding specified into the form parameter + + V1, V2 : Natural; + + begin + Form_Parameter (Formstr, "encoding", V1, V2); + + if V1 = 0 then + Encoding := CRTL.Unspecified; + elsif Formstr (V1 .. V2) = "utf8" then + Encoding := CRTL.UTF8; + elsif Formstr (V1 .. V2) = "8bits" then + Encoding := CRTL.ASCII_8bits; + else + raise Use_Error with "invalid Form"; + end if; + + if CRTL.mkdir (C_Dir_Name, Encoding) /= 0 then + raise Use_Error with + "creation of new directory """ & New_Directory & """ failed"; + end if; + end; end if; end Create_Directory; @@ -425,8 +444,6 @@ package body Ada.Directories is (New_Directory : String; Form : String := "") is - pragma Unreferenced (Form); - New_Dir : String (1 .. New_Directory'Length + 1); Last : Positive := 1; Start : Positive := 1; @@ -487,7 +504,8 @@ package body Ada.Directories is "file """ & New_Dir (1 .. Last) & """ already exists"; else - Create_Directory (New_Directory => New_Dir (1 .. Last)); + Create_Directory + (New_Directory => New_Dir (1 .. Last), Form => Form); end if; end if; end loop; diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index a42c82efa09..4c5f6662985 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -116,26 +116,27 @@ package body Ada.Exceptions is --------------------------------- procedure Set_Exception_C_Msg - (Id : Exception_Id; + (Excep : EOA; + Id : Exception_Id; Msg1 : System.Address; Line : Integer := 0; Column : Integer := 0; Msg2 : System.Address := System.Null_Address); - -- This routine is called to setup the exception referenced by the - -- Current_Excep field in the TSD to contain the indicated Id value - -- and message. Msg1 is a null terminated string which is generated - -- as the exception message. If line is non-zero, then a colon and - -- the decimal representation of this integer is appended to the - -- message. Ditto for Column. When Msg2 is non-null, a space and this - -- additional null terminated string is added to the message. + -- This routine is called to setup the exception referenced by X + -- to contain the indicated Id value and message. Msg1 is a null + -- terminated string which is generated as the exception message. If + -- line is non-zero, then a colon and the decimal representation of + -- this integer is appended to the message. Ditto for Column. When Msg2 + -- is non-null, a space and this additional null terminated string is + -- added to the message. procedure Set_Exception_Msg - (Id : Exception_Id; + (Excep : EOA; + Id : Exception_Id; Message : String); - -- This routine is called to setup the exception referenced by the - -- Current_Excep field in the TSD to contain the indicated Id value - -- and message. Message is a string which is generated as the - -- exception message. + -- This routine is called to setup the exception referenced by X + -- to contain the indicated Id value and message. Message is a string + -- which is generated as the exception message. -------------------------------------- -- Exception information subprogram -- @@ -208,19 +209,19 @@ package body Ada.Exceptions is -- exported to be usable by the Ada exception handling personality -- routine when the GCC 3 mechanism is used. - procedure Notify_Handled_Exception; + procedure Notify_Handled_Exception (Excep : EOA); pragma Export (C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); -- This routine is called for a handled occurrence is about to be -- propagated. - procedure Notify_Unhandled_Exception; + procedure Notify_Unhandled_Exception (Excep : EOA); pragma Export (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); -- This routine is called when an unhandled occurrence is about to be -- propagated. - procedure Unhandled_Exception_Terminate; + procedure Unhandled_Exception_Terminate (Excep : EOA); pragma No_Return (Unhandled_Exception_Terminate); -- This procedure is called to terminate execution following an -- unhandled exception. The exception information, including @@ -232,18 +233,16 @@ package body Ada.Exceptions is package Exception_Propagation is - use Exception_Traces; - -- Imports Notify_Unhandled_Exception and - -- Unhandled_Exception_Terminate - ------------------------------------ -- Exception propagation routines -- ------------------------------------ - procedure Propagate_Exception; + function Allocate_Occurrence return EOA; + -- Allocate an exception occurence (as well as the machine occurence) + + procedure Propagate_Exception (Excep : EOA); pragma No_Return (Propagate_Exception); - -- This procedure propagates the exception represented by the occurrence - -- referenced by Current_Excep in the TSD for the current task. + -- This procedure propagates the exception represented by Excep end Exception_Propagation; @@ -264,17 +263,32 @@ package body Ada.Exceptions is end Stream_Attributes; - procedure Raise_Current_Excep (E : Exception_Id); - pragma No_Return (Raise_Current_Excep); - pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg"); - -- This is a simple wrapper to Exception_Propagation.Propagate_Exception. - -- - -- This external name for Raise_Current_Excep is historical, and probably - -- should be changed but for now we keep it, because gdb and gigi know - -- about it. + procedure Complete_Occurrence (X : EOA); + -- Finish building the occurrence: save the call chain and notify the + -- debugger. + + procedure Complete_And_Propagate_Occurrence (X : EOA); + pragma No_Return (Complete_And_Propagate_Occurrence); + -- This is a simple wrapper to Complete_Occurrence and + -- Exception_Propagation.Propagate_Exception. + + function Create_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return EOA; + -- Create and build an exception occurrence using exception id E and + -- nul-terminated message M. + + function Create_Machine_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return System.Address; + pragma Export (C, Create_Machine_Occurrence_From_Signal_Handler, + "__gnat_create_machine_occurrence_from_signal_handler"); + -- Create and build an exception occurrence using exception id E and + -- nul-terminated message M. Return the machine occurrence. procedure Raise_Exception_No_Defer - (E : Exception_Id; Message : String := ""); + (E : Exception_Id; + Message : String := ""); pragma Export (Ada, Raise_Exception_No_Defer, "ada__exceptions__raise_exception_no_defer"); @@ -372,7 +386,7 @@ package body Ada.Exceptions is -- | | | | -- | | | Set_E_C_Msg(i) -- | | | - -- Raise_Current_Excep + -- Complete_And_Propagate_Occurrence procedure Reraise; pragma No_Return (Reraise); @@ -380,15 +394,16 @@ package body Ada.Exceptions is -- Reraises the exception referenced by the Current_Excep field of -- the TSD (all fields of this exception occurrence are set). Abort -- is deferred before the reraise operation. + -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous procedure Transfer_Occurrence (Target : Exception_Occurrence_Access; Source : Exception_Occurrence); pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); - -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous - -- to setup Target from Source as an exception to be propagated in the - -- caller task. Target is expected to be a pointer to the fixed TSD - -- occurrence for this task. + -- Called from s-tasren.adb:Local_Complete_RendezVous and + -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from + -- Source as an exception to be propagated in the caller task. Target is + -- expected to be a pointer to the fixed TSD occurrence for this task. ----------------------------- -- Run-Time Check Routines -- @@ -887,14 +902,47 @@ package body Ada.Exceptions is end Raise_Constraint_Error_Msg; ------------------------- - -- Raise_Current_Excep -- + -- Complete_Occurrence -- ------------------------- - procedure Raise_Current_Excep (E : Exception_Id) is + procedure Complete_Occurrence (X : EOA) is + begin + -- Compute the backtrace for this occurrence if the corresponding + -- binder option has been set. Call_Chain takes care of the reraise + -- case. + + -- ??? Using Call_Chain here means we are going to walk up the stack + -- once only for backtracing purposes before doing it again for the + -- propagation per se. + + -- The first inspection is much lighter, though, as it only requires + -- partial unwinding of each frame. Additionally, although we could use + -- the personality routine to record the addresses while propagating, + -- this method has two drawbacks: + + -- 1) the trace is incomplete if the exception is handled since we + -- don't walk past the frame with the handler, + + -- and + + -- 2) we would miss the frames for which our personality routine is not + -- called, e.g. if C or C++ calls are on the way. + + Call_Chain (X); + + -- Notify the debugger + Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (X.Id)); + end Complete_Occurrence; + + --------------------------------------- + -- Complete_And_Propagate_Occurrence -- + --------------------------------------- + + procedure Complete_And_Propagate_Occurrence (X : EOA) is begin - Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E)); - Exception_Propagation.Propagate_Exception; - end Raise_Current_Excep; + Complete_Occurrence (X); + Exception_Propagation.Propagate_Exception (X); + end Complete_And_Propagate_Occurrence; --------------------- -- Raise_Exception -- @@ -905,7 +953,6 @@ package body Ada.Exceptions is Message : String := "") is EF : Exception_Id := E; - begin -- Raise CE if E = Null_ID (AI-446) @@ -915,13 +962,7 @@ package body Ada.Exceptions is -- Go ahead and raise appropriate exception - Exception_Data.Set_Exception_Msg (EF, Message); - - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Raise_Current_Excep (EF); + Raise_Exception_Always (EF, Message); end Raise_Exception; ---------------------------- @@ -932,12 +973,13 @@ package body Ada.Exceptions is (E : Exception_Id; Message : String := "") is + X : constant EOA := Exception_Propagation.Allocate_Occurrence; begin - Exception_Data.Set_Exception_Msg (E, Message); + Exception_Data.Set_Exception_Msg (X, E, Message); if not ZCX_By_Default then Abort_Defer.all; end if; - Raise_Current_Excep (E); + Complete_And_Propagate_Occurrence (X); end Raise_Exception_Always; ------------------------------ @@ -948,12 +990,13 @@ package body Ada.Exceptions is (E : Exception_Id; Message : String := "") is + X : constant EOA := Exception_Propagation.Allocate_Occurrence; begin - Exception_Data.Set_Exception_Msg (E, Message); + Exception_Data.Set_Exception_Msg (X, E, Message); -- Do not call Abort_Defer.all, as specified by the spec - Raise_Current_Excep (E); + Complete_And_Propagate_Occurrence (X); end Raise_Exception_No_Defer; ------------------------------------- @@ -1001,22 +1044,50 @@ package body Ada.Exceptions is end if; end Raise_From_Controlled_Operation; - ------------------------------- - -- Raise_From_Signal_Handler -- - ------------------------------- + ------------------------------------------- + -- Create_Occurrence_From_Signal_Handler -- + ------------------------------------------- - procedure Raise_From_Signal_Handler + function Create_Occurrence_From_Signal_Handler (E : Exception_Id; - M : System.Address) + M : System.Address) return EOA is + X : constant EOA := Exception_Propagation.Allocate_Occurrence; + begin - Exception_Data.Set_Exception_C_Msg (E, M); + Exception_Data.Set_Exception_C_Msg (X, E, M); if not ZCX_By_Default then Abort_Defer.all; end if; - Raise_Current_Excep (E); + Complete_Occurrence (X); + return X; + end Create_Occurrence_From_Signal_Handler; + + --------------------------------------------------- + -- Create_Machine_Occurrence_From_Signal_Handler -- + --------------------------------------------------- + + function Create_Machine_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return System.Address + is + begin + return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence; + end Create_Machine_Occurrence_From_Signal_Handler; + + ------------------------------- + -- Raise_From_Signal_Handler -- + ------------------------------- + + procedure Raise_From_Signal_Handler + (E : Exception_Id; + M : System.Address) + is + begin + Exception_Propagation.Propagate_Exception + (Create_Occurrence_From_Signal_Handler (E, M)); end Raise_From_Signal_Handler; ------------------------- @@ -1082,14 +1153,15 @@ package body Ada.Exceptions is C : Integer := 0; M : System.Address := System.Null_Address) is + X : constant EOA := Exception_Propagation.Allocate_Occurrence; begin - Exception_Data.Set_Exception_C_Msg (E, F, L, C, M); + Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M); if not ZCX_By_Default then Abort_Defer.all; end if; - Raise_Current_Excep (E); + Complete_And_Propagate_Occurrence (X); end Raise_With_Location_And_Msg; -------------------- @@ -1097,14 +1169,20 @@ package body Ada.Exceptions is -------------------- procedure Raise_With_Msg (E : Exception_Id) is - Excep : constant EOA := Get_Current_Excep.all; - + Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; + Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; begin Excep.Exception_Raised := False; Excep.Id := E; Excep.Num_Tracebacks := 0; Excep.Pid := Local_Partition_ID; + -- Copy the message from the current exception + -- Change the interface to be called with an occurrence ??? + + Excep.Msg_Length := Ex.Msg_Length; + Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length); + -- The following is a common pattern, should be abstracted -- into a procedure call ??? @@ -1112,7 +1190,7 @@ package body Ada.Exceptions is Abort_Defer.all; end if; - Raise_Current_Excep (E); + Complete_And_Propagate_Occurrence (Excep); end Raise_With_Msg; -------------------------------------- @@ -1400,7 +1478,7 @@ package body Ada.Exceptions is procedure Rcheck_PE_Finalize_Raised_Exception (File : System.Address; Line : Integer) is - E : constant Exception_Id := Program_Error_Def'Access; + X : constant EOA := Exception_Propagation.Allocate_Occurrence; begin -- This is "finalize/adjust raised exception". This subprogram is always @@ -1409,8 +1487,9 @@ package body Ada.Exceptions is -- This is consistent with Raise_From_Controlled_Operation - Exception_Data.Set_Exception_C_Msg (E, File, Line, 0, Rmsg_22'Address); - Raise_Current_Excep (E); + Exception_Data.Set_Exception_C_Msg + (X, Program_Error_Def'Access, File, Line, 0, Rmsg_22'Address); + Complete_And_Propagate_Occurrence (X); end Rcheck_PE_Finalize_Raised_Exception; ------------- @@ -1418,12 +1497,15 @@ package body Ada.Exceptions is ------------- procedure Reraise is - Excep : constant EOA := Get_Current_Excep.all; + Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; + Saved_MO : constant System.Address := Excep.Machine_Occurrence; begin if not ZCX_By_Default then Abort_Defer.all; end if; - Raise_Current_Excep (Excep.Id); + Save_Occurrence (Excep.all, Get_Current_Excep.all.all); + Excep.Machine_Occurrence := Saved_MO; + Complete_And_Propagate_Occurrence (Excep); end Reraise; -------------------------------------- @@ -1451,14 +1533,11 @@ package body Ada.Exceptions is procedure Reraise_Occurrence (X : Exception_Occurrence) is begin - if X.Id /= null then - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Save_Occurrence (Get_Current_Excep.all.all, X); - Raise_Current_Excep (X.Id); + if X.Id = null then + return; end if; + + Reraise_Occurrence_Always (X); end Reraise_Occurrence; ------------------------------- @@ -1471,8 +1550,7 @@ package body Ada.Exceptions is Abort_Defer.all; end if; - Save_Occurrence (Get_Current_Excep.all.all, X); - Raise_Current_Excep (X.Id); + Reraise_Occurrence_No_Defer (X); end Reraise_Occurrence_Always; --------------------------------- @@ -1480,9 +1558,12 @@ package body Ada.Exceptions is --------------------------------- procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is + Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; + Saved_MO : constant System.Address := Excep.Machine_Occurrence; begin - Save_Occurrence (Get_Current_Excep.all.all, X); - Raise_Current_Excep (X.Id); + Save_Occurrence (Excep.all, X); + Excep.Machine_Occurrence := Saved_MO; + Complete_And_Propagate_Occurrence (Excep); end Reraise_Occurrence_No_Defer; --------------------- @@ -1494,10 +1575,14 @@ package body Ada.Exceptions is Source : Exception_Occurrence) is begin - Target.Id := Source.Id; - Target.Msg_Length := Source.Msg_Length; - Target.Num_Tracebacks := Source.Num_Tracebacks; - Target.Pid := Source.Pid; + -- As the machine occurrence might be a data that must be finalized + -- (outside any Ada mechanism), do not copy it + + Target.Id := Source.Id; + Target.Machine_Occurrence := System.Null_Address; + Target.Msg_Length := Source.Msg_Length; + Target.Num_Tracebacks := Source.Num_Tracebacks; + Target.Pid := Source.Pid; Target.Msg (1 .. Target.Msg_Length) := Source.Msg (1 .. Target.Msg_Length); diff --git a/gcc/ada/a-except-2005.ads b/gcc/ada/a-except-2005.ads index 3f4b17a8d3a..bb597ed0982 100644 --- a/gcc/ada/a-except-2005.ads +++ b/gcc/ada/a-except-2005.ads @@ -301,10 +301,10 @@ private type Exception_Occurrence is record Id : Exception_Id; -- Exception_Identity for this exception occurrence - -- - -- WARNING System.System.Finalization_Implementation.Finalize_List - -- relies on the fact that this field is always first in the exception - -- occurrence + + Machine_Occurrence : System.Address; + -- The underlying machine occurrence. For GCC, this corresponds to the + -- _Unwind_Exception structure address. Msg_Length : Natural := 0; -- Length of message (zero = no message) @@ -343,12 +343,13 @@ private -- Functions for implementing Exception_Occurrence stream attributes Null_Occurrence : constant Exception_Occurrence := ( - Id => null, - Msg_Length => 0, - Msg => (others => ' '), - Exception_Raised => False, - Pid => 0, - Num_Tracebacks => 0, - Tracebacks => (others => TBE.Null_TB_Entry)); + Id => null, + Machine_Occurrence => System.Null_Address, + Msg_Length => 0, + Msg => (others => ' '), + Exception_Raised => False, + Pid => 0, + Num_Tracebacks => 0, + Tracebacks => (others => TBE.Null_TB_Entry)); end Ada.Exceptions; diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 6c05b6e6482..3d3ba615cc7 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -93,7 +93,8 @@ package body Ada.Exceptions is --------------------------------- procedure Set_Exception_C_Msg - (Id : Exception_Id; + (Excep : EOA; + Id : Exception_Id; Msg1 : System.Address; Line : Integer := 0; Column : Integer := 0; @@ -107,7 +108,8 @@ package body Ada.Exceptions is -- additional null terminated string is added to the message. procedure Set_Exception_Msg - (Id : Exception_Id; + (Excep : EOA; + Id : Exception_Id; Message : String); -- This routine is called to setup the exception referenced by the -- Current_Excep field in the TSD to contain the indicated Id value and @@ -187,19 +189,19 @@ package body Ada.Exceptions is -- exported to be usable by the Ada exception handling personality -- routine when the GCC 3 mechanism is used. - procedure Notify_Handled_Exception; + procedure Notify_Handled_Exception (Excep : EOA); pragma Export (C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); -- This routine is called for a handled occurrence is about to be -- propagated. - procedure Notify_Unhandled_Exception; + procedure Notify_Unhandled_Exception (Excep : EOA); pragma Export (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); -- This routine is called when an unhandled occurrence is about to be -- propagated. - procedure Unhandled_Exception_Terminate; + procedure Unhandled_Exception_Terminate (Excep : EOA); pragma No_Return (Unhandled_Exception_Terminate); -- This procedure is called to terminate program execution following an -- unhandled exception. The exception information, including traceback @@ -893,14 +895,14 @@ package body Ada.Exceptions is if Jumpbuf_Ptr /= Null_Address then if not Excep.Exception_Raised then Excep.Exception_Raised := True; - Exception_Traces.Notify_Handled_Exception; + Exception_Traces.Notify_Handled_Exception (Excep); end if; builtin_longjmp (Jumpbuf_Ptr, 1); else - Exception_Traces.Notify_Unhandled_Exception; - Exception_Traces.Unhandled_Exception_Terminate; + Exception_Traces.Notify_Unhandled_Exception (Excep); + Exception_Traces.Unhandled_Exception_Terminate (Excep); end if; end Process_Raise_Exception; @@ -966,8 +968,8 @@ package body Ada.Exceptions is (E : Exception_Id; Message : String := "") is - EF : Exception_Id := E; - + EF : Exception_Id := E; + Excep : constant EOA := Get_Current_Excep.all; begin -- Raise CE if E = Null_ID (AI-446) @@ -977,7 +979,7 @@ package body Ada.Exceptions is -- Go ahead and raise appropriate exception - Exception_Data.Set_Exception_Msg (EF, Message); + Exception_Data.Set_Exception_Msg (Excep, EF, Message); Abort_Defer.all; Raise_Current_Excep (EF); end Raise_Exception; @@ -990,8 +992,9 @@ package body Ada.Exceptions is (E : Exception_Id; Message : String := "") is + Excep : constant EOA := Get_Current_Excep.all; begin - Exception_Data.Set_Exception_Msg (E, Message); + Exception_Data.Set_Exception_Msg (Excep, E, Message); Abort_Defer.all; Raise_Current_Excep (E); end Raise_Exception_Always; @@ -1004,8 +1007,9 @@ package body Ada.Exceptions is (E : Exception_Id; Message : String := "") is + Excep : constant EOA := Get_Current_Excep.all; begin - Exception_Data.Set_Exception_Msg (E, Message); + Exception_Data.Set_Exception_Msg (Excep, E, Message); -- Do not call Abort_Defer.all, as specified by the spec @@ -1065,8 +1069,9 @@ package body Ada.Exceptions is (E : Exception_Id; M : System.Address) is + Excep : constant EOA := Get_Current_Excep.all; begin - Exception_Data.Set_Exception_C_Msg (E, M); + Exception_Data.Set_Exception_C_Msg (Excep, E, M); Abort_Defer.all; Process_Raise_Exception (E); end Raise_From_Signal_Handler; @@ -1135,8 +1140,9 @@ package body Ada.Exceptions is L : Integer; M : System.Address := System.Null_Address) is + Excep : constant EOA := Get_Current_Excep.all; begin - Exception_Data.Set_Exception_C_Msg (E, F, L, Msg2 => M); + Exception_Data.Set_Exception_C_Msg (Excep, E, F, L, Msg2 => M); Abort_Defer.all; Raise_Current_Excep (E); end Raise_With_Location_And_Msg; @@ -1402,8 +1408,8 @@ package body Ada.Exceptions is procedure Rcheck_PE_Finalize_Raised_Exception (File : System.Address; Line : Integer) is - E : constant Exception_Id := Program_Error_Def'Access; - + E : constant Exception_Id := Program_Error_Def'Access; + Excep : constant EOA := Get_Current_Excep.all; begin -- This is "finalize/adjust raised exception". This subprogram is always -- called with abort deferred, unlike all other Rcheck_* routines, it @@ -1411,7 +1417,8 @@ package body Ada.Exceptions is -- This is consistent with Raise_From_Controlled_Operation - Exception_Data.Set_Exception_C_Msg (E, File, Line, 0, Rmsg_22'Address); + Exception_Data.Set_Exception_C_Msg (Excep, E, File, Line, 0, + Rmsg_22'Address); Raise_Current_Excep (E); end Rcheck_PE_Finalize_Raised_Exception; diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads index 0561fb74a11..e395cf4f3b0 100644 --- a/gcc/ada/a-except.ads +++ b/gcc/ada/a-except.ads @@ -271,9 +271,6 @@ private type Exception_Occurrence is record Id : Exception_Id; -- Exception_Identity for this exception occurrence - -- WARNING System.System.Finalization_Implementation.Finalize_List - -- relies on the fact that this field is always first in the exception - -- occurrence Msg_Length : Natural := 0; -- Length of message (zero = no message) diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index 37cb115988d..aa91cdcfe8f 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -558,13 +558,13 @@ package body Exception_Data is ------------------------- procedure Set_Exception_C_Msg - (Id : Exception_Id; + (Excep : EOA; + Id : Exception_Id; Msg1 : System.Address; Line : Integer := 0; Column : Integer := 0; Msg2 : System.Address := System.Null_Address) is - Excep : constant EOA := Get_Current_Excep.all; Remind : Integer; Ptr : Natural; @@ -654,13 +654,13 @@ package body Exception_Data is ----------------------- procedure Set_Exception_Msg - (Id : Exception_Id; + (Excep : EOA; + Id : Exception_Id; Message : String) is Len : constant Natural := Natural'Min (Message'Length, Exception_Msg_Max_Length); First : constant Integer := Message'First; - Excep : constant EOA := Get_Current_Excep.all; begin Excep.Exception_Raised := False; Excep.Msg_Length := Len; diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb index 2f2e7a76cba..e62ffd2ef93 100644 --- a/gcc/ada/a-exexpr-gcc.adb +++ b/gcc/ada/a-exexpr-gcc.adb @@ -39,14 +39,14 @@ with System.Storage_Elements; use System.Storage_Elements; separate (Ada.Exceptions) package body Exception_Propagation is + use Exception_Traces; + ------------------------------------------------ -- Entities to interface with the GCC runtime -- ------------------------------------------------ -- These come from "C++ ABI for Itanium: Exception handling", which is - -- the reference for GCC. They are used only when we are relying on - -- back-end tables for exception propagation, which in turn is currently - -- only the case for Zero_Cost_Exceptions in GNAT5. + -- the reference for GCC. -- Return codes from the GCC runtime functions used to propagate -- an exception. @@ -63,7 +63,8 @@ package body Exception_Propagation is URC_CONTINUE_UNWIND); pragma Unreferenced - (URC_FOREIGN_EXCEPTION_CAUGHT, + (URC_NO_REASON, + URC_FOREIGN_EXCEPTION_CAUGHT, URC_PHASE2_ERROR, URC_PHASE1_ERROR, URC_NORMAL_STOP, @@ -83,13 +84,14 @@ package body Exception_Propagation is UA_CLEANUP_PHASE : constant Unwind_Action := 2; UA_HANDLER_FRAME : constant Unwind_Action := 4; UA_FORCE_UNWIND : constant Unwind_Action := 8; - UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension ? + UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension pragma Unreferenced (UA_SEARCH_PHASE, UA_CLEANUP_PHASE, UA_HANDLER_FRAME, - UA_FORCE_UNWIND); + UA_FORCE_UNWIND, + UA_END_OF_STACK); -- Mandatory common header for any exception object handled by the -- GCC unwinding runtime. @@ -110,7 +112,7 @@ package body Exception_Propagation is Private2 : Unwind_Word; -- Usual exception structure has only two private fields, but the SEH - -- one has six. To avoid makeing this file more complex, we use six + -- one has six. To avoid making this file more complex, we use six -- fields on all platforms, wasting a few bytes on some. Private3 : Unwind_Word; @@ -151,7 +153,7 @@ package body Exception_Propagation is Header : Unwind_Exception; -- ABI Exception header first - Occurrence : Exception_Occurrence; + Occurrence : aliased Exception_Occurrence; -- The Ada occurrence end record; @@ -177,7 +179,7 @@ package body Exception_Propagation is type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; function To_GCC_Exception is new - Unchecked_Conversion (GNAT_GCC_Exception_Access, GCC_Exception_Access); + Unchecked_Conversion (System.Address, GCC_Exception_Access); function To_GNAT_GCC_Exception is new Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access); @@ -200,11 +202,20 @@ package body Exception_Propagation is -- Called to implement raise without exception, ie reraise. Called -- directly from gigi. - procedure Setup_Current_Excep - (GCC_Exception : not null GCC_Exception_Access); + function Setup_Current_Excep + (GCC_Exception : not null GCC_Exception_Access) return EOA; pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); -- Write Get_Current_Excep.all from GCC_Exception + procedure Unhandled_Except_Handler + (GCC_Exception : not null GCC_Exception_Access); + pragma No_Return (Unhandled_Except_Handler); + pragma Export (C, Unhandled_Except_Handler, + "__gnat_unhandled_except_handler"); + -- Called for handle unhandled exceptions, ie the last chance handler + -- on platforms (such as SEH) that never returns after throwing an + -- exception. Called directly by gigi. + function CleanupUnwind_Handler (UW_Version : Integer; UW_Phases : Unwind_Action; @@ -212,6 +223,8 @@ package body Exception_Propagation is UW_Exception : not null GCC_Exception_Access; UW_Context : System.Address; UW_Argument : System.Address) return Unwind_Reason_Code; + pragma Import (C, CleanupUnwind_Handler, + "__gnat_cleanupunwind_handler"); -- Hook called at each step of the forced unwinding we perform to -- trigger cleanups found during the propagation of an unhandled -- exception. @@ -280,6 +293,30 @@ package body Exception_Propagation is All_Others_Value : constant Integer := 16#7FFF#; pragma Export (C, All_Others_Value, "__gnat_all_others_value"); + Unhandled_Others_Value : constant Integer := 16#7FFF#; + pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value"); + -- Special choice (emitted by gigi) to catch and notify unhandled + -- exceptions on targets which always handle exceptions (such as SEH). + -- The handler will simply call Unhandled_Except_Handler. + + ------------------------- + -- Allocate_Occurrence -- + ------------------------- + + function Allocate_Occurrence return EOA is + Res : GNAT_GCC_Exception_Access; + begin + Res := + new GNAT_GCC_Exception' + (Header => (Class => GNAT_Exception_Class, + Cleanup => GNAT_GCC_Exception_Cleanup'Address, + others => 0), + Occurrence => (others => <>)); + Res.Occurrence.Machine_Occurrence := Res.all'Address; + + return Res.Occurrence'Access; + end Allocate_Occurrence; + -------------------------------- -- GNAT_GCC_Exception_Cleanup -- -------------------------------- @@ -301,41 +338,12 @@ package body Exception_Propagation is Free (Copy); end GNAT_GCC_Exception_Cleanup; - --------------------------- - -- CleanupUnwind_Handler -- - --------------------------- - - function CleanupUnwind_Handler - (UW_Version : Integer; - UW_Phases : Unwind_Action; - UW_Eclass : Exception_Class; - UW_Exception : not null GCC_Exception_Access; - UW_Context : System.Address; - UW_Argument : System.Address) return Unwind_Reason_Code - is - pragma Unreferenced (UW_Version, UW_Eclass, UW_Context, UW_Argument); - - begin - -- Terminate when the end of the stack is reached - - if UW_Phases >= UA_END_OF_STACK then - Setup_Current_Excep (UW_Exception); - Unhandled_Exception_Terminate; - end if; - - -- We know there is at least one cleanup further up. Return so that it - -- is searched and entered, after which Unwind_Resume will be called - -- and this hook will gain control again. - - return URC_NO_REASON; - end CleanupUnwind_Handler; - ------------------------- -- Setup_Current_Excep -- ------------------------- - procedure Setup_Current_Excep - (GCC_Exception : not null GCC_Exception_Access) + function Setup_Current_Excep + (GCC_Exception : not null GCC_Exception_Access) return EOA is Excep : constant EOA := Get_Current_Excep.all; @@ -351,16 +359,21 @@ package body Exception_Propagation is To_GNAT_GCC_Exception (GCC_Exception); begin Excep.all := GNAT_Occurrence.Occurrence; + + return GNAT_Occurrence.Occurrence'Access; end; else -- A default one Excep.Id := Foreign_Exception'Access; + Excep.Machine_Occurrence := GCC_Exception.all'Address; Excep.Msg_Length := 0; Excep.Exception_Raised := True; Excep.Pid := Local_Partition_ID; Excep.Num_Tracebacks := 0; + + return Excep; end if; end Setup_Current_Excep; @@ -411,6 +424,8 @@ package body Exception_Propagation is procedure Propagate_GCC_Exception (GCC_Exception : not null GCC_Exception_Access) is + Excep : EOA; + begin -- Perform a standard raise first. If a regular handler is found, it -- will be entered after all the intermediate cleanups have run. If @@ -423,8 +438,8 @@ package body Exception_Propagation is -- the necessary steps to enable the debugger to gain control while the -- stack is still intact. - Setup_Current_Excep (GCC_Exception); - Notify_Unhandled_Exception; + Excep := Setup_Current_Excep (GCC_Exception); + Notify_Unhandled_Exception (Excep); -- Now, un a forced unwind to trigger cleanups. Control should not -- resume there, if there are cleanups and in any cases as the @@ -438,59 +453,30 @@ package body Exception_Propagation is -- We get here in case of error. The debugger has been notified before -- the second step above. - Setup_Current_Excep (GCC_Exception); - Unhandled_Exception_Terminate; + Unhandled_Except_Handler (GCC_Exception); end Propagate_GCC_Exception; ------------------------- -- Propagate_Exception -- ------------------------- - -- Build an object suitable for the libgcc processing and call - -- Unwind_RaiseException to actually do the raise, taking care of - -- handling the two phase scheme it implements. - - procedure Propagate_Exception is - Excep : constant EOA := Get_Current_Excep.all; - GCC_Exception : GNAT_GCC_Exception_Access; - + procedure Propagate_Exception (Excep : EOA) is begin - -- Compute the backtrace for this occurrence if the corresponding - -- binder option has been set. Call_Chain takes care of the reraise - -- case. - - -- ??? Using Call_Chain here means we are going to walk up the stack - -- once only for backtracing purposes before doing it again for the - -- propagation per se. - - -- The first inspection is much lighter, though, as it only requires - -- partial unwinding of each frame. Additionally, although we could use - -- the personality routine to record the addresses while propagating, - -- this method has two drawbacks: - - -- 1) the trace is incomplete if the exception is handled since we - -- don't walk past the frame with the handler, - - -- and - - -- 2) we would miss the frames for which our personality routine is not - -- called, e.g. if C or C++ calls are on the way. - - Call_Chain (Excep); - - -- Allocate the GCC exception - - GCC_Exception := - new GNAT_GCC_Exception' - (Header => (Class => GNAT_Exception_Class, - Cleanup => GNAT_GCC_Exception_Cleanup'Address, - others => 0), - Occurrence => Excep.all); + Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence)); + end Propagate_Exception; - -- Propagate it + ------------------------------ + -- Unhandled_Except_Handler -- + ------------------------------ - Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception)); - end Propagate_Exception; + procedure Unhandled_Except_Handler + (GCC_Exception : not null GCC_Exception_Access) + is + Excep : EOA; + begin + Excep := Setup_Current_Excep (GCC_Exception); + Unhandled_Exception_Terminate (Excep); + end Unhandled_Except_Handler; ------------- -- EID_For -- diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb index cbe8a5c1c38..e2fd7d70e1e 100644 --- a/gcc/ada/a-exexpr.adb +++ b/gcc/ada/a-exexpr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,42 +43,30 @@ package body Exception_Propagation is pragma No_Return (builtin_longjmp); pragma Import (Intrinsic, builtin_longjmp, "__builtin_longjmp"); + procedure Propagate_Continue (E : Exception_Id); + pragma No_Return (Propagate_Continue); + pragma Export (C, Propagate_Continue, "__gnat_raise_nodefer_with_msg"); + -- A call to this procedure is inserted automatically by GIGI, in order + -- to continue the propagation when the exception was not handled. + -- The linkage name is historical. + ------------------------- - -- Propagate_Exception -- + -- Allocate_Occurrence -- ------------------------- - procedure Propagate_Exception - is - Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; - Excep : constant EOA := Get_Current_Excep.all; + function Allocate_Occurrence return EOA is begin - -- Compute the backtrace for this occurrence if corresponding binder - -- option has been set. Call_Chain takes care of the reraise case. - - Call_Chain (Excep); - - -- Note on above call to Call_Chain: - - -- We used to only do this if From_Signal_Handler was not set, - -- based on the assumption that backtracing from a signal handler - -- would not work due to stack layout oddities. However, since - - -- 1. The flag is never set in tasking programs (Notify_Exception - -- performs regular raise statements), and - - -- 2. No problem has shown up in tasking programs around here so - -- far, this turned out to be too strong an assumption. - - -- As, in addition, the test was + return Get_Current_Excep.all; + end Allocate_Occurrence; - -- 1. preventing the production of backtraces in non-tasking - -- programs, and - - -- 2. introducing a behavior inconsistency between - -- the tasking and non-tasking cases, + ------------------------- + -- Propagate_Exception -- + ------------------------- - -- we have simply removed it + procedure Propagate_Exception (Excep : EOA) is + Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; + begin -- If the jump buffer pointer is non-null, transfer control using -- it. Otherwise announce an unhandled exception (note that this -- means that we have no finalizations to do other than at the outer @@ -87,15 +75,25 @@ package body Exception_Propagation is if Jumpbuf_Ptr /= Null_Address then if not Excep.Exception_Raised then Excep.Exception_Raised := True; - Exception_Traces.Notify_Handled_Exception; + Exception_Traces.Notify_Handled_Exception (Excep); end if; builtin_longjmp (Jumpbuf_Ptr, 1); else - Exception_Traces.Notify_Unhandled_Exception; - Exception_Traces.Unhandled_Exception_Terminate; + Exception_Traces.Notify_Unhandled_Exception (Excep); + Exception_Traces.Unhandled_Exception_Terminate (Excep); end if; end Propagate_Exception; + ------------------------ + -- Propagate_Continue -- + ------------------------ + + procedure Propagate_Continue (E : Exception_Id) is + pragma Unreferenced (E); + begin + Propagate_Exception (Get_Current_Excep.all); + end Propagate_Continue; + end Exception_Propagation; diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb index d8f4072e402..fe4b706f7ee 100644 --- a/gcc/ada/a-exextr.adb +++ b/gcc/ada/a-exextr.adb @@ -72,17 +72,6 @@ package body Exception_Traces is -- latter case because Notify_Handled_Exception may be called for an -- actually unhandled occurrence in the Front-End-SJLJ case. - -------------------------------- - -- Import Run-Time C Routines -- - -------------------------------- - - -- The purpose of the following pragma Import is to ensure that we - -- generate appropriate subprogram descriptors for all C routines in - -- the standard GNAT library that can raise exceptions. This ensures - -- that the exception propagation can properly find these routines - - pragma Propagate_Exceptions; - ---------------------- -- Notify_Exception -- ---------------------- @@ -132,18 +121,16 @@ package body Exception_Traces is -- Notify_Handled_Exception -- ------------------------------ - procedure Notify_Handled_Exception is + procedure Notify_Handled_Exception (Excep : EOA) is begin - Notify_Exception (Get_Current_Excep.all, Is_Unhandled => False); + Notify_Exception (Excep, Is_Unhandled => False); end Notify_Handled_Exception; -------------------------------- -- Notify_Unhandled_Exception -- -------------------------------- - procedure Notify_Unhandled_Exception is - Excep : constant EOA := Get_Current_Excep.all; - + procedure Notify_Unhandled_Exception (Excep : EOA) is begin -- Check whether there is any termination handler to be executed for -- the environment task, and execute it if needed. Here we handle both @@ -161,8 +148,8 @@ package body Exception_Traces is -- Unhandled_Exception_Terminate -- ----------------------------------- - procedure Unhandled_Exception_Terminate is - Excep : Exception_Occurrence; + procedure Unhandled_Exception_Terminate (Excep : EOA) is + Occ : Exception_Occurrence; -- This occurrence will be used to display a message after finalization. -- It is necessary to save a copy here, or else the designated value -- could be overwritten if an exception is raised during finalization @@ -172,8 +159,8 @@ package body Exception_Traces is -- that there is enough room on the stack however. begin - Save_Occurrence (Excep, Get_Current_Excep.all.all); - Last_Chance_Handler (Excep); + Save_Occurrence (Occ, Excep.all); + Last_Chance_Handler (Occ); end Unhandled_Exception_Terminate; ------------------------------------ diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb index ae95d66547b..cd426ca7511 100644 --- a/gcc/ada/a-ngelfu.adb +++ b/gcc/ada/a-ngelfu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -31,9 +31,7 @@ -- This body is specifically for using an Ada interface to C math.h to get -- the computation engine. Many special cases are handled locally to avoid --- unnecessary calls. This is not a "strict" implementation, but takes full --- advantage of the C functions, e.g. in providing interface to hardware --- provided versions of the elementary functions. +-- unnecessary calls or to meet Annex G strict mode requirements. -- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan, sinh, -- cosh, tanh from C library via math.h diff --git a/gcc/ada/a-ststio.ads b/gcc/ada/a-ststio.ads index d14dd3e2380..4049163fa8f 100644 --- a/gcc/ada/a-ststio.ads +++ b/gcc/ada/a-ststio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -37,6 +37,7 @@ with Ada.IO_Exceptions; with System.File_Control_Block; package Ada.Streams.Stream_IO is + pragma Preelaborate; type Stream_Access is access all Root_Stream_Type'Class; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index b76b3c6c4ce..54244bdf2af 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -80,7 +80,6 @@ extern "C" { #ifdef IN_RTS #include "tconfig.h" #include "tsystem.h" - #include <sys/stat.h> #include <fcntl.h> #include <time.h> diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 8c46aed1773..6097e61f882 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -120,7 +120,7 @@ extern int __gnat_symlink (char *, char *); extern int __gnat_try_lock (char *, char *); extern int __gnat_open_new (char *, int); extern int __gnat_open_new_temp (char *, int); -extern int __gnat_mkdir (char *); +extern int __gnat_mkdir (char *, int); extern int __gnat_stat (char *, GNAT_STRUCT_STAT *); extern int __gnat_unlink (char *); diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 28307ac72a4..86ad184de2b 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -135,7 +135,7 @@ package body ALI is Ignore_Errors : Boolean := False; Directly_Scanned : Boolean := False) return ALI_Id is - P : Text_Ptr := T'First; + P : Text_Ptr := T'First; Line : Logical_Line_Number := 1; Id : ALI_Id; C : Character; @@ -1154,7 +1154,7 @@ package body ALI is C := Getc; Check_Unknown_Line; - -- Acquire first restrictions line + -- Loop to skip to first restrictions line while C /= 'R' loop if Ignore_Errors then @@ -1169,10 +1169,15 @@ package body ALI is end if; end loop; + -- Ignore all 'R' lines if that is required + if Ignore ('R') then - Skip_Line; + while C = 'R' loop + Skip_Line; + C := Getc; + end loop; - -- Process restrictions line + -- Here we process the restrictions lines (other than unit name cases) else Scan_Restrictions : declare @@ -1182,16 +1187,191 @@ package body ALI is Bad_R_Line : exception; -- Signal bad restrictions line (raised on unexpected character) - begin - Checkc (' '); - Skip_Space; + Typ : Character; + R : Restriction_Id; + N : Natural; - -- Acquire information for boolean restrictions + begin + -- Named restriction case - for R in All_Boolean_Restrictions loop + if Nextc = 'N' then + Skip_Line; C := Getc; - case C is + -- Loop through RR and RV lines + + while C = 'R' and then Nextc /= ' ' loop + Typ := Getc; + Checkc (' '); + + -- Acquire restriction name + + Name_Len := 0; + while not At_Eol and then Nextc /= '=' loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Getc; + end loop; + + -- Now search list of restrictions to find match + + declare + RN : String renames Name_Buffer (1 .. Name_Len); + + begin + R := Restriction_Id'First; + while R < Not_A_Restriction_Id loop + if Restriction_Id'Image (R) = RN then + goto R_Found; + end if; + + R := Restriction_Id'Succ (R); + end loop; + + -- We don't recognize the restriction. This might be + -- thought of as an error, and it really is, but we + -- want to allow building with inconsistent versions + -- of the binder and ali files (see comments at the + -- start of package System.Rident), so we just ignore + -- this situation. + + goto Done_With_Restriction_Line; + end; + + <<R_Found>> + + case R is + + -- Boolean restriction case + + when All_Boolean_Restrictions => + case Typ is + when 'V' => + ALIs.Table (Id).Restrictions.Violated (R) := + True; + Cumulative_Restrictions.Violated (R) := True; + + when 'R' => + ALIs.Table (Id).Restrictions.Set (R) := True; + Cumulative_Restrictions.Set (R) := True; + + when others => + raise Bad_R_Line; + end case; + + -- Parameter restriction case + + when All_Parameter_Restrictions => + if At_Eol or else Nextc /= '=' then + raise Bad_R_Line; + else + Skipc; + end if; + + N := Natural (Get_Nat); + + case Typ is + + -- Restriction set + + when 'R' => + ALIs.Table (Id).Restrictions.Set (R) := True; + ALIs.Table (Id).Restrictions.Value (R) := N; + + if Cumulative_Restrictions.Set (R) then + Cumulative_Restrictions.Value (R) := + Integer'Min + (Cumulative_Restrictions.Value (R), N); + else + Cumulative_Restrictions.Set (R) := True; + Cumulative_Restrictions.Value (R) := N; + end if; + + -- Restriction violated + + when 'V' => + ALIs.Table (Id).Restrictions.Violated (R) := + True; + Cumulative_Restrictions.Violated (R) := True; + ALIs.Table (Id).Restrictions.Count (R) := N; + + -- Checked Max_Parameter case + + if R in Checked_Max_Parameter_Restrictions then + Cumulative_Restrictions.Count (R) := + Integer'Max + (Cumulative_Restrictions.Count (R), N); + + -- Other checked parameter cases + + else + declare + pragma Unsuppress (Overflow_Check); + + begin + Cumulative_Restrictions.Count (R) := + Cumulative_Restrictions.Count (R) + N; + + exception + when Constraint_Error => + + -- A constraint error comes from the + -- additionh. We reset to the maximum + -- and indicate that the real value is + -- now unknown. + + Cumulative_Restrictions.Value (R) := + Integer'Last; + Cumulative_Restrictions.Unknown (R) := + True; + end; + end if; + + -- Deal with + case + + if Nextc = '+' then + Skipc; + ALIs.Table (Id).Restrictions.Unknown (R) := + True; + Cumulative_Restrictions.Unknown (R) := True; + end if; + + -- Other than 'R' or 'V' + + when others => + raise Bad_R_Line; + end case; + + if not At_Eol then + raise Bad_R_Line; + end if; + + -- Bizarre error case NOT_A_RESTRICTION + + when Not_A_Restriction_Id => + raise Bad_R_Line; + end case; + + if not At_Eol then + raise Bad_R_Line; + end if; + + <<Done_With_Restriction_Line>> + Skip_Line; + C := Getc; + end loop; + + -- Positional restriction case + + else + Checkc (' '); + Skip_Space; + + -- Acquire information for boolean restrictions + + for R in All_Boolean_Restrictions loop + C := Getc; + + case C is when 'v' => ALIs.Table (Id).Restrictions.Violated (R) := True; Cumulative_Restrictions.Violated (R) := True; @@ -1205,44 +1385,42 @@ package body ALI is when others => raise Bad_R_Line; - end case; - end loop; - - -- Acquire information for parameter restrictions + end case; + end loop; - for RP in All_Parameter_Restrictions loop + -- Acquire information for parameter restrictions - -- Acquire restrictions pragma information + for RP in All_Parameter_Restrictions loop + case Getc is + when 'n' => + null; - case Getc is - when 'n' => - null; + when 'r' => + ALIs.Table (Id).Restrictions.Set (RP) := True; - when 'r' => - ALIs.Table (Id).Restrictions.Set (RP) := True; + declare + N : constant Integer := Integer (Get_Nat); + begin + ALIs.Table (Id).Restrictions.Value (RP) := N; - declare - N : constant Integer := Integer (Get_Nat); - begin - ALIs.Table (Id).Restrictions.Value (RP) := N; + if Cumulative_Restrictions.Set (RP) then + Cumulative_Restrictions.Value (RP) := + Integer'Min + (Cumulative_Restrictions.Value (RP), N); + else + Cumulative_Restrictions.Set (RP) := True; + Cumulative_Restrictions.Value (RP) := N; + end if; + end; - if Cumulative_Restrictions.Set (RP) then - Cumulative_Restrictions.Value (RP) := - Integer'Min - (Cumulative_Restrictions.Value (RP), N); - else - Cumulative_Restrictions.Set (RP) := True; - Cumulative_Restrictions.Value (RP) := N; - end if; - end; + when others => + raise Bad_R_Line; + end case; - when others => - raise Bad_R_Line; - end case; + -- Acquire restrictions violations information - -- Acquire restrictions violations information + case Getc is - case Getc is when 'n' => null; @@ -1252,7 +1430,6 @@ package body ALI is declare N : constant Integer := Integer (Get_Nat); - pragma Unsuppress (Overflow_Check); begin ALIs.Table (Id).Restrictions.Count (RP) := N; @@ -1261,34 +1438,47 @@ package body ALI is Cumulative_Restrictions.Count (RP) := Integer'Max (Cumulative_Restrictions.Count (RP), N); + else - Cumulative_Restrictions.Count (RP) := - Cumulative_Restrictions.Count (RP) + N; - end if; + declare + pragma Unsuppress (Overflow_Check); - exception - when Constraint_Error => + begin + Cumulative_Restrictions.Count (RP) := + Cumulative_Restrictions.Count (RP) + N; + + exception + when Constraint_Error => - -- A constraint error comes from the addition in - -- the else branch. We reset to the maximum and - -- indicate that the real value is now unknown. + -- A constraint error comes from the add. We + -- reset to the maximum and indicate that the + -- real value is now unknown. + + Cumulative_Restrictions.Value (RP) := + Integer'Last; + Cumulative_Restrictions.Unknown (RP) := True; + end; + end if; - Cumulative_Restrictions.Value (RP) := Integer'Last; + if Nextc = '+' then + Skipc; + ALIs.Table (Id).Restrictions.Unknown (RP) := True; Cumulative_Restrictions.Unknown (RP) := True; + end if; end; - if Nextc = '+' then - Skipc; - ALIs.Table (Id).Restrictions.Unknown (RP) := True; - Cumulative_Restrictions.Unknown (RP) := True; - end if; - when others => raise Bad_R_Line; - end case; - end loop; + end case; + end loop; - Skip_Eol; + if not At_Eol then + raise Bad_R_Line; + else + Skip_Line; + C := Getc; + end if; + end if; -- Here if error during scanning of restrictions line @@ -1296,25 +1486,29 @@ package body ALI is when Bad_R_Line => -- In Ignore_Errors mode, undo any changes to restrictions - -- from this unit, and continue on. + -- from this unit, and continue on, skipping remaining R + -- lines for this unit. if Ignore_Errors then Cumulative_Restrictions := Save_R; ALIs.Table (Id).Restrictions := No_Restrictions; - Skip_Eol; + + loop + Skip_Eol; + C := Getc; + exit when C /= 'R'; + end loop; -- In normal mode, this is a fatal error else Fatal_Error; end if; - end Scan_Restrictions; end if; -- Acquire additional restrictions (No_Dependence) lines if present - C := Getc; while C = 'R' loop if Ignore ('R') then Skip_Line; diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index b21b1e23973..ebe71aec0c3 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -184,6 +184,10 @@ package Aspects is Aspect_Lock_Free); + subtype Aspect_Id_Exclude_No_Aspect is + Aspect_Id range Aspect_Id'Succ (No_Aspect) .. Aspect_Id'Last; + -- Aspect_Id's excluding No_Aspect + -- The following array indicates aspects that accept 'Class Class_Aspect_OK : constant array (Aspect_Id) of Boolean := diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index 6c4b63ff75f..fa7c54d2f19 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -237,7 +237,7 @@ package body Back_End is elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then Opt.Suppress_Control_Flow_Optimizations := True; - -- Back end switcg -fdump-scos, which exists primarily for C, is + -- Back end switch -fdump-scos, which exists primarily for C, is -- also accepted for Ada as a synonym of -gnateS. elsif Switch_Chars (First .. Last) = "fdump-scos" then diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index 23840d3048c..e9d39504af1 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -76,9 +76,10 @@ package body Bindusg is Write_Line (" -a Automatically initialize elaboration " & "procedure"); - -- Line for -A switch + -- Lines for -A switch Write_Line (" -A Give list of ALI files in partition"); + Write_Line (" -A=file Write ALI file list to named file"); -- Line for -b switch diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 195b69e1be8..b086c754807 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -322,7 +322,7 @@ package body Checks is if Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Access_Check); else - return Scope_Suppress (Access_Check); + return Scope_Suppress.Suppress (Access_Check); end if; end Access_Checks_Suppressed; @@ -335,7 +335,7 @@ package body Checks is if Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Accessibility_Check); else - return Scope_Suppress (Accessibility_Check); + return Scope_Suppress.Suppress (Accessibility_Check); end if; end Accessibility_Checks_Suppressed; @@ -378,7 +378,7 @@ package body Checks is if Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Alignment_Check); else - return Scope_Suppress (Alignment_Check); + return Scope_Suppress.Suppress (Alignment_Check); end if; end Alignment_Checks_Suppressed; @@ -2616,7 +2616,7 @@ package body Checks is -- Otherwise result depends on current scope setting else - return Scope_Suppress (Atomic_Synchronization); + return Scope_Suppress.Suppress (Atomic_Synchronization); end if; end Atomic_Synchronization_Disabled; @@ -3151,6 +3151,9 @@ package body Checks is Cindex : Cache_Index; -- Used to search cache + Btyp : Entity_Id; + -- Base type + function OK_Operands return Boolean; -- Used for binary operators. Determines the ranges of the left and -- right operands, and if they are both OK, returns True, and puts @@ -3267,6 +3270,15 @@ package body Checks is Typ := Underlying_Type (Base_Type (Typ)); end if; + -- Retrieve the base type. Handle the case where the base type is a + -- private enumeration type. + + Btyp := Base_Type (Typ); + + if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then + Btyp := Full_View (Btyp); + end if; + -- We use the actual bound unless it is dynamic, in which case use the -- corresponding base type bound if possible. If we can't get a bound -- then we figure we can't determine the range (a peculiar case, that @@ -3280,8 +3292,8 @@ package body Checks is if Compile_Time_Known_Value (Bound) then Lo := Expr_Value (Bound); - elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then - Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ))); + elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then + Lo := Expr_Value (Type_Low_Bound (Btyp)); else OK := False; @@ -3296,8 +3308,8 @@ package body Checks is -- always be compile time known. Again, it is not clear that this -- can ever be false, but no point in bombing. - if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then - Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ))); + if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then + Hbound := Expr_Value (Type_High_Bound (Btyp)); Hi := Hbound; else @@ -3629,7 +3641,7 @@ package body Checks is end if; end if; - return Scope_Suppress (Discriminant_Check); + return Scope_Suppress.Suppress (Discriminant_Check); end Discriminant_Checks_Suppressed; -------------------------------- @@ -3641,7 +3653,7 @@ package body Checks is if Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Division_Check); else - return Scope_Suppress (Division_Check); + return Scope_Suppress.Suppress (Division_Check); end if; end Division_Checks_Suppressed; @@ -3670,10 +3682,10 @@ package body Checks is end if; end if; - if Scope_Suppress (Elaboration_Check) then + if Scope_Suppress.Suppress (Elaboration_Check) then return True; elsif Dynamic_Elaboration_Checks then - return Scope_Suppress (All_Checks); + return Scope_Suppress.Suppress (All_Checks); else return False; end if; @@ -4744,17 +4756,17 @@ package body Checks is -- associated subtype. Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Not_In (Loc, - Left_Opnd => - Convert_To (Base_Type (Etype (Sub)), - Duplicate_Subexpr_Move_Checks (Sub)), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Etype (A), Loc), - Attribute_Name => Name_Range)), - Reason => CE_Index_Check_Failed)); + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => + Convert_To (Base_Type (Etype (Sub)), + Duplicate_Subexpr_Move_Checks (Sub)), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Etype (A), Loc), + Attribute_Name => Name_Range)), + Reason => CE_Index_Check_Failed)); end if; -- General case @@ -4831,14 +4843,14 @@ package body Checks is end if; Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Not_In (Loc, - Left_Opnd => - Convert_To (Base_Type (Etype (Sub)), - Duplicate_Subexpr_Move_Checks (Sub)), - Right_Opnd => Range_N), - Reason => CE_Index_Check_Failed)); + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => + Convert_To (Base_Type (Etype (Sub)), + Duplicate_Subexpr_Move_Checks (Sub)), + Right_Opnd => Range_N), + Reason => CE_Index_Check_Failed)); end if; A_Idx := Next_Index (A_Idx); @@ -5293,7 +5305,7 @@ package body Checks is if Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Index_Check); else - return Scope_Suppress (Index_Check); + return Scope_Suppress.Suppress (Index_Check); end if; end Index_Checks_Suppressed; @@ -5809,7 +5821,7 @@ package body Checks is if Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Length_Check); else - return Scope_Suppress (Length_Check); + return Scope_Suppress.Suppress (Length_Check); end if; end Length_Checks_Suppressed; @@ -5822,7 +5834,7 @@ package body Checks is if Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Overflow_Check); else - return Scope_Suppress (Overflow_Check); + return Scope_Suppress.Suppress (Overflow_Check); end if; end Overflow_Checks_Suppressed; @@ -5846,7 +5858,7 @@ package body Checks is end if; end if; - return Scope_Suppress (Range_Check); + return Scope_Suppress.Suppress (Range_Check); end Range_Checks_Suppressed; ----------------------------------------- @@ -5863,7 +5875,10 @@ package body Checks is begin -- Immediate return if scope checks suppressed for either check - if Scope_Suppress (Range_Check) or Scope_Suppress (Validity_Check) then + if Scope_Suppress.Suppress (Range_Check) + or + Scope_Suppress.Suppress (Validity_Check) + then return True; end if; @@ -6648,12 +6663,6 @@ package body Checks is LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc); end if; - if Nkind (HB) = N_Identifier - and then Ekind (Entity (HB)) = E_Discriminant - then - HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc); - end if; - Left_Opnd := Make_Op_Lt (Loc, Left_Opnd => @@ -6665,28 +6674,10 @@ package body Checks is (Base_Type (Typ), Get_E_First_Or_Last (Loc, Typ, 0, Name_First))); - if Base_Type (Typ) = Typ then - return Left_Opnd; - - elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ))) - and then - Compile_Time_Known_Value (High_Bound (Scalar_Range - (Base_Type (Typ)))) + if Nkind (HB) = N_Identifier + and then Ekind (Entity (HB)) = E_Discriminant then - if Is_Floating_Point_Type (Typ) then - if Expr_Value_R (High_Bound (Scalar_Range (Typ))) = - Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ)))) - then - return Left_Opnd; - end if; - - else - if Expr_Value (High_Bound (Scalar_Range (Typ))) = - Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ)))) - then - return Left_Opnd; - end if; - end if; + HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc); end if; Right_Opnd := @@ -7368,7 +7359,7 @@ package body Checks is if Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Storage_Check); else - return Scope_Suppress (Storage_Check); + return Scope_Suppress.Suppress (Storage_Check); end if; end Storage_Checks_Suppressed; @@ -7384,7 +7375,7 @@ package body Checks is return Is_Check_Suppressed (E, Tag_Check); end if; - return Scope_Suppress (Tag_Check); + return Scope_Suppress.Suppress (Tag_Check); end Tag_Checks_Suppressed; -------------------------- @@ -7410,7 +7401,7 @@ package body Checks is if Present (E) and then Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Validity_Check); else - return Scope_Suppress (Validity_Check); + return Scope_Suppress.Suppress (Validity_Check); end if; end Validity_Checks_Suppressed; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index cbcdf0cbb51..33f99c68cff 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -135,7 +135,7 @@ package body Debug is -- d.O Dump internal SCO tables -- d.P Previous (non-optimized) handling of length comparisons -- d.Q - -- d.R + -- d.R Restrictions in ali files in positional form -- d.S Force Optimize_Alignment (Space) -- d.T Force Optimize_Alignment (Time) -- d.U Ignore indirect calls for static elaboration @@ -642,6 +642,11 @@ package body Debug is -- This is there in case we find a situation where the optimization -- malfunctions, to provide a work around. + -- d.R As documented in lib-writ.ads, restrictions in the ali file can + -- have two forms, positional and named. The named notation is the + -- current preferred form, but the use of this debug switch will force + -- the use of the obsolescent positional form. + -- d.S Force Optimize_Alignment (Space) mode as the default -- d.T Force Optimize_Alignment (Time) mode as the default diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index d5fad3ecf54..6ef644a94cf 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -2602,7 +2602,7 @@ package body Einfo is function Reverse_Storage_Order (Id : E) return B is begin - pragma Assert (Is_Record_Type (Id)); + pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id)); return Flag93 (Base_Type (Id)); end Reverse_Storage_Order; @@ -5163,7 +5163,8 @@ package body Einfo is procedure Set_Reverse_Storage_Order (Id : E; V : B := True) is begin pragma Assert - (Is_Record_Type (Id) and then Is_Base_Type (Id)); + (Is_Base_Type (Id) + and then (Is_Record_Type (Id) or else Is_Array_Type (Id))); Set_Flag93 (Id, V); end Set_Reverse_Storage_Order; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 0f8250ac7ab..3da53018fae 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3535,11 +3535,12 @@ package Einfo is -- Ada 2005 AI-133), or must occupy an integral number of storage units. -- Reverse_Storage_Order (Flag93) [base type only] --- Present in all record type entities. Set if entity has a +-- Present in all record and array type entities. Set if entity has a -- Scalar_Storage_Order aspect (set by an aspect clause or attribute -- definition clause) that has reversed the order of storage elements --- from the default value. When this flag is set, the Bit_Order aspect --- must be set to the same value. +-- from the default value. When this flag is set for a record type, +-- the Bit_Order aspect must be set to the same value (either explicitly +-- or as the target default value). -- RM_Size (Uint13) -- Present in all type and subtype entities. Contains the value of @@ -5020,6 +5021,7 @@ package Einfo is -- Has_Component_Size_Clause (Flag68) (base type only) -- Has_Pragma_Pack (Flag121) (impl base type only) -- Is_Constrained (Flag12) + -- Reverse_Storage_Order (Flag93) (base type only) -- Next_Index (synth) -- Number_Dimensions (synth) -- (plus type attributes) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index aae88942453..bcfca25c6b0 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -238,6 +238,14 @@ package body Exp_Aggr is -- This is the top-level routine to perform array aggregate expansion. -- N is the N_Aggregate node to be expanded. + function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean; + + -- For two-dimensional packed aggregates with constant bounds and constant + -- components, it is preferable to pack the inner aggregates because the + -- whole matrix can then be presented to the back-end as a one-dimensional + -- list of literals. This is much more efficient than expanding into single + -- component assignments. + function Late_Expansion (N : Node_Id; Typ : Entity_Id; @@ -275,6 +283,13 @@ package body Exp_Aggr is -- the assignment can be done in place even if bounds are not static, -- by converting it into a loop over the discrete range of the slice. + function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean; + -- If the type of the aggregate is a two-dimensional bit_packed array + -- it may be transformed into an array of bytes with constant values, + -- and presented to the back-end as a static value. The function returns + -- false if this transformation cannot be performed. THis is similar to, + -- and reuses part of the machinery in Packed_Array_Aggregate_Handled. + ------------------ -- Aggr_Size_OK -- ------------------ @@ -294,15 +309,28 @@ package body Exp_Aggr is -- The normal limit is 5000, but we increase this limit to 2**24 (about -- 16 million) if Restrictions (No_Elaboration_Code) or Restrictions - -- (No_Implicit_Loops) is specified, since in either case, we are at - -- risk of declaring the program illegal because of this limit. + -- (No_Implicit_Loops) is specified, since in either case we are at + -- risk of declaring the program illegal because of this limit. We also + -- increase the limit when Static_Elaboration_Desired, given that this + -- means that objects are intended to be placed in data memory. + + -- We also increase the limit if the aggregate is for a packed two- + -- dimensional array, because if components are static it is much more + -- efficient to construct a one-dimensional equivalent array with static + -- components. Max_Aggr_Size : constant Nat := 5000 + (2 ** 24 - 5000) * Boolean'Pos (Restriction_Active (No_Elaboration_Code) - or else - Restriction_Active (No_Implicit_Loops)); + or else + Restriction_Active (No_Implicit_Loops) + or else + Is_Two_Dim_Packed_Array (Typ) + or else + ((Ekind (Current_Scope) = E_Package + and then + Static_Elaboration_Desired (Current_Scope)))); function Component_Count (T : Entity_Id) return Int; -- The limit is applied to the total number of components that the @@ -3511,11 +3539,12 @@ package body Exp_Aggr is -- Check for maximum others replication. Note that -- we skip this test if either of the restrictions -- No_Elaboration_Code or No_Implicit_Loops is - -- active, if this is a preelaborable unit or a - -- predefined unit. This ensures that predefined - -- units get the same level of constant folding in - -- Ada 95 and Ada 2005, where their categorization - -- has changed. + -- active, if this is a preelaborable unit or + -- a predefined unit, or if the unit must be + -- placed in data memory. This also ensures that + -- predefined units get the same level of constant + -- folding in Ada 95 and Ada 2005, where their + -- categorization has changed. declare P : constant Entity_Id := @@ -3527,6 +3556,11 @@ package body Exp_Aggr is if Restriction_Active (No_Elaboration_Code) or else Restriction_Active (No_Implicit_Loops) + or else + (Ekind (Current_Scope) = E_Package + and then + Static_Elaboration_Desired + (Current_Scope)) or else Is_Preelaborated (P) or else (Ekind (P) = E_Package_Body and then @@ -3717,6 +3751,43 @@ package body Exp_Aggr is Analyze_And_Resolve (N, Typ); end if; + + -- Is Static_Eaboration_Desired has been specified, diagnose aggregates + -- that will still require initialization code. + + if (Ekind (Current_Scope) = E_Package + and then Static_Elaboration_Desired (Current_Scope)) + and then Nkind (Parent (N)) = N_Object_Declaration + then + declare + Expr : Node_Id; + + begin + if Nkind (N) = N_Aggregate and then Present (Expressions (N)) then + Expr := First (Expressions (N)); + while Present (Expr) loop + if Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) + or else + (Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Enumeration_Literal) + then + null; + + else + Error_Msg_N + ("non-static object requires elaboration code?", N); + exit; + end if; + + Next (Expr); + end loop; + + if Present (Component_Associations (N)) then + Error_Msg_N ("object requires elaboration code?", N); + end if; + end if; + end; + end if; end Convert_To_Positional; ---------------------------- @@ -4735,8 +4806,9 @@ package body Exp_Aggr is if Nkind (N) /= N_Aggregate then return; - -- We are also done if the result is an analyzed aggregate - -- This case could use more comments ??? + -- We are also done if the result is an analyzed aggregate, indicating + -- that Convert_To_Positional succeeded and reanalyzed the rewritten + -- aggregate. elsif Analyzed (N) and then N /= Original_Node (N) @@ -5843,6 +5915,19 @@ package body Exp_Aggr is and then Typ = RTE (RE_Interface_Data_Element))); end Is_Static_Dispatch_Table_Aggregate; + ----------------------------- + -- Is_Two_Dim_Packed_Array -- + ----------------------------- + + function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean is + C : constant Int := UI_To_Int (Component_Size (Typ)); + begin + return Number_Dimensions (Typ) = 2 + and then Is_Bit_Packed_Array (Typ) + and then + (C = 1 or else C = 2 or else C = 4); + end Is_Two_Dim_Packed_Array; + -------------------- -- Late_Expansion -- -------------------- @@ -5922,11 +6007,14 @@ package body Exp_Aggr is -- The current version of this procedure will handle at compile time -- any array aggregate that meets these conditions: - -- One dimensional, bit packed + -- One and two dimensional, bit packed -- Underlying packed type is modular type -- Bounds are within 32-bit Int range -- All bounds and values are static + -- Note: for now, in the 2-D case, we only handle component sizes of + -- 1, 2, 4 (cases where an integral number of elements occupies a byte). + function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); @@ -5936,15 +6024,26 @@ package body Exp_Aggr is -- Exception raised if this aggregate cannot be handled begin - -- For now, handle only one dimensional bit packed arrays + -- Handle one- or two dimensional bit packed array if not Is_Bit_Packed_Array (Typ) - or else Number_Dimensions (Typ) > 1 - or else not Is_Modular_Integer_Type (Packed_Array_Type (Typ)) + or else Number_Dimensions (Typ) > 2 then return False; end if; + -- If two-dimensional, check whether it can be folded, and transformed + -- into a one-dimensional aggregate for the Packed_Array_Type of the + -- original type. + + if Number_Dimensions (Typ) = 2 then + return Two_Dim_Packed_Array_Handled (N); + end if; + + if not Is_Modular_Integer_Type (Packed_Array_Type (Typ)) then + return False; + end if; + if not Is_Scalar_Type (Component_Type (Typ)) and then Has_Non_Standard_Rep (Component_Type (Typ)) then @@ -6038,8 +6137,9 @@ package body Exp_Aggr is -- If the aggregate is not fully positional at this stage, then -- convert it to positional form. Either this will fail, in which -- case we can do nothing, or it will succeed, in which case we have - -- succeeded in handling the aggregate, or it will stay an aggregate, - -- in which case we have failed to handle this case. + -- succeeded in handling the aggregate and transforming it into a + -- modular value, or it will stay an aggregate, in which case we + -- have failed to create a packed value for it. if Present (Component_Associations (N)) then Convert_To_Positional @@ -6077,35 +6177,7 @@ package body Exp_Aggr is Expr : Node_Id; -- Next expression from positional parameters of aggregate - Enclosing_Aggregate : Node_Id; - - In_Reverse_Storage_Order_Record : Boolean; - -- True if we are within an aggregate of a record type with - -- reversed storage order. - begin - -- Determine whether we are in a reversed storage order record - -- aggregate. - - In_Reverse_Storage_Order_Record := False; - Enclosing_Aggregate := Parent (N); - while Present (Enclosing_Aggregate) loop - if Nkind (Enclosing_Aggregate) = N_Component_Association then - null; - - elsif Nkind (Enclosing_Aggregate) /= N_Aggregate then - exit; - - elsif Is_Record_Type (Etype (Enclosing_Aggregate)) - and then Reverse_Storage_Order (Etype (Enclosing_Aggregate)) - then - In_Reverse_Storage_Order_Record := True; - exit; - end if; - - Enclosing_Aggregate := Parent (Enclosing_Aggregate); - end loop; - -- For little endian, we fill up the low order bits of the target -- value. For big endian we fill up the high order bits of the -- target value (which is a left justified modular value). @@ -6118,7 +6190,7 @@ package body Exp_Aggr is if Bytes_Big_Endian xor Debug_Flag_8 - xor In_Reverse_Storage_Order_Record + xor Reverse_Storage_Order (Base_Type (Typ)) then Shift := Csiz * (Len - 1); Incr := -Csiz; @@ -6145,9 +6217,7 @@ package body Exp_Aggr is -- Now we can rewrite with the proper value - Lit := - Make_Integer_Literal (Loc, - Intval => Aggregate_Val); + Lit := Make_Integer_Literal (Loc, Intval => Aggregate_Val); Set_Print_In_Hex (Lit); -- Construct the expression using this literal. Note that it is @@ -6266,7 +6336,8 @@ package body Exp_Aggr is return False; else return Expr_Value (L1) /= Expr_Value (L2) - or else Expr_Value (H1) /= Expr_Value (H2); + or else + Expr_Value (H1) /= Expr_Value (H2); end if; end if; end Must_Slide; @@ -6335,6 +6406,179 @@ package body Exp_Aggr is end if; end Safe_Slice_Assignment; + ---------------------------------- + -- Two_Dim_Packed_Array_Handled -- + ---------------------------------- + + function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Ctyp : constant Entity_Id := Component_Type (Typ); + Comp_Size : constant Int := UI_To_Int (Component_Size (Typ)); + Packed_Array : constant Entity_Id := Packed_Array_Type (Base_Type (Typ)); + + One_Comp : Node_Id; + -- Expression in original aggregate + + One_Dim : Node_Id; + -- One-dimensional subaggregate + + begin + + -- For now, only deal with cases where an integral number of elements + -- fit in a single byte. This includes the most common boolean case. + + if not (Comp_Size = 1 or else + Comp_Size = 2 or else + Comp_Size = 4) + then + return False; + end if; + + Convert_To_Positional + (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True); + + -- Verify that all components are static + + if Nkind (N) = N_Aggregate + and then Compile_Time_Known_Aggregate (N) + then + null; + + -- The aggregate may have been re-analyzed and converted already + + elsif Nkind (N) /= N_Aggregate then + return True; + + -- If component associations remain, the aggregate is not static + + elsif Present (Component_Associations (N)) then + return False; + + else + One_Dim := First (Expressions (N)); + while Present (One_Dim) loop + if Present (Component_Associations (One_Dim)) then + return False; + end if; + + One_Comp := First (Expressions (One_Dim)); + while Present (One_Comp) loop + if not Is_OK_Static_Expression (One_Comp) then + return False; + end if; + + Next (One_Comp); + end loop; + + Next (One_Dim); + end loop; + end if; + + -- Two-dimensional aggregate is now fully positional so pack one + -- dimension to create a static one-dimensional array, and rewrite + -- as an unchecked conversion to the original type. + + declare + Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array)); + -- The packed array type is a byte array + + Packed_Num : Int; + -- Number of components accumulated in current byte + + Comps : List_Id; + -- Assembled list of packed values for equivalent aggregate + + Comp_Val : Uint; + -- integer value of component + + Incr : Int; + -- Step size for packing + + Init_Shift : Int; + -- Endian-dependent start position for packing + + Shift : Int; + -- Current insertion position + + Val : Int; + -- Component of packed array being assembled. + + begin + Comps := New_List; + Val := 0; + Packed_Num := 0; + + -- Account for endianness. See corresponding comment in + -- Packed_Array_Aggregate_Handled concerning the following. + + if Bytes_Big_Endian + xor Debug_Flag_8 + xor Reverse_Storage_Order (Base_Type (Typ)) + then + Init_Shift := Byte_Size - Comp_Size; + Incr := -Comp_Size; + else + Init_Shift := 0; + Incr := +Comp_Size; + end if; + + Shift := Init_Shift; + One_Dim := First (Expressions (N)); + + -- Iterate over each subaggregate + + while Present (One_Dim) loop + One_Comp := First (Expressions (One_Dim)); + + while Present (One_Comp) loop + if Packed_Num = Byte_Size / Comp_Size then + + -- Byte is complete, add to list of expressions + + Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps); + Val := 0; + Shift := Init_Shift; + Packed_Num := 0; + + else + Comp_Val := Expr_Rep_Value (One_Comp); + + -- Adjust for bias, and strip proper number of bits + + if Has_Biased_Representation (Ctyp) then + Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp)); + end if; + + Comp_Val := Comp_Val mod Uint_2 ** Comp_Size; + Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift); + Shift := Shift + Incr; + One_Comp := Next (One_Comp); + Packed_Num := Packed_Num + 1; + end if; + end loop; + + One_Dim := Next (One_Dim); + end loop; + + if Packed_Num > 0 then + + -- Add final incomplete byte if present + + Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps); + end if; + + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc), + Expression => + Make_Aggregate (Loc, Expressions => Comps)))); + Analyze_And_Resolve (N); + return True; + end; + end Two_Dim_Packed_Array_Handled; + --------------------- -- Sort_Case_Table -- --------------------- diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 54ce3ee0baa..105df466bec 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -815,11 +815,19 @@ package body Exp_Attr is -- rewrite into reference to current instance. if Is_Protected_Self_Reference (Pref) - and then not - (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint, - N_Discriminant_Association) - and then Nkind (Parent (Parent (Parent (Parent (N))))) = + and then not + (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint, + N_Discriminant_Association) + and then Nkind (Parent (Parent (Parent (Parent (N))))) = N_Component_Definition) + + -- No action needed for these attributes since the current instance + -- will be rewritten to be the name of the _object parameter + -- associated with the enclosing protected subprogram (see below). + + and then Id /= Attribute_Access + and then Id /= Attribute_Unchecked_Access + and then Id /= Attribute_Unrestricted_Access then Rewrite (Pref, Concurrent_Ref (Pref)); Analyze (Pref); @@ -827,6 +835,11 @@ package body Exp_Attr is -- Remaining processing depends on specific attribute + -- Note: individual sections of the following case statement are + -- allowed to assume there is no code after the case statement, and + -- are legitimately allowed to execute return statements if they have + -- nothing more to do. + case Id is -- Attributes related to Ada 2012 iterators (placeholder ???) @@ -835,13 +848,14 @@ package body Exp_Attr is Attribute_Default_Iterator | Attribute_Implicit_Dereference | Attribute_Iterator_Element | - Attribute_Variable_Indexing => null; + Attribute_Variable_Indexing => + null; - -- Attributes related to Ada 2012 aspects + -- Internal attributes used to deal with Ada 2012 delayed aspects. These + -- were already rejected by the parser. Thus they shouldn't appear here. - when Attribute_CPU | - Attribute_Dispatching_Domain | - Attribute_Interrupt_Priority => null; + when Internal_Attribute_Id => + raise Program_Error; ------------ -- Access -- @@ -1027,10 +1041,36 @@ package body Exp_Attr is New_Occurrence_Of (Formal, Loc))); Set_Etype (N, Typ); - -- The expression must appear in a default expression, - -- (which in the initialization procedure is the - -- right-hand side of an assignment), and not in a - -- discriminant constraint. + elsif Is_Protected_Type (Entity (Pref)) then + + -- No action needed for current instance located in a + -- component definition (expansion will occur in the + -- init proc) + + if Is_Protected_Type (Current_Scope) then + null; + + -- If the current instance reference is located in a + -- protected subprogram or entry then rewrite the access + -- attribute to be the name of the "_object" parameter. + -- An unchecked conversion is applied to ensure a type + -- match in cases of expander-generated calls (e.g. init + -- procs). + + else + Formal := + First_Entity + (Protected_Body_Subprogram (Current_Scope)); + Rewrite (N, + Unchecked_Convert_To (Typ, + New_Occurrence_Of (Formal, Loc))); + Set_Etype (N, Typ); + end if; + + -- The expression must appear in a default expression, + -- (which in the initialization procedure is the right-hand + -- side of an assignment), and not in a discriminant + -- constraint. else Par := Parent (N); @@ -3065,29 +3105,6 @@ package body Exp_Attr is end if; end; - --------------- - -- Lock_Free -- - --------------- - - -- Rewrite the attribute reference with the value of Uses_Lock_Free - - when Attribute_Lock_Free => Lock_Free : declare - Val : Entity_Id; - - begin - if Uses_Lock_Free (Ptyp) then - Val := Standard_True; - - else - Val := Standard_False; - end if; - - Rewrite (N, - New_Occurrence_Of (Val, Loc)); - - Analyze_And_Resolve (N, Standard_Boolean); - end Lock_Free; - ------------- -- Machine -- ------------- @@ -3176,9 +3193,26 @@ package body Exp_Attr is -- Max_Size_In_Storage_Elements -- ---------------------------------- - when Attribute_Max_Size_In_Storage_Elements => + when Attribute_Max_Size_In_Storage_Elements => declare + Typ : constant Entity_Id := Etype (N); + Attr : Node_Id; + + Conversion_Added : Boolean := False; + -- A flag which tracks whether the original attribute has been + -- wrapped inside a type conversion. + + begin Apply_Universal_Integer_Attribute_Checks (N); + -- The universal integer check may sometimes add a type conversion, + -- retrieve the original attribute reference from the expression. + + Attr := N; + if Nkind (Attr) = N_Type_Conversion then + Attr := Expression (Attr); + Conversion_Added := True; + end if; + -- Heap-allocated controlled objects contain two extra pointers which -- are not part of the actual type. Transform the attribute reference -- into a runtime expression to add the size of the hidden header. @@ -3187,20 +3221,20 @@ package body Exp_Attr is -- two pointers are already present in the type. if VM_Target = No_VM - and then Nkind (N) = N_Attribute_Reference + and then Nkind (Attr) = N_Attribute_Reference and then Needs_Finalization (Ptyp) - and then not Header_Size_Added (N) + and then not Header_Size_Added (Attr) then - Set_Header_Size_Added (N); + Set_Header_Size_Added (Attr); -- Generate: -- P'Max_Size_In_Storage_Elements + -- Universal_Integer -- (Header_Size_With_Padding (Ptyp'Alignment)) - Rewrite (N, + Rewrite (Attr, Make_Op_Add (Loc, - Left_Opnd => Relocate_Node (N), + Left_Opnd => Relocate_Node (Attr), Right_Opnd => Convert_To (Universal_Integer, Make_Function_Call (Loc, @@ -3214,9 +3248,19 @@ package body Exp_Attr is New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Alignment)))))); - Analyze (N); + -- Add a conversion to the target type + + if not Conversion_Added then + Rewrite (Attr, + Make_Type_Conversion (Loc, + Subtype_Mark => New_Reference_To (Typ, Loc), + Expression => Relocate_Node (Attr))); + end if; + + Analyze (Attr); return; end if; + end; -------------------- -- Mechanism_Code -- @@ -3340,6 +3384,13 @@ package body Exp_Attr is Asn_Stm : Node_Id; begin + -- If assertions are disabled, no need to create the declaration + -- that preserves the value. + + if not Assertions_Enabled then + return; + end if; + -- Find the nearest subprogram body, ignoring _Preconditions Subp := N; @@ -5320,6 +5371,13 @@ package body Exp_Attr is Validity_Checks_On := False; + -- Retrieve the base type. Handle the case where the base type is a + -- private enumeration type. + + if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then + Btyp := Full_View (Btyp); + end if; + -- Floating-point case. This case is handled by the Valid attribute -- code in the floating-point attribute run-time library. @@ -5420,15 +5478,14 @@ package body Exp_Attr is -- (X >= type(X)'First and then type(X)'Last <= X) elsif Is_Enumeration_Type (Ptyp) - and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp))) + and then Present (Enum_Pos_To_Rep (Btyp)) then Tst := Make_Op_Ge (Loc, Left_Opnd => Make_Function_Call (Loc, Name => - New_Reference_To - (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc), + New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc), Parameter_Associations => New_List ( Pref, New_Occurrence_Of (Standard_False, Loc))), @@ -5960,6 +6017,7 @@ package body Exp_Attr is when Attribute_Abort_Signal | Attribute_Address_Size | + Attribute_Atomic_Always_Lock_Free | Attribute_Base | Attribute_Class | Attribute_Compiler_Version | @@ -5977,6 +6035,7 @@ package body Exp_Attr is Attribute_Has_Tagged_Values | Attribute_Large | Attribute_Last_Valid | + Attribute_Lock_Free | Attribute_Machine_Emax | Attribute_Machine_Emin | Attribute_Machine_Mantissa | @@ -6020,6 +6079,11 @@ package body Exp_Attr is null; end case; + -- Note: as mentioned earlier, individual sections of the above case + -- statement assume there is no code after the case statement, and are + -- legitimately allowed to execute return statements if they have nothing + -- more to do, so DO NOT add code at this point. + exception when RE_Not_Available => return; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index e4584753fec..56cf190e2a8 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1916,7 +1916,7 @@ package body Exp_Ch11 is begin if LCN = Statements (P) or else - LCN = SSE.Actions_To_Be_Wrapped_Before + LCN = SSE.Actions_To_Be_Wrapped_Before or else LCN = SSE.Actions_To_Be_Wrapped_After then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 7f7aa6f6bb7..066b37d1775 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -202,6 +202,9 @@ 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 Is_User_Defined_Equality (Prim : Node_Id) return Boolean; + -- Returns true if Prim is a user defined equality function + function Is_Variable_Size_Array (E : Entity_Id) return Boolean; -- Returns true if E has variable size components @@ -237,6 +240,11 @@ package body Exp_Ch3 is -- formals at some upper level). E provides the Sloc to be used for the -- generated code. + function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id; + -- Search for a renaming of the inequality dispatching primitive of + -- this tagged type. If found then build and return the corresponding + -- rename-as-body inequality subprogram; otherwise return Empty. + procedure Make_Predefined_Primitive_Specs (Tag_Typ : Entity_Id; Predef_List : out List_Id; @@ -510,11 +518,11 @@ package body Exp_Ch3 is --------------------------- procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is - Loc : constant Source_Ptr := Sloc (Nod); Comp_Type : constant Entity_Id := Component_Type (A_Type); Body_Stmts : List_Id; Has_Default_Init : Boolean; Index_List : List_Id; + Loc : Source_Ptr; Proc_Id : Entity_Id; function Init_Component return List_Id; @@ -623,6 +631,19 @@ package body Exp_Ch3 is -- Start of processing for Build_Array_Init_Proc begin + -- The init proc is created when analyzing the freeze node for the type, + -- but it properly belongs with the array type declaration. However, if + -- the freeze node is for a subtype of a type declared in another unit + -- it seems preferable to use the freeze node as the source location of + -- of the init proc. In any case this is preferable for gcov usage, and + -- the Sloc is not otherwise used by the compiler. + + if In_Open_Scopes (Scope (A_Type)) then + Loc := Sloc (A_Type); + else + Loc := Sloc (Nod); + end if; + -- Nothing to generate in the following cases: -- 1. Initialization is suppressed for the type @@ -760,6 +781,140 @@ package body Exp_Ch3 is end Build_Array_Init_Proc; -------------------------------- + -- Build_Array_Invariant_Proc -- + -------------------------------- + + procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id) is + Loc : constant Source_Ptr := Sloc (Nod); + + Object_Name : constant Name_Id := New_Internal_Name ('I'); + -- Name for argument of invariant procedure + + Object_Entity : constant Node_Id := + Make_Defining_Identifier (Loc, Object_Name); + -- The procedure declaration entity for the argument + + Body_Stmts : List_Id; + Index_List : List_Id; + Proc_Id : Entity_Id; + Proc_Body : Node_Id; + + function Build_Component_Invariant_Call return Node_Id; + -- Create one statement to verify invariant on one array component, + -- designated by a full set of indexes. + + function Check_One_Dimension (N : Int) return List_Id; + -- Create loop to check on one dimension of the array. The single + -- statement in the loop body checks the inner dimensions if any, or + -- else a single component. This procedure is called recursively, with + -- N being the dimension to be initialized. A call with N greater than + -- the number of dimensions generates the component initialization + -- and terminates the recursion. + + ------------------------------------ + -- Build_Component_Invariant_Call -- + ------------------------------------ + + function Build_Component_Invariant_Call return Node_Id is + Comp : Node_Id; + begin + Comp := + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Object_Entity, Loc), + Expressions => Index_List); + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (Invariant_Procedure (Component_Type (A_Type)), Loc), + Parameter_Associations => New_List (Comp)); + end Build_Component_Invariant_Call; + + ------------------------- + -- Check_One_Dimension -- + ------------------------- + + function Check_One_Dimension (N : Int) return List_Id is + Index : Entity_Id; + + begin + -- If all dimensions dealt with, we simply check invariant of the + -- component. + + if N > Number_Dimensions (A_Type) then + return New_List (Build_Component_Invariant_Call); + + -- Else generate one loop and recurse + + else + Index := + Make_Defining_Identifier (Loc, New_External_Name ('J', N)); + + Append (New_Reference_To (Index, Loc), Index_List); + + return New_List ( + Make_Implicit_Loop_Statement (Nod, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Index, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Object_Entity, Loc), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))))), + Statements => Check_One_Dimension (N + 1))); + end if; + end Check_One_Dimension; + + -- Start of processing for Build_Array_Invariant_Proc + + begin + Index_List := New_List; + + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (A_Type), "Invariant")); + Set_Has_Invariants (Proc_Id); + Set_Invariant_Procedure (A_Type, Proc_Id); + + Body_Stmts := Check_One_Dimension (1); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (A_Type, Loc)))), + + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Body_Stmts)); + + Set_Ekind (Proc_Id, E_Procedure); + Set_Is_Public (Proc_Id, Is_Public (A_Type)); + Set_Is_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Proc_Id); + end if; + + -- The procedure body is placed after the freeze node for the type. + + Insert_After (Nod, Proc_Body); + Analyze (Proc_Body); + end Build_Array_Invariant_Proc; + + -------------------------------- -- Build_Discr_Checking_Funcs -- -------------------------------- @@ -2986,7 +3141,7 @@ package body Exp_Ch3 is -- to make it a valid Ada tree. if Is_Empty_List (Stmts) then - Append (New_Node (N_Null_Statement, Loc), Stmts); + Append (Make_Null_Statement (Loc), Stmts); end if; return Stmts; @@ -5505,6 +5660,10 @@ package body Exp_Ch3 is then Build_Array_Init_Proc (Base, N); end if; + + if Has_Invariants (Component_Type (Base)) then + Build_Array_Invariant_Proc (Base, N); + end if; end Expand_Freeze_Array_Type; ----------------------------------- @@ -7677,6 +7836,18 @@ package body Exp_Ch3 is end loop; end Init_Secondary_Tags; + ------------------------ + -- Is_User_Defined_Eq -- + ------------------------ + + function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is + begin + return Chars (Prim) = Name_Op_Eq + and then Etype (First_Formal (Prim)) = + Etype (Next_Formal (First_Formal (Prim))) + and then Base_Type (Etype (Prim)) = Standard_Boolean; + end Is_User_Defined_Equality; + ---------------------------- -- Is_Variable_Size_Array -- ---------------------------- @@ -8140,6 +8311,175 @@ package body Exp_Ch3 is end if; end Make_Eq_If; + -------------------- + -- Make_Neq_Body -- + -------------------- + + function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is + + function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean; + -- Returns true if Prim is a renaming of an unresolved predefined + -- inequality operation. + + -------------------------------- + -- Is_Predefined_Neq_Renaming -- + -------------------------------- + + function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is + begin + return Chars (Prim) /= Name_Op_Ne + and then Present (Alias (Prim)) + and then Comes_From_Source (Prim) + and then Is_Intrinsic_Subprogram (Alias (Prim)) + and then Chars (Alias (Prim)) = Name_Op_Ne; + end Is_Predefined_Neq_Renaming; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ)); + Stmts : constant List_Id := New_List; + Decl : Node_Id; + Eq_Prim : Entity_Id; + Left_Op : Entity_Id; + Renaming_Prim : Entity_Id; + Right_Op : Entity_Id; + Target : Entity_Id; + + -- Start of processing for Make_Neq_Body + + begin + -- For a call on a renaming of a dispatching subprogram that is + -- overridden, if the overriding occurred before the renaming, then + -- the body executed is that of the overriding declaration, even if the + -- overriding declaration is not visible at the place of the renaming; + -- otherwise, the inherited or predefined subprogram is called, see + -- (RM 8.5.4(8)) + + -- Stage 1: Search for a renaming of the inequality primitive and also + -- search for an overriding of the equality primitive located before the + -- renaming declaration. + + declare + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + Eq_Prim := Empty; + Renaming_Prim := Empty; + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Is_User_Defined_Equality (Prim) + and then No (Alias (Prim)) + then + if No (Renaming_Prim) then + pragma Assert (No (Eq_Prim)); + Eq_Prim := Prim; + end if; + + elsif Is_Predefined_Neq_Renaming (Prim) then + Renaming_Prim := Prim; + end if; + + Next_Elmt (Elmt); + end loop; + end; + + -- No further action needed if no renaming was found + + if No (Renaming_Prim) then + return Empty; + end if; + + -- Stage 2: Replace the renaming declaration by a subprogram declaration + -- (required to add its body) + + Decl := Parent (Parent (Renaming_Prim)); + Rewrite (Decl, + Make_Subprogram_Declaration (Loc, + Specification => Specification (Decl))); + Set_Analyzed (Decl); + + -- Remove the decoration of intrinsic renaming subprogram + + Set_Is_Intrinsic_Subprogram (Renaming_Prim, False); + Set_Convention (Renaming_Prim, Convention_Ada); + Set_Alias (Renaming_Prim, Empty); + Set_Has_Completion (Renaming_Prim, False); + + -- Stage 3: Build the corresponding body + + Left_Op := First_Formal (Renaming_Prim); + Right_Op := Next_Formal (Left_Op); + + Decl := + Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Chars (Renaming_Prim), + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Left_Op)), + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Right_Op)), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + + Ret_Type => Standard_Boolean, + For_Body => True); + + -- If the overriding of the equality primitive occurred before the + -- renaming, then generate: + + -- function <Neq_Name> (X : Y : Typ) return Boolean is + -- begin + -- return not Oeq (X, Y); + -- end; + + if Present (Eq_Prim) then + Target := Eq_Prim; + + -- Otherwise build a nested subprogram which performs the predefined + -- evaluation of the equality operator. That is, generate: + + -- function <Neq_Name> (X : Y : Typ) return Boolean is + -- function Oeq (X : Y) return Boolean is + -- begin + -- <<body of default implementation>> + -- end; + -- begin + -- return not Oeq (X, Y); + -- end; + + else + declare + Local_Subp : Node_Id; + begin + Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq); + Set_Declarations (Decl, New_List (Local_Subp)); + Target := Defining_Entity (Local_Subp); + end; + end if; + + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Op_Not (Loc, + Make_Function_Call (Loc, + Name => New_Reference_To (Target, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Chars (Left_Op)), + Make_Identifier (Loc, Chars (Right_Op))))))); + + Set_Handled_Statement_Sequence + (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + return Decl; + end Make_Neq_Body; + ------------------------------- -- Make_Null_Procedure_Specs -- ------------------------------- @@ -8238,13 +8578,6 @@ package body Exp_Ch3 is Predef_List : out List_Id; Renamed_Eq : out Entity_Id) is - Loc : constant Source_Ptr := Sloc (Tag_Typ); - Res : constant List_Id := New_List; - Eq_Name : Name_Id := Name_Op_Eq; - Eq_Needed : Boolean; - Eq_Spec : Node_Id; - Prim : Elmt_Id; - function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; -- Returns true if Prim is a renaming of an unresolved predefined -- equality operation. @@ -8262,6 +8595,19 @@ package body Exp_Ch3 is and then Chars (Alias (Prim)) = Name_Op_Eq; end Is_Predefined_Eq_Renaming; + -- Local variables + + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Res : constant List_Id := New_List; + Eq_Name : Name_Id := Name_Op_Eq; + Eq_Needed : Boolean; + Eq_Spec : Node_Id; + Prim : Elmt_Id; + + Has_Predef_Eq_Renaming : Boolean := False; + -- Set to True if Tag_Typ has a primitive that renames the predefined + -- equality operator. Used to implement (RM 8-5-4(8)). + -- Start of processing for Make_Predefined_Primitive_Specs begin @@ -8299,9 +8645,9 @@ package body Exp_Ch3 is end loop; end; - -- Spec of "=" is expanded if the type is not limited and if a - -- user defined "=" was not already declared for the non-full - -- view of a private extension + -- Spec of "=" is expanded if the type is not limited and if a user + -- defined "=" was not already declared for the non-full view of a + -- private extension if not Is_Limited_Type (Tag_Typ) then Eq_Needed := True; @@ -8311,21 +8657,18 @@ package body Exp_Ch3 is -- If a primitive is encountered that renames the predefined -- equality operator before reaching any explicit equality -- primitive, then we still need to create a predefined equality - -- function, because calls to it can occur via the renaming. A new - -- name is created for the equality to avoid conflicting with any - -- user-defined equality. (Note that this doesn't account for + -- function, because calls to it can occur via the renaming. A + -- new name is created for the equality to avoid conflicting with + -- any user-defined equality. (Note that this doesn't account for -- renamings of equality nested within subpackages???) if Is_Predefined_Eq_Renaming (Node (Prim)) then + Has_Predef_Eq_Renaming := True; Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); -- User-defined equality - elsif Chars (Node (Prim)) = Name_Op_Eq - and then Etype (First_Formal (Node (Prim))) = - Etype (Next_Formal (First_Formal (Node (Prim)))) - and then Base_Type (Etype (Node (Prim))) = Standard_Boolean - then + elsif Is_User_Defined_Equality (Node (Prim)) then if No (Alias (Node (Prim))) or else Nkind (Unit_Declaration_Node (Node (Prim))) = N_Subprogram_Renaming_Declaration @@ -8394,7 +8737,7 @@ package body Exp_Ch3 is Ret_Type => Standard_Boolean); Append_To (Res, Eq_Spec); - if Eq_Name /= Name_Op_Eq then + if Has_Predef_Eq_Renaming then Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); Prim := First_Elmt (Primitive_Operations (Tag_Typ)); @@ -8966,6 +9309,14 @@ package body Exp_Ch3 is Append_To (Res, Decl); end if; + -- Body for inequality (if required!) + + Decl := Make_Neq_Body (Tag_Typ); + + if Present (Decl) then + Append_To (Res, Decl); + end if; + -- Body for dispatching assignment Decl := diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 8cedc0b05cd..1abc4567a33 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -46,6 +46,12 @@ package Exp_Ch3 is procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id); -- Add a field _parent in the extension part of the record + procedure Build_Array_Invariant_Proc (A_Type : Entity_Id; Nod : Node_Id); + -- If the component of type of array type has invariants, build procedure + -- that checks invariant on all components of the array. Ada 2012 specifies + -- that an invariant on some type T must be applied to in-out parameters + -- and return values that include a part of type T. + procedure Build_Discr_Checking_Funcs (N : Node_Id); -- Builds function which checks whether the component name is consistent -- with the current discriminants. N is the full type declaration node, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 5ed4e8afaca..9cc8865b64d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -659,7 +659,7 @@ package body Exp_Ch4 is -- Ada 2005 (AI-344): For an allocator with a class-wide designated -- type, generate an accessibility check to verify that the level of the -- type of the created object is not deeper than the level of the access - -- type. If the type of the qualified expression is class- wide, then + -- type. If the type of the qualified expression is class-wide, then -- always generate the check (except in the case where it is known to be -- unnecessary, see comment below). Otherwise, only generate the check -- if the level of the qualified expression type is statically deeper @@ -690,17 +690,22 @@ package body Exp_Ch4 is (Ref : Node_Id; Built_In_Place : Boolean := False) is - New_Node : Node_Id; + Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT); + Cond : Node_Id; + Free_Stmt : Node_Id; + Obj_Ref : Node_Id; + Stmts : List_Id; begin if Ada_Version >= Ada_2005 and then Is_Class_Wide_Type (DesigT) - and then not Scope_Suppress (Accessibility_Check) + and then not Scope_Suppress.Suppress (Accessibility_Check) and then (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) or else (Is_Class_Wide_Type (Etype (Exp)) and then Scope (PtrT) /= Current_Scope)) + and then (Tagged_Type_Expansion or else VM_Target /= No_VM) then -- If the allocator was built in place, Ref is already a reference -- to the access object initialized to the result of the allocator @@ -712,39 +717,109 @@ package body Exp_Ch4 is if Built_In_Place then Remove_Side_Effects (Ref); - New_Node := New_Copy (Ref); + Obj_Ref := New_Copy (Ref); else - New_Node := New_Reference_To (Ref, Loc); + Obj_Ref := New_Reference_To (Ref, Loc); end if; - New_Node := + -- Step 1: Create the object clean up code + + Stmts := New_List; + + -- Create an explicit free statement to clean up the allocated + -- object in case the accessibility check fails. Generate: + + -- Free (Obj_Ref); + + Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref)); + Set_Storage_Pool (Free_Stmt, Pool_Id); + + Append_To (Stmts, Free_Stmt); + + -- Finalize the object (if applicable), but wrap the call inside + -- a block to ensure that the object would still be deallocated in + -- case the finalization fails. Generate: + + -- begin + -- [Deep_]Finalize (Obj_Ref.all); + -- exception + -- when others => + -- Free (Obj_Ref); + -- raise; + -- end; + + if Needs_Finalization (DesigT) then + Prepend_To (Stmts, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Final_Call ( + Obj_Ref => + Make_Explicit_Dereference (Loc, + Prefix => New_Copy (Obj_Ref)), + Typ => DesigT)), + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + Statements => New_List ( + New_Copy_Tree (Free_Stmt), + Make_Raise_Statement (Loc))))))); + end if; + + -- Signal the accessibility failure through a Program_Error + + Append_To (Stmts, + Make_Raise_Program_Error (Loc, + Condition => New_Reference_To (Standard_True, Loc), + Reason => PE_Accessibility_Check_Failed)); + + -- Step 2: Create the accessibility comparison + + -- Generate: + -- Ref'Tag + + Obj_Ref := Make_Attribute_Reference (Loc, - Prefix => New_Node, + Prefix => Obj_Ref, Attribute_Name => Name_Tag); + -- For tagged types, determine the accessibility level by looking + -- at the type specific data of the dispatch table. Generate: + + -- Type_Specific_Data (Address (Ref'Tag)).Access_Level + if Tagged_Type_Expansion then - New_Node := Build_Get_Access_Level (Loc, New_Node); + Cond := Build_Get_Access_Level (Loc, Obj_Ref); - elsif VM_Target /= No_VM then - New_Node := - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Get_Access_Level), Loc), - Parameter_Associations => New_List (New_Node)); + -- Use a runtime call to determine the accessibility level when + -- compiling on virtual machine targets. Generate: - -- Cannot generate the runtime check + -- Get_Access_Level (Ref'Tag) else - return; + Cond := + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Get_Access_Level), Loc), + Parameter_Associations => New_List (Obj_Ref)); end if; + Cond := + Make_Op_Gt (Loc, + Left_Opnd => Cond, + Right_Opnd => + Make_Integer_Literal (Loc, Type_Access_Level (PtrT))); + + -- Due to the complexity and side effects of the check, utilize an + -- if statement instead of the regular Program_Error circuitry. + Insert_Action (N, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => New_Node, - Right_Opnd => - Make_Integer_Literal (Loc, Type_Access_Level (PtrT))), - Reason => PE_Accessibility_Check_Failed)); + Make_If_Statement (Loc, + Condition => Cond, + Then_Statements => Stmts)); end if; end Apply_Accessibility_Check; @@ -11327,12 +11402,7 @@ package body Exp_Ch4 is if AV = False then if True_Result or False_Result then - if True_Result then - Result := Standard_True; - else - Result := Standard_False; - end if; - + Result := Boolean_Literals (True_Result); Rewrite (N, Convert_To (Typ, New_Occurrence_Of (Result, Sloc (N)))); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index a9f6ce46e5e..a1aaa37363e 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -344,15 +344,6 @@ package body Exp_Ch5 is elsif Has_Controlled_Component (L_Type) then Loop_Required := True; - -- If changing scalar storage order and assigning a bit packed array, - -- force loop expansion. - - elsif Is_Bit_Packed_Array (L_Type) - and then (In_Reverse_Storage_Order_Record (Rhs) /= - In_Reverse_Storage_Order_Record (Lhs)) - then - Loop_Required := True; - -- If object is atomic, we cannot tolerate a loop elsif Is_Atomic_Object (Act_Lhs) @@ -3213,6 +3204,13 @@ package body Exp_Ch5 is Statements => Stats, End_Label => Empty); + -- If present, preserve identifier of loop, which can be used in + -- an exit statement in the body. + + if Present (Identifier (N)) then + Set_Identifier (New_Loop, Relocate_Node (Identifier (N))); + end if; + -- Create the declarations for Iterator and cursor and insert them -- before the source loop. Given that the domain of iteration is -- already an entity, the iterator is just a renaming of that @@ -3389,6 +3387,13 @@ package body Exp_Ch5 is end loop; end if; + -- If original loop has a name, preserve it so it can be recognized by + -- an exit statement in the body of the rewritten loop. + + if Present (Identifier (N)) then + Set_Identifier (Core_Loop, Relocate_Node (Identifier (N))); + end if; + Rewrite (N, Core_Loop); Analyze (N); end Expand_Iterator_Loop_Over_Array; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index eb37fa3c2fa..930f82befc0 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4835,8 +4835,8 @@ package body Exp_Ch6 is Ret_Type := Etype (Subp); end if; - -- Create temporaries for the actuals that are expressions, or that - -- are scalars and require copying to preserve semantics. + -- Create temporaries for the actuals that are expressions, or that are + -- scalars and require copying to preserve semantics. F := First_Formal (Subp); A := First_Actual (N); @@ -4846,6 +4846,14 @@ package body Exp_Ch6 is return; end if; + -- Reset Last_Assignment for any parameters of mode out or in out, to + -- prevent spurious warnings about overwriting for assignments to the + -- formal in the inlined code. + + if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then + Set_Last_Assignment (Entity (A), Empty); + end if; + -- If the argument may be a controlling argument in a call within -- the inlined body, we must preserve its classwide nature to insure -- that dynamic dispatching take place subsequently. If the formal @@ -4878,9 +4886,9 @@ package body Exp_Ch6 is (not Is_Scalar_Type (Etype (A)) or else Ekind (Entity (A)) = E_Enumeration_Literal)) - -- When the actual is an identifier and the corresponding formal - -- is used only once in the original body, the formal can be - -- substituted directly with the actual parameter. + -- When the actual is an identifier and the corresponding formal is + -- used only once in the original body, the formal can be substituted + -- directly with the actual parameter. or else (Nkind (A) = N_Identifier and then Formal_Is_Used_Once (F)) @@ -4926,8 +4934,8 @@ package body Exp_Ch6 is Set_Sloc (New_A, Sloc (N)); - -- If the actual has a by-reference type, it cannot be copied, so - -- its value is captured in a renaming declaration. Otherwise + -- If the actual has a by-reference type, it cannot be copied, + -- so its value is captured in a renaming declaration. Otherwise -- declare a local constant initialized with the actual. -- We also use a renaming declaration for expressions of an array @@ -5151,8 +5159,8 @@ package body Exp_Ch6 is end if; end if; - -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on - -- conflicting private views that Gigi would ignore. If this is a + -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors + -- on conflicting private views that Gigi would ignore. If this is a -- predefined unit, analyze with checks off, as is done in the non- -- inlined run-time units. @@ -7466,7 +7474,7 @@ package body Exp_Ch6 is elsif Ada_Version >= Ada_2005 and then Tagged_Type_Expansion and then Is_Class_Wide_Type (R_Type) - and then not Scope_Suppress (Accessibility_Check) + and then not Scope_Suppress.Suppress (Accessibility_Check) and then (Is_Class_Wide_Type (Etype (Exp)) or else Nkind_In (Exp, N_Type_Conversion, diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index a1d5634bb47..725cd2ac4b6 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2645,7 +2645,18 @@ package body Exp_Ch7 is Obj_Ref => Obj_Ref, Typ => Obj_Typ); - if Exceptions_OK then + -- For CodePeer, the exception handlers normally generated here + -- generate complex flowgraphs which result in capacity problems. + -- Omitting these handlers for CodePeer is justified as follows: + + -- If a handler is dead, then omitting it is surely ok + + -- If a handler is live, then CodePeer should flag the + -- potentially-exception-raising construct that causes it + -- to be live. That is what we are interested in, not what + -- happens after the exception is raised. + + if Exceptions_OK and not CodePeer_Mode then Fin_Stmts := New_List ( Make_Block_Statement (Loc, Handled_Statement_Sequence => @@ -4334,9 +4345,13 @@ 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); - After : List_Id renames SE.Actions_To_Be_Wrapped_After; - Before : List_Id renames SE.Actions_To_Be_Wrapped_Before; + After : constant List_Id := + Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_After; + Before : constant List_Id := + Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_Before; + -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack. + -- Last), but this was incorrect as Process_Transient_Object may + -- introduce new scopes and cause a reallocation of Scope_Stack.Table. procedure Process_Transient_Objects (First_Object : Node_Id; @@ -4369,12 +4384,16 @@ package body Exp_Ch7 is function Requires_Hooking return Boolean is begin -- The context is either a procedure or function call or an object - -- declaration initialized by a function call. In all these cases, - -- the calls might raise an exception. + -- declaration initialized by a function call. Note that in the + -- latter case, a function call that returns on the secondary + -- stack is usually rewritten into something else. Its proper + -- detection requires examination of the original initialization + -- expression. return Nkind (N) in N_Subprogram_Call - or else (Nkind (N) = N_Object_Declaration - and then Nkind (Expression (N)) = N_Function_Call); + or else (Nkind (N) = N_Object_Declaration + and then Nkind (Original_Node (Expression (N))) = + N_Function_Call); end Requires_Hooking; -- Local variables @@ -4390,10 +4409,13 @@ package body Exp_Ch7 is Obj_Id : Entity_Id; Obj_Ref : Node_Id; Obj_Typ : Entity_Id; + Prev_Fin : Node_Id := Empty; Stmt : Node_Id; Stmts : List_Id; Temp_Id : Entity_Id; + -- Start of processing for Process_Transient_Objects + begin -- Examine all objects in the list First_Object .. Last_Object @@ -4428,7 +4450,6 @@ package body Exp_Ch7 is Fin_Decls := New_List; Build_Object_Declarations (Fin_Data, Fin_Decls, Loc); - Insert_List_Before_And_Analyze (First_Object, Fin_Decls); Built := True; end if; @@ -4560,56 +4581,33 @@ package body Exp_Ch7 is Exception_Handlers => New_List ( Build_Exception_Handler (Fin_Data)))); - Insert_After_And_Analyze (Last_Object, Fin_Block); + -- The single raise statement must be inserted after all the + -- finalization blocks, and we put everything into a wrapper + -- block to clearly expose the construct to the back-end. + + -- This requirement for "clearly expose" must be properly + -- documented in sinfo/einfo ??? - -- The raise statement must be inserted after all the - -- finalization blocks. + if Present (Prev_Fin) then + Insert_Before_And_Analyze (Prev_Fin, Fin_Block); + else + Insert_After_And_Analyze (Last_Object, + Make_Block_Statement (Loc, + Declarations => Fin_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Block)))); - if No (Last_Fin) then Last_Fin := Fin_Block; end if; - -- When the associated node is an array object, the expander may - -- sometimes generate a loop and create transient objects inside - -- the loop. - - elsif Nkind (Related_Node) = N_Object_Declaration - and then Is_Array_Type - (Base_Type - (Etype (Defining_Identifier (Related_Node)))) - and then Nkind (Stmt) = N_Loop_Statement - then - declare - Block_HSS : Node_Id := First (Statements (Stmt)); - - begin - -- The loop statements may have been wrapped in a block by - -- Process_Statements_For_Controlled_Objects, inspect the - -- handled sequence of statements. - - if Nkind (Block_HSS) = N_Block_Statement - and then No (Next (Block_HSS)) - then - Block_HSS := Handled_Statement_Sequence (Block_HSS); - - Process_Transient_Objects - (First_Object => First (Statements (Block_HSS)), - Last_Object => Last (Statements (Block_HSS)), - Related_Node => Related_Node); - - -- Inspect the statements of the loop - - else - Process_Transient_Objects - (First_Object => First (Statements (Stmt)), - Last_Object => Last (Statements (Stmt)), - Related_Node => Related_Node); - end if; - end; + Prev_Fin := Fin_Block; + end if; - -- Terminate the scan after the last object has been processed + -- Terminate the scan after the last object has been processed to + -- avoid touching unrelated code. - elsif Stmt = Last_Object then + if Stmt = Last_Object then exit; end if; @@ -4637,10 +4635,10 @@ package body Exp_Ch7 is end if; declare - Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped; - First_Obj : Node_Id; - Last_Obj : Node_Id; - Target : Node_Id; + Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped; + First_Obj : Node_Id; + Last_Obj : Node_Id; + Target : Node_Id; begin -- If the node to be wrapped is the trigger of an asynchronous @@ -4700,11 +4698,13 @@ package body Exp_Ch7 is -- Reset the action lists if Present (Before) then - Before := No_List; + Scope_Stack.Table (Scope_Stack.Last). + Actions_To_Be_Wrapped_Before := No_List; end if; if Present (After) then - After := No_List; + Scope_Stack.Table (Scope_Stack.Last). + Actions_To_Be_Wrapped_After := No_List; end if; end; end Insert_Actions_In_Scope_Around; diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index a0e9d4cf1be..3b5c7d3ae64 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -239,8 +239,52 @@ package body Exp_Ch8 is ---------------------------------------------- procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Entity (N); + + function Build_Body_For_Renaming return Node_Id; + -- Build and return the body for the renaming declaration of an equality + -- or inequality operator. + + ----------------------------- + -- Build_Body_For_Renaming -- + ----------------------------- + + function Build_Body_For_Renaming return Node_Id is + Body_Id : Entity_Id; + Decl : Node_Id; + + begin + Set_Alias (Id, Empty); + Set_Has_Completion (Id, False); + Rewrite (N, + Make_Subprogram_Declaration (Sloc (N), + Specification => Specification (N))); + Set_Has_Delayed_Freeze (Id); + + Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id)); + Set_Debug_Info_Needed (Body_Id); + + Decl := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Body_Id, + Parameter_Specifications => Copy_Parameter_List (Id), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + Declarations => Empty_List, + Handled_Statement_Sequence => Empty); + + return Decl; + end Build_Body_For_Renaming; + + -- Local variables + Nam : constant Node_Id := Name (N); + -- Start of processing for Expand_N_Subprogram_Renaming_Declaration + begin -- When the prefix of the name is a function call, we must force the -- call to be made by removing side effects from the call, since we @@ -259,25 +303,24 @@ package body Exp_Ch8 is Force_Evaluation (Prefix (Nam)); end if; - -- Check whether this is a renaming of a predefined equality on an - -- untagged record type (AI05-0123). + -- Handle cases where we build a body for a renamed equality if Is_Entity_Name (Nam) and then Chars (Entity (Nam)) = Name_Op_Eq and then Scope (Entity (Nam)) = Standard_Standard - and then Ada_Version >= Ada_2012 then declare - Loc : constant Source_Ptr := Sloc (N); - Id : constant Entity_Id := Defining_Entity (N); - Typ : constant Entity_Id := Etype (First_Formal (Id)); - - Decl : Node_Id; - Body_Id : constant Entity_Id := - Make_Defining_Identifier (Sloc (N), Chars (Id)); + Left : constant Entity_Id := First_Formal (Id); + Right : constant Entity_Id := Next_Formal (Left); + Typ : constant Entity_Id := Etype (Left); + Decl : Node_Id; begin - if Is_Record_Type (Typ) + -- Check whether this is a renaming of a predefined equality on an + -- untagged record type (AI05-0123). + + if Ada_Version >= Ada_2012 + and then Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then @@ -288,23 +331,7 @@ package body Exp_Ch8 is -- declaration, and the body is inserted at the end of the -- current declaration list to prevent premature freezing. - Set_Alias (Id, Empty); - Set_Has_Completion (Id, False); - Rewrite (N, - Make_Subprogram_Declaration (Sloc (N), - Specification => Specification (N))); - Set_Has_Delayed_Freeze (Id); - - Decl := Make_Subprogram_Body (Loc, - Specification => - Make_Function_Specification (Loc, - Defining_Unit_Name => Body_Id, - Parameter_Specifications => - Copy_Parameter_List (Id), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)), - Declarations => Empty_List, - Handled_Statement_Sequence => Empty); + Decl := Build_Body_For_Renaming; Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, @@ -313,16 +340,12 @@ package body Exp_Ch8 is Expression => Expand_Record_Equality (Id, - Typ => Typ, - Lhs => - Make_Identifier (Loc, Chars (First_Formal (Id))), - Rhs => - Make_Identifier - (Loc, Chars (Next_Formal (First_Formal (Id)))), + Typ => Typ, + Lhs => Make_Identifier (Loc, Chars (Left)), + Rhs => Make_Identifier (Loc, Chars (Right)), Bodies => Declarations (Decl)))))); Append (Decl, List_Containing (N)); - Set_Debug_Info_Needed (Body_Id); end if; end; end if; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 620efc96ad7..248984d89a9 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -339,6 +339,17 @@ package body Exp_Ch9 is -- step of the expansion must to be done after private data has been moved -- to its final resting scope to ensure proper visibility of debug objects. + procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id); + -- If control flow optimizations are suppressed, and Alt is an accept, + -- delay, or entry call alternative with no trailing statements, insert a + -- null trailing statement with the given Loc (which is the sloc of the + -- accept, delay, or entry call statement). There might not be any + -- generated code for the accept, delay, or entry call itself (the + -- effect of these statements is part of the general processsing done + -- for the enclosing selective accept, timed entry call, or asynchronous + -- select), and the null statement is there to carry the sloc of that + -- statement to the back-end for trace-based coverage analysis purposes. + procedure Extract_Dispatching_Call (N : Node_Id; Call_Ent : out Entity_Id; @@ -2955,26 +2966,40 @@ package body Exp_Ch9 is -- manner: -- procedure P (...) is - -- <original declarations> + -- Expected_Comp : constant Comp_Type := + -- Comp_Type + -- (System.Atomic_Primitives.Lock_Free_Read_N + -- (_Object.Comp'Address)); -- begin -- loop -- declare - -- Saved_Comp : constant ... := - -- Atomic_Load (Comp'Address, Relaxed); - -- Current_Comp : ... := Saved_Comp; + -- <original declarations before the object renaming declaration + -- of Comp> + -- + -- Desired_Comp : Comp_Type := Expected_Comp; + -- Comp : Comp_Type renames Desired_Comp; + -- + -- <original delarations after the object renaming declaration + -- of Comp> + -- -- begin -- <original statements> - -- exit when Atomic_Compare (Comp, Saved_Comp, Current_Comp); + -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N + -- (_Object.Comp'Address, + -- Interfaces.Unsigned_N (Expected_Comp), + -- Interfaces.Unsigned_N (Desired_Comp)); -- end; - -- <<L0>> -- end loop; -- end P; - -- References to Comp which appear in the original statements are replaced - -- with references to Current_Comp. Each return and raise statement of P is - -- transformed into an atomic status check: + -- Each return and raise statement of P is transformed into an atomic + -- status check: - -- if Atomic_Compare (Comp, Saved_Comp, Current_Comp) then + -- if System.Atomic_Primitives.Lock_Free_Try_Write_N + -- (_Object.Comp'Address, + -- Interfaces.Unsigned_N (Expected_Comp), + -- Interfaces.Unsigned_N (Desired_Comp)); + -- then -- <original statement> -- else -- goto L0; @@ -2985,180 +3010,31 @@ package body Exp_Ch9 is -- manner: -- function F (...) return ... is - -- <original declarations> - -- Saved_Comp : constant ... := Atomic_Load (Comp'Address); + -- <original declarations before the object renaming declaration + -- of Comp> + -- + -- Expected_Comp : constant Comp_Type := + -- Comp_Type + -- (System.Atomic_Primitives.Lock_Free_Read_N + -- (_Object.Comp'Address)); + -- Comp : Comp_Type renames Expected_Comp; + -- + -- <original delarations after the object renaming declaration of + -- Comp> + -- -- begin -- <original statements> -- end F; - -- References to Comp which appear in the original statements are replaced - -- with references to Saved_Comp. - function Build_Lock_Free_Unprotected_Subprogram_Body (N : Node_Id; Prot_Typ : Node_Id) return Node_Id is - Is_Procedure : constant Boolean := - Ekind (Corresponding_Spec (N)) = E_Procedure; - Loc : constant Source_Ptr := Sloc (N); - Label_Id : Entity_Id := Empty; - - procedure Process_Stmts - (Stmts : List_Id; - Compare : Entity_Id; - Unsigned : Entity_Id; - Comp : Entity_Id; - Saved_Comp : Entity_Id; - Current_Comp : Entity_Id); - -- Given a statement sequence Stmts, wrap any return or raise statements - -- in the following manner: - -- - -- if System.Atomic_Primitives.Atomic_Compare_Exchange - -- (Comp'Address, - -- Interfaces.Unsigned (Saved_Comp), - -- Interfaces.Unsigned (Current_Comp)) - -- then - -- <Stmt>; - -- else - -- goto L0; - -- end if; - -- - -- Replace all references to Comp with a reference to Current_Comp. - function Referenced_Component (N : Node_Id) return Entity_Id; -- Subprograms which meet the lock-free implementation criteria are -- allowed to reference only one unique component. Return the prival -- of the said component. - ------------------- - -- Process_Stmts -- - ------------------- - - procedure Process_Stmts - (Stmts : List_Id; - Compare : Entity_Id; - Unsigned : Entity_Id; - Comp : Entity_Id; - Saved_Comp : Entity_Id; - Current_Comp : Entity_Id) - is - function Process_Node (N : Node_Id) return Traverse_Result; - -- Transform a single node if it is a return statement, a raise - -- statement or a reference to Comp. - - ------------------ - -- Process_Node -- - ------------------ - - function Process_Node (N : Node_Id) return Traverse_Result is - - procedure Wrap_Statement (Stmt : Node_Id); - -- Wrap an arbitrary statement inside an if statement where the - -- condition does an atomic check on the state of the object. - - -------------------- - -- Wrap_Statement -- - -------------------- - - procedure Wrap_Statement (Stmt : Node_Id) is - begin - -- The first time through, create the declaration of a label - -- which is used to skip the remainder of source statements if - -- the state of the object has changed. - - if No (Label_Id) then - Label_Id := - Make_Identifier (Loc, New_External_Name ('L', 0)); - Set_Entity (Label_Id, - Make_Defining_Identifier (Loc, Chars (Label_Id))); - end if; - - -- Generate: - - -- if System.Atomic_Primitives.Atomic_Compare_Exchange - -- (Comp'Address, - -- Interfaces.Unsigned (Saved_Comp), - -- Interfaces.Unsigned (Current_Comp)) - -- then - -- <Stmt>; - -- else - -- goto L0; - -- end if; - - Rewrite (Stmt, - Make_If_Statement (Loc, - Condition => - Make_Function_Call (Loc, - Name => - New_Reference_To (Compare, Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Comp, Loc), - Attribute_Name => Name_Address), - - Unchecked_Convert_To (Unsigned, - New_Reference_To (Saved_Comp, Loc)), - - Unchecked_Convert_To (Unsigned, - New_Reference_To (Current_Comp, Loc)))), - - Then_Statements => New_List (Relocate_Node (Stmt)), - - Else_Statements => New_List ( - Make_Goto_Statement (Loc, - Name => New_Reference_To (Entity (Label_Id), Loc))))); - end Wrap_Statement; - - -- Start of processing for Process_Node - - begin - -- Wrap each return and raise statement that appear inside a - -- procedure. Skip the last return statement which is added by - -- default since it is transformed into an exit statement. - - if Is_Procedure - and then Nkind_In (N, N_Simple_Return_Statement, - N_Extended_Return_Statement, - N_Raise_Statement) - and then Nkind (Last (Stmts)) /= N_Simple_Return_Statement - then - Wrap_Statement (N); - return Skip; - - -- Replace all references to the original component by a reference - -- to the current state of the component. - - elsif Nkind (N) = N_Identifier - and then Present (Entity (N)) - and then Entity (N) = Comp - then - Rewrite (N, Make_Identifier (Loc, Chars (Current_Comp))); - return Skip; - end if; - - -- Force reanalysis - - Set_Analyzed (N, False); - - return OK; - end Process_Node; - - procedure Process_Nodes is new Traverse_Proc (Process_Node); - - -- Local variables - - Stmt : Node_Id; - - -- Start of processing for Process_Stmts - - begin - Stmt := First (Stmts); - while Present (Stmt) loop - Process_Nodes (Stmt); - Next (Stmt); - end loop; - end Process_Stmts; - -------------------------- -- Referenced_Component -- -------------------------- @@ -3214,152 +3090,311 @@ package body Exp_Ch9 is -- Local variables - Comp : constant Entity_Id := Referenced_Component (N); - Decls : constant List_Id := Declarations (N); - Stmts : List_Id; + Comp : constant Entity_Id := Referenced_Component (N); + Loc : constant Source_Ptr := Sloc (N); + Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N); + Decls : List_Id := Declarations (N); -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body begin - Stmts := New_Copy_List (Statements (Handled_Statement_Sequence (N))); + -- Add renamings for the protection object, discriminals, privals and + -- the entry index constant for use by debugger. + + Debug_Private_Data_Declarations (Decls); -- Perform the lock-free expansion when the subprogram references a -- protected component. if Present (Comp) then - declare + Protected_Component_Ref : declare + Comp_Decl : constant Node_Id := Parent (Comp); + Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl); Comp_Type : constant Entity_Id := Etype (Comp); - Block_Decls : List_Id; - Compare : Entity_Id; - Current_Comp : Entity_Id; - Decl : Node_Id; - Label : Node_Id; - Load : Entity_Id; - Load_Params : List_Id; - Saved_Comp : Entity_Id; - Stmt : Node_Id; - Typ_Size : Int; - Unsigned : Entity_Id; + + Is_Procedure : constant Boolean := + Ekind (Corresponding_Spec (N)) = E_Procedure; + -- Indicates if N is a protected procedure body + + Block_Decls : List_Id; + Try_Write : Entity_Id; + Desired_Comp : Entity_Id; + Decl : Node_Id; + Label : Node_Id; + Label_Id : Entity_Id := Empty; + Read : Entity_Id; + Expected_Comp : Entity_Id; + Stmt : Node_Id; + Stmts : List_Id := + New_Copy_List (Statements (Hand_Stmt_Seq)); + Typ_Size : Int; + Unsigned : Entity_Id; + + function Process_Node (N : Node_Id) return Traverse_Result; + -- Transform a single node if it is a return statement, a raise + -- statement or a reference to Comp. + + procedure Process_Stmts (Stmts : List_Id); + -- Given a statement sequence Stmts, wrap any return or raise + -- statements in the following manner: + -- + -- if System.Atomic_Primitives.Lock_Free_Try_Write_N + -- (_Object.Comp'Address, + -- Interfaces.Unsigned_N (Expected_Comp), + -- Interfaces.Unsigned_N (Desired_Comp)) + -- then + -- <Stmt>; + -- else + -- goto L0; + -- end if; + + ------------------ + -- Process_Node -- + ------------------ + + function Process_Node (N : Node_Id) return Traverse_Result is + + procedure Wrap_Statement (Stmt : Node_Id); + -- Wrap an arbitrary statement inside an if statement where the + -- condition does an atomic check on the state of the object. + + -------------------- + -- Wrap_Statement -- + -------------------- + + procedure Wrap_Statement (Stmt : Node_Id) is + begin + -- The first time through, create the declaration of a label + -- which is used to skip the remainder of source statements + -- if the state of the object has changed. + + if No (Label_Id) then + Label_Id := + Make_Identifier (Loc, New_External_Name ('L', 0)); + Set_Entity (Label_Id, + Make_Defining_Identifier (Loc, Chars (Label_Id))); + end if; + + -- Generate: + -- if System.Atomic_Primitives.Lock_Free_Try_Write_N + -- (_Object.Comp'Address, + -- Interfaces.Unsigned_N (Expected_Comp), + -- Interfaces.Unsigned_N (Desired_Comp)) + -- then + -- <Stmt>; + -- else + -- goto L0; + -- end if; + + Rewrite (Stmt, + Make_Implicit_If_Statement (N, + Condition => + Make_Function_Call (Loc, + Name => + New_Reference_To (Try_Write, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Comp_Sel_Nam), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (Unsigned, + New_Reference_To (Expected_Comp, Loc)), + + Unchecked_Convert_To (Unsigned, + New_Reference_To (Desired_Comp, Loc)))), + + Then_Statements => New_List (Relocate_Node (Stmt)), + + Else_Statements => New_List ( + Make_Goto_Statement (Loc, + Name => + New_Reference_To (Entity (Label_Id), Loc))))); + end Wrap_Statement; + + -- Start of processing for Process_Node + + begin + -- Wrap each return and raise statement that appear inside a + -- procedure. Skip the last return statement which is added by + -- default since it is transformed into an exit statement. + + if Is_Procedure + and then ((Nkind (N) = N_Simple_Return_Statement + and then N /= Last (Stmts)) + or else Nkind (N) = N_Extended_Return_Statement + or else (Nkind_In (N, N_Raise_Constraint_Error, + N_Raise_Program_Error, + N_Raise_Statement, + N_Raise_Storage_Error) + and then Comes_From_Source (N))) + then + Wrap_Statement (N); + return Skip; + end if; + + -- Force reanalysis + + Set_Analyzed (N, False); + + return OK; + end Process_Node; + + procedure Process_Nodes is new Traverse_Proc (Process_Node); + + ------------------- + -- Process_Stmts -- + ------------------- + + procedure Process_Stmts (Stmts : List_Id) is + Stmt : Node_Id; + begin + Stmt := First (Stmts); + while Present (Stmt) loop + Process_Nodes (Stmt); + Next (Stmt); + end loop; + end Process_Stmts; + + -- Start of processing for Protected_Component_Ref begin -- Get the type size - -- Surely this should be Known_Static_Esize if you are about - -- to assume you can do UI_To_Int on it! ??? - - if Known_Esize (Comp_Type) then + if Known_Static_Esize (Comp_Type) then Typ_Size := UI_To_Int (Esize (Comp_Type)); -- If the Esize (Object_Size) is unknown at compile-time, look at -- the RM_Size (Value_Size) since it may have been set by an -- explicit representation clause. - -- And how do we know this is statically known??? + elsif Known_Static_RM_Size (Comp_Type) then + Typ_Size := UI_To_Int (RM_Size (Comp_Type)); + + -- Should not happen since this has already been checked in + -- Allows_Lock_Free_Implementation (see Sem_Ch9). else - Typ_Size := UI_To_Int (RM_Size (Comp_Type)); + raise Program_Error; end if; -- Retrieve all relevant atomic routines and types case Typ_Size is when 8 => - Compare := RTE (RE_Atomic_Compare_Exchange_8); - Load := RTE (RE_Atomic_Load_8); - Unsigned := RTE (RE_Uint8); + Try_Write := RTE (RE_Lock_Free_Try_Write_8); + Read := RTE (RE_Lock_Free_Read_8); + Unsigned := RTE (RE_Uint8); when 16 => - Compare := RTE (RE_Atomic_Compare_Exchange_16); - Load := RTE (RE_Atomic_Load_16); - Unsigned := RTE (RE_Uint16); + Try_Write := RTE (RE_Lock_Free_Try_Write_16); + Read := RTE (RE_Lock_Free_Read_16); + Unsigned := RTE (RE_Uint16); when 32 => - Compare := RTE (RE_Atomic_Compare_Exchange_32); - Load := RTE (RE_Atomic_Load_32); - Unsigned := RTE (RE_Uint32); + Try_Write := RTE (RE_Lock_Free_Try_Write_32); + Read := RTE (RE_Lock_Free_Read_32); + Unsigned := RTE (RE_Uint32); when 64 => - Compare := RTE (RE_Atomic_Compare_Exchange_64); - Load := RTE (RE_Atomic_Load_64); - Unsigned := RTE (RE_Uint64); + Try_Write := RTE (RE_Lock_Free_Try_Write_64); + Read := RTE (RE_Lock_Free_Read_64); + Unsigned := RTE (RE_Uint64); when others => raise Program_Error; end case; -- Generate: - -- For functions: - - -- Saved_Comp : constant Comp_Type := - -- Comp_Type (Atomic_Load (Comp'Address)); - - -- For procedures: + -- Expected_Comp : constant Comp_Type := + -- Comp_Type + -- (System.Atomic_Primitives.Lock_Free_Read_N + -- (_Object.Comp'Address)); - -- Saved_Comp : constant Comp_Type := - -- Comp_Type (Atomic_Load (Comp'Address), - -- Relaxed); - - Saved_Comp := + Expected_Comp := Make_Defining_Identifier (Loc, New_External_Name (Chars (Comp), Suffix => "_saved")); - Load_Params := New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Comp, Loc), - Attribute_Name => Name_Address)); - - -- For protected procedures, set the memory model to be relaxed - - if Is_Procedure then - Append_To (Load_Params, - New_Reference_To (RTE (RE_Relaxed), Loc)); - end if; - Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Saved_Comp, - Constant_Present => True, + Defining_Identifier => Expected_Comp, Object_Definition => New_Reference_To (Comp_Type, Loc), + Constant_Present => True, Expression => Unchecked_Convert_To (Comp_Type, Make_Function_Call (Loc, - Name => New_Reference_To (Load, Loc), - Parameter_Associations => Load_Params))); + Name => New_Reference_To (Read, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Comp_Sel_Nam), + Attribute_Name => Name_Address))))); -- Protected procedures if Is_Procedure then - Block_Decls := New_List (Decl); + -- Move the original declarations inside the generated block + + Block_Decls := Decls; + + -- Reset the declarations list of the protected procedure to + -- contain only Decl. + + Decls := New_List (Decl); -- Generate: - -- Current_Comp : Comp_Type := Saved_Comp; + -- Desired_Comp : Comp_Type := Expected_Comp; - Current_Comp := + Desired_Comp := Make_Defining_Identifier (Loc, New_External_Name (Chars (Comp), Suffix => "_current")); - Append_To (Block_Decls, + -- Insert the declarations of Expected_Comp and Desired_Comp in + -- the block declarations right before the renaming of the + -- protected component. + + Insert_Before (Comp_Decl, Make_Object_Declaration (Loc, - Defining_Identifier => Current_Comp, + Defining_Identifier => Desired_Comp, Object_Definition => New_Reference_To (Comp_Type, Loc), - Expression => New_Reference_To (Saved_Comp, Loc))); + Expression => + New_Reference_To (Expected_Comp, Loc))); -- Protected function else - Append_To (Decls, Decl); - Current_Comp := Saved_Comp; + Desired_Comp := Expected_Comp; + + -- Insert the declaration of Expected_Comp in the function + -- declarations right before the renaming of the protected + -- component. + + Insert_Before (Comp_Decl, Decl); end if; - Process_Stmts - (Stmts, Compare, Unsigned, Comp, Saved_Comp, Current_Comp); + -- Rewrite the protected component renaming declaration to be a + -- renaming of Desired_Comp. -- Generate: + -- Comp : Comp_Type renames Desired_Comp; + + Rewrite (Comp_Decl, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Defining_Identifier (Comp_Decl), + Subtype_Mark => + New_Occurrence_Of (Comp_Type, Loc), + Name => + New_Reference_To (Desired_Comp, Loc))); + + -- Wrap any return or raise statements in Stmts in same the manner + -- described in Process_Stmts. - -- exit when System.Atomic_Primitives.Atomic_Compare_Exchange - -- (Comp'Address, - -- Interfaces.Unsigned (Saved_Comp), - -- Interfaces.Unsigned (Current_Comp)) + Process_Stmts (Stmts); + + -- Generate: + -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N + -- (_Object.Comp'Address, + -- Interfaces.Unsigned_N (Expected_Comp), + -- Interfaces.Unsigned_N (Desired_Comp)) if Is_Procedure then Stmt := @@ -3367,17 +3402,17 @@ package body Exp_Ch9 is Condition => Make_Function_Call (Loc, Name => - New_Reference_To (Compare, Loc), + New_Reference_To (Try_Write, Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Comp, Loc), + Prefix => Relocate_Node (Comp_Sel_Nam), Attribute_Name => Name_Address), Unchecked_Convert_To (Unsigned, - New_Reference_To (Saved_Comp, Loc)), + New_Reference_To (Expected_Comp, Loc)), Unchecked_Convert_To (Unsigned, - New_Reference_To (Current_Comp, Loc))))); + New_Reference_To (Desired_Comp, Loc))))); -- Small optimization: transform the default return statement -- of a procedure into the atomic exit statement. @@ -3402,7 +3437,6 @@ package body Exp_Ch9 is end if; -- Generate: - -- loop -- declare -- <Decls> @@ -3412,26 +3446,22 @@ package body Exp_Ch9 is -- end loop; if Is_Procedure then - Stmts := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Atomic_Synchronize), Loc)), - Make_Loop_Statement (Loc, - Statements => New_List ( - Make_Block_Statement (Loc, - Declarations => Block_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts))), - End_Label => Empty)); + Stmts := + New_List ( + Make_Loop_Statement (Loc, + Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => Block_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))), + End_Label => Empty)); end if; - end; - end if; - - -- Add renamings for the protection object, discriminals, privals and - -- the entry index constant for use by debugger. - Debug_Private_Data_Declarations (Decls); + Hand_Stmt_Seq := + Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts); + end Protected_Component_Ref; + end if; -- Make an unprotected version of the subprogram for use within the same -- object, with new name and extra parameter representing the object. @@ -3441,8 +3471,7 @@ package body Exp_Ch9 is Specification => Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode), Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); + Handled_Statement_Sequence => Hand_Stmt_Seq); end Build_Lock_Free_Unprotected_Subprogram_Body; ------------------------- @@ -4767,7 +4796,7 @@ package body Exp_Ch9 is Rewrite (N, Make_Block_Statement (Loc, - Declarations => Decls, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); @@ -4817,7 +4846,7 @@ package body Exp_Ch9 is Name => Name, Parameter_Associations => New_List (Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Chain, Loc), + Prefix => New_Occurrence_Of (Chain, Loc), Attribute_Name => Name_Unchecked_Access))); if Nkind (N) = N_Package_Declaration then @@ -4933,7 +4962,7 @@ package body Exp_Ch9 is Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Chain, Loc), + Prefix => New_Reference_To (Chain, Loc), Attribute_Name => Name_Unchecked_Access))))), Has_Created_Identifier => True, @@ -4970,7 +4999,7 @@ package body Exp_Ch9 is Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Chain, Loc), + Prefix => New_Reference_To (Chain, Loc), Attribute_Name => Name_Unchecked_Access)))); Block := @@ -5208,8 +5237,8 @@ package body Exp_Ch9 is Formal : Entity_Id; begin - -- If the result type is an access_to_subprogram, we must create - -- new entities for its spec. + -- If the result type is an access_to_subprogram, we must create new + -- entities for its spec. if Nkind (New_Res) = N_Access_Definition and then Present (Access_To_Subprogram_Definition (New_Res)) @@ -5333,9 +5362,7 @@ package body Exp_Ch9 is Make_Explicit_Dereference (Loc, N)), Selector_Name => Make_Identifier (Loc, Sel)); - elsif Is_Entity_Name (N) - and then Is_Concurrent_Type (Entity (N)) - then + elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then if Is_Task_Type (Entity (N)) then if Is_Current_Task (Entity (N)) then @@ -5421,9 +5448,7 @@ package body Exp_Ch9 is begin Decl := First (Decls); - while Present (Decl) - and then not Comes_From_Source (Decl) - loop + while Present (Decl) and then not Comes_From_Source (Decl) loop -- Declaration for concurrent entity _object and its access type, -- along with the entry index subtype: -- type prot_typVP is access prot_typV; @@ -5455,6 +5480,31 @@ package body Exp_Ch9 is end loop; end Debug_Private_Data_Declarations; + ------------------------------ + -- Ensure_Statement_Present -- + ------------------------------ + + procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is + Stmt : Node_Id; + + begin + if Opt.Suppress_Control_Flow_Optimizations + and then Is_Empty_List (Statements (Alt)) + then + Stmt := Make_Null_Statement (Loc); + + -- Mark NULL statement as coming from source so that it is not + -- eliminated by GIGI. + + -- Another covert channel! If this is a requirement, it must be + -- documented in sinfo/einfo ??? + + Set_Comes_From_Source (Stmt, True); + + Set_Statements (Alt, New_List (Stmt)); + end if; + end Ensure_Statement_Present; + ---------------------------- -- Entry_Index_Expression -- ---------------------------- @@ -5515,8 +5565,8 @@ package body Exp_Ch9 is Sloc, Make_Attribute_Reference (Sloc, Attribute_Name => Name_Pos, - Prefix => New_Reference_To (Base_Type (S), Sloc), - Expressions => New_List (Relocate_Node (Index))), + Prefix => New_Reference_To (Base_Type (S), Sloc), + Expressions => New_List (Relocate_Node (Index))), Type_Low_Bound (S), Ttyp, False)); @@ -5638,7 +5688,6 @@ package body Exp_Ch9 is Stats : constant Node_Id := Handled_Statement_Sequence (N); Ann : Entity_Id := Empty; Adecl : Node_Id; - Lab_Id : Node_Id; Lab : Node_Id; Ldecl : Node_Id; Ldecl2 : Node_Id; @@ -5671,8 +5720,7 @@ package body Exp_Ch9 is begin Ent := Make_Temporary (Loc, 'L'); - Lab_Id := New_Reference_To (Ent, Loc); - Lab := Make_Label (Loc, Lab_Id); + Lab := Make_Label (Loc, New_Reference_To (Ent, Loc)); Ldecl := Make_Implicit_Label_Declaration (Loc, Defining_Identifier => Ent, @@ -5680,8 +5728,7 @@ package body Exp_Ch9 is Append (Lab, Statements (Handled_Statement_Sequence (N))); Ent := Make_Temporary (Loc, 'L'); - Lab_Id := New_Reference_To (Ent, Loc); - Lab := Make_Label (Loc, Lab_Id); + Lab := Make_Label (Loc, New_Reference_To (Ent, Loc)); Ldecl2 := Make_Implicit_Label_Declaration (Loc, Defining_Identifier => Ent, @@ -5690,7 +5737,7 @@ package body Exp_Ch9 is end; else - Ldecl := Empty; + Ldecl := Empty; Ldecl2 := Empty; end if; @@ -5704,17 +5751,12 @@ package body Exp_Ch9 is Adecl := Make_Object_Declaration (Loc, Defining_Identifier => Ann, - Object_Definition => + Object_Definition => New_Reference_To (RTE (RE_Address), Loc)); - Insert_Before (N, Adecl); - Analyze (Adecl); - - Insert_Before (N, Ldecl); - Analyze (Ldecl); - - Insert_Before (N, Ldecl2); - Analyze (Ldecl2); + Insert_Before_And_Analyze (N, Adecl); + Insert_Before_And_Analyze (N, Ldecl); + Insert_Before_And_Analyze (N, Ldecl2); end if; -- Case of accept statement which is in an accept alternative @@ -5760,11 +5802,10 @@ package body Exp_Ch9 is Adecl := Make_Object_Declaration (Loc, Defining_Identifier => Ann, - Object_Definition => + Object_Definition => New_Reference_To (RTE (RE_Address), Loc)); - Insert_Before (Sel_Acc, Adecl); - Analyze (Adecl); + Insert_Before_And_Analyze (Sel_Acc, Adecl); -- If we are not the first accept statement, then find the Ann -- variable allocated by the first accept and use it. @@ -5809,8 +5850,7 @@ package body Exp_Ch9 is while Present (Formal) loop Comp := Entry_Component (Formal); - New_F := - Make_Defining_Identifier (Loc, Chars (Formal)); + New_F := Make_Defining_Identifier (Loc, Chars (Formal)); Set_Etype (New_F, Etype (Formal)); Set_Scope (New_F, Ent); @@ -5894,10 +5934,9 @@ package body Exp_Ch9 is Decl1 := Make_Full_Type_Declaration (Loc, Defining_Identifier => D_T2, - Type_Definition => Def1); + Type_Definition => Def1); - Insert_After (N, Decl1); - Analyze (Decl1); + Insert_After_And_Analyze (N, Decl1); -- Associate the access to subprogram with its original access to -- protected subprogram type. Needed by the backend to know that this @@ -5913,7 +5952,7 @@ package body Exp_Ch9 is Defining_Identifier => Make_Temporary (Loc, 'P'), Component_Definition => Make_Component_Definition (Loc, - Aliased_Present => False, + Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RTE (RE_Address), Loc))), @@ -5932,8 +5971,7 @@ package body Exp_Ch9 is Component_List => Make_Component_List (Loc, Component_Items => Comps))); - Insert_After (Decl1, Decl2); - Analyze (Decl2); + Insert_After_And_Analyze (Decl1, Decl2); Set_Equivalent_Type (T, E_T); end Expand_Access_Protected_Subprogram_Type; @@ -6003,9 +6041,7 @@ package body Exp_Ch9 is -- condition does not reference any of the generated renamings -- within the function. - if Full_Expander_Active - and then Scope (Entity (Cond)) /= Func - then + if Full_Expander_Active and then Scope (Entity (Cond)) /= Func then Set_Declarations (B_F, Empty_List); end if; @@ -6073,8 +6109,7 @@ package body Exp_Ch9 is then Append_To (Component_Associations (Aggr), Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, Count)), + Choices => New_List (Make_Integer_Literal (Loc, Count)), Expression => -- Task_Id (Tasknm._disp_get_task_id) @@ -6082,7 +6117,7 @@ package body Exp_Ch9 is Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RO_ST_Task_Id), Loc), - Expression => + Expression => Make_Selected_Component (Loc, Prefix => New_Copy_Tree (Tasknm), Selector_Name => @@ -6091,8 +6126,7 @@ package body Exp_Ch9 is else Append_To (Component_Associations (Aggr), Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, Count)), + Choices => New_List (Make_Integer_Literal (Loc, Count)), Expression => Concurrent_Ref (Tasknm))); end if; @@ -6105,7 +6139,7 @@ package body Exp_Ch9 is Parameter_Associations => New_List ( Make_Qualified_Expression (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Task_List), Loc), - Expression => Aggr)))); + Expression => Aggr)))); Analyze (N); end Expand_N_Abort_Statement; @@ -6183,11 +6217,9 @@ package body Exp_Ch9 is Call : Node_Id; Block : Node_Id; - -- Start of processing for Expand_N_Accept_Statement - begin - -- If accept statement is not part of a list, then its parent must be - -- an accept alternative, and, as described above, we do not do any + -- If the accept statement is not part of a list, then its parent must + -- be an accept alternative, and, as described above, we do not do any -- expansion for such accept statements at this level. if not Is_List_Member (N) then @@ -6279,9 +6311,7 @@ package body Exp_Ch9 is if Parent (Stats) = N then Prepend (Call, Statements (Stats)); else - Set_Declarations - (Parent (Stats), - New_List (Call)); + Set_Declarations (Parent (Stats), New_List (Call)); end if; Analyze (Call); @@ -6594,7 +6624,7 @@ package body Exp_Ch9 is Abortable_Block : Node_Id; Actuals : List_Id; Astats : List_Id; - Blk_Ent : Entity_Id; + Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A'); Blk_Typ : Entity_Id; Call : Node_Id; Call_Ent : Entity_Id; @@ -6639,15 +6669,16 @@ package body Exp_Ch9 is Process_Statements_For_Controlled_Objects (Trig); Process_Statements_For_Controlled_Objects (Abrt); + Ecall := Triggering_Statement (Trig); + + Ensure_Statement_Present (Sloc (Ecall), Trig); + -- Retrieve Astats and Tstats now because the finalization machinery may -- wrap them in blocks. Astats := Statements (Abrt); Tstats := Statements (Trig); - Blk_Ent := Make_Temporary (Loc, 'A'); - Ecall := Triggering_Statement (Trig); - -- The arguments in the call may require dynamic allocation, and the -- call statement may have been transformed into a block. The block -- may contain additional declarations for internal entities, and the @@ -6776,10 +6807,8 @@ package body Exp_Ch9 is New_Copy_Tree (Obj), -- <object> New_Reference_To (S, Loc), -- S Make_Attribute_Reference (Loc, -- P'Address - Prefix => - New_Reference_To (P, Loc), - Attribute_Name => - Name_Address), + Prefix => New_Reference_To (P, Loc), + Attribute_Name => Name_Address), Make_Identifier (Loc, Name_uD), -- D New_Reference_To (B, Loc)))); -- B @@ -6789,14 +6818,13 @@ package body Exp_Ch9 is -- end if; Append_To (Cleanup_Stmts, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Enqueued), Loc), Parameter_Associations => - New_List ( - New_Reference_To (Bnn, Loc))), + New_List (New_Reference_To (Bnn, Loc))), Then_Statements => New_Copy_List_Tree (Astats))); @@ -6835,8 +6863,7 @@ package body Exp_Ch9 is ProtE_Stmts := New_List ( Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => - Abort_Block_Ent), + Defining_Identifier => Abort_Block_Ent), Build_Abort_Block (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); @@ -6847,7 +6874,7 @@ package body Exp_Ch9 is -- end if; Append_To (ProtE_Stmts, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Op_Not (Loc, Right_Opnd => @@ -6855,8 +6882,7 @@ package body Exp_Ch9 is Name => New_Reference_To (RTE (RE_Cancelled), Loc), Parameter_Associations => - New_List ( - New_Reference_To (Bnn, Loc)))), + New_List (New_Reference_To (Bnn, Loc)))), Then_Statements => New_Copy_List_Tree (Tstats))); @@ -6895,15 +6921,14 @@ package body Exp_Ch9 is Find_Prim_Op (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), Loc), + Parameter_Associations => New_List ( New_Copy_Tree (Obj), -- <object> New_Reference_To (S, Loc), -- S Make_Attribute_Reference (Loc, -- P'Address - Prefix => - New_Reference_To (P, Loc), - Attribute_Name => - Name_Address), + Prefix => New_Reference_To (P, Loc), + Attribute_Name => Name_Address), Make_Identifier (Loc, Name_uD), -- D New_Reference_To (B, Loc)))); -- B @@ -6912,10 +6937,8 @@ package body Exp_Ch9 is Prepend_To (TaskE_Stmts, Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Abort_Defer), Loc), - Parameter_Associations => - No_List)); + Name => New_Reference_To (RTE (RE_Abort_Defer), Loc), + Parameter_Associations => No_List)); -- Generate: -- Abort_Undefer; @@ -6925,10 +6948,8 @@ package body Exp_Ch9 is Prepend_To (Cleanup_Stmts, Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Abort_Undefer), Loc), - Parameter_Associations => - No_List)); + Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => No_List)); -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions -- will generate a _clean for the additional status flag. @@ -6974,11 +6995,9 @@ package body Exp_Ch9 is -- end if; Append_To (TaskE_Stmts, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => - Make_Op_Not (Loc, - Right_Opnd => - New_Reference_To (T, Loc)), + Make_Op_Not (Loc, Right_Opnd => New_Reference_To (T, Loc)), Then_Statements => New_Copy_List_Tree (Tstats))); @@ -7027,10 +7046,10 @@ package body Exp_Ch9 is -- end if; Append_To (Conc_Typ_Stmts, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Op_Eq (Loc, - Left_Opnd => + Left_Opnd => New_Reference_To (C, Loc), Right_Opnd => New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)), @@ -7043,7 +7062,7 @@ package body Exp_Ch9 is Make_Elsif_Part (Loc, Condition => Make_Op_Eq (Loc, - Left_Opnd => + Left_Opnd => New_Reference_To (C, Loc), Right_Opnd => New_Reference_To (RTE (RE_POK_Task_Entry), Loc)), @@ -7069,10 +7088,10 @@ package body Exp_Ch9 is -- end if; Append_To (Stmts, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Op_Eq (Loc, - Left_Opnd => + Left_Opnd => New_Reference_To (K, Loc), Right_Opnd => New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)), @@ -7117,7 +7136,7 @@ package body Exp_Ch9 is Append_To (Parameter_Associations (Ecall), Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Dblock_Ent, Loc), + Prefix => New_Reference_To (Dblock_Ent, Loc), Attribute_Name => Name_Unchecked_Access)); -- Create the inner block to protect the abortable part @@ -7141,9 +7160,10 @@ package body Exp_Ch9 is Rewrite (Ecall, Make_Implicit_If_Statement (N, - Condition => Make_Function_Call (Loc, - Name => Enqueue_Call, - Parameter_Associations => Parameter_Associations (Ecall)), + Condition => + Make_Function_Call (Loc, + Name => Enqueue_Call, + Parameter_Associations => Parameter_Associations (Ecall)), Then_Statements => New_List (Make_Block_Statement (Loc, Handled_Statement_Sequence => @@ -7161,13 +7181,14 @@ package body Exp_Ch9 is Append_To (Stmts, Make_Implicit_If_Statement (N, - Condition => Make_Function_Call (Loc, - Name => New_Reference_To ( - RTE (RE_Timed_Out), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Dblock_Ent, Loc), - Attribute_Name => Name_Unchecked_Access))), + Condition => + Make_Function_Call (Loc, + Name => New_Reference_To ( + RTE (RE_Timed_Out), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Dblock_Ent, Loc), + Attribute_Name => Name_Unchecked_Access))), Then_Statements => Tstats)); -- The result is the new block @@ -7179,8 +7200,8 @@ package body Exp_Ch9 is Declarations => New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Dblock_Ent, - Aliased_Present => True, - Object_Definition => New_Reference_To ( + Aliased_Present => True, + Object_Definition => New_Reference_To ( RTE (RE_Delay_Block), Loc))), Handled_Statement_Sequence => @@ -7257,18 +7278,18 @@ package body Exp_Ch9 is Append_To (Stmts, Make_Implicit_If_Statement (N, - Condition => Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Enqueued), Loc), - Parameter_Associations => New_List ( - New_Reference_To (Cancel_Param, Loc))), + Condition => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Enqueued), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Cancel_Param, Loc))), Then_Statements => Astats)); Abortable_Block := Make_Block_Statement (Loc, Identifier => New_Reference_To (Blk_Ent, Loc), Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts), + Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts), Has_Created_Identifier => True, Is_Asynchronous_Call_Block => True); @@ -7346,7 +7367,7 @@ package body Exp_Ch9 is Prepend_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => B, - Object_Definition => New_Reference_To (Standard_Boolean, Loc))); + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); @@ -7355,7 +7376,7 @@ package body Exp_Ch9 is Prepend_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Cancel_Param, - Object_Definition => New_Reference_To (Standard_Boolean, Loc))); + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); -- Remove and save the call to Call_Simple @@ -7381,11 +7402,10 @@ package body Exp_Ch9 is Abortable_Block := Make_Block_Statement (Loc, - Identifier => New_Reference_To (Blk_Ent, Loc), + Identifier => New_Reference_To (Blk_Ent, Loc), Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Astats), - Has_Created_Identifier => True, + Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats), + Has_Created_Identifier => True, Is_Asynchronous_Call_Block => True); Insert_After (Call, @@ -7394,10 +7414,8 @@ package body Exp_Ch9 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => - Blk_Ent, - Label_Construct => - Abortable_Block), + Defining_Identifier => Blk_Ent, + Label_Construct => Abortable_Block), Abortable_Block), Exception_Handlers => Hdle))); @@ -7407,13 +7425,11 @@ package body Exp_Ch9 is Append_To (Params, New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); - Append_To (Params, - New_Reference_To (B, Loc)); + Append_To (Params, New_Reference_To (B, Loc)); Rewrite (Call, Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Task_Entry_Call), Loc), + Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), Parameter_Associations => Params)); -- Construct statement sequence for new block @@ -7421,8 +7437,7 @@ package body Exp_Ch9 is Append_To (Stmts, Make_Implicit_If_Statement (N, Condition => - Make_Op_Not (Loc, - New_Reference_To (Cancel_Param, Loc)), + Make_Op_Not (Loc, New_Reference_To (Cancel_Param, Loc)), Then_Statements => Tstats)); -- Protected the call against abort @@ -7650,10 +7665,8 @@ package body Exp_Ch9 is New_Copy_Tree (Obj), -- <object> New_Reference_To (S, Loc), -- S Make_Attribute_Reference (Loc, -- P'Address - Prefix => - New_Reference_To (P, Loc), - Attribute_Name => - Name_Address), + Prefix => New_Reference_To (P, Loc), + Attribute_Name => Name_Address), New_Reference_To (C, Loc), -- C New_Reference_To (B, Loc)))); -- B @@ -7673,8 +7686,7 @@ package body Exp_Ch9 is if Present (Unpack) then Append_To (Conc_Typ_Stmts, - Make_If_Statement (Loc, - + Make_Implicit_If_Statement (N, Condition => Make_Or_Else (Loc, Left_Opnd => @@ -7684,6 +7696,7 @@ package body Exp_Ch9 is Right_Opnd => New_Reference_To (RTE ( RE_POK_Protected_Entry), Loc)), + Right_Opnd => Make_Op_Eq (Loc, Left_Opnd => @@ -7691,8 +7704,7 @@ package body Exp_Ch9 is Right_Opnd => New_Reference_To (RTE (RE_POK_Task_Entry), Loc))), - Then_Statements => - Unpack)); + Then_Statements => Unpack)); end if; -- Generate: @@ -7711,7 +7723,7 @@ package body Exp_Ch9 is N_Stats := New_Copy_List_Tree (Statements (Alt)); Prepend_To (N_Stats, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Or_Else (Loc, Left_Opnd => @@ -7743,8 +7755,8 @@ package body Exp_Ch9 is New_List (Blk))); Append_To (Conc_Typ_Stmts, - Make_If_Statement (Loc, - Condition => New_Reference_To (B, Loc), + Make_Implicit_If_Statement (N, + Condition => New_Reference_To (B, Loc), Then_Statements => N_Stats, Else_Statements => Else_Statements (N))); @@ -7763,7 +7775,7 @@ package body Exp_Ch9 is -- end if; Append_To (Stmts, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Op_Eq (Loc, Left_Opnd => @@ -7784,7 +7796,7 @@ package body Exp_Ch9 is Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts))); - -- As described above, The entry alternative is transformed into a + -- As described above, the entry alternative is transformed into a -- block that contains the gnulli call, and possibly assignment -- statements for in-out parameters. The gnulli call may itself be -- rewritten into a transient block if some unconstrained parameters @@ -7861,7 +7873,7 @@ package body Exp_Ch9 is Prepend_To (Declarations (Blk), Make_Object_Declaration (Loc, Defining_Identifier => B, - Object_Definition => + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); -- Create new call statement @@ -7879,7 +7891,7 @@ package body Exp_Ch9 is Append_To (Stmts, Make_Implicit_If_Statement (N, - Condition => New_Reference_To (B, Loc), + Condition => New_Reference_To (B, Loc), Then_Statements => Statements (Alt), Else_Statements => Else_Statements (N))); end if; @@ -9693,7 +9705,7 @@ package body Exp_Ch9 is -- or else C = POK_Task_Entry -- then - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Op_Or (Loc, Left_Opnd => @@ -10001,8 +10013,8 @@ package body Exp_Ch9 is Alts : constant List_Id := Select_Alternatives (N); -- Note: in the below declarations a lot of new lists are allocated - -- unconditionally which may well not end up being used. That's - -- not a good idea since it wastes space gratuitously ??? + -- unconditionally which may well not end up being used. That's not + -- a good idea since it wastes space gratuitously ??? Accept_Case : List_Id; Accept_List : constant List_Id := New_List; @@ -10012,7 +10024,6 @@ package body Exp_Ch9 is Alt_Stats : List_Id; Ann : Entity_Id := Empty; - Block : Node_Id; Check_Guard : Boolean := True; Decls : constant List_Id := New_List; @@ -10045,9 +10056,7 @@ package body Exp_Ch9 is Num_Alts : Int; Num_Accept : Nat := 0; Proc : Node_Id; - Q : Node_Id; Time_Type : Entity_Id; - X : Node_Id; Select_Call : Node_Id; Qnam : constant Entity_Id := @@ -10131,25 +10140,24 @@ package body Exp_Ch9 is Stats := New_List ( Make_Implicit_Loop_Statement (N, - Identifier => Empty, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => J, + Defining_Identifier => J, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Qnam, Loc), + Prefix => New_Reference_To (Qnam, Loc), Attribute_Name => Name_Range, - Expressions => New_List ( + Expressions => New_List ( Make_Integer_Literal (Loc, 1))))), - Statements => New_List ( + Statements => New_List ( Make_Implicit_If_Statement (N, - Condition => Cond, + Condition => Cond, Then_Statements => New_List ( Make_Select_Call ( - New_Reference_To (RTE (RE_Simple_Mode), Loc)), + New_Reference_To (RTE (RE_Simple_Mode), Loc)), Make_Exit_Statement (Loc)))))); Append_To (Stats, @@ -10217,12 +10225,12 @@ package body Exp_Ch9 is Proc_Body := Make_Subprogram_Body (Eloc, - Specification => + Specification => Make_Procedure_Specification (Eloc, Defining_Unit_Name => PB_Ent), - Declarations => Declarations (Acc_Stm), - Handled_Statement_Sequence => - Build_Accept_Body (Accept_Statement (Alt))); + Declarations => Declarations (Acc_Stm), + Handled_Statement_Sequence => + Build_Accept_Body (Accept_Statement (Alt))); -- During the analysis of the body of the accept statement, any -- zero cost exception handler records were collected in the @@ -10266,7 +10274,7 @@ package body Exp_Ch9 is Make_Implicit_Label_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Chars (Lab_Id)), - Label_Construct => Lab)); + Label_Construct => Lab)); return Lab; end Make_And_Declare_Label; @@ -10281,11 +10289,11 @@ package body Exp_Ch9 is begin Append ( Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Qnam, Loc), + Prefix => New_Reference_To (Qnam, Loc), Attribute_Name => Name_Unchecked_Access), Params); - Append (Select_Mode, Params); - Append (New_Reference_To (Ann, Loc), Params); + Append (Select_Mode, Params); + Append (New_Reference_To (Ann, Loc), Params); Append (New_Reference_To (Xnam, Loc), Params); return @@ -10303,60 +10311,54 @@ package body Exp_Ch9 is Index : Int; Proc : Node_Id) is - Choices : List_Id := No_List; + Astmt : constant Node_Id := Accept_Statement (Alt); Alt_Stats : List_Id; begin Adjust_Condition (Condition (Alt)); - Alt_Stats := No_List; - - if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then - Choices := New_List ( - Make_Integer_Literal (Loc, Index)); - - Alt_Stats := New_List ( - Make_Procedure_Call_Statement (Sloc (Proc), - Name => New_Reference_To ( - Defining_Unit_Name (Specification (Proc)), Sloc (Proc)))); - end if; - if Statements (Alt) /= Empty_List then + -- Accept with body - if No (Alt_Stats) then + if Present (Handled_Statement_Sequence (Astmt)) then + Alt_Stats := + New_List ( + Make_Procedure_Call_Statement (Sloc (Proc), + Name => + New_Reference_To + (Defining_Unit_Name (Specification (Proc)), + Sloc (Proc)))); - -- Accept with no body, followed by trailing statements + -- Accept with no body (followed by trailing statements) - Choices := New_List ( - Make_Integer_Literal (Loc, Index)); + else + Alt_Stats := Empty_List; + end if; - Alt_Stats := New_List; - end if; + Ensure_Statement_Present (Sloc (Astmt), Alt); - -- After the call, if any, branch to trailing statements. We - -- create a label for each, as well as the corresponding label - -- declaration. + -- After the call, if any, branch to trailing statements, if any. + -- We create a label for each, as well as the corresponding label + -- declaration. + if not Is_Empty_List (Statements (Alt)) then Lab := Make_And_Declare_Label (Index); - Append_To (Alt_Stats, - Make_Goto_Statement (Loc, - Name => New_Copy (Identifier (Lab)))); - Append (Lab, Trailing_List); Append_List (Statements (Alt), Trailing_List); Append_To (Trailing_List, Make_Goto_Statement (Loc, Name => New_Copy (Identifier (End_Lab)))); - end if; - if Present (Alt_Stats) then + else + Lab := End_Lab; + end if; - -- Procedure call. and/or trailing statements + Append_To (Alt_Stats, + Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab)))); - Append_To (Alt_List, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => Choices, - Statements => Alt_Stats)); - end if; + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)), + Statements => Alt_Stats)); end Process_Accept_Alternative; ------------------------------- @@ -10364,7 +10366,7 @@ package body Exp_Ch9 is ------------------------------- procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is - Choices : List_Id; + Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt)); Cond : Node_Id; Delay_Alt : List_Id; @@ -10388,14 +10390,12 @@ package body Exp_Ch9 is -- The enclosing if-statement is omitted if there is no guard - if Delay_Count = 1 - or else First_Delay - then + if Delay_Count = 1 or else First_Delay then First_Delay := False; Delay_Alt := New_List ( Make_Assignment_Statement (Loc, - Name => New_Reference_To (Delay_Min, Loc), + Name => New_Reference_To (Delay_Min, Loc), Expression => Expression (Delay_Statement (Alt)))); if Delay_Count > 1 then @@ -10408,7 +10408,7 @@ package body Exp_Ch9 is else Delay_Alt := New_List ( Make_Assignment_Statement (Loc, - Name => New_Reference_To (Delay_Val, Loc), + Name => New_Reference_To (Delay_Val, Loc), Expression => Expression (Delay_Statement (Alt)))); if Time_Type = Standard_Duration then @@ -10426,10 +10426,11 @@ package body Exp_Ch9 is Cond := Make_Function_Call (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Reference_To (Scope (Time_Type), Loc), + Prefix => + New_Reference_To (Scope (Time_Type), Loc), Selector_Name => Make_Operator_Symbol (Loc, - Chars => Name_Op_Lt, + Chars => Name_Op_Lt, Strval => No_String)), Parameter_Associations => New_List ( @@ -10455,35 +10456,35 @@ package body Exp_Ch9 is if Check_Guard then Append_To (Delay_Alt, Make_Assignment_Statement (Loc, - Name => New_Reference_To (Guard_Open, Loc), + Name => New_Reference_To (Guard_Open, Loc), Expression => New_Reference_To (Standard_True, Loc))); end if; if Present (Condition (Alt)) then Delay_Alt := New_List ( Make_Implicit_If_Statement (N, - Condition => Condition (Alt), + Condition => Condition (Alt), Then_Statements => Delay_Alt)); end if; Append_List (Delay_Alt, Delay_List); + Ensure_Statement_Present (Dloc, Alt); + -- If the delay alternative has a statement part, add choice to the -- case statements for delays. - if Present (Statements (Alt)) then + if not Is_Empty_List (Statements (Alt)) then if Delay_Count = 1 then Append_List (Statements (Alt), Delay_Alt_List); else - Choices := New_List ( - Make_Integer_Literal (Loc, Index)); - Append_To (Delay_Alt_List, Make_Case_Statement_Alternative (Loc, - Discrete_Choices => Choices, - Statements => Statements (Alt))); + Discrete_Choices => New_List ( + Make_Integer_Literal (Loc, Index)), + Statements => Statements (Alt))); end if; elsif Delay_Count = 1 then @@ -10588,36 +10589,30 @@ package body Exp_Ch9 is -- If a guard is statically known to be false, the entry can simply -- be omitted from the accept list. - Q := + Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Qnam, - Object_Definition => - New_Reference_To (RTE (RE_Accept_List), Loc), - Aliased_Present => True, - - Expression => + Object_Definition => New_Reference_To (RTE (RE_Accept_List), Loc), + Aliased_Present => True, + Expression => Make_Qualified_Expression (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Accept_List), Loc), - Expression => - Make_Aggregate (Loc, Expressions => Accept_List))); - - Append (Q, Decls); + Expression => + Make_Aggregate (Loc, Expressions => Accept_List)))); -- Then we declare the variable that holds the index for the accept -- that will be selected for service: -- Xnn : Select_Index; - X := + Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Xnam, Object_Definition => New_Reference_To (RTE (RE_Select_Index), Loc), Expression => - New_Reference_To (RTE (RE_No_Rendezvous), Loc)); - - Append (X, Decls); + New_Reference_To (RTE (RE_No_Rendezvous), Loc))); -- After this follow procedure declarations for each accept body @@ -10723,7 +10718,7 @@ package body Exp_Ch9 is Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => D, - Object_Definition => + Object_Definition => New_Reference_To (Standard_Duration, Loc))); Append_To (Decls, @@ -10839,7 +10834,7 @@ package body Exp_Ch9 is Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => Choices, - Statements => Alt_Stats)); + Statements => Alt_Stats)); -- We make use of the fact that Accept_Index is an integer type, and -- generate successive literals for entries for each accept. Only those @@ -10884,7 +10879,6 @@ package body Exp_Ch9 is Alternatives => Alt_List)); Append_List (Trailing_List, Accept_Case); - Append (End_Lab, Accept_Case); Append_List (Body_List, Decls); -- Construct case statement for trailing statements of delay @@ -10957,7 +10951,7 @@ package body Exp_Ch9 is end if; Stmt := Make_Assignment_Statement (Loc, - Name => New_Reference_To (D, Loc), + Name => New_Reference_To (D, Loc), Expression => Conv); -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) @@ -10965,9 +10959,7 @@ package body Exp_Ch9 is Parms := Parameter_Associations (Select_Call); Parm := First (Parms); - while Present (Parm) - and then Parm /= Select_Mode - loop + while Present (Parm) and then Parm /= Select_Mode loop Next (Parm); end loop; @@ -10997,10 +10989,10 @@ package body Exp_Ch9 is if Check_Guard then Stmt := Make_Implicit_If_Statement (N, - Condition => New_Reference_To (Guard_Open, Loc), - Then_Statements => - New_List (New_Copy_Tree (Stmt), - New_Copy_Tree (Select_Call)), + Condition => New_Reference_To (Guard_Open, Loc), + Then_Statements => New_List ( + New_Copy_Tree (Stmt), + New_Copy_Tree (Select_Call)), Else_Statements => Accept_Or_Raise); Rewrite (Select_Call, Stmt); else @@ -11020,17 +11012,15 @@ package body Exp_Ch9 is Append (Cases, Stats); end; end if; + Append (End_Lab, Stats); -- Replace accept statement with appropriate block - Block := + Rewrite (N, Make_Block_Statement (Loc, - Declarations => Decls, + Declarations => Decls, Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stats)); - - Rewrite (N, Block); + Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); Analyze (N); -- Note: have to worry more about abort deferral in above code ??? @@ -11783,11 +11773,11 @@ package body Exp_Ch9 is -- T.E; -- S1; -- or - -- Delay D; + -- delay D; -- S2; -- end select; - -- is expanded as follow: + -- is expanded as follows: -- 1) When T.E is a task entry_call; @@ -11888,14 +11878,16 @@ package body Exp_Ch9 is Call_Ent : Entity_Id; Conc_Typ_Stmts : List_Id; Concval : Node_Id; + D_Alt : constant Node_Id := Delay_Alternative (N); D_Conv : Node_Id; D_Disc : Node_Id; - D_Stat : Node_Id; + D_Stat : Node_Id := Delay_Statement (D_Alt); D_Stats : List_Id; D_Type : Entity_Id; Decls : List_Id; Dummy : Node_Id; - E_Call : Node_Id; + E_Alt : constant Node_Id := Entry_Call_Alternative (N); + E_Call : Node_Id := Entry_Call_Statement (E_Alt); E_Stats : List_Id; Ename : Node_Id; Formals : List_Id; @@ -11926,17 +11918,16 @@ package body Exp_Ch9 is return; end if; - E_Call := Entry_Call_Statement (Entry_Call_Alternative (N)); - D_Stat := Delay_Statement (Delay_Alternative (N)); + Process_Statements_For_Controlled_Objects (E_Alt); + Process_Statements_For_Controlled_Objects (D_Alt); - Process_Statements_For_Controlled_Objects (Entry_Call_Alternative (N)); - Process_Statements_For_Controlled_Objects (Delay_Alternative (N)); + Ensure_Statement_Present (Sloc (D_Stat), D_Alt); -- Retrieve E_Stats and D_Stats now because the finalization machinery -- may wrap them in blocks. - E_Stats := Statements (Entry_Call_Alternative (N)); - D_Stats := Statements (Delay_Alternative (N)); + E_Stats := Statements (E_Alt); + D_Stats := Statements (D_Alt); -- The arguments in the call may require dynamic allocation, and the -- call statement may have been transformed into a block. The block @@ -12134,7 +12125,7 @@ package body Exp_Ch9 is if Present (Unpack) then Append_To (Conc_Typ_Stmts, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Or_Else (Loc, @@ -12171,7 +12162,7 @@ package body Exp_Ch9 is N_Stats := Copy_Separate_List (E_Stats); Prepend_To (N_Stats, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Or_Else (Loc, @@ -12199,7 +12190,7 @@ package body Exp_Ch9 is Then_Statements => New_List (E_Call))); Append_To (Conc_Typ_Stmts, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => New_Reference_To (B, Loc), Then_Statements => N_Stats, Else_Statements => D_Stats)); @@ -12219,7 +12210,7 @@ package body Exp_Ch9 is -- end if; Append_To (Stmts, - Make_If_Statement (Loc, + Make_Implicit_If_Statement (N, Condition => Make_Op_Eq (Loc, Left_Opnd => New_Reference_To (K, Loc), @@ -13955,13 +13946,10 @@ package body Exp_Ch9 is -- will allocate an array to hold the string names of task entries. if not Restricted_Profile then - if Has_Entries (Ttyp) - and then Entry_Names_OK - then - Append_To (Args, New_Reference_To (Standard_True, Loc)); - else - Append_To (Args, New_Reference_To (Standard_False, Loc)); - end if; + Append_To (Args, + New_Reference_To + (Boolean_Literals (Has_Entries (Ttyp) and then Entry_Names_OK), + Loc)); end if; if Restricted_Profile then diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index ac722d7876f..0290168ff01 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2012, 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- -- @@ -411,14 +411,6 @@ package Exp_Dbug is -- Conversion between Entities and External Names -- ---------------------------------------------------- - No_Dollar_In_Label : constant Boolean := True; - -- True iff the target does not allow dollar signs ("$") in external names - -- ??? We want to migrate all platforms to use the same convention. As a - -- first step, we force this constant to always be True. This constant will - -- eventually be deleted after we have verified that the migration does not - -- cause any unforeseen adverse impact. We chose "__" because it is - -- supported on all platforms, which is not the case of "$". - procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index fd175bd02c3..f2482826356 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -803,6 +803,11 @@ package body Exp_Disp is Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node); Set_Etype (Subp_Typ, Res_Typ); Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp)); + Set_Convention (Subp_Typ, Convention (Subp)); + + -- Notify gigi that the designated type is a dispatching primitive + + Set_Is_Dispatch_Table_Entity (Subp_Typ); -- Create a new list of parameters which is a copy of the old formal -- list including the creation of a new set of matching entities. @@ -1850,6 +1855,7 @@ package body Exp_Disp is Thunk_Id := Make_Temporary (Loc, 'T'); Set_Is_Thunk (Thunk_Id); + Set_Convention (Thunk_Id, Convention (Prim)); -- Procedure case @@ -5771,7 +5777,7 @@ package body Exp_Disp is Prefix => New_Reference_To (TSD, Loc), Attribute_Name => Name_Address)); - -- Stage 2: Initialize the table of primitive operations + -- Stage 2: Initialize the table of user-defined primitive operations Prim_Ops_Aggr_List := New_List; @@ -6249,12 +6255,6 @@ package body Exp_Disp is Elmt : Elmt_Id; begin - -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have - -- the decoration required by the backend - - Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr)); - Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr)); - -- Object declarations Elmt := First_Elmt (DT_Decl); @@ -7131,6 +7131,15 @@ package body Exp_Disp is Set_Ekind (DT_Ptr, E_Variable); Set_Related_Type (DT_Ptr, Typ); + -- Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have + -- the decoration required by the backend. + + -- Odd comment, the back end cannot require anything not properly + -- documented in einfo! ??? + + Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr)); + Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr)); + -- For CPP types there is no need to build the dispatch tables since -- they are imported from the C++ side. If the CPP type has an IP then -- we declare now the variable that will store the copy of the C++ tag. @@ -8468,8 +8477,9 @@ package body Exp_Disp is Set_Init_Proc (Typ, Init); Set_Is_Imported (Init); + Set_Is_Constructor (Init); Set_Interface_Name (Init, Interface_Name (E)); - Set_Convention (Init, Convention_C); + Set_Convention (Init, Convention_CPP); Set_Is_Public (Init); Set_Has_Completion (Init); end if; @@ -8562,8 +8572,9 @@ package body Exp_Disp is Parameter_Specifications => Parms)); Set_Is_Imported (Constructor_Id); + Set_Is_Constructor (Constructor_Id); Set_Interface_Name (Constructor_Id, Interface_Name (E)); - Set_Convention (Constructor_Id, Convention_C); + Set_Convention (Constructor_Id, Convention_CPP); Set_Is_Public (Constructor_Id); Set_Has_Completion (Constructor_Id); @@ -8849,7 +8860,8 @@ package body Exp_Disp is -- If the DTC_Entity attribute is already set we can also output -- the name of the interface covered by this primitive (if any). - if Present (DTC_Entity (Alias (Prim))) + if Ekind_In (Alias (Prim), E_Function, E_Procedure) + and then Present (DTC_Entity (Alias (Prim))) and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) then Write_Str (" from interface "); diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 73befd16742..0d9ed4ee19d 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -543,6 +543,41 @@ package body Exp_Pakd is -- array type on the fly). Such actions are inserted into the tree -- directly using Insert_Action. + function Byte_Swap (N : Node_Id) return Node_Id; + -- Wrap N in a call to a byte swapping function, with appropriate type + -- conversions. + + --------------- + -- Byte_Swap -- + --------------- + + function Byte_Swap (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + T : constant Entity_Id := Etype (N); + Swap_RE : RE_Id; + Swap_F : Entity_Id; + + begin + pragma Assert (Esize (T) > 8); + + if Esize (T) <= 16 then + Swap_RE := RE_Bswap_16; + elsif Esize (T) <= 32 then + Swap_RE := RE_Bswap_32; + else pragma Assert (Esize (T) <= 64); + Swap_RE := RE_Bswap_64; + end if; + + Swap_F := RTE (Swap_RE); + + return + Unchecked_Convert_To (T, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Swap_F, Loc), + Parameter_Associations => + New_List (Unchecked_Convert_To (Etype (Swap_F), N)))); + end Byte_Swap; + ------------------------------ -- Compute_Linear_Subscript -- ------------------------------ @@ -1304,6 +1339,12 @@ package body Exp_Pakd is -- contains the value. Otherwise Rhs_Val_Known is set False, and -- the Rhs_Val is undefined. + Require_Byte_Swapping : Boolean := False; + -- True if byte swapping required, for the Reverse_Storage_Order case + -- when the packed array is a free-standing object. (If it is part + -- of a composite type, and therefore potentially not aligned on a byte + -- boundary, the swapping is done by the back-end). + function Get_Shift return Node_Id; -- Function used to get the value of Shift, making sure that it -- gets duplicated if the function is called more than once. @@ -1415,6 +1456,11 @@ package body Exp_Pakd is -- Obj := atyp!((Obj and Mask1) or (shift_left (rhs, Shift))) + -- or in the case of a freestanding Reverse_Storage_Order object, + + -- Obj := Swap (atyp!((Swap (Obj) and Mask1) + -- or (shift_left (rhs, Shift)))) + -- where Mask1 is obtained by shifting Cmask left Shift bits -- and then complementing the result. @@ -1485,6 +1531,14 @@ package body Exp_Pakd is Set_Etype (Obj, T); Set_Etype (New_Lhs, T); Set_Etype (New_Rhs, T); + + if Reverse_Storage_Order (Base_Type (Atyp)) + and then Esize (T) > 8 + and then not In_Reverse_Storage_Order_Object (Obj) + then + Require_Byte_Swapping := True; + New_Rhs := Byte_Swap (New_Rhs); + end if; end; -- First we deal with the "and" @@ -1593,8 +1647,7 @@ package body Exp_Pakd is -- Note that Rhs_Val has already been normalized to -- be an unsigned value with the proper number of bits. - Rhs := - Make_Integer_Literal (Loc, Rhs_Val); + Rhs := Make_Integer_Literal (Loc, Rhs_Val); -- Otherwise we need an unchecked conversion @@ -1616,6 +1669,11 @@ package body Exp_Pakd is end; end if; + if Require_Byte_Swapping then + Set_Etype (New_Rhs, Etype (Obj)); + New_Rhs := Byte_Swap (New_Rhs); + end if; + -- Now do the rewrite Rewrite (N, @@ -1978,6 +2036,17 @@ package body Exp_Pakd is Lit := Make_Integer_Literal (Loc, Cmask); Set_Print_In_Hex (Lit); + -- Byte swapping required for the Reverse_Storage_Order case, but + -- only for a free-standing object (see note on Require_Byte_Swapping + -- in Expand_Bit_Packed_Element_Set). + + if Reverse_Storage_Order (Atyp) + and then Esize (Atyp) > 8 + and then not In_Reverse_Storage_Order_Object (Obj) + then + Obj := Byte_Swap (Obj); + end if; + -- We generate a shift right to position the field, followed by a -- masking operation to extract the bit field, and we finally do an -- unchecked conversion to convert the result to the required target. @@ -2727,7 +2796,7 @@ package body Exp_Pakd is -- We also have to adjust if the storage order is reversed - if Bytes_Big_Endian xor In_Reverse_Storage_Order_Record (Obj) then + if Bytes_Big_Endian xor Reverse_Storage_Order (Base_Type (Atyp)) then Shift := Make_Op_Subtract (Loc, Left_Opnd => Make_Integer_Literal (Loc, Osiz - Csiz), diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index a732da215c4..f7b9d450128 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3818,20 +3818,20 @@ package body Exp_Util is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; Insert_Actions (Assoc_Node, Ins_Actions); Scope_Suppress := Svg; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Insert_Actions (Assoc_Node, Ins_Actions); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Insert_Actions; @@ -6272,9 +6272,9 @@ package body Exp_Util is Name_Req : Boolean := False; Variable_Ref : Boolean := False) is - Loc : constant Source_Ptr := Sloc (Exp); - Exp_Type : constant Entity_Id := Etype (Exp); - Svg_Suppress : constant Suppress_Array := Scope_Suppress; + Loc : constant Source_Ptr := Sloc (Exp); + Exp_Type : constant Entity_Id := Etype (Exp); + Svg_Suppress : constant Suppress_Record := Scope_Suppress; Def_Id : Entity_Id; E : Node_Id; New_Exp : Node_Id; @@ -6705,7 +6705,7 @@ package body Exp_Util is -- All this must not have any checks - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; -- If it is a scalar type and we need to capture the value, just make -- a copy. Likewise for a function call, an attribute reference, an diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5464462a229..ad9f06a0675 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -42,7 +42,7 @@ with Nmake; use Nmake; with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; -with Rtsfind; use Rtsfind; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; @@ -88,6 +88,14 @@ package body Freeze is -- Apply legality checks to address clauses for object declarations, -- at the point the object is frozen. + procedure Check_Component_Storage_Order + (Encl_Type : Entity_Id; + Comp : Entity_Id); + -- For an Encl_Type that has a Scalar_Storage_Order attribute definition + -- clause, verify that the component type is compatible. For arrays, + -- Comp is Empty; for records, it is the entity of the component under + -- consideration. + procedure Check_Strict_Alignment (E : Entity_Id); -- E is a base type. If E is tagged or has a component that is aliased -- or tagged or contains something this is aliased or tagged, set @@ -1008,6 +1016,76 @@ package body Freeze is Set_Size_Known_At_Compile_Time (T, Size_Known (T)); end Check_Compile_Time_Size; + ----------------------------------- + -- Check_Component_Storage_Order -- + ----------------------------------- + + procedure Check_Component_Storage_Order + (Encl_Type : Entity_Id; + Comp : Entity_Id) + is + Comp_Type : Entity_Id; + Comp_Def : Node_Id; + Err_Node : Node_Id; + ADC : Node_Id; + + Comp_Byte_Aligned : Boolean; + -- Set True for the record case, when Comp starts on a byte boundary + -- (in which case it is allowed to have different storage order). + + begin + -- Record case + + if Present (Comp) then + Err_Node := Comp; + Comp_Type := Etype (Comp); + Comp_Def := Component_Definition (Parent (Comp)); + + Comp_Byte_Aligned := + Present (Component_Clause (Comp)) + and then Normalized_First_Bit (Comp) mod System_Storage_Unit = 0; + + -- Array case + + else + Err_Node := Encl_Type; + Comp_Type := Component_Type (Encl_Type); + Comp_Def := Component_Definition + (Type_Definition (Declaration_Node (Encl_Type))); + + Comp_Byte_Aligned := False; + end if; + + -- Note: the Reverse_Storage_Order flag is set on the base type, but + -- the attribute definition clause is attached to the first subtype. + + Comp_Type := Base_Type (Comp_Type); + ADC := Get_Attribute_Definition_Clause + (First_Subtype (Comp_Type), + Attribute_Scalar_Storage_Order); + + if Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then + if No (ADC) then + Error_Msg_N ("nested composite must have explicit scalar " + & "storage order", Err_Node); + + elsif (Reverse_Storage_Order (Encl_Type) + /= + Reverse_Storage_Order (Etype (Comp_Type))) + and then not Comp_Byte_Aligned + then + Error_Msg_N + ("type of non-byte-aligned component must have same scalar " + & "storage order as enclosing composite", Err_Node); + end if; + + elsif Aliased_Present (Comp_Def) then + Error_Msg_N + ("aliased component not permitted for type with " + & "explicit Scalar_Storage_Order", Err_Node); + end if; + end Check_Component_Storage_Order; + ----------------------------- -- Check_Debug_Info_Needed -- ----------------------------- @@ -1814,6 +1892,11 @@ package body Freeze is Junk : Boolean; pragma Warnings (Off, Junk); + Rec_Pushed : Boolean := False; + -- Set True if the record type scope Rec has been pushed on the scope + -- stack. Needed for the analysis of delayed aspects specified to the + -- components of Rec. + Unplaced_Component : Boolean := False; -- Set True if we find at least one component with no component -- clause (used to warn about useless Pack pragmas). @@ -1901,17 +1984,56 @@ package body Freeze is -- Start of processing for Freeze_Record_Type begin + -- Deal with delayed aspect specifications for components. The + -- analysis of the aspect is required to be delayed to the freeze + -- point, thus we analyze the pragma or attribute definition + -- clause in the tree at this point. We also analyze the aspect + -- specification node at the freeze point when the aspect doesn't + -- correspond to pragma/attribute definition clause. + + Comp := First_Entity (Rec); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Has_Delayed_Aspects (Comp) + then + if not Rec_Pushed then + Push_Scope (Rec); + Rec_Pushed := True; + + -- The visibility to the discriminants must be restored in + -- order to properly analyze the aspects. + + if Has_Discriminants (Rec) then + Install_Discriminants (Rec); + end if; + end if; + + Analyze_Aspects_At_Freeze_Point (Comp); + end if; + + Next_Entity (Comp); + end loop; + + -- Pop the scope if Rec scope has been pushed on the scope stack + -- during the delayed aspect analysis process. + + if Rec_Pushed then + if Has_Discriminants (Rec) then + Uninstall_Discriminants (Rec); + end if; + + Pop_Scope; + end if; + -- Freeze components and embedded subtypes Comp := First_Entity (Rec); Prev := Empty; while Present (Comp) loop - -- First handle the component case + -- Handle the component and discriminant case - if Ekind (Comp) = E_Component - or else Ekind (Comp) = E_Discriminant - then + if Ekind_In (Comp, E_Component, E_Discriminant) then declare CC : constant Node_Id := Component_Clause (Comp); @@ -2158,12 +2280,21 @@ package body Freeze is end if; -- Warn if there is a Scalar_Storage_Order but no component clause + -- (or pragma Pack). - if not Placed_Component then + if not (Placed_Component or else Is_Packed (Rec)) then Error_Msg_N ("?scalar storage order specified but no component clause", ADC); end if; + + -- Check attribute on component types + + Comp := First_Component (Rec); + while Present (Comp) loop + Check_Component_Storage_Order (Rec, Comp); + Next_Component (Comp); + end loop; end if; -- Deal with Bit_Order aspect specifying a non-default bit order @@ -2171,7 +2302,7 @@ package body Freeze is ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); if Present (ADC) and then Base_Type (Rec) = Rec then - if not Placed_Component then + if not (Placed_Component or else Is_Packed (Rec)) then Error_Msg_N ("?bit order specification has no effect", ADC); Error_Msg_N ("\?since no component clauses were specified", ADC); @@ -2895,6 +3026,23 @@ package body Freeze is end if; end if; end; + + -- Pre/post conditions are implemented through a subprogram in + -- the corresponding body, and therefore are not checked on an + -- imported subprogram for which the body is not available. + + -- Could consider generating a wrapper to take care of this??? + + if Is_Subprogram (E) + and then Is_Imported (E) + and then Present (Contract (E)) + and then Present (Spec_PPC_List (Contract (E))) + then + Error_Msg_NE ("pre/post conditions on imported subprogram " + & "are not enforced?", + E, Spec_PPC_List (Contract (E))); + end if; + end if; -- Must freeze its parent first if it is a derived subprogram @@ -3286,11 +3434,22 @@ package body Freeze is end if; end if; + -- A subtype inherits all the type-related representation aspects + -- from its parents (RM 13.1(8)). + + Inherit_Aspects_At_Freeze_Point (E); + -- For a derived type, freeze its parent type first (RM 13.14(15)) elsif Is_Derived_Type (E) then Freeze_And_Append (Etype (E), N, Result); Freeze_And_Append (First_Subtype (Etype (E)), N, Result); + + -- A derived type inherits each type-related representation aspect + -- of its parent type that was directly specified before the + -- declaration of the derived type (RM 13.1(15)). + + Inherit_Aspects_At_Freeze_Point (E); end if; -- For array type, freeze index types and component type first @@ -3628,6 +3787,14 @@ package body Freeze is end if; end if; + -- Check for scalar storage order + + if Present (Get_Attribute_Definition_Clause + (E, Attribute_Scalar_Storage_Order)) + then + Check_Component_Storage_Order (E, Empty); + end if; + -- Processing that is done only for subtypes else @@ -3737,11 +3904,19 @@ package body Freeze is return Result; end if; - -- If the Class_Wide_Type is an Itype (when type is the anonymous - -- parent of a derived type) and it is a library-level entity, - -- generate an itype reference for it. Otherwise, its first - -- explicit reference may be in an inner scope, which will be - -- rejected by the back-end. + -- The equivalent type associated with a class-wide subtype needs + -- to be frozen to ensure that its layout is done. + + if Ekind (E) = E_Class_Wide_Subtype + and then Present (Equivalent_Type (E)) + then + Freeze_And_Append (Equivalent_Type (E), N, Result); + end if; + + -- Generate an itype reference for a library-level class-wide type + -- at the freeze point. Otherwise the first explicit reference to + -- the type may appear in an inner scope which will be rejected by + -- the back-end. if Is_Itype (E) and then Is_Compilation_Unit (Scope (E)) @@ -3751,28 +3926,29 @@ package body Freeze is begin Set_Itype (Ref, E); - Add_To_Result (Ref); - end; - end if; - -- The equivalent type associated with a class-wide subtype needs - -- to be frozen to ensure that its layout is done. + -- From a gigi point of view, a class-wide subtype derives + -- from its record equivalent type. As a result, the itype + -- reference must appear after the freeze node of the + -- equivalent type or gigi will reject the reference. - if Ekind (E) = E_Class_Wide_Subtype - and then Present (Equivalent_Type (E)) - then - Freeze_And_Append (Equivalent_Type (E), N, Result); + if Ekind (E) = E_Class_Wide_Subtype + and then Present (Equivalent_Type (E)) + then + Insert_After (Freeze_Node (Equivalent_Type (E)), Ref); + else + Add_To_Result (Ref); + end if; + end; end if; - -- For a record (sub)type, freeze all the component types (RM - -- 13.14(15). We test for E_Record_(sub)Type here, rather than using - -- Is_Record_Type, because we don't want to attempt the freeze for - -- the case of a private type with record extension (we will do that - -- later when the full type is frozen). + -- For a record type or record subtype, freeze all component types + -- (RM 13.14(15)). We test for E_Record_(sub)Type here, rather than + -- using Is_Record_Type, because we don't want to attempt the freeze + -- for the case of a private type with record extension (we will do + -- that later when the full type is frozen). - elsif Ekind (E) = E_Record_Type - or else Ekind (E) = E_Record_Subtype - then + elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) then Freeze_Record_Type (E); -- For a concurrent type, freeze corresponding record type. This @@ -4036,13 +4212,17 @@ package body Freeze is Check_Suspicious_Modulus (E); end if; - elsif Is_Access_Type (E) then - + elsif Is_Access_Type (E) + and then not Is_Access_Subprogram_Type (E) + then -- If a pragma Default_Storage_Pool applies, and this type has no -- Storage_Pool or Storage_Size clause (which must have occurred -- before the freezing point), then use the default. This applies -- only to base types. + -- None of this applies to access to subprograms, for which there + -- are clearly no pools. + if Present (Default_Pool) and then Is_Base_Type (E) and then not Has_Storage_Size_Clause (E) @@ -4697,16 +4877,17 @@ package body Freeze is else Id := Defining_Unit_Name (Specification (P)); + -- Following complex conditional could use comments ??? + if Nkind (Id) = N_Defining_Identifier - and then (Is_Init_Proc (Id) or else - Is_TSS (Id, TSS_Stream_Input) or else - Is_TSS (Id, TSS_Stream_Output) or else - Is_TSS (Id, TSS_Stream_Read) or else - Is_TSS (Id, TSS_Stream_Write) or else - Nkind (Original_Node (P)) = - N_Subprogram_Renaming_Declaration or else - Nkind (Original_Node (P)) = - N_Expression_Function) + and then (Is_Init_Proc (Id) + or else Is_TSS (Id, TSS_Stream_Input) + or else Is_TSS (Id, TSS_Stream_Output) + or else Is_TSS (Id, TSS_Stream_Read) + or else Is_TSS (Id, TSS_Stream_Write) + or else Nkind_In (Original_Node (P), + N_Subprogram_Renaming_Declaration, + N_Expression_Function)) then return True; else @@ -5122,7 +5303,7 @@ package body Freeze is if not Is_Compilation_Unit (Current_Scope) and then (Is_Record_Type (Scope (Current_Scope)) or else Nkind (Parent (Current_Scope)) = - N_Quantified_Expression) + N_Quantified_Expression) then Pos := Pos - 1; end if; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 35e7d9e769b..749e94875d7 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -283,6 +283,12 @@ begin if Config_Pragmas /= Error_List and then Operating_Mode /= Check_Syntax + + -- Do not attempt to process deferred configuration pragmas if the main + -- unit failed to load, to avoid cascaded inconsistencies that can lead + -- to a compiler crash. + + and then not Fatal_Error (Main_Unit) then -- Pragmas that require some semantic activity, such as -- Interrupt_State, cannot be processed until the main unit diff --git a/gcc/ada/g-bytswa.adb b/gcc/ada/g-bytswa.adb index 329c078fff4..9628bbc5da9 100644 --- a/gcc/ada/g-bytswa.adb +++ b/gcc/ada/g-bytswa.adb @@ -34,20 +34,9 @@ with Ada.Unchecked_Conversion; use Ada; -package body GNAT.Byte_Swapping is - - type U16 is mod 2**16; - type U32 is mod 2**32; - type U64 is mod 2**64; - - function Bswap_16 (X : U16) return U16 is (X / 256 or X * 256); - -- The above is an idiom recognized by GCC - - function Bswap_32 (X : U32) return U32; - pragma Import (Intrinsic, Bswap_32, "__builtin_bswap32"); +with System.Byte_Swapping; use System.Byte_Swapping; - function Bswap_64 (X : U64) return U64; - pragma Import (Intrinsic, Bswap_64, "__builtin_bswap64"); +package body GNAT.Byte_Swapping is -------------- -- Swapped2 -- @@ -56,9 +45,6 @@ package body GNAT.Byte_Swapping is function Swapped2 (Input : Item) return Item is function As_U16 is new Unchecked_Conversion (Item, U16); function As_Item is new Unchecked_Conversion (U16, Item); - - function Bswap_16 (X : U16) return U16 is (X / 256 or X * 256); - -- ??? Need to have function local here to allow inlining pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 2, "storage size must be 2 bytes"); begin @@ -123,4 +109,5 @@ package body GNAT.Byte_Swapping is begin X := Bswap_64 (X); end Swap8; + end GNAT.Byte_Swapping; diff --git a/gcc/ada/g-bytswa.ads b/gcc/ada/g-bytswa.ads index 7e0dd8fc46d..35656fc8045 100644 --- a/gcc/ada/g-bytswa.ads +++ b/gcc/ada/g-bytswa.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2011, AdaCore -- +-- Copyright (C) 2006-2012, AdaCore -- -- -- -- 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- -- diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index ef7ce9e3dbd..5ee63d9896f 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -668,9 +668,8 @@ package body GNAT.Debug_Pools is -- terms of wasted memory). To do that, all we should have to do it to -- set the size of this array to the page size. See mprotect(). - P : Ptr; - Current : Byte_Count; + P : Ptr; Trace : Traceback_Htable_Elem_Ptr; begin @@ -693,7 +692,9 @@ package body GNAT.Debug_Pools is -- Use standard (i.e. through malloc) allocations. This automatically -- raises Storage_Error if needed. We also try once more to physically -- release memory, so that even marked blocks, in the advanced scanning, - -- are freed. + -- are freed. Note that we do not initialize the storage array since it + -- is not necessary to do so (however this will cause bogus valgrind + -- warnings, which should simply be ignored). begin P := new Local_Storage_Array; diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb index d68db87a9c4..bf579f57da4 100644 --- a/gcc/ada/g-dirope.adb +++ b/gcc/ada/g-dirope.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2010, AdaCore -- +-- Copyright (C) 1998-2012, AdaCore -- -- -- -- 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- -- @@ -604,12 +604,8 @@ package body GNAT.Directory_Operations is procedure Make_Dir (Dir_Name : Dir_Name_Str) is C_Dir_Name : constant String := Dir_Name & ASCII.NUL; - - function mkdir (Dir_Name : String) return Integer; - pragma Import (C, mkdir, "__gnat_mkdir"); - begin - if mkdir (C_Dir_Name) /= 0 then + if CRTL.mkdir (C_Dir_Name, Unspecified) /= 0 then raise Directory_Error; end if; end Make_Dir; diff --git a/gcc/ada/g-sercom-linux.adb b/gcc/ada/g-sercom-linux.adb index db1aec76553..d485c1b75e3 100644 --- a/gcc/ada/g-sercom-linux.adb +++ b/gcc/ada/g-sercom-linux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2010, AdaCore -- +-- Copyright (C) 2007-2012, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -38,11 +38,14 @@ with Ada.Unchecked_Deallocation; with System; use System; with System.Communication; use System.Communication; with System.CRTL; use System.CRTL; +with System.OS_Constants; with GNAT.OS_Lib; use GNAT.OS_Lib; package body GNAT.Serial_Communications is + package OSC renames System.OS_Constants; + use type Interfaces.C.unsigned; type Port_Data is new int; @@ -54,43 +57,26 @@ package body GNAT.Serial_Communications is function fcntl (fd : int; cmd : int; value : int) return int; pragma Import (C, fcntl, "fcntl"); - O_RDWR : constant := 8#02#; - O_NOCTTY : constant := 8#0400#; - O_NDELAY : constant := 8#04000#; - FNDELAY : constant := O_NDELAY; - F_SETFL : constant := 4; - TCSANOW : constant := 0; - TCIFLUSH : constant := 0; - CLOCAL : constant := 8#04000#; - CREAD : constant := 8#0200#; - CSTOPB : constant := 8#0100#; - CRTSCTS : constant := 8#020000000000#; - PARENB : constant := 8#00400#; - PARODD : constant := 8#01000#; - - -- c_cc indexes - - VTIME : constant := 5; - VMIN : constant := 6; - C_Data_Rate : constant array (Data_Rate) of unsigned := - (B1200 => 8#000011#, - B2400 => 8#000013#, - B4800 => 8#000014#, - B9600 => 8#000015#, - B19200 => 8#000016#, - B38400 => 8#000017#, - B57600 => 8#010001#, - B115200 => 8#010002#); + (B1200 => OSC.B1200, + B2400 => OSC.B2400, + B4800 => OSC.B4800, + B9600 => OSC.B9600, + B19200 => OSC.B19200, + B38400 => OSC.B38400, + B57600 => OSC.B57600, + B115200 => OSC.B115200); C_Bits : constant array (Data_Bits) of unsigned := - (CS7 => 8#040#, CS8 => 8#060#); + (CS7 => OSC.CS7, CS8 => OSC.CS8); C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned := - (One => 0, Two => CSTOPB); + (One => 0, Two => OSC.CSTOPB); C_Parity : constant array (Parity_Check) of unsigned := - (None => 0, Odd => PARENB or PARODD, Even => PARENB); + (None => 0, + Odd => OSC.PARENB or OSC.PARODD, + Even => OSC.PARENB); procedure Raise_Error (Message : String; Error : Integer := Errno); pragma No_Return (Raise_Error); @@ -114,6 +100,8 @@ package body GNAT.Serial_Communications is (Port : out Serial_Port; Name : Port_Name) is + use OSC; + C_Name : constant String := String (Name) & ASCII.NUL; Res : int; @@ -184,8 +172,12 @@ package body GNAT.Serial_Communications is Stop_Bits : Stop_Bits_Number := One; Parity : Parity_Check := None; Block : Boolean := True; + Local : Boolean := True; + Flow : Flow_Control := None; Timeout : Duration := 10.0) is + use OSC; + type termios is record c_iflag : unsigned; c_oflag : unsigned; @@ -229,12 +221,24 @@ package body GNAT.Serial_Communications is or C_Bits (Bits) or C_Stop_Bits (Stop_Bits) or C_Parity (Parity) - or CLOCAL - or CREAD - or CRTSCTS; - Current.c_lflag := 0; + or CREAD; Current.c_iflag := 0; + Current.c_lflag := 0; Current.c_oflag := 0; + + if Local then + Current.c_cflag := Current.c_cflag or CLOCAL; + end if; + + case Flow is + when None => + null; + when RTS_CTS => + Current.c_cflag := Current.c_cflag or CRTSCTS; + when Xon_Xoff => + Current.c_iflag := Current.c_iflag or IXON; + end case; + Current.c_ispeed := Data_Rate_Value (Rate); Current.c_ospeed := Data_Rate_Value (Rate); Current.c_cc (VMIN) := char'Val (0); diff --git a/gcc/ada/g-sercom-mingw.adb b/gcc/ada/g-sercom-mingw.adb index df3754b685a..afc4d4773be 100644 --- a/gcc/ada/g-sercom-mingw.adb +++ b/gcc/ada/g-sercom-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2010, AdaCore -- +-- Copyright (C) 2007-2012, AdaCore -- -- -- -- 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- -- @@ -37,11 +37,14 @@ with Ada.Streams; use Ada.Streams; with System; use System; with System.Communication; use System.Communication; with System.CRTL; use System.CRTL; +with System.OS_Constants; with System.Win32; use System.Win32; with System.Win32.Ext; use System.Win32.Ext; package body GNAT.Serial_Communications is + package OSC renames System.OS_Constants; + -- Common types type Port_Data is new HANDLE; @@ -175,8 +178,12 @@ package body GNAT.Serial_Communications is Stop_Bits : Stop_Bits_Number := One; Parity : Parity_Check := None; Block : Boolean := True; + Local : Boolean := True; + Flow : Flow_Control := None; Timeout : Duration := 10.0) is + pragma Unreferenced (Local); + Success : BOOL; Com_Time_Out : aliased COMMTIMEOUTS; Com_Settings : aliased DCB; @@ -197,13 +204,26 @@ package body GNAT.Serial_Communications is Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate)); Com_Settings.fParity := 1; Com_Settings.fBinary := Bits1 (System.Win32.TRUE); - Com_Settings.fOutxCtsFlow := 0; Com_Settings.fOutxDsrFlow := 0; Com_Settings.fDsrSensitivity := 0; - Com_Settings.fDtrControl := DTR_CONTROL_DISABLE; - Com_Settings.fOutX := 0; + Com_Settings.fDtrControl := OSC.DTR_CONTROL_ENABLE; Com_Settings.fInX := 0; - Com_Settings.fRtsControl := RTS_CONTROL_DISABLE; + Com_Settings.fRtsControl := OSC.RTS_CONTROL_ENABLE; + + case Flow is + when None => + Com_Settings.fOutX := 0; + Com_Settings.fOutxCtsFlow := 0; + + when RTS_CTS => + Com_Settings.fOutX := 0; + Com_Settings.fOutxCtsFlow := 1; + + when Xon_Xoff => + Com_Settings.fOutX := 1; + Com_Settings.fOutxCtsFlow := 0; + end case; + Com_Settings.fAbortOnError := 0; Com_Settings.ByteSize := BYTE (C_Bits (Bits)); Com_Settings.Parity := BYTE (C_Parity (Parity)); diff --git a/gcc/ada/g-sercom.adb b/gcc/ada/g-sercom.adb index 0df096522f7..c2b511c59c7 100644 --- a/gcc/ada/g-sercom.adb +++ b/gcc/ada/g-sercom.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2010, AdaCore -- +-- Copyright (C) 2007-2012, AdaCore -- -- -- -- 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- -- @@ -82,6 +82,8 @@ package body GNAT.Serial_Communications is Stop_Bits : Stop_Bits_Number := One; Parity : Parity_Check := None; Block : Boolean := True; + Local : Boolean := True; + Flow : Flow_Control := None; Timeout : Duration := 10.0) is begin diff --git a/gcc/ada/g-sercom.ads b/gcc/ada/g-sercom.ads index 5ea1bb2f7c3..573eba280b6 100644 --- a/gcc/ada/g-sercom.ads +++ b/gcc/ada/g-sercom.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007-2010, AdaCore -- +-- Copyright (C) 2007-2012, AdaCore -- -- -- -- 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- -- @@ -62,6 +62,9 @@ package GNAT.Serial_Communications is type Parity_Check is (None, Even, Odd); -- Either no parity check or an even or odd parity + type Flow_Control is (None, RTS_CTS, Xon_Xoff); + -- No flow control, hardware flow control, software flow control + type Serial_Port is new Ada.Streams.Root_Stream_Type with private; procedure Open @@ -77,12 +80,17 @@ package GNAT.Serial_Communications is Stop_Bits : Stop_Bits_Number := One; Parity : Parity_Check := None; Block : Boolean := True; + Local : Boolean := True; + Flow : Flow_Control := None; Timeout : Duration := 10.0); -- The communication port settings. If Block is set then a read call -- will wait for the whole buffer to be filed. If Block is not set then - -- the given Timeout (in seconds) is used. Note that the timeout precision - -- may be limited on some implementation (e.g. on GNU/Linux the maximum - -- precision is a tenth of seconds). + -- the given Timeout (in seconds) is used. If Local is set then modem + -- control lines (in particular DCD) are ignored (not supported on + -- Windows). Flow indicates the flow control type as defined above. + -- + -- Note that the timeout precision may be limited on some implementation + -- (e.g. on GNU/Linux the maximum precision is a tenth of seconds). overriding procedure Read (Port : in out Serial_Port; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index d48065a23f5..ac03f42165e 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2011, AdaCore -- +-- Copyright (C) 2001-2012, AdaCore -- -- -- -- 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- -- @@ -480,9 +480,7 @@ package body GNAT.Sockets is -- no check required. Warnings suppressed because condition -- is known at compile time. - pragma Warnings (Off); if Target_OS = Windows then - pragma Warnings (On); return; @@ -1112,6 +1110,7 @@ package body GNAT.Sockets is Level : Level_Type := Socket_Level; Name : Option_Name) return Option_Type is + use SOSC; use type C.unsigned_char; V8 : aliased Two_Ints; @@ -1144,8 +1143,19 @@ package body GNAT.Sockets is when Send_Timeout | Receive_Timeout => - Len := VT'Size / 8; - Add := VT'Address; + + -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a + -- struct timeval, but on Windows it is a milliseconds count in + -- a DWORD. + + if Target_OS = Windows then + Len := V4'Size / 8; + Add := V4'Address; + + else + Len := VT'Size / 8; + Add := VT'Address; + end if; when Linger | Add_Membership | @@ -1201,7 +1211,21 @@ package body GNAT.Sockets is when Send_Timeout | Receive_Timeout => - Opt.Timeout := To_Duration (VT); + + if Target_OS = Windows then + + -- Timeout is in milliseconds, actual value is 500 ms + + -- returned value (unless it is 0). + + if V4 = 0 then + Opt.Timeout := 0.0; + else + Opt.Timeout := Natural (V4) * 0.001 + 0.500; + end if; + + else + Opt.Timeout := To_Duration (VT); + end if; end case; return Opt; @@ -1705,8 +1729,6 @@ package body GNAT.Sockets is Item : out Ada.Streams.Stream_Element_Array; Last : out Ada.Streams.Stream_Element_Offset) is - pragma Warnings (Off, Stream); - First : Ada.Streams.Stream_Element_Offset := Item'First; Index : Ada.Streams.Stream_Element_Offset := First - 1; Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; @@ -2176,6 +2198,8 @@ package body GNAT.Sockets is Level : Level_Type := Socket_Level; Option : Option_Type) is + use SOSC; + V8 : aliased Two_Ints; V4 : aliased C.int; V1 : aliased C.unsigned_char; @@ -2236,9 +2260,30 @@ package body GNAT.Sockets is when Send_Timeout | Receive_Timeout => - VT := To_Timeval (Option.Timeout); - Len := VT'Size / 8; - Add := VT'Address; + + if Target_OS = Windows then + + -- On Windows, the timeout is a DWORD in milliseconds, and + -- the actual timeout is 500 ms + the given value (unless it + -- is 0). + + V4 := C.int (Option.Timeout / 0.001); + + if V4 > 500 then + V4 := V4 - 500; + + elsif V4 > 0 then + V4 := 1; + end if; + + Len := V4'Size / 8; + Add := V4'Address; + + else + VT := To_Timeval (Option.Timeout); + Len := VT'Size / 8; + Add := VT'Address; + end if; end case; @@ -2261,17 +2306,12 @@ package body GNAT.Sockets is use type C.unsigned_short; begin - -- 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 + -- Big-endian case. No conversion needed. On these platforms, htons() + -- defaults to a null procedure. 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. diff --git a/gcc/ada/g-spitbo.adb b/gcc/ada/g-spitbo.adb index 22677d72695..22677149ee1 100644 --- a/gcc/ada/g-spitbo.adb +++ b/gcc/ada/g-spitbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2010, AdaCore -- +-- Copyright (C) 1998-2012, AdaCore -- -- -- -- 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- -- @@ -305,7 +305,7 @@ package body GNAT.Spitbol is begin if Start > Str'Length then raise Index_Error; - elsif Start + Len > Str'Length then + elsif Start + Len - 1 > Str'Length then raise Length_Error; else return diff --git a/gcc/ada/g-spitbo.ads b/gcc/ada/g-spitbo.ads index 94068f83af0..e97bb62d033 100644 --- a/gcc/ada/g-spitbo.ads +++ b/gcc/ada/g-spitbo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2010, AdaCore -- +-- Copyright (C) 1997-2012, AdaCore -- -- -- -- 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- -- @@ -180,7 +180,7 @@ package GNAT.Spitbol is -- Returns the substring starting at the given character position (which -- is always counted from the start of the string, regardless of bounds, -- e.g. 2 means starting with the second character of the string), and - -- with the length (Len) given. Indexing_Error is raised if the starting + -- with the length (Len) given. Index_Error is raised if the starting -- position is out of range, and Length_Error is raised if Len is too long. function Trim (Str : VString) return VString; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index c9ddd9bfc4d..ba5148abdaa 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1024,7 +1024,7 @@ ada/trans.o : ada/gcc-interface/trans.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ ada/utils.o : ada/gcc-interface/utils.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(TREE_H) $(FLAGS_H) toplev.h $(RTL_H) output.h debug.h convert.h \ $(TARGET_H) $(COMMON_TARGET_H) function.h langhooks.h \ - $(CGRAPH_H) $(DIAGNOSTIC_H) \ + $(CGRAPH_H) $(DIAGNOSTIC_H) $(TIMEVAR_H) \ $(TREE_DUMP_H) $(TREE_INLINE_H) tree-iterator.h \ ada/gcc-interface/ada.h ada/types.h ada/atree.h ada/elists.h ada/namet.h \ ada/nlists.h ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h ada/einfo.h \ @@ -1116,12 +1116,12 @@ ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ - ada/s-htable.adb ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads + ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads ada/alloc.o : ada/alloc.ads ada/system.ads @@ -1193,12 +1193,12 @@ ada/binde.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \ ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \ ada/system.ads ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/widechar.ads + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads ada/binderr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/binderr.ads ada/binderr.adb \ @@ -1216,12 +1216,12 @@ ada/bindgen.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/g-hesora.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \ ada/namet.ads ada/opt.ads ada/osint.ads ada/osint-b.ads ada/output.ads \ ada/rident.ads ada/system.ads ada/s-casuti.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ - ada/unchconv.ads ada/unchdeal.ads + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/bindusg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/bindusg.ads ada/bindusg.adb \ @@ -2348,35 +2348,30 @@ ada/gnat.o : ada/gnat.ads ada/system.ads ada/gnat1drv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ ada/atree.adb ada/back_end.ads ada/casing.ads ada/comperr.ads \ - ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_cg.ads ada/exp_ch6.ads ada/exp_tss.ads \ - ada/expander.ads ada/fmap.ads ada/fname.ads ada/fname-uf.ads \ + ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_cg.ads \ + ada/exp_ch6.ads ada/fmap.ads ada/fname.ads ada/fname-uf.ads \ ada/frontend.ads ada/get_targ.ads ada/gnat.ads ada/g-byorma.ads \ ada/g-hesorg.ads ada/g-table.ads ada/g-table.adb ada/gnat1drv.ads \ ada/gnat1drv.adb ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ - ada/lib-sort.adb ada/lib-util.ads ada/lib-writ.ads ada/lib-xref.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ - ada/osint.ads ada/output.ads ada/par_sco.ads ada/prepcomp.ads \ - ada/put_alfa.ads ada/repinfo.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scos.ads ada/sem.ads ada/sem.adb \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch11.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_prag.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/sinput-l.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-bitops.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_gen.ads \ - ada/tree_io.ads ada/treepr.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/usage.ads ada/validsw.ads ada/widechar.ads + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-util.ads ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads \ + ada/nlists.ads ada/opt.ads ada/osint.ads ada/output.ads ada/par_sco.ads \ + ada/prepcomp.ads ada/put_alfa.ads ada/repinfo.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scos.ads ada/sem.ads \ + ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch8.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_type.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stylesw.ads \ + ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tree_gen.ads ada/tree_io.ads ada/treepr.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/usage.ads \ + ada/validsw.ads ada/widechar.ads ada/gnatbind.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/ali.ads \ @@ -2737,20 +2732,21 @@ ada/par.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/par_sco.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ - ada/fname.ads ada/gnat.ads ada/g-byorma.ads ada/g-hesorg.ads \ - ada/g-hesorg.adb ada/g-htable.ads ada/g-table.ads ada/g-table.adb \ - ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/lib-util.ads ada/lib-util.adb ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/opt.ads ada/osint.ads ada/osint-c.ads \ - ada/output.ads ada/par_sco.ads ada/par_sco.adb ada/put_scos.ads \ - ada/put_scos.adb ada/scans.ads ada/scos.ads ada/scos.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ + ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \ + ada/gnat.ads ada/g-byorma.ads ada/g-hesorg.ads ada/g-hesorg.adb \ + ada/g-htable.ads ada/g-table.ads ada/g-table.adb ada/hostparm.ads \ + ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ + ada/lib-util.ads ada/lib-util.adb ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/opt.ads ada/osint.ads ada/osint-c.ads ada/output.ads \ + ada/par_sco.ads ada/par_sco.adb ada/put_scos.ads ada/put_scos.adb \ + ada/scans.ads ada/scos.ads ada/scos.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/prep.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -3336,23 +3332,24 @@ ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/put_alfa.ads ada/restrict.ads ada/rident.ads \ ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch13.adb ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dim.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_prag.ads \ - ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads ada/warnsw.ads ada/widechar.ads + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ + ada/sem_ch13.ads ada/sem_ch13.adb ada/sem_ch3.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dim.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/validsw.ads ada/warnsw.ads \ + ada/widechar.ads ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -3449,31 +3446,32 @@ ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \ ada/exp_util.adb ada/expander.ads ada/fname.ads ada/fname-uf.ads \ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ - ada/lib.ads ada/lib-load.ads ada/lib-util.ads ada/lib-xref.ads \ - ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ - ada/opt.ads ada/output.ads ada/par_sco.ads ada/put_alfa.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch5.adb ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_ch9.ads ada/sem_dim.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sem_warn.adb ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ + ada/itypes.ads ada/lib.ads ada/lib-load.ads ada/lib-util.ads \ + ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb ada/output.ads \ + ada/par_sco.ads ada/put_alfa.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb \ + ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_case.ads \ + ada/sem_case.adb ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \ + ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch5.adb ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_dim.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -3576,39 +3574,40 @@ ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ - ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \ - ada/csets.ads ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_disp.ads \ - ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ - ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \ - ada/inline.ads ada/itypes.ads ada/layout.ads ada/lib.ads \ - ada/lib-load.ads ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/opt.adb ada/output.ads ada/put_alfa.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/sem.ads ada/sem.adb ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \ - ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ - ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ - ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_ch9.adb ada/sem_dim.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ - ada/sem_eval.ads ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ + ada/atree.ads ada/atree.adb ada/casing.ads ada/checks.ads \ + ada/checks.adb ada/csets.ads ada/debug.ads ada/debug_a.ads \ + ada/einfo.ads ada/einfo.adb ada/elists.ads ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads \ + ada/exp_ch2.ads ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_ch9.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/expander.ads ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/itypes.ads \ + ada/layout.ads ada/lib.ads ada/lib-load.ads ada/lib-util.ads \ + ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ + ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb ada/output.ads \ + ada/put_alfa.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch10.ads \ + ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads \ + ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads ada/sem_ch9.adb \ + ada/sem_dim.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ + ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/sem_dim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 11dfa7199a5..887a62fd37f 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -784,16 +784,32 @@ ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),) s-tasinf.ads<s-tasinf-vxworks.ads \ s-taspri.ads<s-taspri-vxworks.ads \ s-tpopsp.adb<s-tpopsp-vxworks.adb \ - s-vxwork.ads<s-vxwork-sparcv9.ads \ g-socthi.ads<g-socthi-vxworks.ads \ g-socthi.adb<g-socthi-vxworks.adb \ - g-stsifd.adb<g-stsifd-sockets.adb \ - system.ads<system-vxworks-sparcv9.ads \ + g-stsifd.adb<g-stsifd-sockets.adb TOOLS_TARGET_PAIRS=\ mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \ indepsw.adb<indepsw-gnu.adb + ifeq ($(arch),sparc) + # 32-bits + LIBGNAT_TARGET_PAIRS += \ + s-vxwork.ads<s-vxwork-sparc.ads \ + system.ads<system-vxworks-sparc-kernel.ads + else + # 64-bits + LIBGNAT_TARGET_PAIRS += \ + s-vxwork.ads<s-vxwork-sparcv9.ads \ + system.ads<system-vxworks-sparcv9.ads + endif + + ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),) + LIBGNAT_TARGET_PAIRS += \ + s-vxwext.ads<s-vxwext-kernel.ads \ + s-vxwext.adb<s-vxwext-kernel.adb + endif + EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o @@ -2014,7 +2030,7 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(targ))),) s-osinte.ads<s-osinte-hpux.ads \ s-osprim.adb<s-osprim-posix.adb \ s-taprop.adb<s-taprop-posix.adb \ - s-taspri.ads<s-taspri-posix-noaltstack.ads \ + s-taspri.ads<s-taspri-posix.ads \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ system.ads<system-hpux-ia64.ads \ $(ATOMICS_TARGET_PAIRS) \ @@ -2024,10 +2040,11 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(targ))),) mlib-tgt-specific.adb<mlib-tgt-specific-ia64-hpux.adb MISCLIB= + EH_MECHANISM=-gcc THREADSLIB=-lpthread GNATLIB_SHARED=gnatlib-shared-dual GMEM_LIB = gmemlib - soext = .sl + soext = .so SO_OPTS = -Wl,+h, LIBRARY_VERSION := $(LIB_VERSION) endif @@ -2799,15 +2816,18 @@ gnatlib-shared: $(GNATLIB_SHARED) # When building a SJLJ runtime for VxWorks, in addition to forcing -# ZCX_By_default to True, we need to ensure that -crtbe linker options -# is not passed. Otherwise we will end with weak symbols on -# __register_frame_info and __deregister_frame_info. The VxWorks 5.x -# will issue an error on weak symbols. +# ZCX_By_default to False, we need to ensure that extra linker options +# are not passed to prevent the inclusion of useless objects and +# potential troubles from the presence of extra symbols and references +# in some configurations. The inhibition is performed by commenting +# the pragma instead of deleting the line, as the latter might result +# in getting multiple blank lines, hence a style check error, as a +# result. gnatlib-sjlj: $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="" \ THREAD_KIND="$(THREAD_KIND)" ../stamp-gnatlib1-$(RTSDIR) sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := False;/' $(RTSDIR)/system.ads > $(RTSDIR)/s.ads - cat $(RTSDIR)/s.ads | grep -v "Linker_Options.*-crtbe" > $(RTSDIR)/s2.ads + sed -e 's/\(pragma Linker.*crtbe.*\)/-- \1/' $(RTSDIR)/s.ads > $(RTSDIR)/s2.ads $(RM) $(RTSDIR)/s.ads $(MV) $(RTSDIR)/s2.ads $(RTSDIR)/system.ads $(MAKE) $(FLAGS_TO_PASS) \ diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 169e03eea8a..cb0f074d7d2 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -50,19 +50,23 @@ #include "ada-tree.h" #include "gigi.h" -/* Convention_Stdcall should be processed in a specific way on 32 bits - Windows targets only. The macro below is a helper to avoid having to - check for a Windows specific attribute throughout this unit. */ +/* "stdcall" and "thiscall" conventions should be processed in a specific way + on 32-bit x86/Windows only. The macros below are helpers to avoid having + to check for a Windows specific attribute throughout this unit. */ #if TARGET_DLLIMPORT_DECL_ATTRIBUTES #ifdef TARGET_64BIT #define Has_Stdcall_Convention(E) \ (!TARGET_64BIT && Convention (E) == Convention_Stdcall) +#define Has_Thiscall_Convention(E) \ + (!TARGET_64BIT && is_cplusplus_method (E)) #else #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall) +#define Has_Thiscall_Convention(E) (is_cplusplus_method (E)) #endif #else #define Has_Stdcall_Convention(E) 0 +#define Has_Thiscall_Convention(E) 0 #endif /* Stack realignment is necessary for functions with foreign conventions when @@ -891,6 +895,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) debug_info_p); } + /* ??? If this is an object of CW type initialized to a value, try to + ensure that the object is sufficient aligned for this value, but + without pessimizing the allocation. This is a kludge necessary + because we don't support dynamic alignment. */ + if (align == 0 + && Ekind (Etype (gnat_entity)) == E_Class_Wide_Subtype + && No (Renamed_Object (gnat_entity)) + && No (Address_Clause (gnat_entity))) + align = get_target_system_allocator_alignment () * BITS_PER_UNIT; + #ifdef MINIMUM_ATOMIC_ALIGNMENT /* If the size is a constant and no alignment is specified, force the alignment to be the minimum valid atomic alignment. The @@ -900,7 +914,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) necessary and can interfere with constant replacement. Finally, do not do it for Out parameters since that creates an size inconsistency with In parameters. */ - if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type) + if (align == 0 + && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type) && !FLOAT_TYPE_P (gnu_type) && !const_flag && No (Renamed_Object (gnat_entity)) && !imported_p && No (Address_Clause (gnat_entity)) @@ -2973,6 +2988,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (Present (Parent_Subtype (gnat_entity))) { Entity_Id gnat_parent = Parent_Subtype (gnat_entity); + tree gnu_dummy_parent_type = make_node (RECORD_TYPE); tree gnu_parent; /* A major complexity here is that the parent subtype will @@ -2984,11 +3000,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) each of those discriminants to a COMPONENT_REF of the above dummy parent referencing the corresponding discriminant of the base type of the parent subtype. */ - gnu_get_parent = build3 (COMPONENT_REF, void_type_node, + gnu_get_parent = build3 (COMPONENT_REF, gnu_dummy_parent_type, build0 (PLACEHOLDER_EXPR, gnu_type), build_decl (input_location, FIELD_DECL, NULL_TREE, - void_type_node), + gnu_dummy_parent_type), NULL_TREE); if (has_discr) @@ -3283,9 +3299,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) else gnu_unpad_base_type = gnu_base_type; - /* Look for a REP part in the base type. */ - gnu_rep_part = get_rep_part (gnu_unpad_base_type); - /* Look for a variant part in the base type. */ gnu_variant_part = get_variant_part (gnu_unpad_base_type); @@ -3411,7 +3424,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) and put the field either in the new type if there is a selected variant or in one of the new variants. */ if (gnu_context == gnu_unpad_base_type - || (gnu_rep_part + || ((gnu_rep_part = get_rep_part (gnu_unpad_base_type)) && gnu_context == TREE_TYPE (gnu_rep_part))) gnu_cont_type = gnu_type; else @@ -3421,7 +3434,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) t = NULL_TREE; FOR_EACH_VEC_ELT (variant_desc, gnu_variant_list, i, v) - if (v->type == gnu_context) + if (gnu_context == v->type + || ((gnu_rep_part = get_rep_part (v->type)) + && gnu_context == TREE_TYPE (gnu_rep_part))) { t = v->type; break; @@ -4413,6 +4428,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) (&attr_list, ATTR_MACHINE_ATTRIBUTE, get_identifier ("stdcall"), NULL_TREE, gnat_entity); + else if (Has_Thiscall_Convention (gnat_entity)) + prepend_one_attribute_to + (&attr_list, ATTR_MACHINE_ATTRIBUTE, + get_identifier ("thiscall"), NULL_TREE, + gnat_entity); /* If we should request stack realignment for a foreign convention subprogram, do so. Note that this applies to task entry points in @@ -5276,6 +5296,10 @@ get_minimal_subprog_decl (Entity_Id gnat_entity) prepend_one_attribute_to (&attr_list, ATTR_MACHINE_ATTRIBUTE, get_identifier ("stdcall"), NULL_TREE, gnat_entity); + else if (Has_Thiscall_Convention (gnat_entity)) + prepend_one_attribute_to (&attr_list, ATTR_MACHINE_ATTRIBUTE, + get_identifier ("thiscall"), NULL_TREE, + gnat_entity); if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_name) gnu_ext_name = NULL_TREE; @@ -5285,6 +5309,39 @@ get_minimal_subprog_decl (Entity_Id gnat_entity) false, true, true, true, attr_list, gnat_entity); } +/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is + a C++ imported method or equivalent. + + We use the predicate on 32-bit x86/Windows to find out whether we need to + use the "thiscall" calling convention for GNAT_ENTITY. This convention is + used for C++ methods (functions with METHOD_TYPE) by the back-end. */ + +bool +is_cplusplus_method (Entity_Id gnat_entity) +{ + if (Convention (gnat_entity) != Convention_CPP) + return False; + + /* This is the main case: C++ method imported as a primitive operation. */ + if (Is_Dispatching_Operation (gnat_entity)) + return True; + + /* A thunk needs to be handled like its associated primitive operation. */ + if (Is_Subprogram (gnat_entity) && Is_Thunk (gnat_entity)) + return True; + + /* C++ classes with no virtual functions can be imported as limited + record types, but we need to return true for the constructors. */ + if (Is_Constructor (gnat_entity)) + return True; + + /* This is set on the E_Subprogram_Type built for a dispatching call. */ + if (Is_Dispatch_Table_Entity (gnat_entity)) + return True; + + return False; +} + /* Finalize the processing of From_With_Type incomplete types. */ void @@ -8000,6 +8057,10 @@ intrin_return_compatible_p (intrin_binding_t * inb) && !VOID_TYPE_P (btin_return_type)) return true; + /* If return type is Address (integer type), map it to void *. */ + if (Is_Descendent_Of_Address (Etype (inb->gnat_entity))) + ada_return_type = ptr_void_type_node; + /* Check return types compatibility otherwise. Note that this handles void/void as well. */ if (intrin_types_incompatible_p (btin_return_type, ada_return_type)) @@ -8122,7 +8183,8 @@ get_rep_part (tree record_type) /* The REP part is the first field, internal, another record, and its name starts with an 'R'. */ - if (DECL_INTERNAL_P (field) + if (field + && DECL_INTERNAL_P (field) && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE && IDENTIFIER_POINTER (DECL_NAME (field)) [0] == 'R') return field; diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index cfa52b069db..6edead04b6b 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -116,6 +116,10 @@ extern tree get_unpadded_type (Entity_Id gnat_entity); alias is already present, in which case it is returned instead. */ extern tree get_minimal_subprog_decl (Entity_Id gnat_entity); +/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is + a C++ imported method or equivalent. */ +extern bool is_cplusplus_method (Entity_Id gnat_entity); + /* Create a record type that contains a SIZE bytes long field of TYPE with a starting bit position so that it is aligned to ALIGN bits, and leaving at least ROOM bytes free before the field. BASE_ALIGN is the alignment the diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 27750a6e4a4..cd35cd1b123 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -244,6 +244,7 @@ static void add_cleanup (tree, Node_Id); static void add_stmt_list (List_Id); static void push_exception_label_stack (VEC(tree,gc) **, Entity_Id); static tree build_stmt_group (List_Id, bool); +static inline bool stmt_group_may_fallthru (void); static enum gimplify_status gnat_gimplify_stmt (tree *); static void elaborate_all_entities (Node_Id); static void process_freeze_entity (Node_Id); @@ -1424,6 +1425,15 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; } + /* For 'Access, issue an error message if the prefix is a C++ method + since it can use a special calling convention on some platforms, + which cannot be propagated to the access type. */ + else if (attribute == Attr_Access + && Nkind (Prefix (gnat_node)) == N_Identifier + && is_cplusplus_method (Entity (Prefix (gnat_node)))) + post_error ("access to C++ constructor or member function not allowed", + gnat_node); + /* For other address attributes applied to a nested function, find an inner ADDR_EXPR and annotate it so that we can issue a useful warning with -Wtrampolines. */ @@ -2911,7 +2921,7 @@ finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data) = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1)), - 1)->value; + 1).value; else ret_val = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1); } @@ -2970,7 +2980,7 @@ finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data) TREE_OPERAND (alloc, 0), VEC_index (constructor_elt, CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)), - 0)->value); + 0).value); /* Build a modified CONSTRUCTOR that references NEW_VAR. */ p_array = TYPE_FIELDS (TREE_TYPE (alloc)); @@ -2980,7 +2990,7 @@ finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data) VEC_index (constructor_elt, CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)), - 1)->value); + 1).value); new_ret = build_constructor (TREE_TYPE (alloc), v); } else @@ -4075,7 +4085,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, /* The first entry is for the actual return value if this is a function, so skip it. */ - if (TREE_VALUE (gnu_cico_list) == void_type_node) + if (function_call) gnu_cico_list = TREE_CHAIN (gnu_cico_list); if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) @@ -4179,8 +4189,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, return value from it and update the return type. */ if (TYPE_CI_CO_LIST (gnu_subprog_type)) { - tree gnu_elmt = value_member (void_type_node, - TYPE_CI_CO_LIST (gnu_subprog_type)); + tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type); gnu_call = build_component_ref (gnu_call, NULL_TREE, TREE_PURPOSE (gnu_elmt), false); gnu_result_type = TREE_TYPE (gnu_call); @@ -4447,6 +4456,7 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) else if (gcc_zcx) { tree gnu_handlers; + location_t locus; /* First make a block containing the handlers. */ start_stmt_group (); @@ -4459,6 +4469,14 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) /* Now make the TRY_CATCH_EXPR for the block. */ gnu_result = build2 (TRY_CATCH_EXPR, void_type_node, gnu_inner_block, gnu_handlers); + /* Set a location. We need to find a uniq location for the dispatching + code, otherwise we can get coverage or debugging issues. Try with + the location of the end label. */ + if (Present (End_Label (gnat_node)) + && Sloc_to_locus (Sloc (End_Label (gnat_node)), &locus)) + SET_EXPR_LOCATION (gnu_result, locus); + else + set_expr_location_from_node (gnu_result, gnat_node); } else gnu_result = gnu_inner_block; @@ -6189,12 +6207,18 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Block_Statement: - start_stmt_group (); - gnat_pushlevel (); - process_decls (Declarations (gnat_node), Empty, Empty, true, true); - add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); - gnat_poplevel (); - gnu_result = end_stmt_group (); + /* The only way to enter the block is to fall through to it. */ + if (stmt_group_may_fallthru ()) + { + start_stmt_group (); + gnat_pushlevel (); + process_decls (Declarations (gnat_node), Empty, Empty, true, true); + add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + else + gnu_result = alloc_stmt_list (); break; case N_Exit_Statement: @@ -7232,6 +7256,17 @@ end_stmt_group (void) return gnu_retval; } +/* Return whether the current statement group may fall through. */ + +static inline bool +stmt_group_may_fallthru (void) +{ + if (current_stmt_group->stmt_list) + return block_may_fallthru (current_stmt_group->stmt_list); + else + return true; +} + /* Add a list of statements from GNAT_LIST, a possibly-empty list of statements.*/ diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index d2183bbe160..4cca41bbf39 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -40,6 +40,7 @@ #include "langhooks.h" #include "cgraph.h" #include "diagnostic.h" +#include "timevar.h" #include "tree-dump.h" #include "tree-inline.h" #include "tree-iterator.h" @@ -612,6 +613,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) if (TREE_CODE (t) == POINTER_TYPE) TYPE_NEXT_PTR_TO (t) = tt; TYPE_NAME (tt) = DECL_NAME (decl); + TYPE_CONTEXT (tt) = DECL_CONTEXT (decl); TYPE_STUB_DECL (tt) = TYPE_STUB_DECL (t); DECL_ORIGINAL_TYPE (decl) = tt; } @@ -621,6 +623,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) /* We need a variant for the placeholder machinery to work. */ tree tt = build_variant_type_copy (t); TYPE_NAME (tt) = decl; + TYPE_CONTEXT (tt) = DECL_CONTEXT (decl); TREE_USED (tt) = TREE_USED (t); TREE_TYPE (decl) = tt; if (DECL_ORIGINAL_TYPE (TYPE_NAME (t))) @@ -640,7 +643,10 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) if (t) for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t)) if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)) - TYPE_NAME (t) = decl; + { + TYPE_NAME (t) = decl; + TYPE_CONTEXT (t) = DECL_CONTEXT (decl); + } } } @@ -1363,7 +1369,8 @@ void finish_fat_pointer_type (tree record_type, tree field_list) { /* Make sure we can put it into a register. */ - TYPE_ALIGN (record_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); + if (STRICT_ALIGNMENT) + TYPE_ALIGN (record_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); /* Show what it really is. */ TYPE_FAT_POINTER_P (record_type) = 1; @@ -4485,10 +4492,10 @@ convert (tree type, tree expr) inner expression. */ if (TREE_CODE (expr) == CONSTRUCTOR && !VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (expr)) - && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->index + && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0).index == TYPE_FIELDS (etype)) unpadded - = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->value; + = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0).value; /* Otherwise, build an explicit component reference. */ else @@ -5041,7 +5048,7 @@ remove_conversions (tree exp, bool true_address) && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp))) return remove_conversions (VEC_index (constructor_elt, - CONSTRUCTOR_ELTS (exp), 0)->value, + CONSTRUCTOR_ELTS (exp), 0).value, true); break; diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index c7dfe98fce2..4578114f4a7 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -441,7 +441,7 @@ compare_fat_pointers (location_t loc, tree result_type, tree p1, tree p2) /* The constant folder doesn't fold fat pointer types so we do it here. */ if (TREE_CODE (p1) == CONSTRUCTOR) - p1_array = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (p1), 0)->value; + p1_array = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (p1), 0).value; else p1_array = build_component_ref (p1, NULL_TREE, TYPE_FIELDS (TREE_TYPE (p1)), true); @@ -452,7 +452,7 @@ compare_fat_pointers (location_t loc, tree result_type, tree p1, tree p2) null_pointer_node)); if (TREE_CODE (p2) == CONSTRUCTOR) - p2_array = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (p2), 0)->value; + p2_array = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (p2), 0).value; else p2_array = build_component_ref (p2, NULL_TREE, TYPE_FIELDS (TREE_TYPE (p2)), true); @@ -473,14 +473,14 @@ compare_fat_pointers (location_t loc, tree result_type, tree p1, tree p2) = fold_build2_loc (loc, EQ_EXPR, result_type, p1_array, p2_array); if (TREE_CODE (p1) == CONSTRUCTOR) - p1_bounds = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (p1), 1)->value; + p1_bounds = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (p1), 1).value; else p1_bounds = build_component_ref (p1, NULL_TREE, DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (p1))), true); if (TREE_CODE (p2) == CONSTRUCTOR) - p2_bounds = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (p2), 1)->value; + p2_bounds = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (p2), 1).value; else p2_bounds = build_component_ref (p2, NULL_TREE, @@ -1336,7 +1336,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) { result = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (operand), - 0)->value; + 0).value; result = convert (build_pointer_type (TREE_TYPE (operand)), build_unary_op (ADDR_EXPR, NULL_TREE, result)); break; @@ -1912,10 +1912,12 @@ build_simple_component_ref (tree record_variable, tree component, break; /* Next, see if we're looking for an inherited component in an extension. - If so, look thru the extension directly. */ + If so, look thru the extension directly, but not if the type contains + a placeholder, as it might be needed for a later substitution. */ if (!new_field && TREE_CODE (record_variable) == VIEW_CONVERT_EXPR && TYPE_ALIGN_OK (record_type) + && !type_contains_placeholder_p (record_type) && TREE_CODE (TREE_TYPE (TREE_OPERAND (record_variable, 0))) == RECORD_TYPE && TYPE_ALIGN_OK (TREE_TYPE (TREE_OPERAND (record_variable, 0)))) @@ -2642,10 +2644,7 @@ gnat_stabilize_reference (tree ref, bool force, bool *success) result = build3 (BIT_FIELD_REF, type, gnat_stabilize_reference (TREE_OPERAND (ref, 0), force, success), - gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), - force), - gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2), - force)); + TREE_OPERAND (ref, 1), TREE_OPERAND (ref, 2)); break; case ARRAY_REF: @@ -2677,9 +2676,9 @@ gnat_stabilize_reference (tree ref, bool force, bool *success) && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1) { tree index - = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index; + = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0).index; tree value - = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value; + = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0).value; result = build_constructor_single (type, index, gnat_stabilize_reference_1 (value, diff --git a/gcc/ada/gnat-style.texi b/gcc/ada/gnat-style.texi index 1bba7030935..43e6b4310a1 100644 --- a/gcc/ada/gnat-style.texi +++ b/gcc/ada/gnat-style.texi @@ -7,14 +7,14 @@ @c o @c G N A T C O D I N G S T Y L E o @c o -@c GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). o +@c Copyright (C) 1992-2012, AdaCore o @c o @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @setfilename gnat-style.info @copying -Copyright @copyright{} 1992-2008, Free Software Foundation, Inc. +Copyright @copyright{} 1992-2012, AdaCore Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -350,6 +350,24 @@ that give useful information instead. Local names can be shorter, because they are used only within one context, where comments explain their purpose. +@item +When starting an initialization or default expression on the line that follows +the declaration line, use 2 characters for indentation. + +@smallexample @c adanocomment + Entity1 : Integer := + Function_Name (Parameters, For_Call); +@end smallexample + +@item +If an initialization or default expression needs to be continued on subsequent +lines, the continuations should be indented from the start of the expression. + +@smallexample @c adanocomment + Entity1 : Integer := Long_Function_Name + (parameters for call); +@end smallexample + @end itemize @@ -720,7 +738,10 @@ also be used as headers for sections of comments, or collections of declarations that are related. @item -Every subprogram body must have a preceding @syntax{subprogram_declaration}. +Every subprogram body must have a preceding @syntax{subprogram_declaration}, +which includes proper client documentation so that you do not need to +read the subprogram body in order to understand what the subprogram does and +how to call it. All subprograms should be documented, without exceptions. @item @cindex Blank lines (in subprogram bodies) diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 241671776fc..b2f371f3973 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -104,11 +104,6 @@ procedure Gnat1drv is -- Called when we are not generating code, to check if -gnatR was requested -- and if so, explain that we will not be honoring the request. - procedure Check_Library_Items; - -- For debugging -- checks the behavior of Walk_Library_Items - pragma Warnings (Off, Check_Library_Items); - -- In case the call below is commented out - ---------------------------- -- Adjust_Global_Switches -- ---------------------------- @@ -198,13 +193,16 @@ procedure Gnat1drv is -- Enable all other language checks Suppress_Options := - (Access_Check => True, - Alignment_Check => True, - Division_Check => True, - Elaboration_Check => True, - Overflow_Check => True, - others => False); - Enable_Overflow_Checks := False; + (Suppress => (Access_Check => True, + Alignment_Check => True, + Division_Check => True, + Elaboration_Check => True, + Overflow_Check => True, + others => False), + Overflow_Checks_General => Suppress, + Overflow_Checks_Assertions => Suppress); + + Enable_Overflow_Checks := False; Dynamic_Elaboration_Checks := False; -- Kill debug of generated code, since it messes up sloc values @@ -344,9 +342,11 @@ procedure Gnat1drv is and Targparm.Backend_Overflow_Checks_On_Target)) then - Suppress_Options (Overflow_Check) := False; + Suppress_Options.Suppress (Overflow_Check) := False; else - Suppress_Options (Overflow_Check) := True; + Suppress_Options.Suppress (Overflow_Check) := True; + Suppress_Options.Overflow_Checks_General := Check_All; + Suppress_Options.Overflow_Checks_Assertions := Check_All; end if; -- Set default for atomic synchronization. As this synchronization @@ -354,7 +354,8 @@ procedure Gnat1drv is -- on some targets, an optional target parameter can turn the option -- off. Note Atomic Synchronization is implemented as check. - Suppress_Options (Atomic_Synchronization) := not Atomic_Sync_Default; + Suppress_Options.Suppress (Atomic_Synchronization) := + not Atomic_Sync_Default; -- Set switch indicating if we can use N_Expression_With_Actions @@ -431,12 +432,12 @@ procedure Gnat1drv is Restrict.Restrictions.Set (No_Initialize_Scalars) := True; -- Suppress all language checks since they are handled implicitly by - -- the formal verification backend. + -- the formal verification backend. -- Turn off dynamic elaboration checks. -- Turn off alignment checks. -- Turn off validity checking. - Suppress_Options := (others => True); + Suppress_Options := Suppress_All; Enable_Overflow_Checks := False; Dynamic_Elaboration_Checks := False; Reset_Validity_Check_Options; @@ -659,35 +660,6 @@ procedure Gnat1drv is end if; end Check_Bad_Body; - ------------------------- - -- Check_Library_Items -- - ------------------------- - - -- Walk_Library_Items has plenty of assertions, so all we need to do is - -- call it, just for these assertions, not actually doing anything else. - - procedure Check_Library_Items is - - procedure Action (Item : Node_Id); - -- Action passed to Walk_Library_Items to do nothing - - ------------ - -- Action -- - ------------ - - procedure Action (Item : Node_Id) is - begin - null; - end Action; - - procedure Walk is new Sem.Walk_Library_Items (Action); - - -- Start of processing for Check_Library_Items - - begin - Walk; - end Check_Library_Items; - -------------------- -- Check_Rep_Info -- -------------------- @@ -1136,14 +1108,6 @@ begin Namet.Lock; Stringt.Lock; - -- ???Check_Library_Items under control of a debug flag, because it - -- currently does not work if the -gnatn switch (back end inlining) is - -- used. - - if Debug_Flag_Dot_WW then - Check_Library_Items; - end if; - -- Here we call the back end to generate the output code Generating_Code := True; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 3b05e4779a0..eb0b4219c1a 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -1869,8 +1869,6 @@ functions (see pragma @code{CPP_Constructor}). Such types are implicitly limited if not explicitly declared as limited or derived from a limited type, and an error is issued in that case. -Pragma @code{CPP_Class} is intended primarily for automatic generation -using an automatic binding generator tool. See @ref{Interfacing to C++} for related information. Note: Pragma @code{CPP_Class} is currently obsolete. It is supported @@ -1927,7 +1925,8 @@ If no constructors are imported, it is impossible to create any objects on the Ada side and the type is implicitly declared abstract. Pragma @code{CPP_Constructor} is intended primarily for automatic generation -using an automatic binding generator tool. +using an automatic binding generator tool (such as the @code{-fdump-ada-spec} +GCC switch). See @ref{Interfacing to C++} for more related information. Note: The use of functions returning class-wide types for constructors is @@ -6709,7 +6708,7 @@ this attribute. @cindex Scalar storage order @findex Scalar_Storage_Order @noindent -For every record subtype @var{S}, the representation attribute +For every array or record type @var{S}, the representation attribute @code{Scalar_Storage_Order} denotes the order in which storage elements that make up scalar components are ordered within S. Other properties are as for standard representation attribute @code{Bit_Order}, as defined by @@ -6721,15 +6720,22 @@ equal to @code{@var{S}'Bit_Order}. Note: This means that if a then the type's @code{Bit_Order} shall be specified explicitly and set to the same value. +If a component of S has itself a record or array type, then it shall also +have a @code{Scalar_Storage_Order} attribute definition clause. In addition, +if the component does not start on a byte boundary, then the scalar storage +order specified for S and for the nested component type shall be identical. + +No component of a type that has a @code{Scalar_Storage_Order} attribute +definition may be aliased. + A confirming @code{Scalar_Storage_Order} attribute definition clause (i.e. with a value equal to @code{System.Default_Bit_Order}) has no effect. -If the opposite storage order is specified, then whenever the -value of a scalar component of S is read, the storage elements of the -enclosing machine scalar are first reversed (before retrieving the -component value, possibly applying some shift and mask operatings on the -enclosing machine scalar), and the opposite operation is done for -writes. +If the opposite storage order is specified, then whenever the value of +a scalar component of S is read, the storage elements of the enclosing +machine scalar are first reversed (before retrieving the component value, +possibly applying some shift and mask operatings on the enclosing machine +scalar), and the opposite operation is done for writes. In that case, the restrictions set forth in 13.5.1(10.3/2) for scalar components are relaxed. Instead, the following rules apply: @@ -13700,7 +13706,9 @@ ENCODING=[UTF8|8BITS] @end smallexample @noindent -The use of these parameters is described later in this section. +The use of these parameters is described later in this section. If an +unrecognized keyword appears in a form string, it is silently ignored +and not considered invalid. @node Direct_IO @section Direct_IO @@ -16608,8 +16616,7 @@ of the length corresponding to the @code{@var{type}'Size} value in Ada. @noindent The interface to C++ makes use of the following pragmas, which are primarily intended to be constructed automatically using a binding generator -tool, although it is possible to construct them by hand. No suitable binding -generator tool is supplied with GNAT though. +tool, although it is possible to construct them by hand. Using these pragmas it is possible to achieve complete inter-operability between Ada tagged types and C++ class definitions. @@ -16631,6 +16638,12 @@ This pragma identifies an imported function (imported in the usual way with pragma @code{Import}) as corresponding to a C++ constructor. @end table +In addition, C++ exceptions are propagated and can be handled in an +@code{others} choice of an exception handler. The corresponding Ada +occurrence has no message, and the simple name of the exception identity +contains @samp{Foreign_Exception}. Finalization and awaiting dependent +tasks works properly when such foreign exceptions are propagated. + @node Interfacing to COBOL @section Interfacing to COBOL diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 4a1baf2aadf..e440ed517ed 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -487,7 +487,9 @@ Creating Unit Tests Using gnattest * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: +@ifclear vms * Support for other platforms/run-times:: +@end ifclear * Current Limitations:: Other Utility Programs @@ -4306,10 +4308,8 @@ means that no limit applies. @cindex @option{-gnatn} (@command{gcc}) Activate inlining for subprograms for which pragma @code{Inline} is specified. This inlining is performed by the GCC back-end. An optional -digit sets the inlining level: 1 for moderate inlining across modules, -which is a good compromise between compilation times and performances -at run time, and 2 for full inlining across modules, which may bring -about longer compilation times. If no inlining level is specified, +digit sets the inlining level: 1 for moderate inlining across modules +or 2 for full inlining across modules. If no inlining level is specified, the compiler will pick it based on the optimization level. @item -gnatN @@ -7335,21 +7335,28 @@ For the source file naming rules, @xref{File Naming Rules}. @table @option @c !sort! -@item -gnatn +@item -gnatn[12] @cindex @option{-gnatn} (@command{gcc}) @ifclear vms The @code{n} here is intended to suggest the first syllable of the word ``inline''. @end ifclear GNAT recognizes and processes @code{Inline} pragmas. However, for the -inlining to actually occur, optimization must be enabled. To enable -inlining of subprograms specified by pragma @code{Inline}, +inlining to actually occur, optimization must be enabled and, in order +to enable inlining of subprograms specified by pragma @code{Inline}, you must also specify this switch. In the absence of this switch, GNAT does not attempt inlining and does not need to access the bodies of subprograms for which @code{pragma Inline} is specified if they are not in the current unit. +You can optionally specify the inlining level: 1 for moderate inlining across +modules, which is a good compromise between compilation times and performances +at run time, or 2 for full inlining across modules, which may bring about +longer compilation times. If no inlining level is specified, the compiler will +pick it based on the optimization level: 1 for @option{-O1}, @option{-O2} or +@option{-Os} and 2 for @option{-O3}. + If you specify this switch the compiler will access these bodies, creating an extra source dependency for the resulting object file, and where possible, the call will be inlined. @@ -10733,19 +10740,22 @@ Note: The @option{-fno-inline-functions-called-once} switch can be used to prevent inlining of subprograms local to the unit and called once from within it if @option{-O1} is used. -Note regarding the use of @option{-O3}: There is no difference in inlining -behavior between @option{-O2} and @option{-O3} for subprograms with an explicit -pragma @code{Inline} assuming the use of @option{-gnatn} -or @option{-gnatN} (the switches that activate inlining). If you have used -pragma @code{Inline} in appropriate cases, then it is usually much better -to use @option{-O2} and @option{-gnatn} and avoid the use of @option{-O3} which -in this case only has the effect of inlining subprograms you did not -think should be inlined. We often find that the use of @option{-O3} slows -down code by performing excessive inlining, leading to increased instruction -cache pressure from the increased code size. So the bottom line here is -that you should not automatically assume that @option{-O3} is better than -@option{-O2}, and indeed you should use @option{-O3} only if tests show that -it actually improves performance. +Note regarding the use of @option{-O3}: @option{-gnatn} is made up of two +sub-switches @option{-gnatn1} and @option{-gnatn2} that can be directly +specified in lieu of it, @option{-gnatn} being translated into one of them +based on the optimization level. With @option{-O2} or below, @option{-gnatn} +is equivalent to @option{-gnatn1} which activates pragma @code{Inline} with +moderate inlining across modules. With @option{-O3}, @option{-gnatn} is +equivalent to @option{-gnatn2} which activates pragma @code{Inline} with +full inlining across modules. If you have used pragma @code{Inline} in appropriate cases, then it is usually much better to use @option{-O2} and @option{-gnatn} and avoid the use of @option{-O3} which has the additional +effect of inlining subprograms you did not think should be inlined. We have +found that the use of @option{-O3} may slow down the compilation and increase +the code size by performing excessive inlining, leading to increased +instruction cache pressure from the increased code size and thus minor +performance improvements. So the bottom line here is that you should not +automatically assume that @option{-O3} is better than @option{-O2}, and +indeed you should use @option{-O3} only if tests show that it actually +improves performance for your program. @node Vectorization of loops @subsection Vectorization of loops @@ -18099,7 +18109,9 @@ is installed at its default location. * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: +@ifclear vms * Support for other platforms/run-times:: +@end ifclear * Current Limitations:: @end menu @@ -18408,7 +18420,7 @@ as passed to gnattest when generating the test driver. Passing it to the driver generated on the first example: @smallexample -test_runner --stub-default=pass +test_runner --skeleton-default=pass @end smallexample makes both tests pass, even the unimplemented one. @@ -18613,6 +18625,7 @@ gnatmake -Pmixing/test_driver.gpr mixing/test_runner @end smallexample +@ifclear vms @node Support for other platforms/run-times @section Support for other platforms/run-times @@ -18625,12 +18638,15 @@ such as Zero FootPrint (ZFP), a simplified harness is generated. Two variables are used to tell the underlying AUnit framework how to generate the test harness: @code{PLATFORM}, which identifies the target, and @code{RUNTIME}, used to determine the run-time library for which the harness -is generated. For example, the following options are used to generate the -AUnit test harness for a PowerPC ELF target using the ZFP run-time library: +is generated. Corresponding prefix should also be used when calling +@command{gnattest} for non-native targets. For example, the following options +are used to generate the AUnit test harness for a PowerPC ELF target using +the ZFP run-time library: @smallexample -gnattest -Psimple.gpr -XPLATFORM=powerpc-elf -XRUNTIME=zfp +powerpc-elf-gnattest -Psimple.gpr -XPLATFORM=powerpc-elf -XRUNTIME=zfp @end smallexample +@end ifclear @node Current Limitations @section Current Limitations @@ -18642,7 +18658,6 @@ The tool currently does not support following features: @itemize @bullet @item generic tests for generic packages and package instantiations @item tests for protected subprograms and entries -@item generating test packages for code that is not conformant with ada 2005 @end itemize @@ -18676,13 +18691,13 @@ package, in file s-dimmks.ads. type Mks_Type is new Long_Long_Float with Dimension_System => ( - (Meter, 'm'), - (Kilogram, "kg"), - (Second, 's'), - (Ampere, 'A'), - (Kelvin, 'K'), - (Mole, "mol"), - (Candela, "cd")); + (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), + (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), + (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), + (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), + (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Theta"), + (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), + (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); @end smallexample @noindent @@ -18691,8 +18706,8 @@ conventional units. For example: @smallexample @c ada subtype Length is Mks_Type with - Dimension => ('m', - Meter => 1, + Dimension => (Symbol => 'm', + Meter => 1, others => 0); @end smallexample @noindent @@ -18704,10 +18719,10 @@ The package also defines conventional names for values of each unit, for example: @smallexample @c ada - m : constant Length := 1.0; - kg : constant Mass := 1.0; - s : constant Time := 1.0; - A : constant Electric_Current := 1.0; + m : constant Length := 1.0; + kg : constant Mass := 1.0; + s : constant Time := 1.0; + A : constant Electric_Current := 1.0; @end smallexample @noindent @@ -18775,13 +18790,13 @@ are rejected with the following diagnoses: @smallexample Distance := 5.0; >>> dimensions mismatch in assignment - >>> left-hand side has dimensions (1, 0, 0, 0, 0, 0, 0) + >>> left-hand side has dimension [L] >>> right-hand side is dimensionless Distance := 5.0 * kg: >>> dimensions mismatch in assignment - >>> left-hand side has dimensions (1, 0, 0, 0, 0, 0, 0) - >>> right-hand side has dimensions (0, 1, 0, 0, 0, 0, 0) + >>> left-hand side has dimension [L] + >>> right-hand side has dimension [M] @end smallexample @noindent diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 87983997a7a..82e3f4593b4 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -238,12 +238,7 @@ procedure GNATCmd is function Configuration_Pragmas_File return Path_Name_Type; -- Return an argument, if there is a configuration pragmas file to be - -- specified for Project, otherwise return No_Name. Used for gnatstub (GNAT - -- STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric (GNAT - -- METRIC). - - function Mapping_File return Path_Name_Type; - -- Create and return the path name of a mapping file. Used for gnatstub + -- specified for Project, otherwise return No_Name. Used for gnatstub -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric -- (GNAT METRIC). @@ -251,10 +246,22 @@ procedure GNATCmd is -- Delete all temporary config files. The caller is responsible for -- ensuring that Keep_Temporary_Files is False. + procedure Ensure_Absolute_Path + (Switch : in out String_Access; + Parent : String); + -- Test if Switch is a relative search path switch. If it is and it + -- includes directory information, prepend the path with Parent. This + -- subprogram is only called when using project files. + procedure Get_Closure; -- Get the sources in the closure of the ASIS_Main and add them to the -- list of arguments. + function Mapping_File return Path_Name_Type; + -- Create and return the path name of a mapping file. Used for gnatstub + -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric + -- (GNAT METRIC). + procedure Non_VMS_Usage; -- Display usage for platforms other than VMS @@ -268,17 +275,9 @@ procedure GNATCmd is -- If Project is a library project, add the correct -L and -l switches to -- the linker invocation. - procedure Set_Libraries is - new For_Every_Project_Imported (Boolean, Set_Library_For); - -- Add the -L and -l switches to the linker for all of the library - -- projects. - - procedure Test_If_Relative_Path - (Switch : in out String_Access; - Parent : String); - -- Test if Switch is a relative search path switch. If it is and it - -- includes directory information, prepend the path with Parent. This - -- subprogram is only called when using project files. + procedure Set_Libraries is new + For_Every_Project_Imported (Boolean, Set_Library_For); + -- Add the -L and -l switches to the linker for all the library projects -------------------------- -- Add_To_Carg_Switches -- @@ -789,6 +788,22 @@ procedure GNATCmd is end if; end Delete_Temp_Config_Files; + --------------------------- + -- Ensure_Absolute_Path -- + --------------------------- + + procedure Ensure_Absolute_Path + (Switch : in out String_Access; + Parent : String) + is + begin + Makeutl.Ensure_Absolute_Path + (Switch, Parent, + Do_Fail => Osint.Fail'Access, + Including_Non_Switch => False, + Including_RTS => True); + end Ensure_Absolute_Path; + ----------------- -- Get_Closure -- ----------------- @@ -962,6 +977,59 @@ procedure GNATCmd is return Result; end Mapping_File; + ------------------- + -- Non_VMS_Usage -- + ------------------- + + procedure Non_VMS_Usage is + begin + Output_Version; + New_Line; + Put_Line ("List of available commands"); + New_Line; + + for C in Command_List'Range loop + + -- No usage for VMS only command or for Sync + + if not Command_List (C).VMS_Only and then C /= Sync then + if Targparm.AAMP_On_Target then + Put ("gnaampcmd "); + else + Put ("gnat "); + end if; + + Put (To_Lower (Command_List (C).Cname.all)); + Set_Col (25); + + -- Never call gnatstack with a prefix + + if C = Stack then + Put (Command_List (C).Unixcmd.all); + else + Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all); + end if; + + declare + Sws : Argument_List_Access renames Command_List (C).Unixsws; + begin + if Sws /= null then + for J in Sws'Range loop + Put (' '); + Put (Sws (J).all); + end loop; + end if; + end; + + New_Line; + end if; + end loop; + + New_Line; + Put_Line ("All commands except chop, krunch and preprocess " & + "accept project file switches -vPx, -Pprj and -Xnam=val"); + New_Line; + end Non_VMS_Usage; ------------------ -- Process_Link -- ------------------ @@ -1302,76 +1370,6 @@ procedure GNATCmd is end if; end Set_Library_For; - --------------------------- - -- Test_If_Relative_Path -- - --------------------------- - - procedure Test_If_Relative_Path - (Switch : in out String_Access; - Parent : String) - is - begin - Makeutl.Test_If_Relative_Path - (Switch, Parent, - Do_Fail => Osint.Fail'Access, - Including_Non_Switch => False, - Including_RTS => True); - end Test_If_Relative_Path; - - ------------------- - -- Non_VMS_Usage -- - ------------------- - - procedure Non_VMS_Usage is - begin - Output_Version; - New_Line; - Put_Line ("List of available commands"); - New_Line; - - for C in Command_List'Range loop - - -- No usage for VMS only command or for Sync - - if not Command_List (C).VMS_Only and then C /= Sync then - if Targparm.AAMP_On_Target then - Put ("gnaampcmd "); - else - Put ("gnat "); - end if; - - Put (To_Lower (Command_List (C).Cname.all)); - Set_Col (25); - - -- Never call gnatstack with a prefix - - if C = Stack then - Put (Command_List (C).Unixcmd.all); - else - Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all); - end if; - - declare - Sws : Argument_List_Access renames Command_List (C).Unixsws; - begin - if Sws /= null then - for J in Sws'Range loop - Put (' '); - Put (Sws (J).all); - end loop; - end if; - end; - - New_Line; - end if; - end loop; - - New_Line; - Put_Line ("All commands except chop, krunch and preprocess " & - "accept project file switches -vPx, -Pprj and -Xnam=val"); - New_Line; - end Non_VMS_Usage; - -- Start of processing for GNATCmd begin @@ -2387,7 +2385,7 @@ begin -- arguments. for J in 1 .. Last_Switches.Last loop - GNATCmd.Test_If_Relative_Path + GNATCmd.Ensure_Absolute_Path (Last_Switches.Table (J), Current_Work_Dir); end loop; @@ -2397,7 +2395,7 @@ begin Project_Dir : constant String := Name_Buffer (1 .. Name_Len); begin for J in 1 .. First_Switches.Last loop - GNATCmd.Test_If_Relative_Path + GNATCmd.Ensure_Absolute_Path (First_Switches.Table (J), Project_Dir); end loop; end; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index d6834ab5ae2..9562b3bbc8d 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -904,6 +904,7 @@ procedure Gnatlink is procedure Write_RF (S : String) is Success : Boolean := True; + begin -- If a GNU response file is used, space and backslash need to be -- escaped because they are interpreted as a string separator and @@ -912,17 +913,18 @@ procedure Gnatlink is -- they are interpreted as string delimiters on both sides. if Using_GNU_response_file then - for I in S'Range loop - if S (I) = ' ' or else S (I) = '\' then + for J in S'Range loop + if S (J) = ' ' or else S (J) = '\' then if Write (Tname_FD, ASCII.BACK_SLASH'Address, 1) /= 1 then Success := False; end if; end if; - if Write (Tname_FD, S (I)'Address, 1) /= 1 then + if Write (Tname_FD, S (J)'Address, 1) /= 1 then Success := False; end if; end loop; + else if Write (Tname_FD, S'Address, S'Length) /= S'Length then Success := False; @@ -973,9 +975,9 @@ procedure Gnatlink is Linker_Objects.Increment_Last; - -- Mark the positions of first and last object files in case - -- they need to be placed with a named file on systems having - -- linker line limitations. + -- Mark the positions of first and last object files in case they + -- need to be placed with a named file on systems having linker + -- line limitations. if Objs_Begin = 0 then Objs_Begin := Linker_Objects.Last; @@ -1016,9 +1018,9 @@ procedure Gnatlink is and then Link_Bytes > Link_Max) then -- Create a temporary file containing the Ada user object files - -- needed by the link. This list is taken from the bind file - -- and is output one object per line for maximal compatibility with - -- linkers supporting this option. + -- needed by the link. This list is taken from the bind file and is + -- output one object per line for maximal compatibility with linkers + -- supporting this option. Create_Temp_File (Tname_FD, Tname); @@ -1045,9 +1047,9 @@ procedure Gnatlink is Tname (Tname'First .. Tname'Last - 1)); -- The slots containing these object file names are then removed - -- from the objects table so they do not appear in the link. They - -- are removed by moving up the linker options and non-Ada object - -- files appearing after the Ada object list in the table. + -- from the objects table so they do not appear in the link. They are + -- removed by moving up the linker options and non-Ada object files + -- appearing after the Ada object list in the table. declare N : Integer; @@ -1082,8 +1084,8 @@ procedure Gnatlink is elsif Next_Line (Nfirst .. Nlast) = "-shared" then GNAT_Shared := True; - -- Add binder options only if not already set on the command - -- line. This rule is a way to control the linker options order. + -- Add binder options only if not already set on the command line. + -- This rule is a way to control the linker options order. -- The following test needs comments, why is it VMS specific. -- The above comment looks out of date ??? @@ -1095,8 +1097,8 @@ procedure Gnatlink is if Nlast > Nfirst + 2 and then Next_Line (Nfirst .. Nfirst + 1) = "-L" then - -- Construct a library search path for use later - -- to locate static gnatlib libraries. + -- Construct a library search path for use later to locate + -- static gnatlib libraries. if Libpath.Last > 1 then Libpath.Increment_Last; @@ -2208,6 +2210,7 @@ begin System.OS_Lib.Spawn (Linker_Path.all, Args, Success); if Success then + -- Delete the temporary file used in conjunction with linking -- if one was created. See Process_Bind_File for details. diff --git a/gcc/ada/i-cstrea.ads b/gcc/ada/i-cstrea.ads index 5c997bd75be..37d8ab733db 100644 --- a/gcc/ada/i-cstrea.ads +++ b/gcc/ada/i-cstrea.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2012, 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- -- @@ -228,9 +228,10 @@ package Interfaces.C_Streams is -- pass an actual parameter for buffer that is big enough for any full -- path name. Use max_path_len given below as the size of buffer. - max_path_len : Integer; - -- Maximum length of an allowable full path name on the system, - -- including a terminating NUL character. + max_path_len : constant Integer; + -- Maximum length of an allowable full path name on the system,including a + -- terminating NUL character. Declared as a constant to allow references + -- from other preelaborated GNAT library packages. private -- The following functions are specialized in the body depending on the diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 4db5789526c..8a27a601617 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -304,6 +304,27 @@ __gnat_install_handler (void) #include <signal.h> #include <sys/ucontext.h> +#if defined (IN_RTS) && defined (__ia64__) + +#include <sys/uc_access.h> + +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) +{ + ucontext_t *uc = (ucontext_t *) ucontext; + uint64_t ip; + + /* Adjust on itanium, as GetIPInfo is not supported. */ + __uc_get_ip (uc, &ip); + __uc_set_ip (uc, ip + 1); +} +#endif /* IN_RTS && __ia64__ */ + +/* Tasking and Non-tasking signal handler. Map SIGnal to Ada exception + propagation after the required low level adjustments. */ + static void __gnat_error_handler (int sig, siginfo_t *si ATTRIBUTE_UNUSED, @@ -312,6 +333,8 @@ __gnat_error_handler (int sig, struct Exception_Data *exception; const char *msg; + __gnat_adjust_context_for_raise (sig, ucontext); + switch (sig) { case SIGSEGV: diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index 90f35a0a9b4..7e1141a9be7 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2011, Free Software Foundation, Inc. * + * Copyright (C) 1992-2012, 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- * @@ -221,7 +221,8 @@ __gnat_initialize (void *eh ATTRIBUTE_UNUSED) FindClose (hDir); - free (dir); + if (dir != NULL) + free (dir); } } else @@ -280,58 +281,6 @@ void __gnat_initialize (void *eh) { __gnat_init_float (); - - /* On targets where we use the ZCX scheme, we need to register the frame - tables at load/startup time. - - For applications loaded as a set of "modules", the crtstuff objects - linked in (crtbegin.o/end.o) are tailored to provide this service - automatically, a-la C++ constructor fashion, triggered by the VxWorks - loader thanks to a special variable declaration in crtbegin.o (_ctors). - - Automatic de-registration is handled symmetrically, a-la C++ destructor - fashion (with a _dtors variable also in crtbegin.o) triggered by the - dynamic unloader. - - Note that since the tables shall be registered against a common - data structure, libgcc should be one of the modules (vs being partially - linked against all the others at build time) and shall be loaded first. - - For applications linked with the kernel, the scheme above would lead to - duplicated symbols because the VxWorks kernel build "munches" by default, - so we link against crtbeginT.o instead of crtbegin.o, which doesn't - include the special variables. We know which set of crt objects is used - thanks to a boolean indicator present in both sets (__module_has_ctors), - and directly call the appropriate function here in the not-automatic - case. We'll never unload that, so there is no de-registration to worry - about. - - For whole applications loaded as a single module, we may use one scheme - or the other, except for the mixed Ada/C++ case in which the first scheme - would fail for the same reason as in the linked-with-kernel situation. - - The crt set selection is controlled by command line options via GCC's - STARTFILE_SPEC in rs6000/vxworks.h. This is tightly synchronized with a - number of other GCC configuration and crtstuff changes, and we need to - ensure that those changes are there to activate this circuitry. */ - -#if (__GNUC__ >= 3) && (defined (_ARCH_PPC) || defined (__ppc)) - { - /* The scheme described above is only useful for the actual ZCX case, and - we don't want any reference to the crt provided symbols otherwise. We - may not link with any of the crt objects in the non-ZCX case, e.g. from - documented procedures instructing the use of -nostdlib, and references - to the ctors symbols here would just remain unsatisfied. - - We have no way to avoid those references in the right conditions in this - C module, because we have nothing like a IN_ZCX_RTS macro. This aspect - is then deferred to an Ada routine, which can do that based on a test - against a constant System flag value. */ - - extern void __gnat_vxw_setup_for_eh (void); - __gnat_vxw_setup_for_eh (); - } -#endif } #elif defined(_T_HPUX10) || (!defined(IN_RTS) && defined(_X_HPUX10)) diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index 63c043def68..f3750a83aa2 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -70,7 +70,7 @@ package Inline is -- be restored when compiling the body, to insure that internal enti- -- ties use the same counter and are unique over spec and body. - Scope_Suppress : Suppress_Array; + Scope_Suppress : Suppress_Record; Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; -- Save suppress information at the point of instantiation. Used to -- properly inherit check status active at this point (see RM 11.5 diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 9b6c0ce9f94..60a44a90f87 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -2452,18 +2452,22 @@ package body Layout is Init_Size (E, 2 * System_Address_Size); -- When the target is AAMP, access-to-subprogram types are fat - -- pointers consisting of the subprogram address and a static link - -- (with the exception of library-level access types, where a simple - -- subprogram address is used). + -- pointers consisting of the subprogram address and a static link, + -- with the exception of library-level access types (including + -- library-level anonymous access types, such as for components), + -- where a simple subprogram address is used. elsif AAMP_On_Target and then - (Ekind (E) = E_Anonymous_Access_Subprogram_Type - or else (Ekind (E) = E_Access_Subprogram_Type - and then Present (Enclosing_Subprogram (E)))) + ((Ekind (E) = E_Access_Subprogram_Type + and then Present (Enclosing_Subprogram (E))) + or else + (Ekind (E) = E_Anonymous_Access_Subprogram_Type + and then + (not Is_Local_Anonymous_Access (E) + or else Present (Enclosing_Subprogram (E))))) then Init_Size (E, 2 * System_Address_Size); - else Init_Size (E, System_Address_Size); end if; @@ -3103,11 +3107,34 @@ package body Layout is -- the type, or the maximum allowed alignment. declare - S : constant Int := UI_To_Int (Esize (E)) / SSU; - A : Nat; + S : Int; + A : Nat; + Max_Alignment : Nat; begin + -- The given Esize may be larger that int'last because of a previous + -- error, and the call to UI_To_Int will fail, so use default. + + if Esize (E) / SSU > Ttypes.Maximum_Alignment then + S := Ttypes.Maximum_Alignment; + + -- If this is an access type and the target doesn't have strict + -- alignment and we are not doing front end layout, then cap the + -- alignment to that of a regular access type. This will avoid + -- giving fat pointers twice the usual alignment for no practical + -- benefit since the misalignment doesn't really matter. + + elsif Is_Access_Type (E) + and then not Target_Strict_Alignment + and then not Frontend_Layout_On_Target + then + S := System_Address_Size / SSU; + + else + S := UI_To_Int (Esize (E)) / SSU; + end if; + -- If the default alignment of "double" floating-point types is -- specifically capped, enforce the cap. diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 29b435a1bc5..1c55a06aa3e 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -26,6 +26,7 @@ with ALI; use ALI; with Atree; use Atree; with Casing; use Casing; +with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Fname; use Fname; @@ -1140,52 +1141,128 @@ package body Lib.Writ is end if; end loop; - -- Output first restrictions line + -- Positional case (only if debug flag -gnatd.R is set) - Write_Info_Initiate ('R'); - Write_Info_Char (' '); + if Debug_Flag_Dot_RR then - -- First the information for the boolean restrictions + -- Output first restrictions line - for R in All_Boolean_Restrictions loop - if Main_Restrictions.Set (R) - and then not Restriction_Warnings (R) - then - Write_Info_Char ('r'); - elsif Main_Restrictions.Violated (R) then - Write_Info_Char ('v'); - else - Write_Info_Char ('n'); - end if; - end loop; + Write_Info_Initiate ('R'); + Write_Info_Char (' '); - -- And now the information for the parameter restrictions + -- First the information for the boolean restrictions - for RP in All_Parameter_Restrictions loop - if Main_Restrictions.Set (RP) - and then not Restriction_Warnings (RP) - then - Write_Info_Char ('r'); - Write_Info_Nat (Nat (Main_Restrictions.Value (RP))); - else - Write_Info_Char ('n'); - end if; + for R in All_Boolean_Restrictions loop + if Main_Restrictions.Set (R) + and then not Restriction_Warnings (R) + then + Write_Info_Char ('r'); + elsif Main_Restrictions.Violated (R) then + Write_Info_Char ('v'); + else + Write_Info_Char ('n'); + end if; + end loop; - if not Main_Restrictions.Violated (RP) - or else RP not in Checked_Parameter_Restrictions - then - Write_Info_Char ('n'); - else - Write_Info_Char ('v'); - Write_Info_Nat (Nat (Main_Restrictions.Count (RP))); + -- And now the information for the parameter restrictions + + for RP in All_Parameter_Restrictions loop + if Main_Restrictions.Set (RP) + and then not Restriction_Warnings (RP) + then + Write_Info_Char ('r'); + Write_Info_Nat (Nat (Main_Restrictions.Value (RP))); + else + Write_Info_Char ('n'); + end if; + + if not Main_Restrictions.Violated (RP) + or else RP not in Checked_Parameter_Restrictions + then + Write_Info_Char ('n'); + else + Write_Info_Char ('v'); + Write_Info_Nat (Nat (Main_Restrictions.Count (RP))); - if Main_Restrictions.Unknown (RP) then - Write_Info_Char ('+'); + if Main_Restrictions.Unknown (RP) then + Write_Info_Char ('+'); + end if; end if; - end if; - end loop; + end loop; - Write_Info_EOL; + Write_Info_EOL; + + -- Named case (if debug flag -gnatd.R is not set) + + else + declare + C : Character; + + begin + -- Write RN header line with preceding blank line + + Write_Info_EOL; + Write_Info_Initiate ('R'); + Write_Info_Char ('N'); + Write_Info_EOL; + + -- First the lines for the boolean restrictions + + for R in All_Boolean_Restrictions loop + if Main_Restrictions.Set (R) + and then not Restriction_Warnings (R) + then + C := 'R'; + elsif Main_Restrictions.Violated (R) then + C := 'V'; + else + goto Continue; + end if; + + Write_Info_Initiate ('R'); + Write_Info_Char (C); + Write_Info_Char (' '); + Write_Info_Str (All_Boolean_Restrictions'Image (R)); + Write_Info_EOL; + + <<Continue>> + null; + end loop; + end; + + -- And now the lines for the parameter restrictions + + for RP in All_Parameter_Restrictions loop + if Main_Restrictions.Set (RP) + and then not Restriction_Warnings (RP) + then + Write_Info_Initiate ('R'); + Write_Info_Str ("R "); + Write_Info_Str (All_Parameter_Restrictions'Image (RP)); + Write_Info_Char ('='); + Write_Info_Nat (Nat (Main_Restrictions.Value (RP))); + Write_Info_EOL; + end if; + + if not Main_Restrictions.Violated (RP) + or else RP not in Checked_Parameter_Restrictions + then + null; + else + Write_Info_Initiate ('R'); + Write_Info_Str ("V "); + Write_Info_Str (All_Parameter_Restrictions'Image (RP)); + Write_Info_Char ('='); + Write_Info_Nat (Nat (Main_Restrictions.Count (RP))); + + if Main_Restrictions.Unknown (RP) then + Write_Info_Char ('+'); + end if; + + Write_Info_EOL; + end if; + end loop; + end if; -- Output R lines for No_Dependence entries diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index d7bea5ea2c4..fdc99482afe 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -262,6 +262,28 @@ package Lib.Writ is -- -- R Restrictions -- -- --------------------- + -- There are two forms for R lines, positional and named. The positional + -- notation is now considered obsolescent, it is not generated by the most + -- recent versions of the compiler except under control of the debug switch + -- -gnatdR, but is still recognized by the binder. + + -- The recognition by the binder is to ease the transition, and better deal + -- with some cases of inconsistent builds using incompatible versions of + -- the compiler and binder. The named notation is the current preferred + -- approach. + + -- Note that R lines are generated using the information in unit Rident, + -- and intepreted by the binder using the information in System.Rident. + -- Normally these two units should be effectively identical. However in + -- some cases of inconsistent builds, they may be different. This may lead + -- to binder diagnostics, which can be suppressed using the -C switch for + -- the binder, which results in ignoring unrecognized restrictions in the + -- ali files. + + -- --------------------------------------- + -- -- R Restrictions (Positional Form) -- + -- --------------------------------------- + -- The first R line records the status of restrictions generated by pragma -- Restrictions encountered, as well as information on what the compiler -- has been able to determine with respect to restrictions violations. @@ -348,6 +370,74 @@ package Lib.Writ is -- signal a fatal error if it is missing. This means that future -- changes to the ALI file format must retain the R line. + -- ---------------------------------- + -- -- R Restrictions (Named Form) -- + -- ---------------------------------- + + -- The first R line for named form announces that named notation will be + -- used, and also assures that there is at least one R line present, which + -- makes parsing of ali files simpler. A blank line preceds the RN line. + + -- RN + + -- In named notation, the restrictions are given as a series of lines, one + -- per retrictions that is specified or violated (no information is present + -- for restrictions that are not specified or violated). In the following + -- name is the name of the restriction in all upper case. + + -- For boolean restrictions, we have only two possibilities. A restrictions + -- pragma is present, or a violation is detected: + + -- RR name + + -- A restriction pragma is present for the named boolean restriction. + -- No violations were detected by the compiler (or the unit in question + -- would have been found to be illegal). + + -- RV name + + -- No restriction pragma is present for the named boolean restriction. + -- However, the compiler did detect one or more violations of this + -- restriction, which may require a binder consistency check. + + -- For the case of restrictions that take a parameter, we need both the + -- information from pragma if present, and the actual information about + -- what possible violations occur. For example, we can have a unit with + -- a pragma Restrictions (Max_Tasks => 4), where the compiler can detect + -- that there are exactly three tasks declared. Both of these pieces + -- of information must be passed to the binder. The parameter of 4 is + -- important in case the total number of tasks in the partition is greater + -- than 4. The parameter of 3 is important in case some other unit has a + -- restrictions pragma with Max_Tasks=>2. + + -- RR name=N + + -- A restriction pragma is present for the named restriction which is + -- one of the restrictions taking a parameter. The value N (a decimal + -- integer) is the value given in the restriction pragma. + + -- RV name=N + + -- A restriction pragma may or may not be present for the restriction + -- given by name (one of the restrictions taking a parameter). But in + -- either case, the compiler detected possible violations. N (a decimal + -- integer) is the maximum or total count of violations (depending + -- on the checking type) in all the units represented by the ali file). + -- The value here is known to be exact by the compiler and is in the + -- range of Natural. Note that if an RR line is present for the same + -- restriction, then the value in the RV line cannot exceed the value + -- in the RR line (since otherwise the compiler would have detected a + -- violation of the restriction). + + -- RV name=N+ + + -- Similar to the above, but the compiler cannot determine the exact + -- count of violations, but it is at least N. + + -- ------------------------------------------------- + -- -- R Restrictions (No_Dependence Information) -- + -- ------------------------------------------------- + -- Subsequent R lines are present only if pragma Restriction No_Dependence -- is used. There is one such line for each such pragma appearing in the -- extended main unit. The format is: @@ -517,18 +607,25 @@ package Lib.Writ is -- -- The attributes may appear in any order, separated by spaces. - -- --------------------- - -- -- W Withed Units -- - -- --------------------- + -- ----------------------------- + -- -- W, Y and Z Withed Units -- + -- ----------------------------- -- Following each U line, is a series of lines of the form -- W unit-name [source-name lib-name] [E] [EA] [ED] [AD] - -- - -- One of these lines is present for each unit that is mentioned in an - -- explicit with clause by the current unit. The first parameter is the - -- unit name in internal format. The second parameter is the file name - -- of the file that must be compiled to compile this unit. It is + -- or + -- Y unit-name [source-name lib-name] [E] [EA] [ED] [AD] + -- or + -- Z unit-name [source-name lib-name] [E] [EA] [ED] [AD] + -- + -- One W line is present for each unit that is mentioned in an explicit + -- non-limited with clause by the current unit. One Y line is present + -- for each unit that is mentioned in an explicit limited with clause + -- by the current unit. One Z line is present for each unit that is + -- only implicitly withed by the current unit. The first parameter is + -- the unit name in internal format. The second parameter is the file + -- name of the file that must be compiled to compile this unit. It is -- usually the file for the body, except for packages which have no -- body. For units that need a body, if the source file for the body -- cannot be found, the file name of the spec is used instead. The @@ -555,8 +652,6 @@ package Lib.Writ is -- generic unit compiled with earlier versions of GNAT which did not -- generate object or ali files for generics. - -- In fact W lines include implicit withs ??? - -- ----------------------- -- -- L Linker_Options -- -- ----------------------- diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index d7607ee097b..f2cc330fdb9 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -661,7 +661,7 @@ package Lib is -- one with no code, but the ALI file has the normal form, and we need -- this ALI file so that the binder can work out a correct order of -- elaboration. - + -- -- However, ancient versions of GNAT used to not generate code or ALI -- files for generic units, and this would yield complex order of -- elaboration issues. These were fixed in GNAT 3.10. The support for not diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index e43495bd238..d45ee140b11 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -2366,7 +2366,7 @@ package body Make is Last_New := Last_New + 1; New_Args (Last_New) := new String'(Name_Buffer (1 .. Name_Len)); - Test_If_Relative_Path + Ensure_Absolute_Path (New_Args (Last_New), Do_Fail => Make_Failed'Access, Parent => Dir_Path, @@ -2399,7 +2399,7 @@ package body Make is Directory.Display_Name); begin - Test_If_Relative_Path + Ensure_Absolute_Path (New_Args (1), Do_Fail => Make_Failed'Access, Parent => Dir_Path, @@ -4435,6 +4435,13 @@ package body Make is declare Success : Boolean := False; begin + -- If gnatmake was invoked with --subdirs and no project file, + -- put the executable in the subdirectory specified. + + if Prj.Subdirs /= null and then Main_Project = No_Project then + Change_Dir (Object_Directory_Path.all); + end if; + Link (Main_ALI_File, Link_With_Shared_Libgcc.all & Args (Args'First .. Last_Arg), @@ -4571,6 +4578,13 @@ package body Make is end if; end if; + -- If gnatmake was invoked with --subdirs and no project file, put the + -- binder generated files in the subdirectory specified. + + if Main_Project = No_Project and then Prj.Subdirs /= null then + Change_Dir (Object_Directory_Path.all); + end if; + begin Bind (Main_ALI_File, Bind_Shared.all & Args (Args'First .. Last_Arg)); @@ -4807,10 +4821,13 @@ package body Make is return; end if; - -- Regenerate libraries, if there are any and if object files - -- have been regenerated. + -- Regenerate libraries, if there are any and if object files have been + -- regenerated. Note that we skip this in CodePeer mode because we don't + -- need libraries in this case, and more importantly, the object files + -- may not be present. if Main_Project /= No_Project + and then not CodePeer_Mode and then MLib.Tgt.Support_For_Libraries /= Prj.None and then (Do_Bind_Step or Unique_Compile_All_Projects @@ -5011,36 +5028,36 @@ package body Make is Get_Name_String (Main_Project.Directory.Display_Name); begin for J in 1 .. Binder_Switches.Last loop - Test_If_Relative_Path + Ensure_Absolute_Path (Binder_Switches.Table (J), Do_Fail => Make_Failed'Access, - Parent => Dir_Path, Including_L_Switch => False); + Parent => Dir_Path, For_Gnatbind => True); end loop; for J in 1 .. Saved_Binder_Switches.Last loop - Test_If_Relative_Path + Ensure_Absolute_Path (Saved_Binder_Switches.Table (J), - Do_Fail => Make_Failed'Access, - Parent => Current_Work_Dir, - Including_L_Switch => False); + Do_Fail => Make_Failed'Access, + Parent => Current_Work_Dir, + For_Gnatbind => True); end loop; for J in 1 .. Linker_Switches.Last loop - Test_If_Relative_Path + Ensure_Absolute_Path (Linker_Switches.Table (J), Parent => Dir_Path, Do_Fail => Make_Failed'Access); end loop; for J in 1 .. Saved_Linker_Switches.Last loop - Test_If_Relative_Path + Ensure_Absolute_Path (Saved_Linker_Switches.Table (J), Do_Fail => Make_Failed'Access, Parent => Current_Work_Dir); end loop; for J in 1 .. Gcc_Switches.Last loop - Test_If_Relative_Path + Ensure_Absolute_Path (Gcc_Switches.Table (J), Do_Fail => Make_Failed'Access, Parent => Dir_Path, @@ -5048,7 +5065,7 @@ package body Make is end loop; for J in 1 .. Saved_Gcc_Switches.Last loop - Test_If_Relative_Path + Ensure_Absolute_Path (Saved_Gcc_Switches.Table (J), Parent => Current_Work_Dir, Do_Fail => Make_Failed'Access, @@ -5370,14 +5387,14 @@ package body Make is Get_Name_String (Main_Project.Directory.Display_Name); begin for J in Last_Binder_Switch + 1 .. Binder_Switches.Last loop - Test_If_Relative_Path + Ensure_Absolute_Path (Binder_Switches.Table (J), Do_Fail => Make_Failed'Access, - Parent => Dir_Path, Including_L_Switch => False); + Parent => Dir_Path, For_Gnatbind => True); end loop; for J in Last_Linker_Switch + 1 .. Linker_Switches.Last loop - Test_If_Relative_Path + Ensure_Absolute_Path (Linker_Switches.Table (J), Parent => Dir_Path, Do_Fail => Make_Failed'Access); diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index bc3a0ee1409..cdbe1aa134c 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -507,6 +507,109 @@ package body Makeutl is return Name_Find; end Create_Name; + --------------------------- + -- Ensure_Absolute_Path -- + --------------------------- + + procedure Ensure_Absolute_Path + (Switch : in out String_Access; + Parent : String; + Do_Fail : Fail_Proc; + For_Gnatbind : Boolean := False; + Including_Non_Switch : Boolean := True; + Including_RTS : Boolean := False) + is + begin + if Switch /= null then + declare + Sw : String (1 .. Switch'Length); + Start : Positive; + + begin + Sw := Switch.all; + + if Sw (1) = '-' then + if Sw'Length >= 3 + and then (Sw (2) = 'I' + or else (not For_Gnatbind + and then (Sw (2) = 'L' + or else Sw (2) = 'A'))) + then + Start := 3; + + if Sw = "-I-" then + return; + end if; + + elsif Sw'Length >= 4 + and then (Sw (2 .. 3) = "aL" + or else + Sw (2 .. 3) = "aO" + or else + Sw (2 .. 3) = "aI" + or else + (For_Gnatbind and then Sw (2 .. 3) = "A=")) + then + Start := 4; + + elsif Including_RTS + and then Sw'Length >= 7 + and then Sw (2 .. 6) = "-RTS=" + then + Start := 7; + + else + return; + end if; + + -- Because relative path arguments to --RTS= may be relative to + -- the search directory prefix, those relative path arguments + -- are converted only when they include directory information. + + if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then + if Parent'Length = 0 then + Do_Fail + ("relative search path switches (""" + & Sw + & """) are not allowed"); + + elsif Including_RTS then + for J in Start .. Sw'Last loop + if Sw (J) = Directory_Separator then + Switch := + new String' + (Sw (1 .. Start - 1) & + Parent & + Directory_Separator & + Sw (Start .. Sw'Last)); + return; + end if; + end loop; + + else + Switch := + new String' + (Sw (1 .. Start - 1) & + Parent & + Directory_Separator & + Sw (Start .. Sw'Last)); + end if; + end if; + + elsif Including_Non_Switch then + if not Is_Absolute_Path (Sw) then + if Parent'Length = 0 then + Do_Fail + ("relative paths (""" & Sw & """) are not allowed"); + else + Switch := new String'(Parent & Directory_Separator & Sw); + end if; + end if; + end if; + end; + end if; + end Ensure_Absolute_Path; + ---------------------------- -- Executable_Prefix_Path -- ---------------------------- @@ -1316,11 +1419,12 @@ package body Makeutl is -- Object files and -L switches specified with relative -- paths must be converted to absolute paths. - Test_If_Relative_Path - (Switch => Linker_Options_Buffer (Last_Linker_Option), - Parent => Dir_Path, - Do_Fail => Do_Fail, - Including_L_Switch => True); + Ensure_Absolute_Path + (Switch => + Linker_Options_Buffer (Last_Linker_Option), + Parent => Dir_Path, + Do_Fail => Do_Fail, + For_Gnatbind => False); end if; Options := In_Tree.Shared.String_Elements.Table (Options).Next; @@ -1935,106 +2039,6 @@ package body Makeutl is end if; end Path_Or_File_Name; - --------------------------- - -- Test_If_Relative_Path -- - --------------------------- - - procedure Test_If_Relative_Path - (Switch : in out String_Access; - Parent : String; - Do_Fail : Fail_Proc; - Including_L_Switch : Boolean := True; - Including_Non_Switch : Boolean := True; - Including_RTS : Boolean := False) - is - begin - if Switch /= null then - declare - Sw : String (1 .. Switch'Length); - Start : Positive; - - begin - Sw := Switch.all; - - if Sw (1) = '-' then - if Sw'Length >= 3 - and then (Sw (2) = 'A' - or else Sw (2) = 'I' - or else (Including_L_Switch and then Sw (2) = 'L')) - then - Start := 3; - - if Sw = "-I-" then - return; - end if; - - elsif Sw'Length >= 4 - and then (Sw (2 .. 3) = "aL" - or else - Sw (2 .. 3) = "aO" - or else - Sw (2 .. 3) = "aI") - then - Start := 4; - - elsif Including_RTS - and then Sw'Length >= 7 - and then Sw (2 .. 6) = "-RTS=" - then - Start := 7; - - else - return; - end if; - - -- Because relative path arguments to --RTS= may be relative to - -- the search directory prefix, those relative path arguments - -- are converted only when they include directory information. - - if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then - if Parent'Length = 0 then - Do_Fail - ("relative search path switches (""" - & Sw - & """) are not allowed"); - - elsif Including_RTS then - for J in Start .. Sw'Last loop - if Sw (J) = Directory_Separator then - Switch := - new String' - (Sw (1 .. Start - 1) & - Parent & - Directory_Separator & - Sw (Start .. Sw'Last)); - return; - end if; - end loop; - - else - Switch := - new String' - (Sw (1 .. Start - 1) & - Parent & - Directory_Separator & - Sw (Start .. Sw'Last)); - end if; - end if; - - elsif Including_Non_Switch then - if not Is_Absolute_Path (Sw) then - if Parent'Length = 0 then - Do_Fail - ("relative paths (""" & Sw & """) are not allowed"); - else - Switch := new String'(Parent & Directory_Separator & Sw); - end if; - end if; - end if; - end; - end if; - end Test_If_Relative_Path; - ------------------- -- Unit_Index_Of -- ------------------- diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 3ddb2085dd8..1b899c1bb45 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -128,6 +128,21 @@ package Makeutl is -- source files are still associated with the same units). Return the name -- of the unit if everything is still valid. Return No_Name otherwise. + procedure Ensure_Absolute_Path + (Switch : in out String_Access; + Parent : String; + Do_Fail : Fail_Proc; + For_Gnatbind : Boolean := False; + Including_Non_Switch : Boolean := True; + Including_RTS : Boolean := False); + -- Do nothing if Switch is an absolute path switch. If relative, fail if + -- Parent is the empty string, otherwise prepend the path with Parent. This + -- subprogram is only used when using project files. If For_Gnatbind is + -- True, consider gnatbind specific syntax for -L (not a path, left + -- unchanged) and -A (path is optional, preceded with "=" if present). + -- If Including_RTS is True, process also switches --RTS=. Do_Fail is + -- called in case of error. Using Osint.Fail might be appropriate. + function Is_Subunit (Source : Source_Id) return Boolean; -- Return True if source is a subunit @@ -151,26 +166,6 @@ package Makeutl is -- entered by a call to Prj.Ext.Add, so that in a project file, External -- ("name") will return "value". - procedure Verbose_Msg - (N1 : Name_Id; - S1 : String; - N2 : Name_Id := No_Name; - S2 : String := ""; - Prefix : String := " -> "; - Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); - procedure Verbose_Msg - (N1 : File_Name_Type; - S1 : String; - N2 : File_Name_Type := No_File; - S2 : String := ""; - Prefix : String := " -> "; - Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); - -- If the verbose flag (Verbose_Mode) is set and the verbosity level is at - -- least equal to Minimum_Verbosity, then print Prefix to standard output - -- followed by N1 and S1. If N2 /= No_Name then N2 is printed after S1. S2 - -- is printed last. Both N1 and N2 are printed in quotation marks. The two - -- forms differ only in taking Name_Id or File_name_Type arguments. - type Name_Ids is array (Positive range <>) of Name_Id; No_Names : constant Name_Ids := (1 .. 0 => No_Name); -- Name_Ids is used for list of language names in procedure Get_Directories @@ -231,27 +226,32 @@ package Makeutl is -- of project Project, in project tree In_Tree, and in the projects that -- it imports directly or indirectly, and returns the result. + function Path_Or_File_Name (Path : Path_Name_Type) return String; + -- Returns a file name if -df is used, otherwise return a path name + function Unit_Index_Of (ALI_File : File_Name_Type) return Int; -- Find the index of a unit in a source file. Return zero if the file is -- not a multi-unit source file. - procedure Test_If_Relative_Path - (Switch : in out String_Access; - Parent : String; - Do_Fail : Fail_Proc; - Including_L_Switch : Boolean := True; - Including_Non_Switch : Boolean := True; - Including_RTS : Boolean := False); - -- Test if Switch is a relative search path switch. If so, fail if Parent - -- is the empty string, otherwise prepend the path with Parent. This - -- subprogram is only used when using project files. For gnatbind switches, - -- Including_L_Switch is False, because the argument of the -L switch is - -- not a path. If Including_RTS is True, process also switches --RTS=. - -- Do_Fail is called in case of error. Using Osint.Fail might be - -- appropriate. - - function Path_Or_File_Name (Path : Path_Name_Type) return String; - -- Returns a file name if -df is used, otherwise return a path name + procedure Verbose_Msg + (N1 : Name_Id; + S1 : String; + N2 : Name_Id := No_Name; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); + procedure Verbose_Msg + (N1 : File_Name_Type; + S1 : String; + N2 : File_Name_Type := No_File; + S2 : String := ""; + Prefix : String := " -> "; + Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); + -- If the verbose flag (Verbose_Mode) is set and the verbosity level is at + -- least equal to Minimum_Verbosity, then print Prefix to standard output + -- followed by N1 and S1. If N2 /= No_Name then N2 is printed after S1. S2 + -- is printed last. Both N1 and N2 are printed in quotation marks. The two + -- forms differ only in taking Name_Id or File_name_Type arguments. ------------------------- -- Program termination -- @@ -280,10 +280,11 @@ package Makeutl is For_Lang : Name_Id; For_Builder : Boolean; Has_Global_Compilation_Switches : Boolean) return Boolean; - -- For_Builder is true if we have a builder switch - -- This function should return True in case of success (the switch is - -- valid), False otherwise. The error message will be displayed by + -- For_Builder is true if we have a builder switch. This function + -- should return True in case of success (the switch is valid), + -- False otherwise. The error message will be displayed by -- Compute_Builder_Switches itself. + -- -- Has_Global_Compilation_Switches is True if the attribute -- Global_Compilation_Switches is defined in the project. @@ -292,10 +293,10 @@ package Makeutl is Root_Environment : in out Prj.Tree.Environment; Main_Project : Project_Id; Only_For_Lang : Name_Id := No_Name); - -- Compute the builder switches and global compilation switches. - -- Every time a switch is found in the project, it is passed to Add_Switch. - -- You can provide a value for Only_For_Lang so that we only look for - -- this language when parsing the global compilation switches. + -- Compute the builder switches and global compilation switches. Every time + -- a switch is found in the project, it is passed to Add_Switch. You can + -- provide a value for Only_For_Lang so that we only look for this language + -- when parsing the global compilation switches. ----------------------- -- Project_Tree data -- diff --git a/gcc/ada/mkdir.c b/gcc/ada/mkdir.c index debd8067779..b8dba597240 100644 --- a/gcc/ada/mkdir.c +++ b/gcc/ada/mkdir.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2002-2009, Free Software Foundation, Inc. * + * Copyright (C) 2002-2012, 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- * @@ -58,14 +58,20 @@ /* This function provides a portable binding to the mkdir function. */ int -__gnat_mkdir (char *dir_name) +__gnat_mkdir (char *dir_name, int encoding ATTRIBUTE_UNUSED) { #if defined (__vxworks) && !(defined (__RTP__) && (_WRS_VXWORKS_MINOR != 0)) return mkdir (dir_name); #elif defined (__MINGW32__) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; - S2WSC (wname, dir_name, GNAT_MAX_PATH_LEN + 2); + if (encoding == Encoding_Unspecified) + S2WSC (wname, dir_name, GNAT_MAX_PATH_LEN); + else if (encoding == Encoding_UTF8) + S2WSU (wname, dir_name, GNAT_MAX_PATH_LEN); + else + S2WS (wname, dir_name, GNAT_MAX_PATH_LEN); + return _tmkdir (wname); #else return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO); diff --git a/gcc/ada/mlib-utl.adb b/gcc/ada/mlib-utl.adb index 2e3f0c0c108..edd6749d1c7 100644 --- a/gcc/ada/mlib-utl.adb +++ b/gcc/ada/mlib-utl.adb @@ -355,8 +355,10 @@ package body MLib.Utl is -- The linker option which specifies the response file as a string Using_GNU_response_file : constant Boolean := - Object_File_Option'Length > 0 - and then Object_File_Option (Object_File_Option'Last) = '@'; + Object_File_Option'Length > 0 + and then + Object_File_Option + (Object_File_Option'Last) = '@'; -- Whether a GNU response file is used Tname : String_Access; @@ -395,6 +397,7 @@ package body MLib.Utl is procedure Write_RF (S : String) is Success : Boolean := True; + begin -- If a GNU response file is used, space and backslash need to be -- escaped because they are interpreted as a string separator and @@ -403,17 +406,18 @@ package body MLib.Utl is -- they are interpreted as string delimiters on both sides. if Using_GNU_response_file then - for I in S'Range loop - if S (I) = ' ' or else S (I) = '\' then + for J in S'Range loop + if S (J) = ' ' or else S (J) = '\' then if Write (Tname_FD, ASCII.BACK_SLASH'Address, 1) /= 1 then Success := False; end if; end if; - if Write (Tname_FD, S (I)'Address, 1) /= 1 then + if Write (Tname_FD, S (J)'Address, 1) /= 1 then Success := False; end if; end loop; + else if Write (Tname_FD, S'Address, S'Length) /= S'Length then Success := False; @@ -429,6 +433,8 @@ package body MLib.Utl is end if; end Write_RF; + -- Start of processing for Gcc + begin if Driver_Name = No_Name then if Gcc_Exec = null then @@ -544,6 +550,7 @@ package body MLib.Utl is end loop; if Object_List_File_Supported and then Link_Bytes > Link_Max then + -- Create a temporary file containing the object files, one object -- file per line for maximal compatibility with linkers supporting -- this option. diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 97e7ba7897a..a6c0cf3dff2 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1070,8 +1070,9 @@ package Opt is Overflow_Checks_Unsuppressed : Boolean := False; -- GNAT - -- Set to True if at least one occurrence of pragma Unsuppress - -- (All_Checks|Overflow_Checks) has been processed. + -- This flag is True if there has been at least one pragma with the + -- effect of unsuppressing overflow checks, meaning that a more careful + -- check of the current mode is required. Persistent_BSS_Mode : Boolean := False; -- GNAT @@ -1249,7 +1250,7 @@ package Opt is -- GNAT -- Set to True if -gnatp (suppress all checks) switch present. - Suppress_Options : Suppress_Array; + Suppress_Options : Suppress_Record; -- GNAT -- Flags set True to suppress corresponding check, i.e. add an implicit -- pragma Suppress at the outer level of each unit compiled. Note that diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 9a2e7ee26f3..3e452b5d6de 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -1659,7 +1659,7 @@ package body Osint is -- be reset later (turning some on if -gnato is not specified, and -- turning all of them on if -gnatp is specified). - Suppress_Options := (others => False); + Suppress_Options := ((others => False), Check_All, Check_All); -- Reserve the first slot in the search paths table. This is the -- directory of the main source file or main library file and is filled @@ -3103,9 +3103,9 @@ package body Osint is return null; end To_Canonical_Path_Spec; - --------------------------- + ---------------------- -- To_Host_Dir_Spec -- - --------------------------- + ---------------------- function To_Host_Dir_Spec (Canonical_Dir : String; @@ -3138,9 +3138,9 @@ package body Osint is end if; end To_Host_Dir_Spec; - ---------------------------- + ----------------------- -- To_Host_File_Spec -- - ---------------------------- + ----------------------- function To_Host_File_Spec (Canonical_File : String) return String_Access diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 9526e325e0a..d3ed8515c38 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -132,6 +132,251 @@ package body Ch13 is return Result; end Aspect_Specifications_Present; + ------------------------------- + -- Get_Aspect_Specifications -- + ------------------------------- + + function Get_Aspect_Specifications + (Semicolon : Boolean := True) return List_Id + is + Aspects : List_Id; + Aspect : Node_Id; + A_Id : Aspect_Id; + OK : Boolean; + + begin + Aspects := Empty_List; + + -- Check if aspect specification present + + if not Aspect_Specifications_Present then + if Semicolon then + TF_Semicolon; + end if; + + return Aspects; + end if; + + Scan; -- past WITH + Aspects := Empty_List; + + loop + OK := True; + + if Token /= Tok_Identifier then + Error_Msg_SC ("aspect identifier expected"); + + if Semicolon then + Resync_Past_Semicolon; + end if; + + return Aspects; + end if; + + -- We have an identifier (which should be an aspect identifier) + + A_Id := Get_Aspect_Id (Token_Name); + Aspect := + Make_Aspect_Specification (Token_Ptr, + Identifier => Token_Node); + + -- No valid aspect identifier present + + if A_Id = No_Aspect then + Error_Msg_SC ("aspect identifier expected"); + + -- Check bad spelling + + for J in Aspect_Id_Exclude_No_Aspect loop + if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then + Error_Msg_Name_1 := Aspect_Names (J); + Error_Msg_SC -- CODEFIX + ("\possible misspelling of%"); + exit; + end if; + end loop; + + Scan; -- past incorrect identifier + + if Token = Tok_Apostrophe then + Scan; -- past ' + Scan; -- past presumably CLASS + end if; + + if Token = Tok_Arrow then + Scan; -- Past arrow + Set_Expression (Aspect, P_Expression); + OK := False; + + elsif Token = Tok_Comma then + OK := False; + + else + if Semicolon then + Resync_Past_Semicolon; + end if; + + return Aspects; + end if; + + -- OK aspect scanned + + else + Scan; -- past identifier + + -- Check for 'Class present + + if Token = Tok_Apostrophe then + if not Class_Aspect_OK (A_Id) then + Error_Msg_Node_1 := Identifier (Aspect); + Error_Msg_SC ("aspect& does not permit attribute here"); + Scan; -- past apostrophe + Scan; -- past presumed CLASS + OK := False; + + else + Scan; -- past apostrophe + + if Token /= Tok_Identifier + or else Token_Name /= Name_Class + then + Error_Msg_SC ("Class attribute expected here"); + OK := False; + + if Token = Tok_Identifier then + Scan; -- past identifier not CLASS + end if; + + else + Scan; -- past CLASS + Set_Class_Present (Aspect); + end if; + end if; + end if; + + -- Test case of missing aspect definition + + if Token = Tok_Comma + or else Token = Tok_Semicolon + then + if Aspect_Argument (A_Id) /= Optional then + Error_Msg_Node_1 := Identifier (Aspect); + Error_Msg_AP ("aspect& requires an aspect definition"); + OK := False; + end if; + + elsif not Semicolon and then Token /= Tok_Arrow then + if Aspect_Argument (A_Id) /= Optional then + + -- The name or expression may be there, but the arrow is + -- missing. Skip to the end of the declaration. + + T_Arrow; + Resync_To_Semicolon; + end if; + + -- Here we have an aspect definition + + else + if Token = Tok_Arrow then + Scan; -- past arrow + else + T_Arrow; + OK := False; + end if; + + if Aspect_Argument (A_Id) = Name then + Set_Expression (Aspect, P_Name); + else + Set_Expression (Aspect, P_Expression); + end if; + end if; + + -- If OK clause scanned, add it to the list + + if OK then + Append (Aspect, Aspects); + end if; + + if Token = Tok_Comma then + Scan; -- past comma + goto Continue; + + -- Recognize the case where a comma is missing between two + -- aspects, issue an error and proceed with next aspect. + + elsif Token = Tok_Identifier + and then Get_Aspect_Id (Token_Name) /= No_Aspect + then + declare + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); + Scan; -- past identifier + + if Token = Tok_Arrow then + Restore_Scan_State (Scan_State); + Error_Msg_AP -- CODEFIX + ("|missing "","""); + goto Continue; + + else + Restore_Scan_State (Scan_State); + end if; + end; + + -- Recognize the case where a semicolon was mistyped for a comma + -- between two aspects, issue an error and proceed with next + -- aspect. + + elsif Token = Tok_Semicolon then + declare + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); + Scan; -- past semicolon + + if Token = Tok_Identifier + and then Get_Aspect_Id (Token_Name) /= No_Aspect + then + Scan; -- past identifier + + if Token = Tok_Arrow then + Restore_Scan_State (Scan_State); + Error_Msg_SC -- CODEFIX + ("|"";"" should be "","""); + Scan; -- past semicolon + goto Continue; + + else + Restore_Scan_State (Scan_State); + end if; + + else + Restore_Scan_State (Scan_State); + end if; + end; + end if; + + -- Must be terminator character + + if Semicolon then + T_Semicolon; + end if; + + exit; + + <<Continue>> + null; + end if; + end loop; + + return Aspects; + + end Get_Aspect_Specifications; + -------------------------------------------- -- 13.1 Representation Clause (also I.7) -- -------------------------------------------- @@ -221,7 +466,14 @@ package body Ch13 is if Token = Tok_Identifier then Attr_Name := Token_Name; - if not Is_Attribute_Name (Attr_Name) then + -- Note that the parser must complain in case of an internal + -- attribute name that comes from source since internal names + -- are meant to be used only by the compiler. + + if not Is_Attribute_Name (Attr_Name) + and then (not Is_Internal_Attribute_Name (Attr_Name) + or else Comes_From_Source (Token_Node)) + then Signal_Bad_Attribute; end if; @@ -390,244 +642,18 @@ package body Ch13 is Semicolon : Boolean := True) is Aspects : List_Id; - Aspect : Node_Id; - A_Id : Aspect_Id; - OK : Boolean; Ptr : Source_Ptr; begin - -- Check if aspect specification present - - if not Aspect_Specifications_Present then - if Semicolon then - TF_Semicolon; - end if; - - return; - end if; - -- Aspect Specification is present Ptr := Token_Ptr; - Scan; -- past WITH -- Here we have an aspect specification to scan, note that we don't -- set the flag till later, because it may turn out that we have no -- valid aspects in the list. - Aspects := Empty_List; - loop - OK := True; - - if Token /= Tok_Identifier then - Error_Msg_SC ("aspect identifier expected"); - - if Semicolon then - Resync_Past_Semicolon; - end if; - - return; - end if; - - -- We have an identifier (which should be an aspect identifier) - - A_Id := Get_Aspect_Id (Token_Name); - Aspect := - Make_Aspect_Specification (Token_Ptr, - Identifier => Token_Node); - - -- No valid aspect identifier present - - if A_Id = No_Aspect then - Error_Msg_SC ("aspect identifier expected"); - - -- Check bad spelling - - for J in Aspect_Id loop - if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then - Error_Msg_Name_1 := Aspect_Names (J); - Error_Msg_SC -- CODEFIX - ("\possible misspelling of%"); - exit; - end if; - end loop; - - Scan; -- past incorrect identifier - - if Token = Tok_Apostrophe then - Scan; -- past ' - Scan; -- past presumably CLASS - end if; - - if Token = Tok_Arrow then - Scan; -- Past arrow - Set_Expression (Aspect, P_Expression); - OK := False; - - elsif Token = Tok_Comma then - OK := False; - - else - if Semicolon then - Resync_Past_Semicolon; - end if; - - return; - end if; - - -- OK aspect scanned - - else - Scan; -- past identifier - - -- Check for 'Class present - - if Token = Tok_Apostrophe then - if not Class_Aspect_OK (A_Id) then - Error_Msg_Node_1 := Identifier (Aspect); - Error_Msg_SC ("aspect& does not permit attribute here"); - Scan; -- past apostrophe - Scan; -- past presumed CLASS - OK := False; - - else - Scan; -- past apostrophe - - if Token /= Tok_Identifier - or else Token_Name /= Name_Class - then - Error_Msg_SC ("Class attribute expected here"); - OK := False; - - if Token = Tok_Identifier then - Scan; -- past identifier not CLASS - end if; - - else - Scan; -- past CLASS - Set_Class_Present (Aspect); - end if; - end if; - end if; - - -- Test case of missing aspect definition - - if Token = Tok_Comma - or else Token = Tok_Semicolon - then - if Aspect_Argument (A_Id) /= Optional then - Error_Msg_Node_1 := Identifier (Aspect); - Error_Msg_AP ("aspect& requires an aspect definition"); - OK := False; - end if; - - elsif not Semicolon and then Token /= Tok_Arrow then - if Aspect_Argument (A_Id) /= Optional then - - -- The name or expression may be there, but the arrow is - -- missing. Skip to the end of the declaration. - - T_Arrow; - Resync_To_Semicolon; - end if; - - -- Here we have an aspect definition - - else - if Token = Tok_Arrow then - Scan; -- past arrow - else - T_Arrow; - OK := False; - end if; - - if Aspect_Argument (A_Id) = Name then - Set_Expression (Aspect, P_Name); - else - Set_Expression (Aspect, P_Expression); - end if; - end if; - - -- If OK clause scanned, add it to the list - - if OK then - Append (Aspect, Aspects); - end if; - - if Token = Tok_Comma then - Scan; -- past comma - goto Continue; - - -- Recognize the case where a comma is missing between two - -- aspects, issue an error and proceed with next aspect. - - elsif Token = Tok_Identifier - and then Get_Aspect_Id (Token_Name) /= No_Aspect - then - declare - Scan_State : Saved_Scan_State; - - begin - Save_Scan_State (Scan_State); - Scan; -- past identifier - - if Token = Tok_Arrow then - Restore_Scan_State (Scan_State); - Error_Msg_AP -- CODEFIX - ("|missing "","""); - goto Continue; - - else - Restore_Scan_State (Scan_State); - end if; - end; - - -- Recognize the case where a semicolon was mistyped for a comma - -- between two aspects, issue an error and proceed with next - -- aspect. - - elsif Token = Tok_Semicolon then - declare - Scan_State : Saved_Scan_State; - - begin - Save_Scan_State (Scan_State); - Scan; -- past semicolon - - if Token = Tok_Identifier - and then Get_Aspect_Id (Token_Name) /= No_Aspect - then - Scan; -- past identifier - - if Token = Tok_Arrow then - Restore_Scan_State (Scan_State); - Error_Msg_SC -- CODEFIX - ("|"";"" should be "","""); - Scan; -- past semicolon - goto Continue; - - else - Restore_Scan_State (Scan_State); - end if; - - else - Restore_Scan_State (Scan_State); - end if; - end; - end if; - - -- Must be terminator character - - if Semicolon then - T_Semicolon; - end if; - - exit; - - <<Continue>> - null; - end if; - end loop; + Aspects := Get_Aspect_Specifications (Semicolon); -- Here if aspects present @@ -807,11 +833,10 @@ package body Ch13 is -- Otherwise we have an illegal range attribute. Note that P_Name -- ensures that Token = Tok_Range is the only possibility left here. - else -- Token = Tok_Range + else Error_Msg_SC ("RANGE attribute illegal here!"); raise Error_Resync; end if; - end P_Code_Statement; end Ch13; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index f527dbe81cb..4f6ccb52339 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -154,6 +154,7 @@ package body Ch6 is function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is Specification_Node : Node_Id; Name_Node : Node_Id; + Aspects : List_Id; Fpart_List : List_Id; Fpart_Sloc : Source_Ptr; Result_Not_Null : Boolean := False; @@ -186,6 +187,8 @@ package body Ch6 is Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Lreq := False; + Aspects := Empty_List; + -- Ada 2005: Scan leading NOT OVERRIDING indicator if Token = Tok_Not then @@ -810,6 +813,16 @@ package body Ch6 is New_Node (N_Subprogram_Body, Sloc (Specification_Node)); Set_Specification (Body_Node, Specification_Node); + -- If aspects are present, the specification is parsed as + -- a subprogram declaration, and we jump here after seeing + -- the keyword IS. Attach asspects previously collected to + -- the body. + + if Is_Non_Empty_List (Aspects) then + Set_Parent (Aspects, Body_Node); + Set_Aspect_Specifications (Body_Node, Aspects); + end if; + -- In SPARK, a HIDE directive can be placed at the beginning -- of a subprogram implementation, thus hiding the -- subprogram body from SPARK tool-set. No violation of the @@ -841,7 +854,24 @@ package body Ch6 is Decl_Node := New_Node (N_Subprogram_Declaration, Sloc (Specification_Node)); Set_Specification (Decl_Node, Specification_Node); - P_Aspect_Specifications (Decl_Node); + Aspects := Get_Aspect_Specifications (Semicolon => False); + + -- Aspects may be present on a subprogram body. The source parsed + -- so far is that of its specification, go parse the body and attach + -- the collected aspects, if any, to the body. + + if Token = Tok_Is then + Scan; + goto Subprogram_Body; + + else + if Is_Non_Empty_List (Aspects) then + Set_Parent (Aspects, Decl_Node); + Set_Aspect_Specifications (Decl_Node, Aspects); + end if; + + TF_Semicolon; + end if; -- If this is a context in which a subprogram body is permitted, -- set active SIS entry in case (see section titled "Handling @@ -1532,7 +1562,12 @@ package body Ch6 is ("(style) IN should be omitted"); end if; - if Token = Tok_Access then + -- Since Ada 2005, formal objects can have an anonymous access type, + -- and of course carry a mode indicator. + + if Token = Tok_Access + and then Nkind (Node) /= N_Formal_Object_Declaration + then Error_Msg_SP ("IN not allowed together with ACCESS"); Scan; -- past ACCESS end if; diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 12f7015f6a5..e6d4e19d6ac 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -199,7 +199,7 @@ package body Endh is End_OK := True; Scan; -- past END - -- Set End_Span if expected. note that this will be useless + -- Set End_Span if expected. Note that this will be useless -- if we do not have the right ending keyword, but in this -- case we have a malformed program anyway, and the setting -- of End_Span will simply be unreliable in this case anyway. diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index f281c7964f0..efcf70bf352 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 3f9d541ef7f..892aac86bfd 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -876,6 +876,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- for aspects so it does not matter whether the aspect specifications -- are terminated by semicolon or some other character. + function Get_Aspect_Specifications + (Semicolon : Boolean := True) return List_Id; + -- Parse a list of aspects but do not attach them to a declaration node. + -- Subsidiary to the following procedure. Used when parsing a subprogram + -- specification that may be a declaration or a body. + procedure P_Aspect_Specifications (Decl : Node_Id; Semicolon : Boolean := True); diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 28fa18681ce..78ff71bfd3b 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2012, 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- -- @@ -25,6 +25,7 @@ with Atree; use Atree; with Debug; use Debug; +with Errout; use Errout; with Lib; use Lib; with Lib.Util; use Lib.Util; with Namet; use Namet; @@ -69,9 +70,9 @@ package body Par_SCO is -- We need to be able to get to conditions quickly for handling the calls -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to - -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify - -- the conditions and pragmas in the table by their starting sloc, and use - -- this hash table to map from these sloc values to SCO_Table indexes. + -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the + -- conditions and pragmas in the table by their starting sloc, and use this + -- hash table to map from these sloc values to SCO_Table indexes. type Header_Num is new Integer range 0 .. 996; -- Type for hash table headers @@ -133,13 +134,16 @@ package body Par_SCO is -- F/T/S/E for a valid dominance marker, or ' ' for no dominant N : Node_Id; - -- Node providing the sloc(s) for the dominance marker + -- Node providing the Sloc(s) for the dominance marker end record; No_Dominant : constant Dominant_Info := (' ', Empty); procedure Traverse_Declarations_Or_Statements (L : List_Id; - D : Dominant_Info := No_Dominant); + D : Dominant_Info := No_Dominant; + P : Node_Id := Empty); + -- Process L, a list of statements or declarations dominated by D. + -- If P is present, it is processed as though it had been prepended to L. procedure Traverse_Generic_Instantiation (N : Node_Id); procedure Traverse_Generic_Package_Declaration (N : Node_Id); @@ -328,9 +332,7 @@ package body Par_SCO is function Is_Logical_Operator (N : Node_Id) return Boolean is begin - return Nkind_In (N, N_Op_Not, - N_And_Then, - N_Or_Else); + return Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else); end Is_Logical_Operator; ----------------------- @@ -475,7 +477,7 @@ package body Par_SCO is procedure Output_Header (T : Character) is Loc : Source_Ptr := No_Location; - -- Node whose sloc is used for the decision + -- Node whose Sloc is used for the decision begin case T is @@ -488,13 +490,27 @@ package body Par_SCO is when 'G' | 'P' => - -- For entry, the token sloc is from the N_Entry_Body. For - -- PRAGMA, we must get the location from the pragma node. - -- Argument N is the pragma argument, and we have to go up two - -- levels (through the pragma argument association) to get to - -- the pragma node itself. - - Loc := Sloc (Parent (Parent (N))); + -- For entry guard, the token sloc is from the N_Entry_Body. + -- For PRAGMA, we must get the location from the pragma node. + -- Argument N is the pragma argument, and we have to go up + -- two levels (through the pragma argument association) to + -- get to the pragma node itself. For the guard on a select + -- alternative, we do not have access to the token location for + -- the WHEN, so we use the first sloc of the condition itself + -- (note: we use First_Sloc, not Sloc, because this is what is + -- referenced by dominance markers). + + -- Doesn't this requirement of using First_Sloc need to be + -- documented in the spec ??? + + if Nkind_In (Parent (N), N_Accept_Alternative, + N_Delay_Alternative, + N_Terminate_Alternative) + then + Loc := First_Sloc (N); + else + Loc := Sloc (Parent (Parent (N))); + end if; when 'X' => @@ -547,10 +563,7 @@ package body Par_SCO is -- Logical operators, output table entries and then process -- operands recursively to deal with nested conditions. - when N_And_Then | - N_Or_Else | - N_Op_Not => - + when N_And_Then | N_Or_Else | N_Op_Not => declare T : Character; @@ -1036,7 +1049,8 @@ package body Par_SCO is procedure Traverse_Declarations_Or_Statements (L : List_Id; - D : Dominant_Info := No_Dominant) + D : Dominant_Info := No_Dominant; + P : Node_Id := Empty) is Current_Dominant : Dominant_Info := D; -- Dominance information for the current basic block @@ -1044,8 +1058,7 @@ package body Par_SCO is Current_Test : Node_Id; -- Conditional node (N_If_Statement or N_Elsiif being processed - N : Node_Id; - Dummy : Source_Ptr; + N : Node_Id; SC_First : constant Nat := SC.Last + 1; SD_First : constant Nat := SD.Last + 1; @@ -1056,15 +1069,6 @@ package body Par_SCO is -- is the letter that identifies the type of statement/declaration that -- is being added to the sequence. - procedure Extend_Statement_Sequence - (From : Node_Id; - To : Node_Id; - Typ : Character); - -- This version extends the current statement sequence with an entry - -- that starts with the first token of From, and ends with the last - -- token of To. It is used for example in a CASE statement to cover - -- the range from the CASE token to the last token of the expression. - procedure Set_Statement_Entry; -- Output CS entries for all statements saved in table SC, and end the -- current CS sequence. @@ -1080,6 +1084,9 @@ package body Par_SCO is pragma Inline (Process_Decisions_Defer); -- Same case for list arguments, deferred call to Process_Decisions + procedure Traverse_One (N : Node_Id); + -- Traverse one declaration or statement + ------------------------- -- Set_Statement_Entry -- ------------------------- @@ -1180,24 +1187,50 @@ package body Par_SCO is ------------------------------- procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is - F : Source_Ptr; - T : Source_Ptr; + F : Source_Ptr; + T : Source_Ptr; + Dummy : Source_Ptr; + To_Node : Node_Id := Empty; + begin Sloc_Range (N, F, T); - SC.Append ((N, F, T, Typ)); - end Extend_Statement_Sequence; - procedure Extend_Statement_Sequence - (From : Node_Id; - To : Node_Id; - Typ : Character) - is - F : Source_Ptr; - T : Source_Ptr; - begin - Sloc_Range (From, F, Dummy); - Sloc_Range (To, Dummy, T); - SC.Append ((From, F, T, Typ)); + case Nkind (N) is + when N_Accept_Statement => + if Present (Parameter_Specifications (N)) then + To_Node := Last (Parameter_Specifications (N)); + elsif Present (Entry_Index (N)) then + To_Node := Entry_Index (N); + end if; + + when N_Case_Statement => + To_Node := Expression (N); + + when N_If_Statement | N_Elsif_Part => + To_Node := Condition (N); + + when N_Extended_Return_Statement => + To_Node := Last (Return_Object_Declarations (N)); + + when N_Loop_Statement => + To_Node := Iteration_Scheme (N); + + when N_Selective_Accept | + N_Timed_Entry_Call | + N_Conditional_Entry_Call | + N_Asynchronous_Select => + T := F; + + when others => + null; + + end case; + + if Present (To_Node) then + Sloc_Range (To_Node, Dummy, T); + end if; + + SC.Append ((N, F, T, Typ)); end Extend_Statement_Sequence; ----------------------------- @@ -1214,430 +1247,554 @@ package body Par_SCO is SD.Append ((Empty, L, T, Current_Pragma_Sloc)); end Process_Decisions_Defer; - -- Start of processing for Traverse_Declarations_Or_Statements + ------------------ + -- Traverse_One -- + ------------------ - begin - if Is_Non_Empty_List (L) then + procedure Traverse_One (N : Node_Id) is + begin + -- Initialize or extend current statement sequence. Note that for + -- special cases such as IF and Case statements we will modify + -- the range to exclude internal statements that should not be + -- counted as part of the current statement sequence. - -- Loop through statements or declarations + case Nkind (N) is - N := First (L); - while Present (N) loop + -- Package declaration - -- Initialize or extend current statement sequence. Note that for - -- special cases such as IF and Case statements we will modify - -- the range to exclude internal statements that should not be - -- counted as part of the current statement sequence. + when N_Package_Declaration => + Set_Statement_Entry; + Traverse_Package_Declaration (N); - case Nkind (N) is + -- Generic package declaration - -- Package declaration + when N_Generic_Package_Declaration => + Set_Statement_Entry; + Traverse_Generic_Package_Declaration (N); - when N_Package_Declaration => - Set_Statement_Entry; - Traverse_Package_Declaration (N); + -- Package body - -- Generic package declaration + when N_Package_Body => + Set_Statement_Entry; + Traverse_Package_Body (N); - when N_Generic_Package_Declaration => - Set_Statement_Entry; - Traverse_Generic_Package_Declaration (N); + -- Subprogram declaration - -- Package body + when N_Subprogram_Declaration => + Process_Decisions_Defer + (Parameter_Specifications (Specification (N)), 'X'); - when N_Package_Body => - Set_Statement_Entry; - Traverse_Package_Body (N); + -- Generic subprogram declaration + + when N_Generic_Subprogram_Declaration => + Process_Decisions_Defer + (Generic_Formal_Declarations (N), 'X'); + Process_Decisions_Defer + (Parameter_Specifications (Specification (N)), 'X'); - -- Subprogram declaration + -- Task or subprogram body - when N_Subprogram_Declaration => - Process_Decisions_Defer - (Parameter_Specifications (Specification (N)), 'X'); + when N_Task_Body | N_Subprogram_Body => + Set_Statement_Entry; + Traverse_Subprogram_Or_Task_Body (N); - -- Generic subprogram declaration + -- Entry body - when N_Generic_Subprogram_Declaration => - Process_Decisions_Defer - (Generic_Formal_Declarations (N), 'X'); - Process_Decisions_Defer - (Parameter_Specifications (Specification (N)), 'X'); + when N_Entry_Body => + declare + Cond : constant Node_Id := + Condition (Entry_Body_Formal_Part (N)); - -- Task or subprogram body + Inner_Dominant : Dominant_Info := No_Dominant; - when N_Task_Body | N_Subprogram_Body => + begin Set_Statement_Entry; - Traverse_Subprogram_Or_Task_Body (N); - -- Entry body + if Present (Cond) then + Process_Decisions_Defer (Cond, 'G'); - when N_Entry_Body => - declare - Cond : constant Node_Id := - Condition (Entry_Body_Formal_Part (N)); - Inner_Dominant : Dominant_Info := No_Dominant; - begin - Set_Statement_Entry; + -- For an entry body with a barrier, the entry body + -- is dominanted by a True evaluation of the barrier. - if Present (Cond) then - Process_Decisions_Defer (Cond, 'G'); + Inner_Dominant := ('T', N); + end if; - -- For an entry body with a barrier, the entry body - -- is dominanted by a True evaluation of the barrier. + Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant); + end; - Inner_Dominant := ('T', N); - end if; + -- Protected body - Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant); - end; + when N_Protected_Body => + Set_Statement_Entry; + Traverse_Protected_Body (N); - -- Protected body + -- Exit statement, which is an exit statement in the SCO sense, + -- so it is included in the current statement sequence, but + -- then it terminates this sequence. We also have to process + -- any decisions in the exit statement expression. - when N_Protected_Body => - Set_Statement_Entry; - Traverse_Protected_Body (N); + when N_Exit_Statement => + Extend_Statement_Sequence (N, ' '); + Process_Decisions_Defer (Condition (N), 'E'); + Set_Statement_Entry; - -- Exit statement, which is an exit statement in the SCO sense, - -- so it is included in the current statement sequence, but - -- then it terminates this sequence. We also have to process - -- any decisions in the exit statement expression. + -- If condition is present, then following statement is + -- only executed if the condition evaluates to False. - when N_Exit_Statement => - Extend_Statement_Sequence (N, ' '); - Process_Decisions_Defer (Condition (N), 'E'); - Set_Statement_Entry; + if Present (Condition (N)) then + Current_Dominant := ('F', N); + else + Current_Dominant := No_Dominant; + end if; - -- If condition is present, then following statement is - -- only executed if the condition evaluates to False. + -- Label, which breaks the current statement sequence, but the + -- label itself is not included in the next statement sequence, + -- since it generates no code. - if Present (Condition (N)) then - Current_Dominant := ('F', N); - else - Current_Dominant := No_Dominant; - end if; + when N_Label => + Set_Statement_Entry; + Current_Dominant := No_Dominant; - -- Label, which breaks the current statement sequence, but the - -- label itself is not included in the next statement sequence, - -- since it generates no code. + -- Block statement, which breaks the current statement sequence - when N_Label => - Set_Statement_Entry; - Current_Dominant := No_Dominant; + when N_Block_Statement => + Set_Statement_Entry; + Traverse_Declarations_Or_Statements + (L => Declarations (N), + D => Current_Dominant); + Traverse_Handled_Statement_Sequence + (N => Handled_Statement_Sequence (N), + D => Current_Dominant); - -- Block statement, which breaks the current statement sequence + -- If statement, which breaks the current statement sequence, + -- but we include the condition in the current sequence. - when N_Block_Statement => - Set_Statement_Entry; - Traverse_Declarations_Or_Statements - (L => Declarations (N), - D => Current_Dominant); - Traverse_Handled_Statement_Sequence - (N => Handled_Statement_Sequence (N), - D => Current_Dominant); + when N_If_Statement => + Current_Test := N; + Extend_Statement_Sequence (N, 'I'); + Process_Decisions_Defer (Condition (N), 'I'); + Set_Statement_Entry; - -- If statement, which breaks the current statement sequence, - -- but we include the condition in the current sequence. + -- Now we traverse the statements in the THEN part - when N_If_Statement => - Current_Test := N; - Extend_Statement_Sequence (N, Condition (N), 'I'); - Process_Decisions_Defer (Condition (N), 'I'); - Set_Statement_Entry; + Traverse_Declarations_Or_Statements + (L => Then_Statements (N), + D => ('T', N)); - -- Now we traverse the statements in the THEN part + -- Loop through ELSIF parts if present - Traverse_Declarations_Or_Statements - (L => Then_Statements (N), - D => ('T', N)); + if Present (Elsif_Parts (N)) then + declare + Saved_Dominant : constant Dominant_Info := + Current_Dominant; - -- Loop through ELSIF parts if present + Elif : Node_Id := First (Elsif_Parts (N)); - if Present (Elsif_Parts (N)) then - declare - Saved_Dominant : constant Dominant_Info := - Current_Dominant; - Elif : Node_Id := First (Elsif_Parts (N)); + begin + while Present (Elif) loop - begin - while Present (Elif) loop + -- An Elsif is executed only if the previous test + -- got a FALSE outcome. - -- An Elsif is executed only if the previous test - -- got a FALSE outcome. + Current_Dominant := ('F', Current_Test); - Current_Dominant := ('F', Current_Test); + -- Now update current test information - -- Now update current test information + Current_Test := Elif; - Current_Test := Elif; + -- We generate a statement sequence for the + -- construct "ELSIF condition", so that we have + -- a statement for the resulting decisions. - -- We generate a statement sequence for the - -- construct "ELSIF condition", so that we have - -- a statement for the resulting decisions. + Extend_Statement_Sequence (Elif, 'I'); + Process_Decisions_Defer (Condition (Elif), 'I'); + Set_Statement_Entry; - Extend_Statement_Sequence - (Elif, Condition (Elif), 'I'); - Process_Decisions_Defer (Condition (Elif), 'I'); - Set_Statement_Entry; + -- An ELSIF part is never guaranteed to have + -- been executed, following statements are only + -- dominated by the initial IF statement. - -- An ELSIF part is never guaranteed to have - -- been executed, following statements are only - -- dominated by the initial IF statement. + Current_Dominant := Saved_Dominant; - Current_Dominant := Saved_Dominant; + -- Traverse the statements in the ELSIF - -- Traverse the statements in the ELSIF + Traverse_Declarations_Or_Statements + (L => Then_Statements (Elif), + D => ('T', Elif)); + Next (Elif); + end loop; + end; + end if; - Traverse_Declarations_Or_Statements - (L => Then_Statements (Elif), - D => ('T', Elif)); - Next (Elif); - end loop; - end; - end if; + -- Finally traverse the ELSE statements if present - -- Finally traverse the ELSE statements if present + Traverse_Declarations_Or_Statements + (L => Else_Statements (N), + D => ('F', Current_Test)); - Traverse_Declarations_Or_Statements - (L => Else_Statements (N), - D => ('F', Current_Test)); + -- CASE statement, which breaks the current statement sequence, + -- but we include the expression in the current sequence. - -- Case statement, which breaks the current statement sequence, - -- but we include the expression in the current sequence. + when N_Case_Statement => + Extend_Statement_Sequence (N, 'C'); + Process_Decisions_Defer (Expression (N), 'X'); + Set_Statement_Entry; - when N_Case_Statement => - Extend_Statement_Sequence (N, Expression (N), 'C'); - Process_Decisions_Defer (Expression (N), 'X'); - Set_Statement_Entry; + -- Process case branches, all of which are dominated by the + -- CASE statement. - -- Process case branches, all of which are dominated by the - -- CASE statement. + declare + Alt : Node_Id; + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + Traverse_Declarations_Or_Statements + (L => Statements (Alt), + D => Current_Dominant); + Next (Alt); + end loop; + end; - declare - Alt : Node_Id; - begin - Alt := First (Alternatives (N)); - while Present (Alt) loop - Traverse_Declarations_Or_Statements - (L => Statements (Alt), - D => Current_Dominant); - Next (Alt); - end loop; - end; + -- ACCEPT statement - -- Unconditional exit points, which are included in the current - -- statement sequence, but then terminate it + when N_Accept_Statement => + Extend_Statement_Sequence (N, 'A'); + Set_Statement_Entry; - when N_Requeue_Statement | - N_Goto_Statement | - N_Raise_Statement => - Extend_Statement_Sequence (N, ' '); - Set_Statement_Entry; - Current_Dominant := No_Dominant; + -- Process sequence of statements, dominant is the ACCEPT + -- statement. - -- Simple return statement. which is an exit point, but we - -- have to process the return expression for decisions. + Traverse_Handled_Statement_Sequence + (N => Handled_Statement_Sequence (N), + D => Current_Dominant); - when N_Simple_Return_Statement => - Extend_Statement_Sequence (N, ' '); - Process_Decisions_Defer (Expression (N), 'X'); - Set_Statement_Entry; - Current_Dominant := No_Dominant; + -- SELECT - -- Extended return statement + when N_Selective_Accept => + Extend_Statement_Sequence (N, 'S'); + Set_Statement_Entry; - when N_Extended_Return_Statement => - Extend_Statement_Sequence - (N, Last (Return_Object_Declarations (N)), 'R'); - Process_Decisions_Defer - (Return_Object_Declarations (N), 'X'); - Set_Statement_Entry; + -- Process alternatives - Traverse_Handled_Statement_Sequence - (N => Handled_Statement_Sequence (N), - D => Current_Dominant); + declare + Alt : Node_Id; + Guard : Node_Id; + S_Dom : Dominant_Info; - Current_Dominant := No_Dominant; + begin + Alt := First (Select_Alternatives (N)); + while Present (Alt) loop + S_Dom := Current_Dominant; + Guard := Condition (Alt); + + if Present (Guard) then + Process_Decisions + (Guard, + 'G', + Pragma_Sloc => No_Location); + Current_Dominant := ('T', Guard); + end if; - -- Loop ends the current statement sequence, but we include - -- the iteration scheme if present in the current sequence. - -- But the body of the loop starts a new sequence, since it - -- may not be executed as part of the current sequence. + Traverse_One (Alt); - when N_Loop_Statement => - declare - ISC : constant Node_Id := Iteration_Scheme (N); - Inner_Dominant : Dominant_Info := No_Dominant; + Current_Dominant := S_Dom; + Next (Alt); + end loop; + end; - begin - if Present (ISC) then + Traverse_Declarations_Or_Statements + (L => Else_Statements (N), + D => Current_Dominant); - -- If iteration scheme present, extend the current - -- statement sequence to include the iteration scheme - -- and process any decisions it contains. + when N_Timed_Entry_Call | N_Conditional_Entry_Call => + Extend_Statement_Sequence (N, 'S'); + Set_Statement_Entry; - -- While loop + -- Process alternatives - if Present (Condition (ISC)) then - Extend_Statement_Sequence (N, ISC, 'W'); - Process_Decisions_Defer (Condition (ISC), 'W'); + Traverse_One (Entry_Call_Alternative (N)); - -- Set more specific dominant for inner statements - -- (the control sloc for the decision is that of - -- the WHILE token). + if Nkind (N) = N_Timed_Entry_Call then + Traverse_One (Delay_Alternative (N)); + else + Traverse_Declarations_Or_Statements + (L => Else_Statements (N), + D => Current_Dominant); + end if; - Inner_Dominant := ('T', ISC); + when N_Asynchronous_Select => + Extend_Statement_Sequence (N, 'S'); + Set_Statement_Entry; - -- For loop + Traverse_One (Triggering_Alternative (N)); + Traverse_Declarations_Or_Statements + (L => Statements (Abortable_Part (N)), + D => Current_Dominant); - else - Extend_Statement_Sequence (N, ISC, 'F'); - Process_Decisions_Defer - (Loop_Parameter_Specification (ISC), 'X'); - end if; - end if; + when N_Accept_Alternative => + Traverse_Declarations_Or_Statements + (L => Statements (N), + D => Current_Dominant, + P => Accept_Statement (N)); - Set_Statement_Entry; + when N_Entry_Call_Alternative => + Traverse_Declarations_Or_Statements + (L => Statements (N), + D => Current_Dominant, + P => Entry_Call_Statement (N)); - if Inner_Dominant = No_Dominant then - Inner_Dominant := Current_Dominant; - end if; + when N_Delay_Alternative => + Traverse_Declarations_Or_Statements + (L => Statements (N), + D => Current_Dominant, + P => Delay_Statement (N)); - Traverse_Declarations_Or_Statements - (L => Statements (N), - D => Inner_Dominant); - end; + when N_Triggering_Alternative => + Traverse_Declarations_Or_Statements + (L => Statements (N), + D => Current_Dominant, + P => Triggering_Statement (N)); - -- Pragma + when N_Terminate_Alternative => - when N_Pragma => + -- It is dubious to emit a statement SCO for a TERMINATE + -- alternative, since no code is actually executed if the + -- alternative is selected -- the tasking runtime call just + -- never returns??? - -- Record sloc of pragma (pragmas don't nest) + Extend_Statement_Sequence (N, ' '); + Set_Statement_Entry; - pragma Assert (Current_Pragma_Sloc = No_Location); - Current_Pragma_Sloc := Sloc (N); + -- Unconditional exit points, which are included in the current + -- statement sequence, but then terminate it - -- Processing depends on the kind of pragma + when N_Requeue_Statement | + N_Goto_Statement | + N_Raise_Statement => + Extend_Statement_Sequence (N, ' '); + Set_Statement_Entry; + Current_Dominant := No_Dominant; - declare - Nam : constant Name_Id := Pragma_Name (N); - Arg : Node_Id := First (Pragma_Argument_Associations (N)); - Typ : Character; + -- Simple return statement. which is an exit point, but we + -- have to process the return expression for decisions. - begin - case Nam is - when Name_Assert | - Name_Check | - Name_Precondition | - Name_Postcondition => - - -- For Assert/Check/Precondition/Postcondition, we - -- must generate a P entry for the decision. Note - -- that this is done unconditionally at this stage. - -- Output for disabled pragmas is suppressed later - -- on when we output the decision line in Put_SCOs, - -- depending on setting by Set_SCO_Pragma_Enabled. - - if Nam = Name_Check then - Next (Arg); - end if; + when N_Simple_Return_Statement => + Extend_Statement_Sequence (N, ' '); + Process_Decisions_Defer (Expression (N), 'X'); + Set_Statement_Entry; + Current_Dominant := No_Dominant; - Process_Decisions_Defer (Expression (Arg), 'P'); - Typ := 'p'; + -- Extended return statement - when Name_Debug => - if Present (Arg) and then Present (Next (Arg)) then + when N_Extended_Return_Statement => + Extend_Statement_Sequence (N, 'R'); + Process_Decisions_Defer + (Return_Object_Declarations (N), 'X'); + Set_Statement_Entry; - -- Case of a dyadic pragma Debug: first argument - -- is a P decision, any nested decision in the - -- second argument is an X decision. + Traverse_Handled_Statement_Sequence + (N => Handled_Statement_Sequence (N), + D => Current_Dominant); - Process_Decisions_Defer (Expression (Arg), 'P'); - Next (Arg); - end if; + Current_Dominant := No_Dominant; - Process_Decisions_Defer (Expression (Arg), 'X'); - Typ := 'p'; + -- Loop ends the current statement sequence, but we include + -- the iteration scheme if present in the current sequence. + -- But the body of the loop starts a new sequence, since it + -- may not be executed as part of the current sequence. - -- For all other pragmas, we generate decision entries - -- for any embedded expressions, and the pragma is - -- never disabled. + when N_Loop_Statement => + declare + ISC : constant Node_Id := Iteration_Scheme (N); + Inner_Dominant : Dominant_Info := No_Dominant; - when others => - Process_Decisions_Defer (N, 'X'); - Typ := 'P'; - end case; + begin + if Present (ISC) then - -- Add statement SCO + -- If iteration scheme present, extend the current + -- statement sequence to include the iteration scheme + -- and process any decisions it contains. - Extend_Statement_Sequence (N, Typ); + -- While loop - Current_Pragma_Sloc := No_Location; - end; + if Present (Condition (ISC)) then + Extend_Statement_Sequence (N, 'W'); + Process_Decisions_Defer (Condition (ISC), 'W'); - -- Object declaration. Ignored if Prev_Ids is set, since the - -- parser generates multiple instances of the whole declaration - -- if there is more than one identifier declared, and we only - -- want one entry in the SCO's, so we take the first, for which - -- Prev_Ids is False. + -- Set more specific dominant for inner statements + -- (the control sloc for the decision is that of + -- the WHILE token). - when N_Object_Declaration => - if not Prev_Ids (N) then - Extend_Statement_Sequence (N, 'o'); + Inner_Dominant := ('T', ISC); - if Has_Decision (N) then - Process_Decisions_Defer (N, 'X'); + -- For loop + + else + Extend_Statement_Sequence (N, 'F'); + Process_Decisions_Defer + (Loop_Parameter_Specification (ISC), 'X'); end if; end if; - -- All other cases, which extend the current statement sequence - -- but do not terminate it, even if they have nested decisions. + Set_Statement_Entry; - when others => + if Inner_Dominant = No_Dominant then + Inner_Dominant := Current_Dominant; + end if; - -- Determine required type character code, or ASCII.NUL if - -- no SCO should be generated for this node. + Traverse_Declarations_Or_Statements + (L => Statements (N), + D => Inner_Dominant); + end; - declare - Typ : Character; + -- Pragma - begin - case Nkind (N) is - when N_Full_Type_Declaration | - N_Incomplete_Type_Declaration | - N_Private_Type_Declaration | - N_Private_Extension_Declaration => - Typ := 't'; + when N_Pragma => - when N_Subtype_Declaration => - Typ := 's'; + -- Record sloc of pragma (pragmas don't nest) - when N_Renaming_Declaration => - Typ := 'r'; + pragma Assert (Current_Pragma_Sloc = No_Location); + Current_Pragma_Sloc := Sloc (N); - when N_Generic_Instantiation => - Typ := 'i'; + -- Processing depends on the kind of pragma - when N_Representation_Clause | - N_Use_Package_Clause | - N_Use_Type_Clause => - Typ := ASCII.NUL; + declare + Nam : constant Name_Id := Pragma_Name (N); + Arg : Node_Id := + First (Pragma_Argument_Associations (N)); + Typ : Character; - when others => - Typ := ' '; - end case; + begin + case Nam is + when Name_Assert | + Name_Check | + Name_Precondition | + Name_Postcondition => + + -- For Assert/Check/Precondition/Postcondition, we + -- must generate a P entry for the decision. Note + -- that this is done unconditionally at this stage. + -- Output for disabled pragmas is suppressed later + -- on when we output the decision line in Put_SCOs, + -- depending on setting by Set_SCO_Pragma_Enabled. + + if Nam = Name_Check then + Next (Arg); + end if; - if Typ /= ASCII.NUL then - Extend_Statement_Sequence (N, Typ); - end if; - end; + Process_Decisions_Defer (Expression (Arg), 'P'); + Typ := 'p'; - -- Process any embedded decisions + when Name_Debug => + if Present (Arg) and then Present (Next (Arg)) then + + -- Case of a dyadic pragma Debug: first argument + -- is a P decision, any nested decision in the + -- second argument is an X decision. + + Process_Decisions_Defer (Expression (Arg), 'P'); + Next (Arg); + end if; + + Process_Decisions_Defer (Expression (Arg), 'X'); + Typ := 'p'; + + -- For all other pragmas, we generate decision entries + -- for any embedded expressions, and the pragma is + -- never disabled. + + when others => + Process_Decisions_Defer (N, 'X'); + Typ := 'P'; + end case; + + -- Add statement SCO + + Extend_Statement_Sequence (N, Typ); + + Current_Pragma_Sloc := No_Location; + end; + + -- Object declaration. Ignored if Prev_Ids is set, since the + -- parser generates multiple instances of the whole declaration + -- if there is more than one identifier declared, and we only + -- want one entry in the SCO's, so we take the first, for which + -- Prev_Ids is False. + + when N_Object_Declaration => + if not Prev_Ids (N) then + Extend_Statement_Sequence (N, 'o'); if Has_Decision (N) then Process_Decisions_Defer (N, 'X'); end if; - end case; + end if; + + -- All other cases, which extend the current statement sequence + -- but do not terminate it, even if they have nested decisions. + + when others => + + -- Determine required type character code, or ASCII.NUL if + -- no SCO should be generated for this node. + + declare + Typ : Character; + + begin + case Nkind (N) is + when N_Full_Type_Declaration | + N_Incomplete_Type_Declaration | + N_Private_Type_Declaration | + N_Private_Extension_Declaration => + Typ := 't'; + + when N_Subtype_Declaration => + Typ := 's'; + + when N_Renaming_Declaration => + Typ := 'r'; + + when N_Generic_Instantiation => + Typ := 'i'; + + when N_Representation_Clause | + N_Use_Package_Clause | + N_Use_Type_Clause => + Typ := ASCII.NUL; + + when others => + Typ := ' '; + end case; + + if Typ /= ASCII.NUL then + Extend_Statement_Sequence (N, Typ); + end if; + end; + + -- Process any embedded decisions + + if Has_Decision (N) then + Process_Decisions_Defer (N, 'X'); + end if; + end case; + + end Traverse_One; + -- Start of processing for Traverse_Declarations_Or_Statements + + begin + if Present (P) then + Traverse_One (P); + end if; + + if Is_Non_Empty_List (L) then + + -- Loop through statements or declarations + + N := First (L); + while Present (N) loop + Traverse_One (N); Next (N); end loop; diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads index 450d76938cb..a57f5c5b982 100644 --- a/gcc/ada/par_sco.ads +++ b/gcc/ada/par_sco.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2012, 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- -- @@ -24,7 +24,7 @@ ------------------------------------------------------------------------------ -- This package contains the routines used to deal with generation and output --- of Soure Coverage Obligations (SCO's) used for coverage analysis purposes. +-- of Source Coverage Obligations (SCO's) used for coverage analysis purposes. -- See package SCOs for full documentation of format of SCO information. with Types; use Types; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 0321533fc18..f2af8379100 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -851,7 +851,7 @@ package body Prj.Attr is for Index in Package_Attributes.First .. Package_Attributes.Last loop if Package_Attributes.Table (Index).Name = Pkg_Name then - Fail ("cannot register a package with a non unique name""" + Fail ("cannot register a package with a non unique name """ & Name & """"); Id := Empty_Package; @@ -889,7 +889,7 @@ package body Prj.Attr is for Index in Package_Attributes.First .. Package_Attributes.Last loop if Package_Attributes.Table (Index).Name = Pkg_Name then - Fail ("cannot register a package with a non unique name""" + Fail ("cannot register a package with a non unique name """ & Name & """"); raise Project_Error; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index cd62bc9bf44..77d1cfd1cde 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -165,6 +165,7 @@ package body Prj.Nmsc is type Lib_Data is record Name : Name_Id; Proj : Project_Id; + Tree : Project_Tree_Ref; end record; package Lib_Data_Table is new GNAT.Table @@ -3639,7 +3640,9 @@ package body Prj.Nmsc is -- Check if the same library name is used in an other library project for J in 1 .. Lib_Data_Table.Last loop - if Lib_Data_Table.Table (J).Name = Project.Library_Name then + if Lib_Data_Table.Table (J).Name = Project.Library_Name + and then Lib_Data_Table.Table (J).Tree = Data.Tree + then Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name; Error_Msg (Data.Flags, @@ -3656,7 +3659,9 @@ package body Prj.Nmsc is -- Record the library name Lib_Data_Table.Append - ((Name => Project.Library_Name, Proj => Project)); + ((Name => Project.Library_Name, + Proj => Project, + Tree => Data.Tree)); end if; end Check_Library_Attributes; @@ -4204,22 +4209,25 @@ package body Prj.Nmsc is Lang_Id := Lang_Id.Next; end loop; - -- Get the naming exceptions for all languages + -- Get the naming exceptions for all languages, but not for virtual + -- projects. - for Kind in Spec_Or_Body loop - Lang_Id := Project.Languages; - while Lang_Id /= No_Language_Index loop - case Lang_Id.Config.Kind is + if not Project.Virtual then + for Kind in Spec_Or_Body loop + Lang_Id := Project.Languages; + while Lang_Id /= No_Language_Index loop + case Lang_Id.Config.Kind is when File_Based => Process_Exceptions_File_Based (Lang_Id, Kind); when Unit_Based => Process_Exceptions_Unit_Based (Lang_Id, Kind); - end case; + end case; - Lang_Id := Lang_Id.Next; + Lang_Id := Lang_Id.Next; + end loop; end loop; - end loop; + end if; end Check_Naming; ---------------------------- diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index 9454f9ff418..1ad1aff58a7 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2012, 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- -- @@ -23,11 +23,14 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Containers.Indefinite_Ordered_Sets; +with Ada.Directories; with Ada.Unchecked_Deallocation; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Regexp; use GNAT.Regexp; +with ALI; use ALI; with Osint; use Osint; with Output; use Output; with Opt; @@ -390,6 +393,149 @@ package body Prj.Util is return Add_Suffix (Name_Find); end Executable_Of; + --------------------------- + -- For_Interface_Sources -- + --------------------------- + + procedure For_Interface_Sources + (Tree : Project_Tree_Ref; + Project : Project_Id) + is + use Ada; + use type Ada.Containers.Count_Type; + + package Dep_Names is new Containers.Indefinite_Ordered_Sets (String); + + function Load_ALI (Filename : String) return ALI_Id; + -- Load an ALI file and return its id + + -------------- + -- Load_ALI -- + -------------- + + function Load_ALI (Filename : String) return ALI_Id is + Result : ALI_Id := No_ALI_Id; + Text : Text_Buffer_Ptr; + Lib_File : File_Name_Type; + + begin + if Directories.Exists (Filename) then + Name_Len := 0; + Add_Str_To_Name_Buffer (Filename); + Lib_File := Name_Find; + Text := Osint.Read_Library_Info (Lib_File); + Result := + ALI.Scan_ALI + (Lib_File, + Text, + Ignore_ED => False, + Err => True, + Read_Lines => "UD"); + Free (Text); + end if; + + return Result; + end Load_ALI; + + -- Local declarations + + Iter : Source_Iterator := For_Each_Source (Tree, Project); + Sid : Source_Id; + ALI : ALI_Id; + + First_Unit : Unit_Id; + Second_Unit : Unit_Id; + Body_Needed : Boolean; + Deps : Dep_Names.Set; + + -- Start of processing for For_Interface_Sources + + begin + -- First look at each spec, check if the body is needed + + loop + Sid := Element (Iter); + exit when Sid = No_Source; + + -- Skip sources that are removed/excluded and sources not part of + -- the interface for standalone libraries. + + if Sid.Kind = Spec + and then not Sid.Locally_Removed + and then (Project.Standalone_Library = No + or else Sid.Declared_In_Interfaces) + then + Action (Sid); + + -- Check ALI for dependencies on body and sep + + ALI := + Load_ALI + (Get_Name_String (Get_Object_Directory (Sid.Project, True)) + & Get_Name_String (Sid.Dep_Name)); + + if ALI /= No_ALI_Id then + First_Unit := ALIs.Table (ALI).First_Unit; + Second_Unit := No_Unit_Id; + Body_Needed := True; + + -- If there is both a spec and a body, check if both needed + + if Units.Table (First_Unit).Utype = Is_Body then + Second_Unit := ALIs.Table (ALI).Last_Unit; + + -- If the body is not needed, then reset First_Unit + + if not Units.Table (Second_Unit).Body_Needed_For_SAL then + Body_Needed := False; + end if; + + elsif Units.Table (First_Unit).Utype = Is_Spec_Only then + Body_Needed := False; + end if; + + -- Handle all the separates, if any + + if Body_Needed then + if Other_Part (Sid) /= null then + Deps.Include (Get_Name_String (Other_Part (Sid).File)); + end if; + + for Dep in ALIs.Table (ALI).First_Sdep .. + ALIs.Table (ALI).Last_Sdep + loop + if Sdep.Table (Dep).Subunit_Name /= No_Name then + Deps.Include + (Get_Name_String (Sdep.Table (Dep).Sfile)); + end if; + end loop; + end if; + end if; + end if; + + Next (Iter); + end loop; + + -- Now handle the bodies and separates if needed + + if Deps.Length /= 0 then + Iter := For_Each_Source (Tree, Project); + + loop + Sid := Element (Iter); + exit when Sid = No_Source; + + if Sid.Kind /= Spec + and then Deps.Contains (Get_Name_String (Sid.File)) + then + Action (Sid); + end if; + + Next (Iter); + end loop; + end if; + end For_Interface_Sources; + -------------- -- Get_Line -- -------------- diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads index 89a6491618f..892db282a57 100644 --- a/gcc/ada/prj-util.ads +++ b/gcc/ada/prj-util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2012, 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- -- @@ -60,8 +60,8 @@ package Prj.Util is -- Describe parameters??? procedure Duplicate - (This : in out Name_List_Index; - Shared : Shared_Project_Tree_Data_Access); + (This : in out Name_List_Index; + Shared : Shared_Project_Tree_Data_Access); -- Duplicate a name list function Value_Of @@ -203,14 +203,14 @@ package Prj.Util is -- the flag Source_Info_File_Exists to True for the tree. type Source_Info_Data is record - Project : Name_Id; - Language : Name_Id; - Kind : Source_Kind; - Display_Path_Name : Name_Id; - Path_Name : Name_Id; - Unit_Name : Name_Id := No_Name; - Index : Int := 0; - Naming_Exception : Naming_Exception_Type := No; + Project : Name_Id; + Language : Name_Id; + Kind : Source_Kind; + Display_Path_Name : Name_Id; + Path_Name : Name_Id; + Unit_Name : Name_Id := No_Name; + Index : Int := 0; + Naming_Exception : Naming_Exception_Type := No; end record; -- Data read from a source info file for a single source @@ -233,6 +233,18 @@ package Prj.Util is procedure Next (Iter : in out Source_Info_Iterator); -- Advance the iterator to the next source in the project + generic + with procedure Action (Source : Source_Id); + procedure For_Interface_Sources + (Tree : Project_Tree_Ref; + Project : Project_Id); + -- Call Action for every sources that are needed to use Project. This is + -- either the sources corresponding to the units in attribute Interfaces + -- or all sources of the project. Note that only the bodies that are + -- needed (because the unit is generic or contains some inline pragmas) + -- are handled. This routine must be called only when the project has + -- been built successfully. + private type Text_File_Data is record FD : File_Descriptor := Invalid_FD; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 9a5e2607aa1..150d524d30f 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -584,8 +584,63 @@ package body Prj is In_Aggregate_Lib : Boolean; From_Encapsulated_Lib : Boolean) is + + function Has_Sources (P : Project_Id) return Boolean; + -- Returns True if P has sources + + function Get_From_Tree (P : Project_Id) return Project_Id; + -- Get project P from Tree. If P has no sources get another + -- instance of this project with sources. If P has sources, + -- returns it. + + ----------------- + -- Has_Sources -- + ----------------- + + function Has_Sources (P : Project_Id) return Boolean is + Lang : Language_Ptr; + + begin + Lang := P.Languages; + while Lang /= No_Language_Index loop + if Lang.First_Source /= No_Source then + return True; + end if; + + Lang := Lang.Next; + end loop; + + return False; + end Has_Sources; + + ------------------- + -- Get_From_Tree -- + ------------------- + + function Get_From_Tree (P : Project_Id) return Project_Id is + List : Project_List := Tree.Projects; + + begin + if not Has_Sources (P) then + while List /= null loop + if List.Project.Name = P.Name + and then Has_Sources (List.Project) + then + return List.Project; + end if; + + List := List.Next; + end loop; + end if; + + return P; + end Get_From_Tree; + + -- Local variables + List : Project_List; - T : Project_Tree_Ref; + + -- Start of processing for Recursive_Check begin if not Seen_Name.Contains (Project.Name) then @@ -597,7 +652,7 @@ package body Prj is if not Imported_First then Action - (Project, + (Get_From_Tree (Project), Tree, Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib), With_State); @@ -640,23 +695,20 @@ package body Prj is -- of the aggregate library. if Project.Qualifier = Aggregate_Library then - T := Tree; Recursive_Check - (Agg.Project, T, + (Agg.Project, Tree, True, From_Encapsulated_Lib or else Project.Standalone_Library = Encapsulated); else - T := Agg.Tree; - -- Use a new context as we want to returns the same -- project in different project tree for aggregated -- projects. Recursive_Check_Context - (Agg.Project, T, False, False); + (Agg.Project, Agg.Tree, False, False); end if; Agg := Agg.Next; @@ -666,7 +718,7 @@ package body Prj is if Imported_First then Action - (Project, + (Get_From_Tree (Project), Tree, Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib), With_State); diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index 1c0c593ac15..2fff4eb1fab 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -342,8 +342,8 @@ locating the specified source files in the specified source directories. is explicitly specified. @xref{Naming Schemes}. -@item @code{Source Files} - @cindex @code{Source_Files} +@item @code{Source_Files} +@cindex @code{Source_Files} In some cases, source directories might contain files that should not be included in a project. One can specify the explicit list of file names to be considered through the @b{Source_Files} attribute. diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index 74983ae093e..4da4bd286e5 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -32,7 +32,10 @@ /* Code related to the integration of the GCC mechanism for exception handling. */ -#ifdef IN_RTS +#ifndef IN_RTS +#error "RTS unit only" +#endif + #include "tconfig.h" #include "tsystem.h" #include <sys/stat.h> @@ -40,10 +43,6 @@ typedef char bool; # define true 1 # define false 0 -#else -#include "config.h" -#include "system.h" -#endif #include "adaint.h" #include "raise.h" @@ -56,49 +55,33 @@ typedef char bool; #endif #endif +#if defined (__hpux__) && defined (USE_LIBUNWIND_EXCEPTIONS) +/* HP-UX B.11.31 ia64 libunwind doesn't have _Unwind_GetIPInfo. */ +#undef HAVE_GETIPINFO +#define _UA_END_OF_STACK 0 +#endif + /* The names of a couple of "standard" routines for unwinding/propagation actually vary depending on the underlying GCC scheme for exception handling (SJLJ or DWARF). We need a consistently named interface to import from - a-except, so wrappers are defined here. - - Besides, even though the compiler is never setup to use the GCC propagation - circuitry, it still relies on exceptions internally and part of the sources - to handle to exceptions are shared with the run-time library. We need - dummy definitions for the wrappers to satisfy the linker in this case. - - The types to be used by those wrappers in the run-time library are target - types exported by unwind.h. We used to piggyback on them for the compiler - stubs, but there is no guarantee that unwind.h is always in sight so we - define our own set below. These are dummy types as the wrappers are never - called in the compiler case. */ - -#ifdef IN_RTS + a-except, so wrappers are defined here. */ #include "unwind.h" typedef struct _Unwind_Context _Unwind_Context; typedef struct _Unwind_Exception _Unwind_Exception; -#else - -typedef void _Unwind_Context; -typedef void _Unwind_Exception; -typedef int _Unwind_Reason_Code; - -#endif - _Unwind_Reason_Code __gnat_Unwind_RaiseException (_Unwind_Exception *); _Unwind_Reason_Code __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *); -extern void __gnat_setup_current_excep (_Unwind_Exception *); - -#ifdef IN_RTS /* For eh personality routine */ +extern struct Exception_Occurrence *__gnat_setup_current_excep + (_Unwind_Exception *); +extern void __gnat_unhandled_except_handler (_Unwind_Exception *); #include "dwarf2.h" -#include "unwind-dw2-fde.h" #include "unwind-pe.h" /* The known and handled exception classes. */ @@ -164,31 +147,19 @@ db_indent (int requests) static int current_indentation_level = 0; if (requests & DB_INDENT_RESET) - { - current_indentation_level = 0; - } + current_indentation_level = 0; if (requests & DB_INDENT_INCREASE) - { - current_indentation_level ++; - } + current_indentation_level ++; if (requests & DB_INDENT_DECREASE) - { - current_indentation_level --; - } + current_indentation_level --; if (requests & DB_INDENT_NEWLINE) - { - fprintf (stderr, "\n"); - } + fprintf (stderr, "\n"); if (requests & DB_INDENT_OUTPUT) - { - fprintf (stderr, "%*s", - current_indentation_level * DB_INDENT_UNIT, " "); - } - + fprintf (stderr, "%*s", current_indentation_level * DB_INDENT_UNIT, " "); } static void ATTRIBUTE_PRINTF_2 @@ -236,6 +207,10 @@ db_phases (int phases) * Tables for the dwarf zero cost case * ======================================= + They are fully documented in: + http://sourcery.mentor.com/public/cxx-abi/exceptions.pdf + Here is a shorter presentation, with some specific comments for Ada. + call_site [] ------------------------------------------------------------------- * region-start | region-length | landing-pad | first-action-index * @@ -264,7 +239,8 @@ db_phases (int phases) This table contains lists (called action chains) of possible actions associated with call-site entries described in the call-site [] table. - There is at most one action list per call-site entry. + There is at most one action list per call-site entry. It is SLEB128 + encoded. A null action-filter indicates a cleanup. @@ -272,28 +248,37 @@ db_phases (int phases) (see below), from which information may be retrieved to check if it matches the exception being propagated. - action-filter > 0 means there is a regular handler to be run, - - action-filter < 0 means there is a some "exception_specification" - data to retrieve, which is only relevant for C++ - and should never show up for Ada. - - next-action indexes the next entry in the list. 0 indicates there is - no other entry. + * action-filter > 0: + means there is a regular handler to be run The value is also passed + to the landing pad to dispatch the exception. + + * action-filter < 0: + means there is a some "exception_specification" data to retrieve, + which is only relevant for C++ and should never show up for Ada. + (Exception specification specifies which exceptions can be thrown + by a function. Such filter is emitted around the body of C++ + functions defined like: + void foo ([...]) throw (A, B) { [...] } + These can be viewed as negativ filter: the landing pad is branched + to for exceptions that doesn't match the filter and usually aborts + the program). + + * next-action + points to the next entry in the list using a relative byte offset. 0 + indicates there is no other entry. ttypes [] --------------- * ttype-value * --------------- - A null value indicates a catch-all handler in C++, and an "others" - handler in Ada. + This table is an array of addresses. + + A null value indicates a catch-all handler. (Not used by Ada) Non null values are used to match the exception being propagated: In C++ this is a pointer to some rtti data, while in Ada this is an - exception id. - - The special id value 1 indicates an "all_others" handler. + exception id (with a fake id for others). For C++, this table is actually also used to store "exception specification" data. The differentiation between the two kinds @@ -339,9 +324,9 @@ db_phases (int phases) +=====================+ | the actual base. | ttype-value | | +============+=====================+ | - | | 0 => "others" | | - | ... | 1 => "all others" | <---+ - | | X => exception id | + | | ... | | + | ... | exception id | <---+ + | | ... | | handlers +---------------------+ | | ... | | ... | ... | @@ -441,7 +426,7 @@ db_phases (int phases) | +--> get_region_description_for (context) | - +--> get_action_description_for (context, exception, region) + +--> get_action_description_for (ip, exception, region) | | | +--> get_call_site_action_for (context, region) | (one version for each underlying scheme) @@ -475,6 +460,9 @@ extern const int __gnat_others_value; extern const int __gnat_all_others_value; #define GNAT_ALL_OTHERS ((_Unwind_Ptr) &__gnat_all_others_value) +extern const int __gnat_unhandled_others_value; +#define GNAT_UNHANDLED_OTHERS ((_Unwind_Ptr) &__gnat_unhandled_others_value) + /* Describe the useful region data associated with an unwind context. */ typedef struct @@ -526,15 +514,11 @@ get_ip_from_context (_Unwind_Context *uw_context) } static void -db_region_for (region_descriptor *region, _Unwind_Context *uw_context) +db_region_for (region_descriptor *region, _Unwind_Ptr ip) { - _Unwind_Ptr ip; - if (! (db_accepted_codes () & DB_REGIONS)) return; - ip = get_ip_from_context (uw_context); - db (DB_REGIONS, "For ip @ %p => ", (void *)ip); if (region->lsda) @@ -619,7 +603,7 @@ get_region_description_for (_Unwind_Context *uw_context, /* Describe an action to be taken when propagating an exception up to some context. */ -typedef enum +enum action_kind { /* Found some call site base data, but need to analyze further before being able to decide. */ @@ -632,8 +616,12 @@ typedef enum cleanup, /* There is a handler for the exception in this context. */ - handler -} action_kind; + handler, + + /* There is a handler for the exception, but it is only for catching + unhandled exceptions. */ + unhandler +}; /* filter value for cleanup actions. */ static const int cleanup_filter = 0; @@ -641,7 +629,7 @@ static const int cleanup_filter = 0; typedef struct { /* The kind of action to be taken. */ - action_kind kind; + enum action_kind kind; /* A pointer to the action record entry. */ const unsigned char *table_entry; @@ -653,15 +641,12 @@ typedef struct /* If we have a handler matching our exception, these are the filter to trigger it and the corresponding id. */ _Unwind_Sword ttype_filter; - _Unwind_Ptr ttype_entry; } action_descriptor; static void -db_action_for (action_descriptor *action, _Unwind_Context *uw_context) +db_action_for (action_descriptor *action, _Unwind_Ptr ip) { - _Unwind_Ptr ip = get_ip_from_context (uw_context); - db (DB_ACTIONS, "For ip @ %p => ", (void *)ip); switch (action->kind) @@ -704,12 +689,10 @@ db_action_for (action_descriptor *action, _Unwind_Context *uw_context) #define __builtin_eh_return_data_regno(x) x static void -get_call_site_action_for (_Unwind_Context *uw_context, +get_call_site_action_for (_Unwind_Ptr call_site, region_descriptor *region, action_descriptor *action) { - _Unwind_Ptr call_site = get_ip_from_context (uw_context); - /* call_site is a direct index into the call-site table, with two special values : -1 for no-action and 0 for "terminate". The latter should never show up for Ada. To test for the former, beware that _Unwind_Ptr might @@ -718,17 +701,16 @@ get_call_site_action_for (_Unwind_Context *uw_context, if ((int)call_site < 0) { action->kind = nothing; - return; } else if (call_site == 0) { db (DB_ERR, "========> Err, null call_site for Ada/sjlj\n"); action->kind = nothing; - return; } else { _uleb128_t cs_lp, cs_action; + const unsigned char *p; /* Let the caller know there may be an action to take, but let it determine the kind. */ @@ -738,13 +720,13 @@ get_call_site_action_for (_Unwind_Context *uw_context, made of leb128 values, the encoding length of which is variable. We can't merely compute an offset from the index, then, but have to read all the entries before the one of interest. */ - - const unsigned char *p = region->call_site_table; - - do { - p = read_uleb128 (p, &cs_lp); - p = read_uleb128 (p, &cs_action); - } while (--call_site); + p = region->call_site_table; + do + { + p = read_uleb128 (p, &cs_lp); + p = read_uleb128 (p, &cs_action); + } + while (--call_site); action->landing_pad = cs_lp + 1; @@ -752,20 +734,17 @@ get_call_site_action_for (_Unwind_Context *uw_context, action->table_entry = region->action_table + cs_action - 1; else action->table_entry = 0; - - return; } } #else /* !__USING_SJLJ_EXCEPTIONS__ */ static void -get_call_site_action_for (_Unwind_Context *uw_context, +get_call_site_action_for (_Unwind_Ptr ip, region_descriptor *region, action_descriptor *action) { const unsigned char *p = region->call_site_table; - _Unwind_Ptr ip = get_ip_from_context (uw_context); /* Unless we are able to determine otherwise... */ action->kind = nothing; @@ -837,23 +816,28 @@ extern Exception_Code Import_Code_For (_Unwind_Ptr eid); extern Exception_Id EID_For (_GNAT_Exception * e); -static int +static enum action_kind is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception) { + if (choice == GNAT_ALL_OTHERS) + return handler; + if (propagated_exception->common.exception_class == GNAT_EXCEPTION_CLASS) { /* Pointer to the GNAT exception data corresponding to the propagated occurrence. */ _Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception); + if (choice == GNAT_UNHANDLED_OTHERS) + return unhandler; + + E = (_Unwind_Ptr) EID_For (propagated_exception); + /* Base matching rules: An exception data (id) matches itself, "when all_others" matches anything and "when others" matches anything unless explicitly stated otherwise in the propagated occurrence. */ - - bool is_handled = - choice == E - || choice == GNAT_ALL_OTHERS - || (choice == GNAT_OTHERS && Is_Handled_By_Others (E)); + if (choice == E || (choice == GNAT_OTHERS && Is_Handled_By_Others (E))) + return handler; /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we may have different exception data pointers that should match for the @@ -866,43 +850,44 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception) # define Non_Ada_Error system__aux_dec__non_ada_error extern struct Exception_Data Non_Ada_Error; - is_handled |= - (Language_For (E) == 'V' - && choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS - && ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0 - && Import_Code_For (choice) == Import_Code_For (E)) - || choice == (_Unwind_Ptr)&Non_Ada_Error)); + if ((Language_For (E) == 'V' + && choice != GNAT_OTHERS + && ((Language_For (choice) == 'V' + && Import_Code_For (choice) != 0 + && Import_Code_For (choice) == Import_Code_For (E)) + || choice == (_Unwind_Ptr)&Non_Ada_Error))) + return handler; #endif - - return is_handled; } else { -# define Foreign_Exception system__exceptions__foreign_exception; +# define Foreign_Exception system__exceptions__foreign_exception extern struct Exception_Data Foreign_Exception; - return choice == GNAT_ALL_OTHERS - || choice == GNAT_OTHERS - || choice == (_Unwind_Ptr)&Foreign_Exception; + if (choice == GNAT_ALL_OTHERS + || choice == GNAT_OTHERS + || choice == (_Unwind_Ptr) &Foreign_Exception) + return handler; } + return nothing; } /* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to UW_CONTEXT in REGION. */ static void -get_action_description_for (_Unwind_Context *uw_context, +get_action_description_for (_Unwind_Ptr ip, _Unwind_Exception *uw_exception, _Unwind_Action uw_phase, region_descriptor *region, action_descriptor *action) { - _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception; + _GNAT_Exception *gnat_exception = (_GNAT_Exception *) uw_exception; /* Search the call site table first, which may get us a landing pad as well as the head of an action record list. */ - get_call_site_action_for (uw_context, region, action); - db_action_for (action, uw_context); + get_call_site_action_for (ip, region, action); + db_action_for (action, ip); /* If there is not even a call_site entry, we are done. */ if (action->kind == nothing) @@ -962,15 +947,17 @@ get_action_description_for (_Unwind_Context *uw_context, passed (to follow the ABI). */ if (!(uw_phase & _UA_FORCE_UNWIND)) { + enum action_kind act; + /* See if the filter we have is for an exception which matches the one we are propagating. */ _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter); - if (is_handled_by (choice, gnat_exception)) + act = is_handled_by (choice, gnat_exception); + if (act != nothing) { - action->kind = handler; + action->kind = act; action->ttype_filter = ar_filter; - action->ttype_entry = choice; return; } } @@ -1018,7 +1005,8 @@ setup_to_install (_Unwind_Context *uw_context, /* The following is defined from a-except.adb. Its purpose is to enable automatic backtraces upon exception raise, as provided through the GNAT.Traceback facilities. */ -extern void __gnat_notify_handled_exception (void); +extern void __gnat_notify_handled_exception (struct Exception_Occurrence *); +extern void __gnat_notify_unhandled_exception (struct Exception_Occurrence *); /* Below is the eh personality routine per se. We currently assume that only GNU-Ada exceptions are met. */ @@ -1085,6 +1073,7 @@ PERSONALITY_FUNCTION (version_arg_t version_arg, _Unwind_Action uw_phases = (_Unwind_Action) phases_arg; region_descriptor region; action_descriptor action; + _Unwind_Ptr ip; /* Check that we're called from the ABI context we expect, with a major possible variation on VMS for IA64. */ @@ -1117,7 +1106,8 @@ PERSONALITY_FUNCTION (version_arg_t version_arg, will tell us if there is some lsda, call_site, action and/or ttype data for the associated ip. */ get_region_description_for (uw_context, ®ion); - db_region_for (®ion, uw_context); + ip = get_ip_from_context (uw_context); + db_region_for (®ion, ip); /* No LSDA => no handlers or cleanups => we shall unwind further up. */ if (! region.lsda) @@ -1125,9 +1115,8 @@ PERSONALITY_FUNCTION (version_arg_t version_arg, /* Search the call-site and action-record tables for the action associated with this IP. */ - get_action_description_for (uw_context, uw_exception, uw_phases, - ®ion, &action); - db_action_for (&action, uw_context); + get_action_description_for (ip, uw_exception, uw_phases, ®ion, &action); + db_action_for (&action, ip); /* Whatever the phase, if there is nothing relevant in this frame, unwinding should just go on. */ @@ -1146,11 +1135,16 @@ PERSONALITY_FUNCTION (version_arg_t version_arg, } else { + struct Exception_Occurrence *excep; + /* Trigger the appropriate notification routines before the second phase starts, which ensures the stack is still intact. First, setup the Ada occurrence. */ - __gnat_setup_current_excep (uw_exception); - __gnat_notify_handled_exception (); + excep = __gnat_setup_current_excep (uw_exception); + if (action.kind == unhandler) + __gnat_notify_unhandled_exception (excep); + else + __gnat_notify_handled_exception (excep); return _URC_HANDLER_FOUND; } @@ -1170,79 +1164,241 @@ PERSONALITY_FUNCTION (version_arg_t version_arg, return _URC_INSTALL_CONTEXT; } -/* Define the consistently named wrappers imported by Propagate_Exception. */ +/* Callback routine called by Unwind_ForcedUnwind to execute all the cleanup + before exiting the task. */ -#ifdef __USING_SJLJ_EXCEPTIONS__ +_Unwind_Reason_Code +__gnat_cleanupunwind_handler (int version ATTRIBUTE_UNUSED, + _Unwind_Action phases, + _Unwind_Exception_Class eclass ATTRIBUTE_UNUSED, + struct _Unwind_Exception *exception, + struct _Unwind_Context *context ATTRIBUTE_UNUSED, + void *arg ATTRIBUTE_UNUSED) +{ + /* Terminate when the end of the stack is reached. */ + if ((phases & _UA_END_OF_STACK) != 0 +#if defined (__ia64__) && defined (__hpux__) && defined (USE_LIBUNWIND_EXCEPTIONS) + /* Strictely follow the ia64 ABI: when end of stack is reached, + the callback will be called with a NULL stack pointer. + No need for that when using libgcc unwinder. */ + || _Unwind_GetGR (context, 12) == 0 +#endif + ) + __gnat_unhandled_except_handler (exception); -#undef _Unwind_RaiseException + /* We know there is at least one cleanup further up. Return so that it + is searched and entered, after which Unwind_Resume will be called + and this hook will gain control again. */ + return _URC_NO_REASON; +} + +/* Define the consistently named wrappers imported by Propagate_Exception. */ _Unwind_Reason_Code __gnat_Unwind_RaiseException (_Unwind_Exception *e) { +#ifdef __USING_SJLJ_EXCEPTIONS__ return _Unwind_SjLj_RaiseException (e); +#else + return _Unwind_RaiseException (e); +#endif } - -#undef _Unwind_ForcedUnwind - _Unwind_Reason_Code __gnat_Unwind_ForcedUnwind (_Unwind_Exception *e, - void * handler, - void * argument) + void *handler, + void *argument) { +#ifdef __USING_SJLJ_EXCEPTIONS__ return _Unwind_SjLj_ForcedUnwind (e, handler, argument); +#else + return _Unwind_ForcedUnwind (e, handler, argument); +#endif } +#ifdef __SEH__ -#else /* __USING_SJLJ_EXCEPTIONS__ */ +#define STATUS_USER_DEFINED (1U << 29) + +/* From unwind-seh.c. */ +#define GCC_MAGIC (('G' << 16) | ('C' << 8) | 'C') +#define GCC_EXCEPTION(TYPE) \ + (STATUS_USER_DEFINED | ((TYPE) << 24) | GCC_MAGIC) +#define STATUS_GCC_THROW GCC_EXCEPTION (0) + +EXCEPTION_DISPOSITION __gnat_SEH_error_handler + (struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); + +struct Exception_Data * +__gnat_map_SEH (EXCEPTION_RECORD* ExceptionRecord, const char **msg); + +struct _Unwind_Exception * +__gnat_create_machine_occurrence_from_signal_handler (Exception_Id, + const char *); + +/* Unwind opcodes. */ +#define UWOP_PUSH_NONVOL 0 +#define UWOP_ALLOC_LARGE 1 +#define UWOP_ALLOC_SMALL 2 +#define UWOP_SET_FPREG 3 +#define UWOP_SAVE_NONVOL 4 +#define UWOP_SAVE_NONVOL_FAR 5 +#define UWOP_SAVE_XMM128 8 +#define UWOP_SAVE_XMM128_FAR 9 +#define UWOP_PUSH_MACHFRAME 10 + +/* Modify the IP value saved in the machine frame. This is really a kludge, + that will be removed if we could propagate the Windows exception (and not + the GCC one). + What is very wrong is that the Windows unwinder will try to decode the + instruction at IP, which isn't valid anymore after the adjust. */ -_Unwind_Reason_Code -__gnat_Unwind_RaiseException (_Unwind_Exception *e) +static void +__gnat_adjust_context (unsigned char *unw, ULONG64 rsp) { - return _Unwind_RaiseException (e); -} + unsigned int len; -_Unwind_Reason_Code -__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e, - void * handler, - void * argument) -{ - return _Unwind_ForcedUnwind (e, handler, argument); + /* Version = 1, no flags, no prolog. */ + if (unw[0] != 1 || unw[1] != 0) + return; + len = unw[2]; + /* No frame pointer. */ + if (unw[3] != 0) + return; + unw += 4; + while (len > 0) + { + /* Offset in prolog = 0. */ + if (unw[0] != 0) + return; + switch (unw[1] & 0xf) + { + case UWOP_ALLOC_LARGE: + /* Expect < 512KB. */ + if ((unw[1] & 0xf0) != 0) + return; + rsp += *(unsigned short *)(unw + 2) * 8; + len--; + unw += 2; + break; + case UWOP_SAVE_NONVOL: + case UWOP_SAVE_XMM128: + len--; + unw += 2; + break; + case UWOP_PUSH_MACHFRAME: + { + ULONG64 *rip; + rip = (ULONG64 *)rsp; + if ((unw[1] & 0xf0) == 0x10) + rip++; + /* Adjust rip. */ + (*rip)++; + } + return; + default: + /* Unexpected. */ + return; + } + unw += 2; + len--; + } } -#endif /* __USING_SJLJ_EXCEPTIONS__ */ - -#ifdef __SEH__ EXCEPTION_DISPOSITION __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame, PCONTEXT ms_orig_context, PDISPATCHER_CONTEXT ms_disp) { - return _GCC_specific_handler (ms_exc, this_frame, ms_orig_context, - ms_disp, __gnat_personality_imp); -} -#endif /* SEH */ -#else -/* ! IN_RTS */ + /* Possibly transform run-time errors into Ada exceptions. As a small + optimization, we call __gnat_SEH_error_handler only on non-user + exceptions. */ + if (!(ms_exc->ExceptionCode & STATUS_USER_DEFINED)) + { + struct Exception_Data *exception; + const char *msg; + ULONG64 excpip = (ULONG64) ms_exc->ExceptionAddress; + + if (excpip != 0 + && excpip >= (ms_disp->ImageBase + + ms_disp->FunctionEntry->BeginAddress) + && excpip < (ms_disp->ImageBase + + ms_disp->FunctionEntry->EndAddress)) + { + /* This is a fault in this function. We need to adjust the return + address before raising the GCC exception. */ + CONTEXT context; + PRUNTIME_FUNCTION mf_func = NULL; + ULONG64 mf_imagebase; + ULONG64 mf_rsp = 0; -/* Define the corresponding stubs for the compiler. */ + /* Get the context. */ + RtlCaptureContext (&context); -/* We don't want fancy_abort here. */ -#undef abort + while (1) + { + PRUNTIME_FUNCTION RuntimeFunction; + ULONG64 ImageBase; + VOID *HandlerData; + ULONG64 EstablisherFrame; + + /* Get function metadata. */ + RuntimeFunction = RtlLookupFunctionEntry + (context.Rip, &ImageBase, ms_disp->HistoryTable); + if (RuntimeFunction == ms_disp->FunctionEntry) + break; + mf_func = RuntimeFunction; + mf_imagebase = ImageBase; + mf_rsp = context.Rsp; + + if (!RuntimeFunction) + { + /* In case of failure, assume this is a leaf function. */ + context.Rip = *(ULONG64 *) context.Rsp; + context.Rsp += 8; + } + else + { + /* Unwind. */ + RtlVirtualUnwind (0, ImageBase, context.Rip, RuntimeFunction, + &context, &HandlerData, &EstablisherFrame, + NULL); + } + + /* 0 means bottom of the stack. */ + if (context.Rip == 0) + { + mf_func = NULL; + break; + } + } + if (mf_func != NULL) + __gnat_adjust_context + ((unsigned char *)(mf_imagebase + mf_func->UnwindData), mf_rsp); + } -_Unwind_Reason_Code -__gnat_Unwind_RaiseException (_Unwind_Exception *e ATTRIBUTE_UNUSED) -{ - abort (); -} + exception = __gnat_map_SEH (ms_exc, &msg); + if (exception != NULL) + { + struct _Unwind_Exception *exc; + + /* Directly convert the system exception to a GCC one. + This is really breaking the API, but is necessary for stack size + reasons: the normal way is to call Raise_From_Signal_Handler, + which build the exception and calls _Unwind_RaiseException, which + unwinds the stack and will call this personality routine. But + the Windows unwinder needs about 2KB of stack. */ + exc = __gnat_create_machine_occurrence_from_signal_handler + (exception, msg); + memset (exc->private_, 0, sizeof (exc->private_)); + ms_exc->ExceptionCode = STATUS_GCC_THROW; + ms_exc->NumberParameters = 1; + ms_exc->ExceptionInformation[0] = (ULONG_PTR)exc; + } + } -_Unwind_Reason_Code -__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e ATTRIBUTE_UNUSED, - void * handler ATTRIBUTE_UNUSED, - void * argument ATTRIBUTE_UNUSED) -{ - abort (); + return _GCC_specific_handler (ms_exc, this_frame, ms_orig_context, + ms_disp, __gnat_personality_imp); } - -#endif /* IN_RTS */ +#endif /* SEH */ diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h index d8c245f0983..57611542350 100644 --- a/gcc/ada/raise.h +++ b/gcc/ada/raise.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2011, Free Software Foundation, Inc. * + * Copyright (C) 1992-2012, 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- * @@ -49,6 +49,8 @@ struct Exception_Data typedef struct Exception_Data *Exception_Id; +struct Exception_Occurrence; + extern void _gnat_builtin_longjmp (void *, int); extern void __gnat_unhandled_terminate (void); extern void *__gnat_malloc (__SIZE_TYPE__); diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index ee45e05473d..14ab452b477 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -541,10 +541,10 @@ package body Restrict is then null; - -- Here if restriction set, check for violation (either this is a - -- Boolean restriction, or a parameter restriction with a value of - -- zero and an unknown count, or a parameter restriction with a - -- known value that exceeds the restriction count). + -- Here if restriction set, check for violation (this is a Boolean + -- restriction, or a parameter restriction with a value of zero and an + -- unknown count, or a parameter restriction with a known value that + -- exceeds the restriction count). elsif R in All_Boolean_Restrictions or else (Restrictions.Unknown (R) @@ -1259,8 +1259,7 @@ package body Restrict is (N : Node_Id; Warning : Boolean) is - A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (N)); - pragma Assert (A_Id /= No_Aspect); + A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N)); begin No_Specification_Of_Aspects (A_Id) := Sloc (N); diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 5d03f831267..1d9d67f910e 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads index 6f771145fe7..615e17bfc78 100644 --- a/gcc/ada/rident.ads +++ b/gcc/ada/rident.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 5b7345f3af4..05983814a5e 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -215,6 +215,7 @@ package Rtsfind is System_Aux_DEC, System_Bit_Ops, System_Boolean_Array_Operations, + System_Byte_Swapping, System_Checked_Pools, System_Compare_Array_Signed_16, System_Compare_Array_Signed_32, @@ -731,16 +732,14 @@ package Rtsfind is RE_Assert_Failure, -- System.Assertions RE_Raise_Assert_Failure, -- System.Assertions - RE_Atomic_Compare_Exchange_8, -- System.Atomic_Primitives - RE_Atomic_Compare_Exchange_16, -- System.Atomic_Primitives - RE_Atomic_Compare_Exchange_32, -- System.Atomic_Primitives - RE_Atomic_Compare_Exchange_64, -- System.Atomic_Primitives - RE_Atomic_Load_8, -- System.Atomic_Primitives - RE_Atomic_Load_16, -- System.Atomic_Primitives - RE_Atomic_Load_32, -- System.Atomic_Primitives - RE_Atomic_Load_64, -- System.Atomic_Primitives - RE_Atomic_Synchronize, -- System.Atomic_Primitives - RE_Relaxed, -- System.Atomic_Primitives + RE_Lock_Free_Read_8, -- System.Atomic_Primitives + RE_Lock_Free_Read_16, -- System.Atomic_Primitives + RE_Lock_Free_Read_32, -- System.Atomic_Primitives + RE_Lock_Free_Read_64, -- System.Atomic_Primitives + RE_Lock_Free_Try_Write_8, -- System.Atomic_Primitives + RE_Lock_Free_Try_Write_16, -- System.Atomic_Primitives + RE_Lock_Free_Try_Write_32, -- System.Atomic_Primitives + RE_Lock_Free_Try_Write_64, -- System.Atomic_Primitives RE_Uint8, -- System.Atomic_Primitives RE_Uint16, -- System.Atomic_Primitives RE_Uint32, -- System.Atomic_Primitives @@ -774,6 +773,10 @@ package Rtsfind is RE_Vector_Nxor, -- System_Boolean_Array_Operations, RE_Vector_Xor, -- System_Boolean_Array_Operations, + RE_Bswap_16, -- System.Byte_Swapping + RE_Bswap_32, -- System.Byte_Swapping + RE_Bswap_64, -- System.Byte_Swapping + RE_Checked_Pool, -- System.Checked_Pools RE_Compare_Array_S8, -- System.Compare_Array_Signed_8 @@ -1955,16 +1958,14 @@ package Rtsfind is RE_Assert_Failure => System_Assertions, RE_Raise_Assert_Failure => System_Assertions, - RE_Atomic_Compare_Exchange_8 => System_Atomic_Primitives, - RE_Atomic_Compare_Exchange_16 => System_Atomic_Primitives, - RE_Atomic_Compare_Exchange_32 => System_Atomic_Primitives, - RE_Atomic_Compare_Exchange_64 => System_Atomic_Primitives, - RE_Atomic_Load_8 => System_Atomic_Primitives, - RE_Atomic_Load_16 => System_Atomic_Primitives, - RE_Atomic_Load_32 => System_Atomic_Primitives, - RE_Atomic_Load_64 => System_Atomic_Primitives, - RE_Atomic_Synchronize => System_Atomic_Primitives, - RE_Relaxed => System_Atomic_Primitives, + RE_Lock_Free_Read_8 => System_Atomic_Primitives, + RE_Lock_Free_Read_16 => System_Atomic_Primitives, + RE_Lock_Free_Read_32 => System_Atomic_Primitives, + RE_Lock_Free_Read_64 => System_Atomic_Primitives, + RE_Lock_Free_Try_Write_8 => System_Atomic_Primitives, + RE_Lock_Free_Try_Write_16 => System_Atomic_Primitives, + RE_Lock_Free_Try_Write_32 => System_Atomic_Primitives, + RE_Lock_Free_Try_Write_64 => System_Atomic_Primitives, RE_Uint8 => System_Atomic_Primitives, RE_Uint16 => System_Atomic_Primitives, RE_Uint32 => System_Atomic_Primitives, @@ -2000,6 +2001,10 @@ package Rtsfind is RE_Vector_Nxor => System_Boolean_Array_Operations, RE_Vector_Xor => System_Boolean_Array_Operations, + RE_Bswap_16 => System_Byte_Swapping, + RE_Bswap_32 => System_Byte_Swapping, + RE_Bswap_64 => System_Byte_Swapping, + RE_Compare_Array_S8 => System_Compare_Array_Signed_8, RE_Compare_Array_S8_Unaligned => System_Compare_Array_Signed_8, diff --git a/gcc/ada/s-assert.ads b/gcc/ada/s-assert.ads index 433e276c600..c19f7c18a74 100644 --- a/gcc/ada/s-assert.ads +++ b/gcc/ada/s-assert.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -29,7 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This package provides support for the GNAT assert pragma +-- This package provides support for assertions (including pragma Assert, +-- pragma Debug, and Precondition/Postcondition/Predicate/Invariant aspects +-- and their corresponding pragmas). -- This unit may be used directly from an application program by providing -- an appropriate WITH, and the interface can be expected to remain stable. diff --git a/gcc/ada/s-atopri.adb b/gcc/ada/s-atopri.adb new file mode 100644 index 00000000000..145cbb6c9db --- /dev/null +++ b/gcc/ada/s-atopri.adb @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Atomic_Primitives is + + ---------------------- + -- Lock_Free_Read_8 -- + ---------------------- + + function Lock_Free_Read_8 (Ptr : Address) return uint8 is + begin + if uint8'Atomic_Always_Lock_Free then + return Atomic_Load_8 (Ptr, Acquire); + else + raise Program_Error; + end if; + end Lock_Free_Read_8; + + ----------------------- + -- Lock_Free_Read_16 -- + ----------------------- + + function Lock_Free_Read_16 (Ptr : Address) return uint16 is + begin + if uint16'Atomic_Always_Lock_Free then + return Atomic_Load_16 (Ptr, Acquire); + else + raise Program_Error; + end if; + end Lock_Free_Read_16; + + ----------------------- + -- Lock_Free_Read_32 -- + ----------------------- + + function Lock_Free_Read_32 (Ptr : Address) return uint32 is + begin + if uint32'Atomic_Always_Lock_Free then + return Atomic_Load_32 (Ptr, Acquire); + else + raise Program_Error; + end if; + end Lock_Free_Read_32; + + ----------------------- + -- Lock_Free_Read_64 -- + ----------------------- + + function Lock_Free_Read_64 (Ptr : Address) return uint64 is + begin + if uint64'Atomic_Always_Lock_Free then + return Atomic_Load_64 (Ptr, Acquire); + else + raise Program_Error; + end if; + end Lock_Free_Read_64; + + --------------------------- + -- Lock_Free_Try_Write_8 -- + --------------------------- + + function Lock_Free_Try_Write_8 + (Ptr : Address; + Expected : in out uint8; + Desired : uint8) return Boolean + is + Actual : uint8; + + begin + if Expected /= Desired then + + if uint8'Atomic_Always_Lock_Free then + Actual := Sync_Compare_And_Swap_8 (Ptr, Expected, Desired); + else + raise Program_Error; + end if; + + if Actual /= Expected then + Expected := Actual; + return False; + end if; + end if; + + return True; + end Lock_Free_Try_Write_8; + + ---------------------------- + -- Lock_Free_Try_Write_16 -- + ---------------------------- + + function Lock_Free_Try_Write_16 + (Ptr : Address; + Expected : in out uint16; + Desired : uint16) return Boolean + is + Actual : uint16; + + begin + if Expected /= Desired then + + if uint16'Atomic_Always_Lock_Free then + Actual := Sync_Compare_And_Swap_16 (Ptr, Expected, Desired); + else + raise Program_Error; + end if; + + if Actual /= Expected then + Expected := Actual; + return False; + end if; + end if; + + return True; + end Lock_Free_Try_Write_16; + + ---------------------------- + -- Lock_Free_Try_Write_32 -- + ---------------------------- + + function Lock_Free_Try_Write_32 + (Ptr : Address; + Expected : in out uint32; + Desired : uint32) return Boolean + is + Actual : uint32; + + begin + if Expected /= Desired then + + if uint32'Atomic_Always_Lock_Free then + Actual := Sync_Compare_And_Swap_32 (Ptr, Expected, Desired); + else + raise Program_Error; + end if; + + if Actual /= Expected then + Expected := Actual; + return False; + end if; + end if; + + return True; + end Lock_Free_Try_Write_32; + + ---------------------------- + -- Lock_Free_Try_Write_64 -- + ---------------------------- + + function Lock_Free_Try_Write_64 + (Ptr : Address; + Expected : in out uint64; + Desired : uint64) return Boolean + is + Actual : uint64; + + begin + if Expected /= Desired then + + if uint64'Atomic_Always_Lock_Free then + Actual := Sync_Compare_And_Swap_64 (Ptr, Expected, Desired); + else + raise Program_Error; + end if; + + if Actual /= Expected then + Expected := Actual; + return False; + end if; + end if; + + return True; + end Lock_Free_Try_Write_64; +end System.Atomic_Primitives; diff --git a/gcc/ada/s-atopri.ads b/gcc/ada/s-atopri.ads index 3b87eb28125..ba4b73351aa 100644 --- a/gcc/ada/s-atopri.ads +++ b/gcc/ada/s-atopri.ads @@ -29,14 +29,15 @@ -- -- ------------------------------------------------------------------------------ --- This package contains atomic primitives defined from gcc built-in functions - --- For now, these operations are only used by the compiler to generate the --- lock-free implementation of protected objects. +-- This package contains both atomic primitives defined from gcc built-in +-- functions and operations used by the compiler to generate the lock-free +-- implementation of protected objects. package System.Atomic_Primitives is pragma Preelaborate; + type uint is mod 2 ** Long_Integer'Size; + type uint8 is mod 2**8 with Size => 8; @@ -59,69 +60,121 @@ package System.Atomic_Primitives is subtype Mem_Model is Integer range Relaxed .. Last; - function Atomic_Compare_Exchange_8 - (X : Address; - X_Old : uint8; - X_Copy : uint8) return Boolean; + ------------------------------------ + -- GCC built-in atomic primitives -- + ------------------------------------ + + function Atomic_Load_8 + (Ptr : Address; + Model : Mem_Model := Seq_Cst) return uint8; + pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1"); + + function Atomic_Load_16 + (Ptr : Address; + Model : Mem_Model := Seq_Cst) return uint16; + pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2"); + + function Atomic_Load_32 + (Ptr : Address; + Model : Mem_Model := Seq_Cst) return uint32; + pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4"); + + function Atomic_Load_64 + (Ptr : Address; + Model : Mem_Model := Seq_Cst) return uint64; + pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8"); + + function Sync_Compare_And_Swap_8 + (Ptr : Address; + Expected : uint8; + Desired : uint8) return uint8; pragma Import (Intrinsic, - Atomic_Compare_Exchange_8, - "__sync_bool_compare_and_swap_1"); + Sync_Compare_And_Swap_8, + "__sync_val_compare_and_swap_1"); -- ??? Should use __atomic_compare_exchange_1 (doesn't work yet): - -- function Atomic_Compare_Exchange_8 - -- (X : Address; - -- X_Old : Address; - -- X_Copy : uint8; + -- function Sync_Compare_And_Swap_8 + -- (Ptr : Address; + -- Expected : Address; + -- Desired : uint8; + -- Weak : Boolean := False; -- Success_Model : Mem_Model := Seq_Cst; -- Failure_Model : Mem_Model := Seq_Cst) return Boolean; -- pragma Import (Intrinsic, - -- Atomic_Compare_Exchange_8, + -- Sync_Compare_And_Swap_8, -- "__atomic_compare_exchange_1"); - function Atomic_Compare_Exchange_16 - (X : Address; - X_Old : uint16; - X_Copy : uint16) return Boolean; + function Sync_Compare_And_Swap_16 + (Ptr : Address; + Expected : uint16; + Desired : uint16) return uint16; pragma Import (Intrinsic, - Atomic_Compare_Exchange_16, - "__sync_bool_compare_and_swap_2"); + Sync_Compare_And_Swap_16, + "__sync_val_compare_and_swap_2"); - function Atomic_Compare_Exchange_32 - (X : Address; - X_Old : uint32; - X_Copy : uint32) return Boolean; + function Sync_Compare_And_Swap_32 + (Ptr : Address; + Expected : uint32; + Desired : uint32) return uint32; pragma Import (Intrinsic, - Atomic_Compare_Exchange_32, - "__sync_bool_compare_and_swap_4"); + Sync_Compare_And_Swap_32, + "__sync_val_compare_and_swap_4"); - function Atomic_Compare_Exchange_64 - (X : Address; - X_Old : uint64; - X_Copy : uint64) return Boolean; + function Sync_Compare_And_Swap_64 + (Ptr : Address; + Expected : uint64; + Desired : uint64) return uint64; pragma Import (Intrinsic, - Atomic_Compare_Exchange_64, - "__sync_bool_compare_and_swap_8"); + Sync_Compare_And_Swap_64, + "__sync_val_compare_and_swap_8"); - function Atomic_Load_8 - (X : Address; - Model : Mem_Model := Seq_Cst) return uint8; - pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1"); + -------------------------- + -- Lock-free operations -- + -------------------------- - function Atomic_Load_16 - (X : Address; - Model : Mem_Model := Seq_Cst) return uint16; - pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2"); + -- The lock-free implementation uses two atomic instructions for the + -- expansion of protected operations: - function Atomic_Load_32 - (X : Address; - Model : Mem_Model := Seq_Cst) return uint32; - pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4"); + -- * Lock_Free_Read_N atomically loads the value of the protected component + -- accessed by the current protected operation. - function Atomic_Load_64 - (X : Address; - Model : Mem_Model := Seq_Cst) return uint64; - pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8"); + -- * Lock_Free_Try_Write_N tries to write the Desired value into Ptr only + -- if Expected and Desired mismatch. + + function Lock_Free_Read_8 (Ptr : Address) return uint8; + + function Lock_Free_Read_16 (Ptr : Address) return uint16; + + function Lock_Free_Read_32 (Ptr : Address) return uint32; + + function Lock_Free_Read_64 (Ptr : Address) return uint64; + + function Lock_Free_Try_Write_8 + (Ptr : Address; + Expected : in out uint8; + Desired : uint8) return Boolean; + + function Lock_Free_Try_Write_16 + (Ptr : Address; + Expected : in out uint16; + Desired : uint16) return Boolean; + + function Lock_Free_Try_Write_32 + (Ptr : Address; + Expected : in out uint32; + Desired : uint32) return Boolean; + + function Lock_Free_Try_Write_64 + (Ptr : Address; + Expected : in out uint64; + Desired : uint64) return Boolean; - procedure Atomic_Synchronize; - pragma Import (Intrinsic, Atomic_Synchronize, "__sync_synchronize"); + pragma Inline (Lock_Free_Read_8); + pragma Inline (Lock_Free_Read_16); + pragma Inline (Lock_Free_Read_32); + pragma Inline (Lock_Free_Read_64); + pragma Inline (Lock_Free_Try_Write_8); + pragma Inline (Lock_Free_Try_Write_16); + pragma Inline (Lock_Free_Try_Write_32); + pragma Inline (Lock_Free_Try_Write_64); end System.Atomic_Primitives; diff --git a/gcc/ada/s-bytswa.ads b/gcc/ada/s-bytswa.ads new file mode 100644 index 00000000000..675e7d8ee5a --- /dev/null +++ b/gcc/ada/s-bytswa.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . B Y T E _ S W A P P I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2012, AdaCore -- +-- -- +-- 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Intrinsic routines for byte swapping. These are used by the expanded code +-- (supporting alternative byte ordering), and by the GNAT.Byte_Swapping run +-- time package which provides user level routines for byte swapping. + +package System.Byte_Swapping is + + pragma Pure; + + type U16 is mod 2**16; + type U32 is mod 2**32; + type U64 is mod 2**64; + + function Bswap_16 (X : U16) return U16; + pragma Import (Intrinsic, Bswap_16, "__builtin_bswap16"); + + function Bswap_32 (X : U32) return U32; + pragma Import (Intrinsic, Bswap_32, "__builtin_bswap32"); + + function Bswap_64 (X : U64) return U64; + pragma Import (Intrinsic, Bswap_64, "__builtin_bswap64"); + +end System.Byte_Swapping; diff --git a/gcc/ada/s-commun.ads b/gcc/ada/s-commun.ads index c59a2c7e4dc..1255efd6b7d 100644 --- a/gcc/ada/s-commun.ads +++ b/gcc/ada/s-commun.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, AdaCore -- +-- Copyright (C) 2001-2012, AdaCore -- -- -- -- 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- -- @@ -35,6 +35,7 @@ with Ada.Streams; with System.CRTL; package System.Communication is + pragma Preelaborate; function Last_Index (First : Ada.Streams.Stream_Element_Offset; diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads index 345e9a570ea..c02d23023eb 100644 --- a/gcc/ada/s-crtl.ads +++ b/gcc/ada/s-crtl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2012, 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- -- @@ -165,6 +165,11 @@ package System.CRTL is function chdir (dir_name : String) return int; pragma Import (C, chdir, "__gnat_chdir"); + function mkdir + (dir_name : String; + encoding : Filename_Encoding := Unspecified) return int; + pragma Import (C, mkdir, "__gnat_mkdir"); + function setvbuf (stream : FILEs; buffer : chars; diff --git a/gcc/ada/s-dimmks.ads b/gcc/ada/s-dimmks.ads index 50553d1d195..fd0fc0060eb 100644 --- a/gcc/ada/s-dimmks.ads +++ b/gcc/ada/s-dimmks.ads @@ -64,31 +64,37 @@ package System.Dim.Mks is Dimension => (Symbol => 'm', Meter => 1, others => 0); + subtype Mass is Mks_Type with Dimension => (Symbol => "kg", Kilogram => 1, others => 0); + subtype Time is Mks_Type with Dimension => (Symbol => 's', Second => 1, others => 0); + subtype Electric_Current is Mks_Type with Dimension => (Symbol => 'A', Ampere => 1, others => 0); + subtype Thermodynamic_Temperature is Mks_Type with Dimension => (Symbol => 'K', Kelvin => 1, others => 0); + subtype Amount_Of_Substance is Mks_Type with Dimension => (Symbol => "mol", Mole => 1, others => 0); + subtype Luminous_Intensity is Mks_Type with Dimension => (Symbol => "cd", @@ -122,6 +128,7 @@ package System.Dim.Mks is Dimension => (Symbol => "Hz", Second => -1, others => 0); + subtype Force is Mks_Type with Dimension => (Symbol => 'N', @@ -129,6 +136,7 @@ package System.Dim.Mks is Kilogram => 1, Second => -2, others => 0); + subtype Pressure is Mks_Type with Dimension => (Symbol => "Pa", @@ -136,6 +144,7 @@ package System.Dim.Mks is Kilogram => 1, Second => -2, others => 0); + subtype Energy is Mks_Type with Dimension => (Symbol => 'J', @@ -143,6 +152,7 @@ package System.Dim.Mks is Kilogram => 1, Second => -2, others => 0); + subtype Power is Mks_Type with Dimension => (Symbol => 'W', @@ -150,12 +160,14 @@ package System.Dim.Mks is Kilogram => 1, Second => -3, others => 0); + subtype Electric_Charge is Mks_Type with Dimension => (Symbol => 'C', Second => 1, Ampere => 1, others => 0); + subtype Electric_Potential_Difference is Mks_Type with Dimension => (Symbol => 'V', @@ -164,6 +176,7 @@ package System.Dim.Mks is Second => -3, Ampere => -1, others => 0); + subtype Electric_Capacitance is Mks_Type with Dimension => (Symbol => 'F', @@ -172,6 +185,7 @@ package System.Dim.Mks is Second => 4, Ampere => 2, others => 0); + subtype Electric_Resistance is Mks_Type with Dimension => (Symbol => "Ω", @@ -180,6 +194,7 @@ package System.Dim.Mks is Second => -3, Ampere => -2, others => 0); + subtype Electric_Conductance is Mks_Type with Dimension => (Symbol => 'S', @@ -188,6 +203,7 @@ package System.Dim.Mks is Second => 3, Ampere => 2, others => 0); + subtype Magnetic_Flux is Mks_Type with Dimension => (Symbol => "Wb", @@ -196,6 +212,7 @@ package System.Dim.Mks is Second => -2, Ampere => -1, others => 0); + subtype Magnetic_Flux_Density is Mks_Type with Dimension => (Symbol => 'T', @@ -203,6 +220,7 @@ package System.Dim.Mks is Second => -2, Ampere => -1, others => 0); + subtype Inductance is Mks_Type with Dimension => (Symbol => 'H', @@ -211,39 +229,46 @@ package System.Dim.Mks is Second => -2, Ampere => -2, others => 0); + subtype Celsius_Temperature is Mks_Type with Dimension => (Symbol => "°C", Kelvin => 1, others => 0); + subtype Luminous_Flux is Mks_Type with Dimension => (Symbol => "lm", Candela => 1, others => 0); + subtype Illuminance is Mks_Type with Dimension => (Symbol => "lx", Meter => -2, Candela => 1, others => 0); + subtype Radioactivity is Mks_Type with Dimension => (Symbol => "Bq", Second => -1, others => 0); + subtype Absorbed_Dose is Mks_Type with Dimension => (Symbol => "Gy", Meter => 2, Second => -2, others => 0); + subtype Equivalent_Dose is Mks_Type with Dimension => (Symbol => "Sv", Meter => 2, Second => -2, others => 0); + subtype Catalytic_Activity is Mks_Type with Dimension => (Symbol => "kat", diff --git a/gcc/ada/s-ficobl.ads b/gcc/ada/s-ficobl.ads index d3e5ef26ed2..cd3d0cbe37f 100644 --- a/gcc/ada/s-ficobl.ads +++ b/gcc/ada/s-ficobl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -40,6 +40,7 @@ with Interfaces.C_Streams; with System.CRTL; package System.File_Control_Block is + pragma Preelaborate; ---------------------------- -- Ada File Control Block -- diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index a11d83311e5..88bad49f76e 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -98,14 +98,6 @@ package body System.File_IO is (C, text_translation_required, "__gnat_text_translation_required"); -- If true, add appropriate suffix to control string for Open - function Get_Case_Sensitive return Integer; - pragma Import (C, Get_Case_Sensitive, - "__gnat_get_file_names_case_sensitive"); - File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; - -- Set to indicate whether the operating system convention is for file - -- names to be case sensitive (e.g., in Unix, set True), or non case - -- sensitive (e.g., in Windows, set False). - ----------------------- -- Local Subprograms -- ----------------------- @@ -634,7 +626,6 @@ package body System.File_IO is then Start := J + 1; Stop := Start - 1; - while Form (Stop + 1) /= ASCII.NUL and then Form (Stop + 1) /= ',' loop @@ -757,6 +748,17 @@ package body System.File_IO is pragma Import (C, Tmp_Name, "__gnat_tmp_name"); -- Set buffer (a String address) with a temporary filename + function Get_Case_Sensitive return Integer; + pragma Import (C, Get_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + + File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; + -- Set to indicate whether the operating system convention is for file + -- names to be case sensitive (e.g., in Unix, set True), or not case + -- sensitive (e.g., in Windows, set False). Declared locally to avoid + -- breaking the Preelaborate rule that disallows function calls at the + -- library level. + Stream : FILEs := C_Stream; -- Stream which we open in response to this request diff --git a/gcc/ada/s-fileio.ads b/gcc/ada/s-fileio.ads index 5ee0c5b99d9..f084d8dc573 100644 --- a/gcc/ada/s-fileio.ads +++ b/gcc/ada/s-fileio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -37,6 +37,7 @@ with Interfaces.C_Streams; with System.File_Control_Block; package System.File_IO is + pragma Preelaborate; package FCB renames System.File_Control_Block; package ICS renames Interfaces.C_Streams; diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb index e2b5235f054..b8116f9437d 100644 --- a/gcc/ada/s-htable.adb +++ b/gcc/ada/s-htable.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2011, AdaCore -- +-- Copyright (C) 1995-2012, AdaCore -- -- -- -- 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- -- @@ -62,7 +62,6 @@ package body System.HTable is begin Elmt := Table (Hash (K)); - loop if Elmt = Null_Ptr then return Null_Ptr; @@ -96,10 +95,10 @@ package body System.HTable is begin if not Iterator_Started then return Null_Ptr; + else + Iterator_Ptr := Next (Iterator_Ptr); + return Get_Non_Null; end if; - - Iterator_Ptr := Next (Iterator_Ptr); - return Get_Non_Null; end Get_Next; ------------------ @@ -183,7 +182,6 @@ package body System.HTable is procedure Set (E : Elmt_Ptr) is Index : Header_Num; - begin Index := Hash (Get_Key (E)); Set_Next (E, Table (Index)); diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index d0b83ae05f4..9848cb82c82 100644 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -54,7 +54,7 @@ with System; with System.Strings; package System.OS_Lib is - pragma Elaborate_Body (OS_Lib); + pragma Preelaborate; ----------------------- -- String Operations -- diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 6ea57752dc4..eef71b4b719 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -156,6 +156,10 @@ pragma Style_Checks ("M32766"); # include <signal.h> #endif +#ifdef __MINGW32__ +# include <winbase.h> +#endif + #ifdef NATIVE #include <stdio.h> @@ -169,6 +173,9 @@ int counter = 0; #define CND(name,comment) \ printf ("\n->CND:$%d:" #name ":$%d:" comment, __LINE__, ((int) _VAL (name))); +#define CNU(name,comment) \ + printf ("\n->CNU:$%d:" #name ":$%u:" comment, __LINE__, ((unsigned int) _VAL (name))); + #define CNS(name,comment) \ printf ("\n->CNS:$%d:" #name ":" name ":" comment, __LINE__); @@ -185,6 +192,13 @@ int counter = 0; : : "i" (__LINE__), "i" ((int) name)); /* Decimal constant in the range of type "int" */ +#define CNU(name, comment) \ + asm volatile("\n->CNU:%0:" #name ":%1:" comment \ + : : "i" (__LINE__), "i" ((int) name)); +/* Decimal constant in the range of type "unsigned int" (note, assembler + * always wants a signed int, we convert back in xoscons). + */ + #define CNS(name, comment) \ asm volatile("\n->CNS:%0:" #name ":" name ":" comment \ : : "i" (__LINE__)); @@ -250,9 +264,9 @@ package System.OS_Constants is /* - ----------------------------- - -- Platform identification -- - ----------------------------- + --------------------------------- + -- General platform parameters -- + --------------------------------- type OS_Type is (Windows, VMS, Other_OS); */ @@ -264,8 +278,19 @@ package System.OS_Constants is # define TARGET_OS "Other_OS" #endif C("Target_OS", OS_Type, TARGET_OS, "") +/* + pragma Warnings (Off, Target_OS); + -- Suppress warnings on Target_OS since it is in general tested for + -- equality with a constant value to implement conditional compilation, + -- which normally generates a constant condition warning. + +*/ #define Target_Name TARGET CST(Target_Name, "") + +#define sizeof_unsigned_int sizeof (unsigned int) +CND(sizeof_unsigned_int, "Size of unsigned int") + /* ------------------- @@ -589,12 +614,21 @@ CND(ETOOMANYREFS, "Too many references") #endif CND(EWOULDBLOCK, "Operation would block") +#ifndef E2BIG +# define E2BIG -1 +#endif +CND(E2BIG, "Argument list too long") + +#ifndef EILSEQ +# define EILSEQ -1 +#endif +CND(EILSEQ, "Illegal byte sequence") + /** - ** Terminal I/O constants + ** Terminal/serial I/O constants **/ -#ifdef HAVE_TERMIOS - +#if defined(HAVE_TERMIOS) || defined(__MINGW32__) /* ---------------------- @@ -602,6 +636,9 @@ CND(EWOULDBLOCK, "Operation would block") ---------------------- */ +#endif + +#ifdef HAVE_TERMIOS #ifndef TCSANOW # define TCSANOW -1 @@ -613,210 +650,215 @@ CND(TCSANOW, "Immediate") #endif CND(TCIFLUSH, "Flush input") +#ifndef IXON +# define IXON -1 +#endif +CNU(IXON, "Output sw flow control") + #ifndef CLOCAL # define CLOCAL -1 #endif -CND(CLOCAL, "Local") +CNU(CLOCAL, "Local") #ifndef CRTSCTS # define CRTSCTS -1 #endif -CND(CRTSCTS, "Hardware flow control") +CNU(CRTSCTS, "Output hw flow control") #ifndef CREAD # define CREAD -1 #endif -CND(CREAD, "Read") +CNU(CREAD, "Read") #ifndef CS5 # define CS5 -1 #endif -CND(CS5, "5 data bits") +CNU(CS5, "5 data bits") #ifndef CS6 # define CS6 -1 #endif -CND(CS6, "6 data bits") +CNU(CS6, "6 data bits") #ifndef CS7 # define CS7 -1 #endif -CND(CS7, "7 data bits") +CNU(CS7, "7 data bits") #ifndef CS8 # define CS8 -1 #endif -CND(CS8, "8 data bits") +CNU(CS8, "8 data bits") #ifndef CSTOPB # define CSTOPB -1 #endif -CND(CSTOPB, "2 stop bits") +CNU(CSTOPB, "2 stop bits") #ifndef PARENB # define PARENB -1 #endif -CND(PARENB, "Parity enable") +CNU(PARENB, "Parity enable") #ifndef PARODD # define PARODD -1 #endif -CND(PARODD, "Parity odd") +CNU(PARODD, "Parity odd") #ifndef B0 # define B0 -1 #endif -CND(B0, "0 bps") +CNU(B0, "0 bps") #ifndef B50 # define B50 -1 #endif -CND(B50, "50 bps") +CNU(B50, "50 bps") #ifndef B75 # define B75 -1 #endif -CND(B75, "75 bps") +CNU(B75, "75 bps") #ifndef B110 # define B110 -1 #endif -CND(B110, "110 bps") +CNU(B110, "110 bps") #ifndef B134 # define B134 -1 #endif -CND(B134, "134 bps") +CNU(B134, "134 bps") #ifndef B150 # define B150 -1 #endif -CND(B150, "150 bps") +CNU(B150, "150 bps") #ifndef B200 # define B200 -1 #endif -CND(B200, "200 bps") +CNU(B200, "200 bps") #ifndef B300 # define B300 -1 #endif -CND(B300, "300 bps") +CNU(B300, "300 bps") #ifndef B600 # define B600 -1 #endif -CND(B600, "600 bps") +CNU(B600, "600 bps") #ifndef B1200 # define B1200 -1 #endif -CND(B1200, "1200 bps") +CNU(B1200, "1200 bps") #ifndef B1800 # define B1800 -1 #endif -CND(B1800, "1800 bps") +CNU(B1800, "1800 bps") #ifndef B2400 # define B2400 -1 #endif -CND(B2400, "2400 bps") +CNU(B2400, "2400 bps") #ifndef B4800 # define B4800 -1 #endif -CND(B4800, "4800 bps") +CNU(B4800, "4800 bps") #ifndef B9600 # define B9600 -1 #endif -CND(B9600, "9600 bps") +CNU(B9600, "9600 bps") #ifndef B19200 # define B19200 -1 #endif -CND(B19200, "19200 bps") +CNU(B19200, "19200 bps") #ifndef B38400 # define B38400 -1 #endif -CND(B38400, "38400 bps") +CNU(B38400, "38400 bps") #ifndef B57600 # define B57600 -1 #endif -CND(B57600, "57600 bps") +CNU(B57600, "57600 bps") #ifndef B115200 # define B115200 -1 #endif -CND(B115200, "115200 bps") +CNU(B115200, "115200 bps") #ifndef B230400 # define B230400 -1 #endif -CND(B230400, "230400 bps") +CNU(B230400, "230400 bps") #ifndef B460800 # define B460800 -1 #endif -CND(B460800, "460800 bps") +CNU(B460800, "460800 bps") #ifndef B500000 # define B500000 -1 #endif -CND(B500000, "500000 bps") +CNU(B500000, "500000 bps") #ifndef B576000 # define B576000 -1 #endif -CND(B576000, "576000 bps") +CNU(B576000, "576000 bps") #ifndef B921600 # define B921600 -1 #endif -CND(B921600, "921600 bps") +CNU(B921600, "921600 bps") #ifndef B1000000 # define B1000000 -1 #endif -CND(B1000000, "1000000 bps") +CNU(B1000000, "1000000 bps") #ifndef B1152000 # define B1152000 -1 #endif -CND(B1152000, "1152000 bps") +CNU(B1152000, "1152000 bps") #ifndef B1500000 # define B1500000 -1 #endif -CND(B1500000, "1500000 bps") +CNU(B1500000, "1500000 bps") #ifndef B2000000 # define B2000000 -1 #endif -CND(B2000000, "2000000 bps") +CNU(B2000000, "2000000 bps") #ifndef B2500000 # define B2500000 -1 #endif -CND(B2500000, "2500000 bps") +CNU(B2500000, "2500000 bps") #ifndef B3000000 # define B3000000 -1 #endif -CND(B3000000, "3000000 bps") +CNU(B3000000, "3000000 bps") #ifndef B3500000 # define B3500000 -1 #endif -CND(B3500000, "3500000 bps") +CNU(B3500000, "3500000 bps") #ifndef B4000000 # define B4000000 -1 #endif -CND(B4000000, "4000000 bps") +CNU(B4000000, "4000000 bps") /* @@ -913,6 +955,11 @@ CND(VEOL2, "Alternative EOL") #endif /* HAVE_TERMIOS */ +#ifdef __MINGW32__ +CNU(DTR_CONTROL_ENABLE, "Enable DTR flow ctrl") +CNU(RTS_CONTROL_ENABLE, "Enable RTS flow ctrl") +#endif + /* ----------------------------- diff --git a/gcc/ada/s-osinte-hpux.ads b/gcc/ada/s-osinte-hpux.ads index 55729f877ab..b916b8db940 100644 --- a/gcc/ada/s-osinte-hpux.ads +++ b/gcc/ada/s-osinte-hpux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2012, 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- -- @@ -290,7 +290,7 @@ package System.OS_Interface is pragma Import (C, Alternate_Stack, "__gnat_alternate_stack"); -- The alternate signal stack for stack overflows - Alternate_Stack_Size : constant := 16 * 1024; + Alternate_Stack_Size : constant := 128 * 1024; -- This must be in keeping with init.c:__gnat_alternate_stack Stack_Base_Available : constant Boolean := False; diff --git a/gcc/ada/s-regexp.adb b/gcc/ada/s-regexp.adb index e1f5f317cb5..56c38a8a5ee 100644 --- a/gcc/ada/s-regexp.adb +++ b/gcc/ada/s-regexp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2010, AdaCore -- +-- Copyright (C) 1999-2012, AdaCore -- -- -- -- 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- -- @@ -100,10 +100,12 @@ package body System.Regexp is Tmp : Regexp_Access; begin - Tmp := new Regexp_Value (Alphabet_Size => R.R.Alphabet_Size, - Num_States => R.R.Num_States); - Tmp.all := R.R.all; - R.R := Tmp; + if R.R /= null then + Tmp := new Regexp_Value (Alphabet_Size => R.R.Alphabet_Size, + Num_States => R.R.Num_States); + Tmp.all := R.R.all; + R.R := Tmp; + end if; end Adjust; ------------- diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index d067f3d7f4f..880a7291505 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -41,6 +41,34 @@ -- so we can do the instantiation under control of Discard_Names to remove -- the tables. +--------------------------------------------------- +-- Note On Compile/Run-Time Consistency Checking -- +--------------------------------------------------- + +-- This unit is with'ed by the run-time (to make System.Restrictions which is +-- used for run-time access to restriction information), by the compiler (to +-- determine what restrictions are implemented and what their category is) and +-- by the binder (in processing ali files, and generating the information used +-- at run-time to access restriction information). + +-- Normally the version of System.Rident referenced in all three contexts +-- should be the same. However, problems could arise in certain inconsistent +-- builds that used inconsistent versions of the compiler and run-time. This +-- sort of thing is not strictly correct, but it does arise when short-cuts +-- are taken in build procedures. + +-- Previously, this kind of inconsistency could cause a significant problem. +-- If versions of System.Rident accessed by the compiler and binder differed, +-- then the binder could fail to recognize the R (restrictions line) in the +-- ali file, leading to bind errors when restrictions were added or removed. + +-- The latest implementation avoids both this problem by using a named +-- scheme for recording restrictions, rather than a positional scheme which +-- fails completely if restrictions are added or subtracted. Now the worst +-- that happens at bind time in incosistent builds is that unrecognized +-- restrictions are ignored, and the consistency checking for restrictions +-- might be incomplete, which is no big deal. + pragma Compiler_Unit; generic diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 2aa5fd7c0b6..75d81cb6327 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -716,57 +716,30 @@ package body System.Task_Primitives.Operations is -- Set_Priority -- ------------------ - type Prio_Array_Type is array (System.Any_Priority) of Integer; - pragma Atomic_Components (Prio_Array_Type); - - Prio_Array : Prio_Array_Type; - -- Global array containing the id of the currently running task for - -- each priority. - -- - -- Note: we assume that we are on a single processor with run-til-blocked - -- scheduling. - procedure Set_Priority (T : Task_Id; Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is - Res : BOOL; - Array_Item : Integer; + Res : BOOL; + pragma Unreferenced (Loss_Of_Inheritance); begin - Res := SetThreadPriority - (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); + Res := + SetThreadPriority + (T.Common.LL.Thread, + Interfaces.C.int (Underlying_Priorities (Prio))); pragma Assert (Res = Win32.TRUE); - if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then - - -- Annex D requirement [RM D.2.2 par. 9]: - -- If the task drops its priority due to the loss of inherited - -- priority, it is added at the head of the ready queue for its - -- new active priority. - - if Loss_Of_Inheritance - and then Prio < T.Common.Current_Priority - then - Array_Item := Prio_Array (T.Common.Base_Priority) + 1; - Prio_Array (T.Common.Base_Priority) := Array_Item; - - loop - -- Let some processes a chance to arrive - - Yield; + -- Note: Annex D (RM D.2.3(5/2)) requires the task to be placed at the + -- head of its priority queue when decreasing its priority as a result + -- of a loss of inherited priority. This is not the case, but we + -- consider it an acceptable variation (RM 1.1.3(6)), given this is + -- the built-in behavior offered by the Windows operating system. - -- Then wait for our turn to proceed - - exit when Array_Item = Prio_Array (T.Common.Base_Priority) - or else Prio_Array (T.Common.Base_Priority) = 1; - end loop; - - Prio_Array (T.Common.Base_Priority) := - Prio_Array (T.Common.Base_Priority) - 1; - end if; - end if; + -- In older versions we attempted to better approximate the Annex D + -- required behavior, but this simulation was not entirely accurate, + -- and it seems better to live with the standard Windows semantics. T.Common.Current_Priority := Prio; end Set_Priority; diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index aab0ac7319e..9643a181b5b 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2012, 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- -- @@ -483,6 +483,12 @@ package body System.Tasking.Restricted.Stages is then Self_ID.Common.Base_Priority else System.Any_Priority (Priority)); + -- Legal values of CPU are the special Unspecified_CPU value which is + -- inserted by the compiler for tasks without CPU aspect, and those in + -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise + -- the task is defined to have failed, and it becomes a completed task + -- (RM D.16(14/3)). + if CPU /= Unspecified_CPU and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) or else CPU > Integer (System.Multiprocessors.CPU_Range'Last) @@ -492,6 +498,13 @@ package body System.Tasking.Restricted.Stages is -- Normal CPU affinity else + -- When the application code says nothing about the task affinity + -- (task without CPU aspect) then the compiler inserts the + -- Unspecified_CPU value which indicates to the run-time library that + -- the task will activate and execute on the same processor as its + -- activating task if the activating task is assigned a processor + -- (RM D.16(14/3)). + Base_CPU := (if CPU = Unspecified_CPU then Self_ID.Common.Base_CPU diff --git a/gcc/ada/s-tasinf-linux.ads b/gcc/ada/s-tasinf-linux.ads index db274f89f52..740c6bb3646 100644 --- a/gcc/ada/s-tasinf-linux.ads +++ b/gcc/ada/s-tasinf-linux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2012, 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- -- @@ -48,10 +48,10 @@ package System.Task_Info is pragma Elaborate_Body; -- To ensure that a body is allowed - -- Windows provides a way to define the ideal processor to use for a given - -- thread. The ideal processor is not necessarily the one that will be used - -- by the OS but the OS will always try to schedule this thread to the - -- specified processor if it is available. + -- The Linux kernel provides a way to define the ideal processor to use for + -- a given thread. The ideal processor is not necessarily the one that will + -- be used by the OS but the OS will always try to schedule this thread to + -- the specified processor if it is available. -- The Task_Info pragma: diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 410cc8c0f06..57c28be4ee5 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -527,6 +527,12 @@ package body System.Tasking.Stages is then Self_ID.Common.Base_Priority else System.Any_Priority (Priority)); + -- Legal values of CPU are the special Unspecified_CPU value which is + -- inserted by the compiler for tasks without CPU aspect, and those in + -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise + -- the task is defined to have failed, and it becomes a completed task + -- (RM D.16(14/3)). + if CPU /= Unspecified_CPU and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) or else @@ -539,6 +545,13 @@ package body System.Tasking.Stages is -- Normal CPU affinity else + -- When the application code says nothing about the task affinity + -- (task without CPU aspect) then the compiler inserts the + -- Unspecified_CPU value which indicates to the run-time library that + -- the task will activate and execute on the same processor as its + -- activating task if the activating task is assigned a processor + -- (RM D.16(14/3)). + Base_CPU := (if CPU = Unspecified_CPU then Self_ID.Common.Base_CPU diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index e0e31b66673..9f478985284 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -152,14 +152,16 @@ package SCOs is -- o object declaration -- r renaming declaration -- i generic instantiation - -- C CASE statement (from CASE through end of expression) + -- A ACCEPT statement (from ACCEPT to end of parameter profile) + -- C CASE statement (from CASE to end of expression) -- E EXIT statement - -- F FOR loop (from FOR through end of iteration scheme) - -- I IF statement (from IF through end of condition) + -- F FOR loop (from FOR to end of iteration scheme) + -- I IF statement (from IF to end of condition) -- P[name:] PRAGMA with the indicated name -- p[name:] disabled PRAGMA with the indicated name -- R extended RETURN statement - -- W WHILE loop statement (from WHILE through end of condition) + -- S SELECT statement + -- W WHILE loop statement (from WHILE to end of condition) -- Note: for I and W, condition above is in the RM syntax sense (this -- condition is a decision in SCO terminology). diff --git a/gcc/ada/seh_init.c b/gcc/ada/seh_init.c index fa5310ffe71..772dab0aa84 100644 --- a/gcc/ada/seh_init.c +++ b/gcc/ada/seh_init.c @@ -68,20 +68,21 @@ extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *); #include <windows.h> #include <excpt.h> +/* Prototypes. */ extern void _global_unwind2 (void *); EXCEPTION_DISPOSITION __gnat_SEH_error_handler (struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); -EXCEPTION_DISPOSITION -__gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord, - void *EstablisherFrame, - struct _CONTEXT* ContextRecord ATTRIBUTE_UNUSED, - void *DispatcherContext ATTRIBUTE_UNUSED) -{ - struct Exception_Data *exception; - const char *msg; +struct Exception_Data * +__gnat_map_SEH (EXCEPTION_RECORD* ExceptionRecord, const char **msg); +/* Convert an SEH exception to an Ada one. Return the exception ID + and set MSG with the corresponding message. */ + +struct Exception_Data * +__gnat_map_SEH (EXCEPTION_RECORD* ExceptionRecord, const char **msg) +{ switch (ExceptionRecord->ExceptionCode) { case EXCEPTION_ACCESS_VIOLATION: @@ -92,93 +93,97 @@ __gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord, || IsBadCodePtr ((void *)(ExceptionRecord->ExceptionInformation[1] + 4096))) { - exception = &program_error; - msg = "EXCEPTION_ACCESS_VIOLATION"; + *msg = "EXCEPTION_ACCESS_VIOLATION"; + return &program_error; } else { /* otherwise it is a stack overflow */ - exception = &storage_error; - msg = "stack overflow or erroneous memory access"; + *msg = "stack overflow or erroneous memory access"; + return &storage_error; } - break; case EXCEPTION_ARRAY_BOUNDS_EXCEEDED: - exception = &constraint_error; - msg = "EXCEPTION_ARRAY_BOUNDS_EXCEEDED"; - break; + *msg = "EXCEPTION_ARRAY_BOUNDS_EXCEEDED"; + return &constraint_error; case EXCEPTION_DATATYPE_MISALIGNMENT: - exception = &constraint_error; - msg = "EXCEPTION_DATATYPE_MISALIGNMENT"; - break; + *msg = "EXCEPTION_DATATYPE_MISALIGNMENT"; + return &constraint_error; case EXCEPTION_FLT_DENORMAL_OPERAND: - exception = &constraint_error; - msg = "EXCEPTION_FLT_DENORMAL_OPERAND"; - break; + *msg = "EXCEPTION_FLT_DENORMAL_OPERAND"; + return &constraint_error; case EXCEPTION_FLT_DIVIDE_BY_ZERO: - exception = &constraint_error; - msg = "EXCEPTION_FLT_DENORMAL_OPERAND"; - break; + *msg = "EXCEPTION_FLT_DENORMAL_OPERAND"; + return &constraint_error; case EXCEPTION_FLT_INVALID_OPERATION: - exception = &constraint_error; - msg = "EXCEPTION_FLT_INVALID_OPERATION"; - break; + *msg = "EXCEPTION_FLT_INVALID_OPERATION"; + return &constraint_error; case EXCEPTION_FLT_OVERFLOW: - exception = &constraint_error; - msg = "EXCEPTION_FLT_OVERFLOW"; - break; + *msg = "EXCEPTION_FLT_OVERFLOW"; + return &constraint_error; case EXCEPTION_FLT_STACK_CHECK: - exception = &program_error; - msg = "EXCEPTION_FLT_STACK_CHECK"; - break; + *msg = "EXCEPTION_FLT_STACK_CHECK"; + return &program_error; case EXCEPTION_FLT_UNDERFLOW: - exception = &constraint_error; - msg = "EXCEPTION_FLT_UNDERFLOW"; - break; + *msg = "EXCEPTION_FLT_UNDERFLOW"; + return &constraint_error; case EXCEPTION_INT_DIVIDE_BY_ZERO: - exception = &constraint_error; - msg = "EXCEPTION_INT_DIVIDE_BY_ZERO"; - break; + *msg = "EXCEPTION_INT_DIVIDE_BY_ZERO"; + return &constraint_error; case EXCEPTION_INT_OVERFLOW: - exception = &constraint_error; - msg = "EXCEPTION_INT_OVERFLOW"; - break; + *msg = "EXCEPTION_INT_OVERFLOW"; + return &constraint_error; case EXCEPTION_INVALID_DISPOSITION: - exception = &program_error; - msg = "EXCEPTION_INVALID_DISPOSITION"; - break; + *msg = "EXCEPTION_INVALID_DISPOSITION"; + return &program_error; case EXCEPTION_NONCONTINUABLE_EXCEPTION: - exception = &program_error; - msg = "EXCEPTION_NONCONTINUABLE_EXCEPTION"; - break; + *msg = "EXCEPTION_NONCONTINUABLE_EXCEPTION"; + return &program_error; case EXCEPTION_PRIV_INSTRUCTION: - exception = &program_error; - msg = "EXCEPTION_PRIV_INSTRUCTION"; - break; + *msg = "EXCEPTION_PRIV_INSTRUCTION"; + return &program_error; case EXCEPTION_SINGLE_STEP: - exception = &program_error; - msg = "EXCEPTION_SINGLE_STEP"; - break; + *msg = "EXCEPTION_SINGLE_STEP"; + return &program_error; case EXCEPTION_STACK_OVERFLOW: - exception = &storage_error; - msg = "EXCEPTION_STACK_OVERFLOW"; - break; + *msg = "EXCEPTION_STACK_OVERFLOW"; + return &storage_error; - default: + default: + *msg = NULL; + return NULL; + } +} + +#if !(defined (_WIN64) && defined (__SEH__)) + +EXCEPTION_DISPOSITION +__gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord, + void *EstablisherFrame ATTRIBUTE_UNUSED, + struct _CONTEXT* ContextRecord ATTRIBUTE_UNUSED, + void *DispatcherContext ATTRIBUTE_UNUSED) +{ + struct Exception_Data *exception; + const char *msg; + + exception = __gnat_map_SEH (ExceptionRecord, &msg); + + if (exception == NULL) + { exception = &program_error; msg = "unhandled signal"; } @@ -195,6 +200,7 @@ __gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord, Raise_From_Signal_Handler (exception, msg); return 0; /* This is never reached, avoid compiler warning */ } +#endif /* !(defined (_WIN64) && defined (__SEH__)) */ #if defined (_WIN64) /* On x86_64 windows exception mechanism is no more based on a chained list diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 352665af23f..46fd546fa76 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -722,20 +722,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; Analyze (N); Scope_Suppress := Svg; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Analyze (N); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Analyze; @@ -761,20 +761,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; Analyze_List (L); Scope_Suppress := Svg; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Analyze_List (L); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Analyze_List; @@ -1022,20 +1022,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; Insert_After_And_Analyze (N, M); Scope_Suppress := Svg; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Insert_After_And_Analyze (N, M); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Insert_After_And_Analyze; @@ -1082,20 +1082,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; Insert_Before_And_Analyze (N, M); Scope_Suppress := Svg; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Insert_Before_And_Analyze (N, M); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Insert_Before_And_Analyze; @@ -1141,20 +1141,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; Insert_List_After_And_Analyze (N, L); Scope_Suppress := Svg; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Insert_List_After_And_Analyze (N, L); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Insert_List_After_And_Analyze; @@ -1199,20 +1199,20 @@ package body Sem is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; Insert_List_Before_And_Analyze (N, L); Scope_Suppress := Svg; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Insert_List_Before_And_Analyze (N, L); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Insert_List_Before_And_Analyze; @@ -1264,9 +1264,9 @@ package body Sem is -- the All_Checks flag. if C in Predefined_Check_Id then - return Scope_Suppress (C); + return Scope_Suppress.Suppress (C); else - return Scope_Suppress (All_Checks); + return Scope_Suppress.Suppress (All_Checks); end if; end Is_Check_Suppressed; diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 00babf3b371..00bce6969b6 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -310,8 +310,8 @@ package Sem is -- that are applicable to all entities. A similar search is needed for any -- non-predefined check even if no specific entity is involved. - Scope_Suppress : Suppress_Array := Suppress_Options; - -- This array contains the current scope based settings of the suppress + Scope_Suppress : Suppress_Record := Suppress_Options; + -- This variable contains the current scope based settings of the suppress -- switches. It is initialized from the options as shown, and then modified -- by pragma Suppress. On entry to each scope, the current setting is saved -- the scope stack, and then restored on exit from the scope. This record @@ -449,7 +449,7 @@ package Sem is -- Pointer to name of last subprogram body in this scope. Used for -- testing proper alpha ordering of subprogram bodies in scope. - Save_Scope_Suppress : Suppress_Array; + Save_Scope_Suppress : Suppress_Record; -- Save contents of Scope_Suppress on entry Save_Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index a5d7bee3212..737ede23845 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -2215,13 +2215,11 @@ package body Sem_Attr is Attribute_Variable_Indexing => Error_Msg_N ("illegal attribute", N); - -- Attributes related to Ada 2012 aspects. Attribute definition clause - -- exists for these, but they cannot be queried. + -- Internal attributes used to deal with Ada 2012 delayed aspects. These + -- were already rejected by the parser. Thus they shouldn't appear here. - when Attribute_CPU | - Attribute_Dispatching_Domain | - Attribute_Interrupt_Priority => - Error_Msg_N ("illegal attribute", N); + when Internal_Attribute_Id => + raise Program_Error; ------------------ -- Abort_Signal -- @@ -2575,6 +2573,15 @@ package body Sem_Attr is Set_Etype (N, RTE (RE_AST_Handler)); end AST_Entry; + ----------------------------- + -- Atomic_Always_Lock_Free -- + ----------------------------- + + when Attribute_Atomic_Always_Lock_Free => + Check_E0; + Check_Type; + Set_Etype (N, Standard_Boolean); + ---------- -- Base -- ---------- @@ -3296,12 +3303,7 @@ package body Sem_Attr is when Attribute_Fast_Math => Check_Standard_Prefix; - - if Opt.Fast_Math then - Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - else - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; + Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc)); ----------- -- First -- @@ -4033,14 +4035,21 @@ package body Sem_Attr is -- an entity in the enclosing subprogram. If it is a component of -- a formal its expansion might generate actual subtypes that may -- be referenced in an inner context, and which must be elaborated - -- within the subprogram itself. As a result we create a - -- declaration for it and insert it at the start of the enclosing - -- subprogram. This is properly an expansion activity but it has - -- to be performed now to prevent out-of-order issues. - - if Nkind (P) = N_Selected_Component - and then Has_Discriminants (Etype (Prefix (P))) - then + -- within the subprogram itself. If the prefix includes a function + -- call it may involve finalization actions that should only be + -- inserted when the attribute has been rewritten as a declarations. + -- As a result, if the prefix is not a simple name we create + -- a declaration for it now, and insert it at the start of the + -- enclosing subprogram. This is properly an expansion activity + -- but it has to be performed now to prevent out-of-order issues. + + -- This expansion is both harmful and not needed in Alfa mode, since + -- the formal verification backend relies on the types of nodes + -- (hence is not robust w.r.t. a change to base type here), and does + -- not suffer from the out-of-order issue described above. Thus, this + -- expansion is skipped in Alfa mode. + + if not Is_Entity_Name (P) and then not Alfa_Mode then P_Type := Base_Type (P_Type); Set_Etype (N, P_Type); Set_Etype (P, P_Type); @@ -4480,9 +4489,9 @@ package body Sem_Attr is Check_Decimal_Fixed_Point_Type; Set_Etype (N, P_Base_Type); - -- Because the context is universal_real (3.5.10(12)) it is a legal - -- context for a universal fixed expression. This is the only - -- attribute whose functional description involves U_R. + -- Because the context is universal_real (3.5.10(12)) it is a + -- legal context for a universal fixed expression. This is the + -- only attribute whose functional description involves U_R. if Etype (E1) = Universal_Fixed then declare @@ -4574,8 +4583,9 @@ package body Sem_Attr is Check_E0; Check_Type; - if not Is_Record_Type (P_Type) then - Error_Attr_P ("prefix of % attribute must be record type"); + if not Is_Record_Type (P_Type) or else Is_Array_Type (P_Type) then + Error_Attr_P + ("prefix of % attribute must be record or array type"); end if; if Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then @@ -4776,8 +4786,8 @@ package body Sem_Attr is Validate_Remote_Access_To_Class_Wide_Type (N); - -- The prefix is allowed to be an implicit dereference - -- of an access value designating a task. + -- The prefix is allowed to be an implicit dereference of an + -- access value designating a task. else Check_Task_Prefix; @@ -5870,7 +5880,7 @@ package body Sem_Attr is begin if No (E1) then if C in Predefined_Check_Id then - R := Scope_Suppress (C); + R := Scope_Suppress.Suppress (C); else R := Is_Check_Suppressed (Empty, C); end if; @@ -5879,11 +5889,7 @@ package body Sem_Attr is R := Is_Check_Suppressed (Entity (E1), C); end if; - if R then - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - else - Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - end if; + Rewrite (N, New_Occurrence_Of (Boolean_Literals (not R), Loc)); end; end if; @@ -5959,6 +5965,13 @@ package body Sem_Attr is return; end if; + -- For Lock_Free, we apply the attribute to the type of the object. + -- This is allowed since we have already verified that the type is a + -- protected type. + + elsif Id = Attribute_Lock_Free then + P_Entity := Etype (P); + -- No other attributes for objects are folded else @@ -6024,10 +6037,13 @@ package body Sem_Attr is -- Definite must be folded if the prefix is not a generic type, -- that is to say if we are within an instantiation. Same processing - -- applies to the GNAT attributes Has_Discriminants, Type_Class, - -- Has_Tagged_Value, and Unconstrained_Array. + -- applies to the GNAT attributes Atomic_Always_Lock_Free, + -- Has_Discriminants, Lock_Free, Type_Class, Has_Tagged_Value, and + -- Unconstrained_Array. - elsif (Id = Attribute_Definite + elsif (Id = Attribute_Atomic_Always_Lock_Free + or else + Id = Attribute_Definite or else Id = Attribute_Has_Access_Values or else @@ -6035,6 +6051,8 @@ package body Sem_Attr is or else Id = Attribute_Has_Tagged_Values or else + Id = Attribute_Lock_Free + or else Id = Attribute_Type_Class or else Id = Attribute_Unconstrained_Array @@ -6139,16 +6157,19 @@ package body Sem_Attr is -- since we can't do anything with unconstrained arrays. In addition, -- only the First, Last and Length attributes are possibly static. - -- Definite, Has_Access_Values, Has_Discriminants, Has_Tagged_Values, - -- Type_Class, and Unconstrained_Array are again exceptions, because - -- they apply as well to unconstrained types. + -- Atomic_Always_Lock_Free, Definite, Has_Access_Values, + -- Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and + -- Unconstrained_Array are again exceptions, because they apply as well + -- to unconstrained types. -- In addition Component_Size is an exception since it is possibly -- foldable, even though it is never static, and it does apply to -- unconstrained arrays. Furthermore, it is essential to fold this -- in the packed case, since otherwise the value will be incorrect. - elsif Id = Attribute_Definite + elsif Id = Attribute_Atomic_Always_Lock_Free + or else + Id = Attribute_Definite or else Id = Attribute_Has_Access_Values or else @@ -6156,6 +6177,8 @@ package body Sem_Attr is or else Id = Attribute_Has_Tagged_Values or else + Id = Attribute_Lock_Free + or else Id = Attribute_Type_Class or else Id = Attribute_Unconstrained_Array @@ -6332,11 +6355,12 @@ package body Sem_Attr is Attribute_Iterator_Element | Attribute_Variable_Indexing => null; - -- Atributes related to Ada 2012 aspects + -- Internal attributes used to deal with Ada 2012 delayed aspects. + -- These were already rejected by the parser. Thus they shouldn't + -- appear here. - when Attribute_CPU | - Attribute_Dispatching_Domain | - Attribute_Interrupt_Priority => null; + when Internal_Attribute_Id => + raise Program_Error; -------------- -- Adjacent -- @@ -6383,6 +6407,30 @@ package body Sem_Attr is null; end if; + ----------------------------- + -- Atomic_Always_Lock_Free -- + ----------------------------- + + -- Atomic_Always_Lock_Free attribute is a Boolean, thus no need to fold + -- here. + + when Attribute_Atomic_Always_Lock_Free => Atomic_Always_Lock_Free : + declare + V : constant Entity_Id := + Boolean_Literals + (Support_Atomic_Primitives_On_Target + and then Support_Atomic_Primitives (P_Type)); + + begin + Rewrite (N, New_Occurrence_Of (V, Loc)); + + -- Analyze and resolve as boolean. Note that this attribute is a + -- static attribute in GNAT. + + Analyze_And_Resolve (N, Standard_Boolean); + Static := True; + end Atomic_Always_Lock_Free; + --------- -- Bit -- --------- @@ -6803,10 +6851,18 @@ package body Sem_Attr is -- Lock_Free -- --------------- - -- Lock_Free attribute is a Boolean, thus no need to fold here. + when Attribute_Lock_Free => Lock_Free : declare + V : constant Entity_Id := Boolean_Literals (Uses_Lock_Free (P_Type)); - when Attribute_Lock_Free => - null; + begin + Rewrite (N, New_Occurrence_Of (V, Loc)); + + -- Analyze and resolve as boolean. Note that this attribute is a + -- static attribute in GNAT. + + Analyze_And_Resolve (N, Standard_Boolean); + Static := True; + end Lock_Free; ---------- -- Last -- diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index d729519003e..bb24fc2e21a 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -489,6 +489,40 @@ package body Sem_Aux is return Empty; end Get_Rep_Item; + function Get_Rep_Item + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Node_Id + is + Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents); + Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents); + + N : Node_Id; + + begin + -- Check both Nam1_Item and Nam2_Item are present + + if No (Nam1_Item) then + return Nam2_Item; + elsif No (Nam2_Item) then + return Nam1_Item; + end if; + + -- Return the first node encountered in the list + + N := First_Rep_Item (E); + while Present (N) loop + if N = Nam1_Item or else N = Nam2_Item then + return N; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Rep_Item; + -------------------- -- Get_Rep_Pragma -- -------------------- @@ -501,31 +535,41 @@ package body Sem_Aux is N : Node_Id; begin - N := First_Rep_Item (E); - while Present (N) loop - if Nkind (N) = N_Pragma - and then - (Pragma_Name (N) = Nam - or else (Nam = Name_Interrupt_Priority - and then Pragma_Name (N) = Name_Priority)) - then - if Check_Parents then - return N; + N := Get_Rep_Item (E, Nam, Check_Parents); - -- If Check_Parents is False, return N if the pragma doesn't - -- appear in the Rep_Item chain of the parent. + if Present (N) and then Nkind (N) = N_Pragma then + return N; + end if; - else - declare - Par : constant Entity_Id := Nearest_Ancestor (E); - -- This node represents the parent type of type E (if any) + return Empty; + end Get_Rep_Pragma; - begin - if No (Par) or else not Present_In_Rep_Item (Par, N) then - return N; - end if; - end; - end if; + function Get_Rep_Pragma + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Node_Id + is + Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents); + Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents); + + N : Node_Id; + + begin + -- Check both Nam1_Item and Nam2_Item are present + + if No (Nam1_Item) then + return Nam2_Item; + elsif No (Nam2_Item) then + return Nam1_Item; + end if; + + -- Return the first node encountered in the list + + N := First_Rep_Item (E); + while Present (N) loop + if N = Nam1_Item or else N = Nam2_Item then + return N; end if; Next_Rep_Item (N); @@ -547,6 +591,16 @@ package body Sem_Aux is return Present (Get_Rep_Item (E, Nam, Check_Parents)); end Has_Rep_Item; + function Has_Rep_Item + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Boolean + is + begin + return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents)); + end Has_Rep_Item; + -------------------- -- Has_Rep_Pragma -- -------------------- @@ -560,6 +614,16 @@ package body Sem_Aux is return Present (Get_Rep_Pragma (E, Nam, Check_Parents)); end Has_Rep_Pragma; + function Has_Rep_Pragma + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Boolean + is + begin + return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents)); + end Has_Rep_Pragma; + ------------------------------- -- Initialization_Suppressed -- ------------------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index bf09e99ba5a..fafd70f7f45 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -168,18 +168,47 @@ package Sem_Aux is -- otherwise Empty is returned. A special case is that when Nam is -- Name_Priority, the call will also find Interrupt_Priority. + function Get_Rep_Item + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for an instance of a + -- rep item (pragma, attribute definition clause, or aspect specification) + -- whose name matches one of the given names Nam1 or Nam2. If Check_Parents + -- is False then it only returns rep item that has been directly specified + -- for E (and not inherited from its parents, if any). If one is found, it + -- is returned, otherwise Empty is returned. A special case is that when + -- one of the given names is Name_Priority, the call will also find + -- Interrupt_Priority. + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id; Check_Parents : Boolean := True) return Node_Id; - -- Searches the Rep_Item chain for a given entity E, for an instance - -- of a representation pragma whose name matches the given name Nam. If + -- Searches the Rep_Item chain for a given entity E, for an instance of a + -- representation pragma whose name matches the given name Nam. If -- Check_Parents is False then it only returns representation pragma that -- has been directly specified for E (and not inherited from its parents, - -- if any). If one is found, it is returned, otherwise Empty is returned. A - -- special case is that when Nam is Name_Priority, the call will also find + -- if any). If one is found and if it is the first rep item in the list + -- that matches Nam, it is returned, otherwise Empty is returned. A special + -- case is that when Nam is Name_Priority, the call will also find -- Interrupt_Priority. + function Get_Rep_Pragma + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for an instance of a + -- representation pragma whose name matches one of the given names Nam1 or + -- Nam2. If Check_Parents is False then it only returns representation + -- pragma that has been directly specified for E (and not inherited from + -- its parents, if any). If one is found and if it is the first rep item in + -- the list that matches one of the given names, it is returned, otherwise + -- Empty is returned. A special case is that when one of the given names is + -- Name_Priority, the call will also find Interrupt_Priority. + function Has_Rep_Item (E : Entity_Id; Nam : Name_Id; @@ -191,6 +220,18 @@ package Sem_Aux is -- from its parents, if any). If found then True is returned, otherwise -- False indicates that no matching entry was found. + function Has_Rep_Item + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Boolean; + -- Searches the Rep_Item chain for the given entity E, for an instance of a + -- rep item (pragma, attribute definition clause, or aspect specification) + -- with the given names Nam1 or Nam2. If Check_Parents is False then it + -- only checks for a rep item that has been directly specified for E (and + -- not inherited from its parents, if any). If found then True is returned, + -- otherwise False indicates that no matching entry was found. + function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id; @@ -199,8 +240,21 @@ package Sem_Aux is -- representation pragma with the given name Nam. If Check_Parents is False -- then it only checks for a representation pragma that has been directly -- specified for E (and not inherited from its parents, if any). If found - -- then True is returned, otherwise False indicates that no matching entry - -- was found. + -- and if it is the first rep item in the list that matches Nam then True + -- is returned, otherwise False indicates that no matching entry was found. + + function Has_Rep_Pragma + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Boolean; + -- Searches the Rep_Item chain for the given entity E, for an instance of a + -- representation pragma with the given names Nam1 or Nam2. If + -- Check_Parents is False then it only checks for a rep item that has been + -- directly specified for E (and not inherited from its parents, if any). + -- If found and if it is the first rep item in the list that matches one of + -- the given names then True is returned, otherwise False indicates that no + -- matching entry was found. function In_Generic_Body (Id : Entity_Id) return Boolean; -- Determine whether entity Id appears inside a generic body diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 8fa307442a6..3dd3b617820 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -162,9 +162,7 @@ package body Sem_Case is -- AI05-0188 : within an instance the non-others choices do not -- have to belong to the actual subtype. - if Ada_Version >= Ada_2012 - and then In_Instance - then + if Ada_Version >= Ada_2012 and then In_Instance then return; end if; @@ -714,7 +712,8 @@ package body Sem_Case is -- Do not insert non static choices in the table to be sorted elsif not Is_Static_Expression (Lo) - or else not Is_Static_Expression (Hi) + or else + not Is_Static_Expression (Hi) then Process_Non_Static_Choice (Choice); return; @@ -727,12 +726,10 @@ package body Sem_Case is Raises_CE := True; return; - -- AI05-0188 : within an instance the non-others choices do not + -- AI05-0188 : Within an instance the non-others choices do not -- have to belong to the actual subtype. - elsif Ada_Version >= Ada_2012 - and then In_Instance - then + elsif Ada_Version >= Ada_2012 and then In_Instance then return; -- Otherwise we have an OK static choice diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index e53645e45de..4d8b8ffc5d0 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -219,10 +219,15 @@ package body Sem_Cat is then null; - -- Special case: Remote_Types can depend on Preelaborated per - -- Ada 2005 AI 0206. + -- Special case: Remote_Types and Remote_Call_Interface declarations + -- can depend on a preelaborated unit via a private with_clause, per + -- AI05-0206. - elsif Unit_Category = Remote_Types + elsif (Unit_Category = Remote_Types + or else + Unit_Category = Remote_Call_Interface) + and then Nkind (N) = N_With_Clause + and then Private_Present (N) and then Is_Preelaborated (Depended_Entity) then null; @@ -263,6 +268,18 @@ package body Sem_Cat is then return; + -- Dependence of Remote_Types or Remote_Call_Interface declaration + -- on a preelaborated unit with a normal with_clause. + + elsif (Unit_Category = Remote_Types + or else + Unit_Category = Remote_Call_Interface) + and then Is_Preelaborated (Depended_Entity) + then + Error_Msg_NE + ("<must use private with clause for preelaborated unit& ", + N, Depended_Entity); + -- Subunit case elsif Is_Subunit then diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 6ed11b87766..31e8e5564e5 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1964,7 +1964,7 @@ package body Sem_Ch10 is Num_Scopes : Int := 0; Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id; Enclosing_Child : Entity_Id := Empty; - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index c4351fce11a..60edce32f2d 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -7068,6 +7068,8 @@ package body Sem_Ch12 is D2 : Integer := 0; P1 : Node_Id := N1; P2 : Node_Id := N2; + T1 : Source_Ptr; + T2 : Source_Ptr; -- Start of processing for Earlier @@ -7208,19 +7210,21 @@ package body Sem_Ch12 is -- At this point either both nodes came from source or we approximated -- their source locations through neighbouring source statements. + T1 := Top_Level_Location (Sloc (P1)); + T2 := Top_Level_Location (Sloc (P2)); + -- When two nodes come from the same instance, they have identical top -- level locations. To determine proper relation within the tree, check -- their locations within the template. - if Top_Level_Location (Sloc (P1)) = Top_Level_Location (Sloc (P2)) then + if T1 = T2 then return Sloc (P1) < Sloc (P2); -- The two nodes either come from unrelated instances or do not come -- from instantiated code at all. else - return Top_Level_Location (Sloc (P1)) - < Top_Level_Location (Sloc (P2)); + return T1 < T2; end if; end Earlier; @@ -7852,9 +7856,9 @@ package body Sem_Ch12 is (N : Node_Id; F_Node : Node_Id) is - Inst : constant Entity_Id := Entity (F_Node); Decl : Node_Id; Decls : List_Id; + Inst : Entity_Id; Par_N : Node_Id; function Enclosing_Body (N : Node_Id) return Node_Id; @@ -7921,9 +7925,18 @@ package body Sem_Ch12 is begin if not Is_List_Member (F_Node) then + Decl := N; Decls := List_Containing (N); + Inst := Entity (F_Node); Par_N := Parent (Decls); - Decl := N; + + -- When processing a subprogram instantiation, utilize the actual + -- subprogram instantiation rather than its package wrapper as it + -- carries all the context information. + + if Is_Wrapper_Package (Inst) then + Inst := Related_Instance (Inst); + end if; -- If this is a package instance, check whether the generic is -- declared in a previous instance and the current instance is @@ -10811,8 +10824,8 @@ package body Sem_Ch12 is pragma Assert (Present (Ancestor)); - -- the ancestor itself may be a previous formal that - -- has been instantiated. + -- The ancestor itself may be a previous formal that has been + -- instantiated. Ancestor := Get_Instance_Of (Ancestor); @@ -10821,6 +10834,17 @@ package body Sem_Ch12 is Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T))); end if; + -- An unusual case: the actual is a type declared in a parent unit, + -- but is not a formal type so there is no instance_of for it. + -- Retrieve it by analyzing the record extension. + + elsif Is_Child_Unit (Scope (A_Gen_T)) + and then In_Open_Scopes (Scope (Act_T)) + and then Is_Generic_Instance (Scope (Act_T)) + then + Analyze (Subtype_Mark (Def)); + Ancestor := Entity (Subtype_Mark (Def)); + else Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T))); end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index e177f930f6b..fff9bded522 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -48,6 +48,7 @@ with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch9; use Sem_Ch9; with Sem_Dim; use Sem_Dim; +with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -850,23 +851,20 @@ package body Sem_Ch13 is Set_Is_Delayed_Aspect (Prag); Set_Parent (Prag, ASN); end if; - end Make_Pragma_From_Boolean_Aspect; -- Start of processing for Analyze_Aspects_At_Freeze_Point begin - -- Must be declared in current scope. This is need for a generic - -- context. + -- Must be visible in current scope. - if Scope (E) /= Current_Scope then + if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then return; end if; -- Look for aspect specification entries for this entity ASN := First_Rep_Item (E); - while Present (ASN) loop if Nkind (ASN) = N_Aspect_Specification and then Entity (ASN) = E @@ -875,6 +873,7 @@ package body Sem_Ch13 is A_Id := Get_Aspect_Id (Chars (Identifier (ASN))); case A_Id is + -- For aspects whose expression is an optional Boolean, make -- the corresponding pragma at the freezing point. @@ -889,7 +888,8 @@ package body Sem_Ch13 is Aspect_Default_Component_Value => Analyze_Aspect_Default_Value (ASN); - when others => null; + when others => + null; end case; Ritem := Aspect_Rep_Item (ASN); @@ -1098,29 +1098,7 @@ package body Sem_Ch13 is ("aspect `%''Class` for & previously given#", Id, E); end if; - - -- Case of Pre and Pre'Class both specified - - elsif Nam = Name_Pre then - if Class_Present (Aspect) then - Error_Msg_NE - ("aspect `Pre''Class` for & is not allowed here", - Id, E); - Error_Msg_NE - ("\since aspect `Pre` previously given#", - Id, E); - - else - Error_Msg_NE - ("aspect `Pre` for & is not allowed here", - Id, E); - Error_Msg_NE - ("\since aspect `Pre''Class` previously given#", - Id, E); - end if; end if; - - -- Allowed case of X and X'Class both specified end if; Next (Anod); @@ -1171,17 +1149,14 @@ package body Sem_Ch13 is Aspect_Bit_Order | Aspect_Component_Size | Aspect_Constant_Indexing | - Aspect_CPU | Aspect_Default_Iterator | Aspect_Dispatching_Domain | Aspect_External_Tag | Aspect_Input | - Aspect_Interrupt_Priority | Aspect_Iterator_Element | Aspect_Machine_Radix | Aspect_Object_Size | Aspect_Output | - Aspect_Priority | Aspect_Read | Aspect_Scalar_Storage_Order | Aspect_Size | @@ -1362,6 +1337,29 @@ package body Sem_Ch13 is Make_Identifier (Loc, P_Name)); end; + -- The following three aspects can be specified for a + -- subprogram body, in which case we generate pragmas for them + -- and insert them ahead of local declarations, rather than + -- after the body. + + when Aspect_CPU | + Aspect_Interrupt_Priority | + Aspect_Priority => + if Nkind (N) = N_Subprogram_Body then + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => + New_List (Relocate_Node (Expr)), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id))); + else + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + end if; + when Aspect_Warnings => -- Construct the pragma @@ -1650,6 +1648,7 @@ package body Sem_Ch13 is if A_Id = Aspect_Lock_Free then if Ekind (E) /= E_Protected_Type then + Error_Msg_Name_1 := Nam; Error_Msg_N ("aspect % only applies to a protected object", Aspect); @@ -1746,7 +1745,8 @@ package body Sem_Ch13 is -- In the context of a compilation unit, we directly put the -- pragma in the Pragmas_After list of the - -- N_Compilation_Unit_Aux node. No delay is required here. + -- N_Compilation_Unit_Aux node (No delay is required here) + -- except for aspects on a subprogram body (see below). if Nkind (Parent (N)) = N_Compilation_Unit and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) @@ -1778,11 +1778,25 @@ package body Sem_Ch13 is end if; end if; - if No (Pragmas_After (Aux)) then - Set_Pragmas_After (Aux, Empty_List); + -- If the aspect is on a subprogram body (relevant aspects + -- are Inline and Priority), add the pragma in front of + -- the declarations. + + if Nkind (N) = N_Subprogram_Body then + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + + Prepend (Aitem, Declarations (N)); + + else + if No (Pragmas_After (Aux)) then + Set_Pragmas_After (Aux, Empty_List); + end if; + + Append (Aitem, Pragmas_After (Aux)); end if; - Append (Aitem, Pragmas_After (Aux)); goto Continue; end; end if; @@ -1852,8 +1866,8 @@ package body Sem_Ch13 is Chars => Name_Address, Expression => Expression (N))); - -- We preserve Comes_From_Source, since logically the clause still - -- comes from the source program even though it is changed in form. + -- We preserve Comes_From_Source, since logically the clause still comes + -- from the source program even though it is changed in form. Set_Comes_From_Source (N, CS); @@ -2420,11 +2434,12 @@ package body Sem_Ch13 is return; -- Must be declared in current scope or in case of an aspect - -- specification, must be the current scope. + -- specification, must be visible in current scope. elsif Scope (Ent) /= Current_Scope - and then (not From_Aspect_Specification (N) - or else Ent /= Current_Scope) + and then + not (From_Aspect_Specification (N) + and then Scope_Within_Or_Same (Current_Scope, Scope (Ent))) then Error_Msg_N ("entity must be declared in this scope", Nam); return; @@ -2671,8 +2686,8 @@ package body Sem_Ch13 is -- Legality checks on the address clause for initialized -- objects is deferred until the freeze point, because - -- a subsequent pragma might indicate that the object is - -- imported and thus not initialized. + -- a subsequent pragma might indicate that the object + -- is imported and thus not initialized. Set_Has_Delayed_Freeze (U_Ent); @@ -3106,8 +3121,8 @@ package body Sem_Ch13 is when Attribute_Implicit_Dereference => - -- Legality checks already performed at the point of - -- the type declaration, aspect is not delayed. + -- Legality checks already performed at the point of the type + -- declaration, aspect is not delayed. null; @@ -3264,10 +3279,11 @@ package body Sem_Ch13 is if From_Aspect_Specification (N) then if not (Is_Protected_Type (U_Ent) - or else Is_Task_Type (U_Ent)) + or else Is_Task_Type (U_Ent) + or else Ekind (U_Ent) = E_Procedure) then Error_Msg_N - ("Priority can only be defined for task and protected" & + ("Priority can only be defined for task and protected " & "object", Nam); @@ -3312,10 +3328,10 @@ package body Sem_Ch13 is when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare begin - if not Is_Record_Type (U_Ent) then + if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then Error_Msg_N - ("Scalar_Storage_Order can only be defined for record type", - Nam); + ("Scalar_Storage_Order can only be defined for " + & "record or array type", Nam); elsif Duplicate_Clause then null; @@ -3332,7 +3348,7 @@ package body Sem_Ch13 is else if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then - Set_Reverse_Storage_Order (U_Ent, True); + Set_Reverse_Storage_Order (Base_Type (U_Ent), True); end if; end if; end if; @@ -4344,6 +4360,46 @@ package body Sem_Ch13 is end; end if; + -- Check Ada derivation of CPP type + + if Expander_Active + and then Tagged_Type_Expansion + and then Ekind (E) = E_Record_Type + and then Etype (E) /= E + and then Is_CPP_Class (Etype (E)) + and then CPP_Num_Prims (Etype (E)) > 0 + and then not Is_CPP_Class (E) + and then not Has_CPP_Constructors (Etype (E)) + then + -- If the parent has C++ primitives but it has no constructor then + -- check that all the primitives are overridden in this derivation; + -- otherwise the constructor of the parent is needed to build the + -- dispatch table. + + declare + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (E)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if not Is_Abstract_Subprogram (Prim) + and then No (Interface_Alias (Prim)) + and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E + then + Error_Msg_Name_1 := Chars (Etype (E)); + Error_Msg_N + ("'C'P'P constructor required for parent type %", E); + exit; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; -- If we have a type with predicates, build predicate function @@ -6350,25 +6406,18 @@ package body Sem_Ch13 is -- but Expression (Ident) is a preanalyzed copy of the expression, -- preanalyzed just after the freeze point. - begin - -- Case of aspects Dimension, Dimension_System and Synchronization - - if A_Id = Aspect_Synchronization then - return; - - -- Case of stream attributes, just have to compare entities. However, - -- the expression is just a name (possibly overloaded), and there may - -- be stream operations declared for unrelated types, so we just need - -- to verify that one of these interpretations is the one available at - -- at the freeze point. + procedure Check_Overloaded_Name; + -- For aspects whose expression is simply a name, this routine checks if + -- the name is overloaded or not. If so, it verifies there is an + -- interpretation that matches the entity obtained at the freeze point, + -- otherwise the compiler complains. - elsif A_Id = Aspect_Input or else - A_Id = Aspect_Output or else - A_Id = Aspect_Read or else - A_Id = Aspect_Write - then - Analyze (End_Decl_Expr); + --------------------------- + -- Check_Overloaded_Name -- + --------------------------- + procedure Check_Overloaded_Name is + begin if not Is_Overloaded (End_Decl_Expr) then Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr); @@ -6391,6 +6440,29 @@ package body Sem_Ch13 is end loop; end; end if; + end Check_Overloaded_Name; + + -- Start of processing for Check_Aspect_At_End_Of_Declarations + + begin + -- Case of aspects Dimension, Dimension_System and Synchronization + + if A_Id = Aspect_Synchronization then + return; + + -- Case of stream attributes, just have to compare entities. However, + -- the expression is just a name (possibly overloaded), and there may + -- be stream operations declared for unrelated types, so we just need + -- to verify that one of these interpretations is the one available at + -- at the freeze point. + + elsif A_Id = Aspect_Input or else + A_Id = Aspect_Output or else + A_Id = Aspect_Read or else + A_Id = Aspect_Write + then + Analyze (End_Decl_Expr); + Check_Overloaded_Name; elsif A_Id = Aspect_Variable_Indexing or else A_Id = Aspect_Constant_Indexing or else @@ -6402,16 +6474,16 @@ package body Sem_Ch13 is Set_Is_Frozen (Ent, False); Analyze (End_Decl_Expr); - Analyze (Aspect_Rep_Item (ASN)); Set_Is_Frozen (Ent, True); -- If the end of declarations comes before any other freeze -- point, the Freeze_Expr is not analyzed: no check needed. - Err := - Analyzed (Freeze_Expr) - and then not In_Instance - and then Entity (End_Decl_Expr) /= Entity (Freeze_Expr); + if Analyzed (Freeze_Expr) and then not In_Instance then + Check_Overloaded_Name; + else + Err := False; + end if; -- All other cases @@ -7719,6 +7791,19 @@ package body Sem_Ch13 is begin Biased := False; + -- Reject patently improper size values. + + if Is_Elementary_Type (T) + and then Siz > UI_From_Int (Int'Last) + then + Error_Msg_N ("Size value too large for elementary type", N); + + if Nkind (Original_Node (N)) = N_Op_Expon then + Error_Msg_N + ("\maybe '* was meant, rather than '*'*", Original_Node (N)); + end if; + end if; + -- Dismiss cases for generic types or types with previous errors if No (UT) @@ -7857,6 +7942,223 @@ package body Sem_Ch13 is end if; end Get_Alignment_Value; + ------------------------------------- + -- Inherit_Aspects_At_Freeze_Point -- + ------------------------------------- + + procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is + function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Rep_Item : Node_Id) return Boolean; + -- This routine checks if Rep_Item is either a pragma or an aspect + -- specification node whose correponding pragma (if any) is present in + -- the Rep Item chain of the entity it has been specified to. + + -------------------------------------------------- + -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item -- + -------------------------------------------------- + + function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Rep_Item : Node_Id) return Boolean + is + begin + return Nkind (Rep_Item) = N_Pragma + or else Present_In_Rep_Item + (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item)); + end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item; + + begin + -- A representation item is either subtype-specific (Size and Alignment + -- clauses) or type-related (all others). Subtype-specific aspects may + -- differ for different subtypes of the same type.(RM 13.1.8) + + -- A derived type inherits each type-related representation aspect of + -- its parent type that was directly specified before the declaration of + -- the derived type. (RM 13.1.15) + + -- A derived subtype inherits each subtype-specific representation + -- aspect of its parent subtype that was directly specified before the + -- declaration of the derived type .(RM 13.1.15) + + -- The general processing involves inheriting a representation aspect + -- from a parent type whenever the first rep item (aspect specification, + -- attribute definition clause, pragma) corresponding to the given + -- representation aspect in the rep item chain of Typ, if any, isn't + -- directly specified to Typ but to one of its parents. + + -- ??? Note that, for now, just a limited number of representation + -- aspects have been inherited here so far. Many of them are still + -- inherited in Sem_Ch3. This will be fixed soon. Here is a + -- non-exhaustive list of aspects that likely also need to be moved to + -- this routine: Alignment, Component_Alignment, Component_Size, + -- Machine_Radix, Object_Size, Pack, Predicates, + -- Preelaborable_Initialization, RM_Size and Small. + + if Nkind (Parent (Typ)) = N_Private_Extension_Declaration then + return; + end if; + + -- Ada_05/Ada_2005 + + if not Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005, False) + and then Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005)) + then + Set_Is_Ada_2005_Only (Typ); + end if; + + -- Ada_12/Ada_2012 + + if not Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012, False) + and then Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012)) + then + Set_Is_Ada_2012_Only (Typ); + end if; + + -- Atomic/Shared + + if not Has_Rep_Item (Typ, Name_Atomic, Name_Shared, False) + and then Has_Rep_Pragma (Typ, Name_Atomic, Name_Shared) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Atomic, Name_Shared)) + then + Set_Is_Atomic (Typ); + Set_Treat_As_Volatile (Typ); + Set_Is_Volatile (Typ); + end if; + + -- Default_Component_Value. + + if Is_Array_Type (Typ) + and then Has_Rep_Item (Typ, Name_Default_Component_Value, False) + and then Has_Rep_Item (Typ, Name_Default_Component_Value) + then + Set_Default_Aspect_Component_Value (Typ, + Default_Aspect_Component_Value + (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value)))); + end if; + + -- Default_Value. + + if Is_Scalar_Type (Typ) + and then Has_Rep_Item (Typ, Name_Default_Value, False) + and then Has_Rep_Item (Typ, Name_Default_Value) + then + Set_Default_Aspect_Value (Typ, + Default_Aspect_Value + (Entity (Get_Rep_Item (Typ, Name_Default_Value)))); + end if; + + -- Discard_Names + + if not Has_Rep_Item (Typ, Name_Discard_Names, False) + and then Has_Rep_Item (Typ, Name_Discard_Names) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Discard_Names)) + then + Set_Discard_Names (Typ); + end if; + + -- Invariants + + if not Has_Rep_Item (Typ, Name_Invariant, False) + and then Has_Rep_Item (Typ, Name_Invariant) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Invariant)) + then + Set_Has_Invariants (Typ); + + if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then + Set_Has_Inheritable_Invariants (Typ); + end if; + end if; + + -- Volatile + + if not Has_Rep_Item (Typ, Name_Volatile, False) + and then Has_Rep_Item (Typ, Name_Volatile) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Volatile)) + then + Set_Treat_As_Volatile (Typ); + Set_Is_Volatile (Typ); + end if; + + -- Inheritance for derived types only + + if Is_Derived_Type (Typ) then + declare + Bas_Typ : constant Entity_Id := Base_Type (Typ); + Imp_Bas_Typ : constant Entity_Id := Implementation_Base_Type (Typ); + + begin + -- Atomic_Components + + if not Has_Rep_Item (Typ, Name_Atomic_Components, False) + and then Has_Rep_Item (Typ, Name_Atomic_Components) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Atomic_Components)) + then + Set_Has_Atomic_Components (Imp_Bas_Typ); + end if; + + -- Volatile_Components + + if not Has_Rep_Item (Typ, Name_Volatile_Components, False) + and then Has_Rep_Item (Typ, Name_Volatile_Components) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Volatile_Components)) + then + Set_Has_Volatile_Components (Imp_Bas_Typ); + end if; + + -- Finalize_Storage_Only. + + if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False) + and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only) + then + Set_Finalize_Storage_Only (Bas_Typ); + end if; + + -- Universal_Aliasing + + if not Has_Rep_Item (Typ, Name_Universal_Aliasing, False) + and then Has_Rep_Item (Typ, Name_Universal_Aliasing) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Universal_Aliasing)) + then + Set_Universal_Aliasing (Imp_Bas_Typ); + end if; + + -- Record type specific aspects + + if Is_Record_Type (Typ) then + -- Bit_Order + + if not Has_Rep_Item (Typ, Name_Bit_Order, False) + and then Has_Rep_Item (Typ, Name_Bit_Order) + then + Set_Reverse_Bit_Order (Bas_Typ, + Reverse_Bit_Order (Entity (Name + (Get_Rep_Item (Typ, Name_Bit_Order))))); + end if; + + -- Scalar_Storage_Order + + if not Has_Rep_Item (Typ, Name_Scalar_Storage_Order, False) + and then Has_Rep_Item (Typ, Name_Scalar_Storage_Order) + then + Set_Reverse_Storage_Order (Bas_Typ, + Reverse_Storage_Order (Entity (Name + (Get_Rep_Item (Typ, Name_Scalar_Storage_Order))))); + end if; + end if; + end; + end if; + end Inherit_Aspects_At_Freeze_Point; + ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index ba335e19585..0ac7386e878 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -310,4 +310,8 @@ package Sem_Ch13 is -- Performs the processing described above at the freeze all point, and -- issues appropriate error messages if the visibility has indeed changed. -- Again, ASN is the N_Aspect_Specification node for the aspect. + + procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id); + -- Given an entity Typ that denotes a derived type or a subtype, this + -- routine performs the inheritance of aspects at the freeze point. end Sem_Ch13; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b58c21f6ca9..b61821e6549 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3078,8 +3078,11 @@ package body Sem_Ch3 is -- in the RM is removed) because accessibility checks are sufficient -- to make handlers not at the library level illegal. + -- AI05-0303: the AI is in fact a binding interpretation, and thus + -- applies to the '95 version of the language as well. + if Has_Interrupt_Handler (T) - and then Ada_Version < Ada_2005 + and then Ada_Version < Ada_95 then Error_Msg_N ("interrupt object can only be declared at library level", Id); @@ -4045,12 +4048,9 @@ package body Sem_Ch3 is -- Inherit common attributes - Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); Set_Is_Volatile (Id, Is_Volatile (T)); Set_Treat_As_Volatile (Id, Treat_As_Volatile (T)); - Set_Is_Atomic (Id, Is_Atomic (T)); - Set_Is_Ada_2005_Only (Id, Is_Ada_2005_Only (T)); - Set_Is_Ada_2012_Only (Id, Is_Ada_2012_Only (T)); + Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); Set_Convention (Id, Convention (T)); -- If ancestor has predicates then so does the subtype, and in addition @@ -4973,6 +4973,13 @@ package body Sem_Ch3 is ("the type of a component cannot be abstract", Subtype_Indication (Component_Def)); end if; + + -- Ada 2012: if the element type has invariants we must create an + -- invariant procedure for the array type as well. + + if Has_Invariants (Element_Type) then + Set_Has_Invariants (T); + end if; end Array_Type_Declaration; ------------------------------------------------------ @@ -5422,7 +5429,8 @@ package body Sem_Ch3 is elsif Constraint_Present then - -- Build constrained subtype and derive from it + -- Build constrained subtype, copying the constraint, and derive + -- from it to create a derived constrained type. declare Loc : constant Source_Ptr := Sloc (N); @@ -5436,7 +5444,7 @@ package body Sem_Ch3 is Make_Subtype_Declaration (Loc, Defining_Identifier => Anon, Subtype_Indication => - Subtype_Indication (Type_Definition (N))); + New_Copy_Tree (Subtype_Indication (Type_Definition (N)))); Insert_Before (N, Decl); Analyze (Decl); @@ -5844,13 +5852,6 @@ package body Sem_Ch3 is Analyze (N); - -- If pragma Discard_Names applies on the first subtype of the parent - -- type, then it must be applied on this subtype as well. - - if Einfo.Discard_Names (First_Subtype (Parent_Type)) then - Set_Discard_Names (Derived_Type); - end if; - -- Apply a range check. Since this range expression doesn't have an -- Etype, we have to specifically pass the Source_Typ parameter. Is -- this right??? @@ -7655,8 +7656,6 @@ package body Sem_Ch3 is -- Fields inherited from the Parent_Type - Set_Discard_Names - (Derived_Type, Einfo.Discard_Names (Parent_Type)); Set_Has_Specified_Layout (Derived_Type, Has_Specified_Layout (Parent_Type)); Set_Is_Limited_Composite @@ -7700,20 +7699,9 @@ package body Sem_Ch3 is Set_OK_To_Reorder_Components (Derived_Type, OK_To_Reorder_Components (Parent_Full)); - Set_Reverse_Bit_Order - (Derived_Type, Reverse_Bit_Order (Parent_Full)); - Set_Reverse_Storage_Order - (Derived_Type, Reverse_Storage_Order (Parent_Full)); end; end if; - -- Direct controlled types do not inherit Finalize_Storage_Only flag - - if not Is_Controlled (Parent_Type) then - Set_Finalize_Storage_Only - (Derived_Type, Finalize_Storage_Only (Parent_Type)); - end if; - -- Set fields for private derived types if Is_Private_Type (Derived_Type) then @@ -8032,11 +8020,6 @@ package body Sem_Ch3 is -- they are inherited from the parent type, and these invariants can -- be further inherited, so both flags are set. - if Has_Inheritable_Invariants (Parent_Type) then - Set_Has_Inheritable_Invariants (Derived_Type); - Set_Has_Invariants (Derived_Type); - end if; - -- We similarly inherit predicates if Has_Predicates (Parent_Type) then @@ -12207,7 +12190,6 @@ package body Sem_Ch3 is Set_Component_Type (T1, Component_Type (T2)); Set_Component_Size (T1, Component_Size (T2)); Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); - Set_Finalize_Storage_Only (T1, Finalize_Storage_Only (T2)); Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); Set_Has_Task (T1, Has_Task (T2)); Set_Is_Packed (T1, Is_Packed (T2)); @@ -12226,7 +12208,6 @@ package body Sem_Ch3 is Set_First_Index (T1, First_Index (T2)); Set_Is_Aliased (T1, Is_Aliased (T2)); - Set_Is_Atomic (T1, Is_Atomic (T2)); Set_Is_Volatile (T1, Is_Volatile (T2)); Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); Set_Is_Constrained (T1, Is_Constrained (T2)); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 563d5b80c21..d1cdeeabf5f 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -253,7 +253,7 @@ package body Sem_Ch4 is function Try_Container_Indexing (N : Node_Id; Prefix : Node_Id; - Expr : Node_Id) return Boolean; + Exprs : List_Id) return Boolean; -- AI05-0139: Generalized indexing to support iterators over containers function Try_Indexed_Call @@ -2114,7 +2114,7 @@ package body Sem_Ch4 is then return; - elsif Try_Container_Indexing (N, P, Exp) then + elsif Try_Container_Indexing (N, P, Exprs) then return; elsif Array_Type = Any_Type then @@ -2276,7 +2276,7 @@ package body Sem_Ch4 is end; end if; - elsif Try_Container_Indexing (N, P, First (Exprs)) then + elsif Try_Container_Indexing (N, P, Exprs) then return; end if; @@ -4222,13 +4222,22 @@ package body Sem_Ch4 is -- Duplicate the call. This is required to avoid problems with -- the tree transformations performed by Try_Object_Operation. + -- Set properly the parent of the copied call, because it is + -- about to be reanalyzed. - and then - Try_Object_Operation - (N => Sinfo.Name (New_Copy_Tree (Parent (N))), - CW_Test_Only => True) then - return; + declare + Par : constant Node_Id := New_Copy_Tree (Parent (N)); + + begin + Set_Parent (Par, Parent (Parent (N))); + + if Try_Object_Operation + (Sinfo.Name (Par), CW_Test_Only => True) + then + return; + end if; + end; end if; end if; @@ -4334,10 +4343,21 @@ package body Sem_Ch4 is -- Emit appropriate message. Gigi will replace the -- node subsequently with the appropriate Raise. - Apply_Compile_Time_Constraint_Error - (N, "component not present in }?", - CE_Discriminant_Check_Failed, - Ent => Prefix_Type, Rep => False); + -- In Alfa mode, this is made into an error to simplify + -- the processing of the formal verification backend. + + if Alfa_Mode then + Apply_Compile_Time_Constraint_Error + (N, "component not present in }", + CE_Discriminant_Check_Failed, + Ent => Prefix_Type, Rep => False); + else + Apply_Compile_Time_Constraint_Error + (N, "component not present in }?", + CE_Discriminant_Check_Failed, + Ent => Prefix_Type, Rep => False); + end if; + Set_Raises_Constraint_Error (N); return; end if; @@ -6475,9 +6495,10 @@ package body Sem_Ch4 is function Try_Container_Indexing (N : Node_Id; Prefix : Node_Id; - Expr : Node_Id) return Boolean + Exprs : List_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); + Assoc : List_Id; Disc : Entity_Id; Func : Entity_Id; Func_Name : Node_Id; @@ -6508,19 +6529,34 @@ package body Sem_Ch4 is if Has_Implicit_Dereference (Etype (Prefix)) then Build_Explicit_Dereference (Prefix, First_Discriminant (Etype (Prefix))); - return Try_Container_Indexing (N, Prefix, Expr); + return Try_Container_Indexing (N, Prefix, Exprs); else return False; end if; end if; + Assoc := New_List (Relocate_Node (Prefix)); + + -- A generalized iterator may have nore than one index expression, so + -- transfer all of them to the argument list to be used in the call. + + declare + Arg : Node_Id; + begin + Arg := First (Exprs); + while Present (Arg) loop + Append (Relocate_Node (Arg), Assoc); + Next (Arg); + end loop; + end; + if not Is_Overloaded (Func_Name) then Func := Entity (Func_Name); - Indexing := Make_Function_Call (Loc, - Name => New_Occurrence_Of (Func, Loc), - Parameter_Associations => - New_List (Relocate_Node (Prefix), Relocate_Node (Expr))); + Indexing := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Func, Loc), + Parameter_Associations => Assoc); Rewrite (N, Indexing); Analyze (N); @@ -6544,8 +6580,7 @@ package body Sem_Ch4 is else Indexing := Make_Function_Call (Loc, Name => Make_Identifier (Loc, Chars (Func_Name)), - Parameter_Associations => - New_List (Relocate_Node (Prefix), Relocate_Node (Expr))); + Parameter_Associations => Assoc); Rewrite (N, Indexing); @@ -6586,7 +6621,8 @@ package body Sem_Ch4 is end if; if Etype (N) = Any_Type then - Error_Msg_NE ("container cannot be indexed with&", N, Etype (Expr)); + Error_Msg_NE + ("container cannot be indexed with&", N, Etype (First (Exprs))); Rewrite (N, New_Occurrence_Of (Any_Id, Loc)); else Analyze (N); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 749393b5d78..f3df8c5c6ab 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1665,16 +1665,21 @@ package body Sem_Ch5 is -- If the domain of iteration is an expression, create a declaration for -- it, so that finalization actions are introduced outside of the loop. -- The declaration must be a renaming because the body of the loop may - -- assign to elements. When the context is a quantified expression, the - -- renaming declaration is delayed until the expansion phase. + -- assign to elements. if not Is_Entity_Name (Iter_Name) + + -- When the context is a quantified expression, the renaming + -- declaration is delayed until the expansion phase if we are + -- doing expansion. + and then (Nkind (Parent (N)) /= N_Quantified_Expression + or else Operating_Mode = Check_Semantics) - -- The following two tests need comments ??? + -- Do not perform this expansion in Alfa mode, since the formal + -- verification directly deals with the source form of the iterator. - or else Operating_Mode = Check_Semantics - or else Alfa_Mode) + and then not Alfa_Mode then declare Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); @@ -1711,7 +1716,7 @@ package body Sem_Ch5 is -- Container is an entity or an array with uncontrolled components, or -- else it is a container iterator given by a function call, typically -- called Iterate in the case of predefined containers, even though - -- Iterate is not a reserved name. What matter is that the return type + -- Iterate is not a reserved name. What matters is that the return type -- of the function is an iterator type. elsif Is_Entity_Name (Iter_Name) then @@ -2226,18 +2231,8 @@ package body Sem_Ch5 is -- Ada 2012: If the domain of iteration is a function call, it is the -- new iterator form. - -- We have also implemented the shorter form : for X in S for Alfa - -- use. In this case, 'Old and 'Result must be treated as entity - -- names over which iterators are legal. - if Nkind (DS_Copy) = N_Function_Call or else - (Alfa_Mode - and then (Nkind (DS_Copy) = N_Attribute_Reference - and then - (Attribute_Name (DS_Copy) = Name_Result - or else Attribute_Name (DS_Copy) = Name_Old))) - or else (Is_Entity_Name (DS_Copy) and then not Is_Type (Entity (DS_Copy))) then @@ -2633,14 +2628,14 @@ package body Sem_Ch5 is -- types the actual subtype of the components will only be determined -- when the cursor declaration is analyzed. - -- If the expander is not active, then we want to analyze the loop body - -- now even in the Ada 2012 iterator case, since the rewriting will not - -- be done. Insert the loop variable in the current scope, if not done - -- when analysing the iteration scheme. + -- If the expander is not active, or in Alfa mode, then we want to + -- analyze the loop body now even in the Ada 2012 iterator case, since + -- the rewriting will not be done. Insert the loop variable in the + -- current scope, if not done when analysing the iteration scheme. if No (Iter) or else No (Iterator_Specification (Iter)) - or else not Expander_Active + or else not Full_Expander_Active then if Present (Iter) and then Present (Iterator_Specification (Iter)) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d0f918df397..d48dd10e524 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1260,9 +1260,7 @@ package body Sem_Ch6 is -- rewritten if the original call was in prefix notation) then error -- has been emitted already, mark node and return. - if Error_Posted (N) - or else Etype (Name (N)) = Any_Type - then + if Error_Posted (N) or else Etype (Name (N)) = Any_Type then Set_Etype (N, Any_Type); return; end if; @@ -1282,9 +1280,9 @@ package body Sem_Ch6 is -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls if Nkind (P) = N_Attribute_Reference - and then (Attribute_Name (P) = Name_Elab_Spec - or else Attribute_Name (P) = Name_Elab_Body - or else Attribute_Name (P) = Name_Elab_Subp_Body) + and then (Attribute_Name (P) = Name_Elab_Spec or else + Attribute_Name (P) = Name_Elab_Body or else + Attribute_Name (P) = Name_Elab_Subp_Body) then if Present (Actuals) then Error_Msg_N @@ -1806,7 +1804,6 @@ package body Sem_Ch6 is procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Body_Deleted : constant Boolean := False; Body_Spec : constant Node_Id := Specification (N); Body_Id : Entity_Id := Defining_Entity (Body_Spec); Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); @@ -2078,9 +2075,8 @@ package body Sem_Ch6 is Set_Has_Missing_Return (Id); end if; - elsif (Is_Generic_Subprogram (Id) - or else not Is_Machine_Code_Subprogram (Id)) - and then not Body_Deleted + elsif Is_Generic_Subprogram (Id) + or else not Is_Machine_Code_Subprogram (Id) then Error_Msg_N ("missing RETURN statement in function body", N); end if; @@ -2506,6 +2502,19 @@ package body Sem_Ch6 is end if; end if; + -- Ada 2012 aspects may appear in a subprogram body, but only if there + -- is no previous spec. + + if Has_Aspects (N) then + if Present (Corresponding_Spec (N)) then + Error_Msg_N + ("aspect specifications must appear in subprogram declaration", + N); + else + Analyze_Aspect_Specifications (N, Body_Id); + end if; + end if; + -- Previously we scanned the body to look for nested subprograms, and -- rejected an inline directive if nested subprograms were present, -- because the back-end would generate conflicting symbols for the @@ -3122,13 +3131,9 @@ package body Sem_Ch6 is end loop; end if; - -- Check references in body unless it was deleted. Note that the - -- check of Body_Deleted here is not just for efficiency, it is - -- necessary to avoid junk warnings on formal parameters. + -- Check references in body - if not Body_Deleted then - Check_References (Body_Id); - end if; + Check_References (Body_Id); end; end Analyze_Subprogram_Body_Helper; @@ -5503,12 +5508,10 @@ package body Sem_Ch6 is end if; end if; - -- Ada 2012: mode conformance also requires that formal parameters + -- Ada 2012: Mode conformance also requires that formal parameters -- be both aliased, or neither. - if Ctype >= Mode_Conformant - and then Ada_Version >= Ada_2012 - then + if Ctype >= Mode_Conformant and then Ada_Version >= Ada_2012 then if Is_Aliased (Old_Formal) /= Is_Aliased (New_Formal) then Conformance_Error ("\aliased parameter mismatch!", New_Formal); @@ -6637,6 +6640,11 @@ package body Sem_Ch6 is and then Exception_Junk (Last_Stm)) or else Nkind (Last_Stm) in N_Push_xxx_Label or else Nkind (Last_Stm) in N_Pop_xxx_Label + + -- Inserted code, such as finalization calls, is irrelevant: we only + -- need to check original source. + + or else Is_Rewrite_Insertion (Last_Stm) loop Prev (Last_Stm); end loop; @@ -7242,7 +7250,9 @@ package body Sem_Ch6 is N1, N2 : Natural; begin - -- Remove trailing numeric parts + -- Deal with special case where names are identical except for a + -- numerical suffix. These are handled specially, taking the numeric + -- ordering from the suffix into account. L1 := S1'Last; while S1 (L1) in '0' .. '9' loop @@ -7254,13 +7264,10 @@ package body Sem_Ch6 is L2 := L2 - 1; end loop; - -- If non-numeric parts non-equal, that's decisive - - if S1 (S1'First .. L1) < S2 (S2'First .. L2) then - return False; + -- If non-numeric parts non-equal, do straight compare - elsif S1 (S1'First .. L1) > S2 (S2'First .. L2) then - return True; + if S1 (S1'First .. L1) /= S2 (S2'First .. L2) then + return S1 > S2; -- If non-numeric parts equal, compare suffixed numeric parts. Note -- that a missing suffix is treated as numeric zero in this test. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index fd90b72d636..b4348c5bdbe 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -7223,7 +7223,7 @@ package body Sem_Ch8 is -- If the actions to be wrapped are still there they will get lost -- causing incomplete code to be generated. It is better to abort in -- this case (and we do the abort even with assertions off since the - -- penalty is incorrect code generation) + -- penalty is incorrect code generation). if SST.Actions_To_Be_Wrapped_Before /= No_List or else diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 58a27c93256..6ee0bceeb81 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -67,25 +68,31 @@ package body Sem_Ch9 is ----------------------- function Allows_Lock_Free_Implementation - (N : Node_Id; - Complain : Boolean := False) return Boolean; + (N : Node_Id; + Lock_Free_Given : Boolean := False) return Boolean; -- This routine returns True iff N satisfies the following list of lock- -- free restrictions for protected type declaration and protected body: -- -- 1) Protected type declaration -- May not contain entries - -- Component types must support atomic compare and exchange + -- Protected subprogram declarations may not have non-elementary + -- parameters. -- -- 2) Protected Body -- Each protected subprogram body within N must satisfy: -- May reference only one protected component -- May not reference non-constant entities outside the protected -- subprogram scope. - -- May not reference non-elementary out parameters - -- May not contain loop statements or procedure calls + -- May not contain address representation items, allocators and + -- quantified expressions. + -- May not contain delay, goto, loop and procedure call + -- statements. + -- May not contain exported and imported entities + -- May not dereference access values -- Function calls and attribute references must be static -- - -- If Complain is True, an error message is issued when False is returned + -- If Lock_Free_Given is True, an error message is issued when False is + -- returned. procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions); -- Given either a protected definition or a task definition in D, check @@ -115,22 +122,31 @@ package body Sem_Ch9 is ------------------------------------- function Allows_Lock_Free_Implementation - (N : Node_Id; - Complain : Boolean := False) return Boolean + (N : Node_Id; + Lock_Free_Given : Boolean := False) return Boolean is + Errors_Count : Nat; + -- Errors_Count is a count of errors detected by the compiler so far + -- when Lock_Free_Given is True. + begin - pragma Assert (Nkind_In (N, - N_Protected_Type_Declaration, - N_Protected_Body)); + pragma Assert (Nkind_In (N, N_Protected_Type_Declaration, + N_Protected_Body)); -- The lock-free implementation is currently enabled through a debug - -- flag. When Complain is True, an aspect Lock_Free forces the lock-free - -- implementation. In that case, the debug flag is not needed. + -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the + -- lock-free implementation. In that case, the debug flag is not needed. - if not Complain and then not Debug_Flag_9 then + if not Lock_Free_Given and then not Debug_Flag_9 then return False; end if; + -- Get the number of errors detected by the compiler so far + + if Lock_Free_Given then + Errors_Count := Serious_Errors_Detected; + end if; + -- Protected type declaration case if Nkind (N) = N_Protected_Type_Declaration then @@ -138,88 +154,71 @@ package body Sem_Ch9 is Pdef : constant Node_Id := Protected_Definition (N); Priv_Decls : constant List_Id := Private_Declarations (Pdef); Vis_Decls : constant List_Id := Visible_Declarations (Pdef); - - Comp_Id : Entity_Id; - Comp_Size : Int; - Comp_Type : Entity_Id; Decl : Node_Id; begin - -- Examine the visible declarations. Entries and entry families - -- are not allowed by the lock-free restrictions. + -- Examine the visible and the private declarations Decl := First (Vis_Decls); while Present (Decl) loop - if Nkind (Decl) = N_Entry_Declaration then - if Complain then - Error_Msg_N ("entry not allowed for lock-free " & - "implementation", - Decl); - end if; - - return False; - end if; - - Next (Decl); - end loop; - - -- Examine the private declarations - - Decl := First (Priv_Decls); - while Present (Decl) loop - - -- The protected type must define at least one scalar component - if Nkind (Decl) = N_Component_Declaration then - Comp_Id := Defining_Identifier (Decl); - Comp_Type := Etype (Comp_Id); - - -- Make sure the protected component type has size and - -- alignment fields set at this point whenever this is - -- possible. - - Layout_Type (Comp_Type); - - if Known_Esize (Comp_Type) then - Comp_Size := UI_To_Int (Esize (Comp_Type)); - - -- If the Esize (Object_Size) is unknown at compile-time, - -- look at the RM_Size (Value_Size) since it may have been - -- set by an explicit representation clause. + -- Entries and entry families are not allowed by the lock-free + -- restrictions. + if Nkind (Decl) = N_Entry_Declaration then + if Lock_Free_Given then + Error_Msg_N + ("entry not allowed when Lock_Free given", Decl); else - Comp_Size := UI_To_Int (RM_Size (Comp_Type)); + return False; end if; - -- Check that the size of the component is 8, 16, 32 or 64 - -- bits. - - case Comp_Size is - when 8 | 16 | 32 | 64 => - null; - when others => - if Complain then - Error_Msg_N ("must support atomic operations for " & - "lock-free implementation", - Decl); - end if; + -- Non-elementary parameters in protected procedure are not + -- allowed by the lock-free restrictions. - return False; - end case; + elsif Nkind (Decl) = N_Subprogram_Declaration + and then + Nkind (Specification (Decl)) = N_Procedure_Specification + and then + Present (Parameter_Specifications (Specification (Decl))) + then + declare + Par_Specs : constant List_Id := + Parameter_Specifications + (Specification (Decl)); - -- Entries and entry families are not allowed + Par : Node_Id; - elsif Nkind (Decl) = N_Entry_Declaration then - if Complain then - Error_Msg_N ("entry not allowed for lock-free " & - "implementation", - Decl); - end if; + begin + Par := First (Par_Specs); + while Present (Par) loop + if not Is_Elementary_Type + (Etype (Defining_Identifier (Par))) + then + if Lock_Free_Given then + Error_Msg_NE + ("non-elementary parameter& not allowed " + & "when Lock_Free given", + Par, Defining_Identifier (Par)); + else + return False; + end if; + end if; - return False; + Next (Par); + end loop; + end; end if; - Next (Decl); + -- Examine private declarations after visible declarations + + if No (Next (Decl)) + and then List_Containing (Decl) = Vis_Decls + then + Decl := First (Priv_Decls); + else + Next (Decl); + end if; end loop; end; @@ -248,9 +247,18 @@ package body Sem_Ch9 is function Satisfies_Lock_Free_Requirements (Sub_Body : Node_Id) return Boolean is + Is_Procedure : constant Boolean := + Ekind (Corresponding_Spec (Sub_Body)) = + E_Procedure; + -- Indicates if Sub_Body is a procedure body + Comp : Entity_Id := Empty; -- Track the current component which the body references + Errors_Count : Nat; + -- Errors_Count is a count of errors detected by the compiler + -- so far when Lock_Free_Given is True. + function Check_Node (N : Node_Id) return Traverse_Result; -- Check that node N meets the lock free restrictions @@ -259,153 +267,361 @@ package body Sem_Ch9 is ---------------- function Check_Node (N : Node_Id) return Traverse_Result is - begin - -- Function calls and attribute references must be static + Kind : constant Node_Kind := Nkind (N); - if Nkind (N) = N_Attribute_Reference - and then not Is_Static_Expression (N) - then - if Complain then - Error_Msg_N - ("non-static attribute reference not allowed", - N); - end if; + -- The following function belongs in sem_eval ??? - return Abandon; + function Is_Static_Function (Attr : Node_Id) return Boolean; + -- Given an attribute reference node Attr, return True if + -- Attr denotes a static function according to the rules in + -- (RM 4.9 (22)). - elsif Nkind (N) = N_Function_Call - and then not Is_Static_Expression (N) - then - if Complain then - Error_Msg_N ("non-static function call not allowed", - N); - end if; + ------------------------ + -- Is_Static_Function -- + ------------------------ - return Abandon; + function Is_Static_Function + (Attr : Node_Id) return Boolean + is + Para : Node_Id; - -- Loop statements and procedure calls are prohibited + begin + pragma Assert (Nkind (Attr) = N_Attribute_Reference); + + case Attribute_Name (Attr) is + when Name_Min | + Name_Max | + Name_Pred | + Name_Succ | + Name_Value | + Name_Wide_Value | + Name_Wide_Wide_Value => + + -- A language-defined attribute denotes a static + -- function if the prefix denotes a static scalar + -- subtype, and if the parameter and result types + -- are scalar (RM 4.9 (22)). + + if Is_Scalar_Type (Etype (Attr)) + and then Is_Scalar_Type (Etype (Prefix (Attr))) + and then Is_Static_Subtype (Etype (Prefix (Attr))) + then + Para := First (Expressions (Attr)); + + while Present (Para) loop + if not Is_Scalar_Type (Etype (Para)) then + return False; + end if; - elsif Nkind (N) = N_Loop_Statement then - if Complain then - Error_Msg_N ("loop not allowed", N); - end if; + Next (Para); + end loop; - return Abandon; + return True; - elsif Nkind (N) = N_Procedure_Call_Statement then - if Complain then - Error_Msg_N ("procedure call not allowed", N); - end if; + else + return False; + end if; - return Abandon; + when others => return False; + end case; + end Is_Static_Function; - -- References + -- Start of processing for Check_Node - elsif Nkind (N) = N_Identifier - and then Present (Entity (N)) - then - declare - Id : constant Entity_Id := Entity (N); - Sub_Id : constant Entity_Id := - Corresponding_Spec (Sub_Body); + begin + if Is_Procedure then + -- Allocators restricted - begin - -- Prohibit references to non-constant entities - -- outside the protected subprogram scope. - - if Ekind (Id) in Assignable_Kind - and then not Scope_Within_Or_Same (Scope (Id), - Sub_Id) - and then not Scope_Within_Or_Same (Scope (Id), - Protected_Body_Subprogram (Sub_Id)) - then - if Complain then - Error_Msg_NE - ("reference to global variable& not allowed", - N, Id); + if Kind = N_Allocator then + if Lock_Free_Given then + Error_Msg_N ("allocator not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Aspects Address, Export and Import restricted + + elsif Kind = N_Aspect_Specification then + declare + Asp_Name : constant Name_Id := + Chars (Identifier (N)); + Asp_Id : constant Aspect_Id := + Get_Aspect_Id (Asp_Name); + + begin + if Asp_Id = Aspect_Address or else + Asp_Id = Aspect_Export or else + Asp_Id = Aspect_Import + then + Error_Msg_Name_1 := Asp_Name; + + if Lock_Free_Given then + Error_Msg_N ("aspect% not allowed", N); + return Skip; + end if; + + return Abandon; end if; + end; - return Abandon; + -- Address attribute definition clause restricted - -- Prohibit non-scalar out parameters (scalar - -- parameters are passed by copy). + elsif Kind = N_Attribute_Definition_Clause + and then Get_Attribute_Id (Chars (N)) = + Attribute_Address + then + Error_Msg_Name_1 := Chars (N); - elsif Ekind_In (Id, E_Out_Parameter, - E_In_Out_Parameter) - and then not Is_Elementary_Type (Etype (Id)) - and then Scope_Within_Or_Same (Scope (Id), Sub_Id) - then - if Complain then - Error_Msg_NE - ("non-elementary out parameter& not allowed", - N, Id); + if Lock_Free_Given then + if From_Aspect_Specification (N) then + Error_Msg_N ("aspect% not allowed", N); + else + Error_Msg_N ("% clause not allowed", N); end if; - return Abandon; - - -- A protected subprogram may reference only one - -- component of the protected type. - - elsif Ekind (Id) = E_Component then - declare - Comp_Decl : constant Node_Id := Parent (Id); - begin - if Nkind (Comp_Decl) = N_Component_Declaration - and then Is_List_Member (Comp_Decl) - and then List_Containing (Comp_Decl) = - Priv_Decls - then - if No (Comp) then - Comp := Id; - - -- Check if another protected component has - -- already been accessed by the subprogram - -- body. - - elsif Comp /= Id then - if Complain then - Error_Msg_N - ("only one protected component " & - "allowed", - N); - end if; + return Skip; + end if; - return Abandon; + return Abandon; + + -- Non-static Attribute references that don't denote a + -- static function restricted. + + elsif Kind = N_Attribute_Reference + and then not Is_Static_Expression (N) + and then not Is_Static_Function (N) + then + if Lock_Free_Given then + Error_Msg_N + ("non-static attribute reference not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Delay statements restricted + + elsif Kind in N_Delay_Statement then + if Lock_Free_Given then + Error_Msg_N ("delay not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Dereferences of access values restricted + + elsif Kind = N_Explicit_Dereference + or else (Kind = N_Selected_Component + and then Is_Access_Type (Etype (Prefix (N)))) + then + if Lock_Free_Given then + Error_Msg_N + ("dereference of access value not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Non-static function calls restricted + + elsif Kind = N_Function_Call + and then not Is_Static_Expression (N) + then + if Lock_Free_Given then + Error_Msg_N + ("non-static function call not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Goto statements restricted + + elsif Kind = N_Goto_Statement then + if Lock_Free_Given then + Error_Msg_N ("goto statement not allowed", N); + return Skip; + end if; + + return Abandon; + + -- References + + elsif Kind = N_Identifier + and then Present (Entity (N)) + then + declare + Id : constant Entity_Id := Entity (N); + Sub_Id : constant Entity_Id := + Corresponding_Spec (Sub_Body); + + begin + -- Prohibit references to non-constant entities + -- outside the protected subprogram scope. + + if Ekind (Id) in Assignable_Kind + and then not + Scope_Within_Or_Same (Scope (Id), Sub_Id) + and then not + Scope_Within_Or_Same + (Scope (Id), + Protected_Body_Subprogram (Sub_Id)) + then + if Lock_Free_Given then + Error_Msg_NE + ("reference to global variable& not " & + "allowed", N, Id); + return Skip; + end if; + + return Abandon; + end if; + end; + + -- Loop statements restricted + + elsif Kind = N_Loop_Statement then + if Lock_Free_Given then + Error_Msg_N ("loop not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Pragmas Export and Import restricted + + elsif Kind = N_Pragma then + declare + Prag_Name : constant Name_Id := Pragma_Name (N); + Prag_Id : constant Pragma_Id := + Get_Pragma_Id (Prag_Name); + + begin + if Prag_Id = Pragma_Export + or else Prag_Id = Pragma_Import + then + Error_Msg_Name_1 := Prag_Name; + + if Lock_Free_Given then + if From_Aspect_Specification (N) then + Error_Msg_N ("aspect% not allowed", N); + else + Error_Msg_N ("pragma% not allowed", N); end if; + + return Skip; end if; - end; + + return Abandon; + end if; + end; + + -- Procedure call statements restricted + + elsif Kind = N_Procedure_Call_Statement then + if Lock_Free_Given then + Error_Msg_N ("procedure call not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Quantified expression restricted. Note that we have + -- to check the original node as well, since at this + -- stage, it may have been rewritten. + + elsif Kind = N_Quantified_Expression + or else + Nkind (Original_Node (N)) = N_Quantified_Expression + then + if Lock_Free_Given then + Error_Msg_N + ("quantified expression not allowed", N); + return Skip; + end if; + + return Abandon; + end if; + end if; + + -- A protected subprogram (function or procedure) may + -- reference only one component of the protected type, plus + -- the type of the component must support atomic operation. + + if Kind = N_Identifier + and then Present (Entity (N)) + then + declare + Id : constant Entity_Id := Entity (N); + Comp_Decl : Node_Id; + Comp_Id : Entity_Id := Empty; + Comp_Type : Entity_Id; + + begin + if Ekind (Id) = E_Component then + Comp_Id := Id; elsif Ekind_In (Id, E_Constant, E_Variable) and then Present (Prival_Link (Id)) then - declare - Comp_Decl : constant Node_Id := - Parent (Prival_Link (Id)); - begin - if Nkind (Comp_Decl) = N_Component_Declaration - and then Is_List_Member (Comp_Decl) - and then List_Containing (Comp_Decl) = - Priv_Decls - then - if No (Comp) then - Comp := Prival_Link (Id); - - -- Check if another protected component has - -- already been accessed by the subprogram - -- body. - - elsif Comp /= Prival_Link (Id) then - if Complain then - Error_Msg_N - ("only one protected component " & - "allowed", - N); + Comp_Id := Prival_Link (Id); + end if; + + if Present (Comp_Id) then + Comp_Decl := Parent (Comp_Id); + Comp_Type := Etype (Comp_Id); + + if Nkind (Comp_Decl) = N_Component_Declaration + and then Is_List_Member (Comp_Decl) + and then List_Containing (Comp_Decl) = Priv_Decls + then + -- Skip generic types since, in that case, we + -- will not build a body anyway (in the generic + -- template), and the size in the template may + -- have a fake value. + + if not Is_Generic_Type (Comp_Type) then + + -- Make sure the protected component type has + -- size and alignment fields set at this + -- point whenever this is possible. + + Layout_Type (Comp_Type); + + if not + Support_Atomic_Primitives (Comp_Type) + then + if Lock_Free_Given then + Error_Msg_NE + ("type of& must support atomic " & + "operations", + N, Comp_Id); + return Skip; end if; return Abandon; end if; end if; - end; + + -- Check if another protected component has + -- already been accessed by the subprogram body. + + if No (Comp) then + Comp := Comp_Id; + + elsif Comp /= Comp_Id then + if Lock_Free_Given then + Error_Msg_N + ("only one protected component allowed", + N); + return Skip; + end if; + + return Abandon; + end if; + end if; end if; end; end if; @@ -418,8 +634,16 @@ package body Sem_Ch9 is -- Start of processing for Satisfies_Lock_Free_Requirements begin - if Check_All_Nodes (Sub_Body) = OK then + -- Get the number of errors detected by the compiler so far + if Lock_Free_Given then + Errors_Count := Serious_Errors_Detected; + end if; + + if Check_All_Nodes (Sub_Body) = OK + and then (not Lock_Free_Given + or else Errors_Count = Serious_Errors_Detected) + then -- Establish a relation between the subprogram body and the -- unique protected component it references. @@ -438,17 +662,16 @@ package body Sem_Ch9 is begin Decl := First (Decls); - while Present (Decl) loop if Nkind (Decl) = N_Subprogram_Body and then not Satisfies_Lock_Free_Requirements (Decl) then - if Complain then - Error_Msg_N ("body prevents lock-free implementation", - Decl); + if Lock_Free_Given then + Error_Msg_N + ("illegal body when Lock_Free given", Decl); + else + return False; end if; - - return False; end if; Next (Decl); @@ -456,6 +679,15 @@ package body Sem_Ch9 is end Protected_Body_Case; end if; + -- When Lock_Free is given, check if no error has been detected during + -- the process. + + if Lock_Free_Given + and then Errors_Count /= Serious_Errors_Detected + then + return False; + end if; + return True; end Allows_Lock_Free_Implementation; @@ -484,7 +716,7 @@ package body Sem_Ch9 is else if Ada_Version >= Ada_2005 then Error_Msg_N ("expect task name or task interface class-wide " - & "object for ABORT", T_Name); + & "object for ABORT", T_Name); else Error_Msg_N ("expect task name for ABORT", T_Name); end if; @@ -1455,14 +1687,17 @@ package body Sem_Ch9 is begin if Present (Ritem) then + -- Pragma with one argument if Nkind (Ritem) = N_Pragma and then Present (Pragma_Argument_Associations (Ritem)) then return - Is_False (Static_Boolean - (Expression (First (Pragma_Argument_Associations (Ritem))))); + Is_False + (Static_Boolean + (Expression + (First (Pragma_Argument_Associations (Ritem))))); -- Aspect Specification with expression present @@ -1548,7 +1783,7 @@ package body Sem_Ch9 is -- otherwise Allows_Lock_Free_Implementation issues an error message. if Uses_Lock_Free (Spec_Id) then - if not Allows_Lock_Free_Implementation (N, Complain => True) then + if not Allows_Lock_Free_Implementation (N, True) then return; end if; @@ -1784,7 +2019,46 @@ package body Sem_Ch9 is -- issued by Allows_Lock_Free_Implementation. if Uses_Lock_Free (Defining_Identifier (N)) then - if not Allows_Lock_Free_Implementation (N, Complain => True) then + + -- Complain when there is an explicit aspect/pragma Priority (or + -- Interrupt_Priority) while the lock-free implementation is forced + -- by an aspect/pragma. + + declare + Id : constant Entity_Id := + Defining_Identifier (Original_Node (N)); + -- The warning must be issued on the original identifier in order + -- to deal properly with the case of a single protected object. + + Prio_Item : constant Node_Id := + Get_Rep_Item + (Defining_Identifier (N), + Name_Priority, + Check_Parents => False); + + begin + if Present (Prio_Item) then + + -- Aspect case + + if Nkind (Prio_Item) = N_Aspect_Specification + or else From_Aspect_Specification (Prio_Item) + then + Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); + Error_Msg_NE ("?aspect% for & has no effect when Lock_Free" & + " given", Prio_Item, Id); + + -- Pragma case + + else + Error_Msg_Name_1 := Pragma_Name (Prio_Item); + Error_Msg_NE ("?pragma% for & has no effect when Lock_Free" & + " given", Prio_Item, Id); + end if; + end if; + end; + + if not Allows_Lock_Free_Implementation (N, True) then return; end if; end if; diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 49f29a3423b..a2dd53c4087 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -116,6 +116,8 @@ package body Sem_Dim is No_Symbols : constant Symbol_Array := (others => No_String); + -- The following record should be documented field by field + type System_Type is record Type_Decl : Node_Id; Unit_Names : Name_Array; @@ -430,7 +432,7 @@ package body Sem_Dim is ------------------------------ -- with Dimension => ( - -- [Symbol =>] SYMBOL, + -- [[Symbol =>] SYMBOL,] -- DIMENSION_VALUE -- [, DIMENSION_VALUE] -- [, DIMENSION_VALUE] @@ -543,8 +545,7 @@ package body Sem_Dim is Errors_Count : Nat; -- Errors_Count is a count of errors detected by the compiler so far -- just before the extraction of symbol, names and values in the - -- aggregate - -- (Step 2). + -- aggregate (Step 2). -- -- At the end of the analysis, there is a check to verify that this -- count equals to Serious_Errors_Detected i.e. no erros have been @@ -614,9 +615,8 @@ package body Sem_Dim is Assoc := First (Component_Associations (Aggr)); Choice := First (Choices (Assoc)); - if No (Next (Choice)) - and then Nkind (Choice) = N_Identifier - then + if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then + -- Symbol component association is present if Chars (Choice) = Name_Symbol then @@ -629,9 +629,9 @@ package body Sem_Dim is N_String_Literal) then Symbol_Expr := Empty; - Error_Msg_N ("symbol expression must be character or " & - "string", - Symbol_Expr); + Error_Msg_N + ("symbol expression must be character or string", + Symbol_Expr); end if; -- Special error if no Symbol choice but expression is string @@ -656,9 +656,7 @@ package body Sem_Dim is -- Skip the symbol expression when present - if Present (Symbol_Expr) - and then Num_Choices = 0 - then + if Present (Symbol_Expr) and then Num_Choices = 0 then Expr := Next (Expr); end if; @@ -689,9 +687,9 @@ package body Sem_Dim is end if; while Present (Assoc) loop - Expr := Expression (Assoc); - Choice := First (Choices (Assoc)); + Expr := Expression (Assoc); + Choice := First (Choices (Assoc)); while Present (Choice) loop -- Identifier case: NAME => EXPRESSION @@ -747,9 +745,7 @@ package body Sem_Dim is -- Others case: OTHERS => EXPRESSION elsif Nkind (Choice) = N_Others_Choice then - if Present (Next (Choice)) - or else Present (Prev (Choice)) - then + if Present (Next (Choice)) or else Present (Prev (Choice)) then Error_Msg_N ("OTHERS must appear alone in a choice list", Choice); @@ -828,11 +824,10 @@ package body Sem_Dim is -- Check that no errors have been detected during the analysis if Errors_Count = Serious_Errors_Detected then - -- useless declaration - if Symbol = No_String - and then not Exists (Dimensions) - then + -- Check for useless declaration + + if Symbol = No_String and then not Exists (Dimensions) then Error_Msg_N ("useless dimension declaration", Aggr); end if; @@ -968,6 +963,7 @@ package body Sem_Dim is -- Named dimension aggregate if Present (Component_Associations (Dim_Aggr)) then + -- Check first argument denotes the unit name Assoc := First (Component_Associations (Dim_Aggr)); @@ -1326,9 +1322,12 @@ package body Sem_Dim is -- value of the exponent must be known compile time. Otherwise, -- the exponentiation evaluation will return an error message. - if L_Has_Dimensions - and then Compile_Time_Known_Value (R) - then + if L_Has_Dimensions then + if not Compile_Time_Known_Value (R) then + Error_Msg_N ("exponent of dimensioned operand must be " & + "known at compile-time", N); + end if; + declare Exponent_Value : Rational := Zero; @@ -1589,8 +1588,7 @@ package body Sem_Dim is Dims_Of_Actual := Dimensions_Of (Actual); if Exists (Dims_Of_Actual) then - Error_Msg_NE ("parameter should be dimensionless for " & - "elementary function&", + Error_Msg_NE ("parameter of& must be dimensionless", Actual, Name_Call); Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual), Actual); @@ -1622,6 +1620,14 @@ package body Sem_Dim is if Exists (Dims_Of_Etyp) then Set_Dimensions (N, Dims_Of_Etyp); + + -- Propagation of the dimensions from the entity for identifier whose + -- entity is a non-dimensionless consant. + + elsif Nkind (N) = N_Identifier + and then Exists (Dimensions_Of (Entity (N))) + then + Set_Dimensions (N, Dimensions_Of (Entity (N))); end if; -- Removal of dimensions in expression @@ -1697,7 +1703,7 @@ package body Sem_Dim is if Present (Expr) then Dim_Of_Expr := Dimensions_Of (Expr); - -- case when expression is not a literal and when dimensions of the + -- Case when expression is not a literal and when dimensions of the -- expression and of the type mismatch if not Nkind_In (Original_Node (Expr), @@ -1705,7 +1711,18 @@ package body Sem_Dim is N_Integer_Literal) and then Dim_Of_Expr /= Dim_Of_Etyp then - Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr); + -- Propagate the dimension from the expression to the object + -- entity when the object is a constant whose type is a + -- dimensioned type. + + if Constant_Present (N) and then not Exists (Dim_Of_Etyp) then + Set_Dimensions (Id, Dim_Of_Expr); + + -- Otherwise, issue an error message + + else + Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr); + end if; end if; -- Removal of dimensions in expression @@ -2235,11 +2252,11 @@ package body Sem_Dim is -- Expand_Put_Call_With_Symbol -- --------------------------------- - -- For procedure Put (resp. Put_Dim_Of) defined in - -- System.Dim.Float_IO/System.Dim.Integer_IO, the default string parameter - -- must be rewritten to include the unit symbols (resp. dimension symbols) - -- in the output of a dimensioned object. Note that if a value is already - -- supplied for parameter Symbol, this routine doesn't do anything. + -- For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO + -- (System.Dim.Integer_IO), the default string parameter must be rewritten + -- to include the unit symbols (resp. dimension symbols) in the output + -- of a dimensioned object. Note that if a value is already supplied for + -- parameter Symbol, this routine doesn't do anything. -- Case 1. Item is dimensionless @@ -2330,22 +2347,20 @@ package body Sem_Dim is if Nkind (Actual) = N_Parameter_Association and then Chars (Selector_Name (Actual)) = Name_Symbol then - - -- return True if the actual comes from source or if the string - -- of symbols doesn't have the default value (i.e ""). + -- Return True if the actual comes from source or if the string + -- of symbols doesn't have the default value (i.e. it is ""). return Comes_From_Source (Actual) - or else String_Length - (Strval - (Explicit_Actual_Parameter (Actual))) /= 0; + or else + String_Length + (Strval (Explicit_Actual_Parameter (Actual))) /= 0; end if; Next (Actual); end loop; - -- At this point, the call has no parameter association - -- Look to the last actual since the symbols parameter is the last - -- one. + -- At this point, the call has no parameter association. Look to the + -- last actual since the symbols parameter is the last one. return Nkind (Last (Actuals)) = N_String_Literal; end Has_Symbols; @@ -2441,6 +2456,7 @@ package body Sem_Dim is -- Put_Dim_Of case if Is_Put_Dim_Of then + -- Check that the item is not dimensionless -- Create the new String_Literal with the new String_Id generated @@ -2536,11 +2552,10 @@ package body Sem_Dim is -- From_Dim_To_Str_Of_Dim_Symbols -- ------------------------------------ - -- Given a dimension vector and the corresponding dimension system, - -- create a String_Id to output the dimension symbols corresponding to the - -- dimensions Dims. If In_Error_Msg is True, there is a special handling - -- for character asterisk * which is an insertion character in error - -- messages. + -- Given a dimension vector and the corresponding dimension system, create + -- a String_Id to output dimension symbols corresponding to the dimensions + -- Dims. If In_Error_Msg is True, there is a special handling for character + -- asterisk * which is an insertion character in error messages. function From_Dim_To_Str_Of_Dim_Symbols (Dims : Dimension_Type; @@ -2551,9 +2566,9 @@ package body Sem_Dim is First_Dim : Boolean := True; procedure Store_String_Oexpon; - -- Store the expon operator symbol "**" to the string. In error - -- messages, asterisk * is a special character and must be precede by a - -- quote ' to be placed literally into the message. + -- Store the expon operator symbol "**" in the string. In error + -- messages, asterisk * is a special character and must be quoted + -- to be placed literally into the message. ------------------------- -- Store_String_Oexpon -- @@ -2563,7 +2578,6 @@ package body Sem_Dim is begin if In_Error_Msg then Store_String_Chars ("'*'*"); - else Store_String_Chars ("**"); end if; @@ -2639,7 +2653,6 @@ package body Sem_Dim is end loop; Store_String_Char (']'); - return End_String; end From_Dim_To_Str_Of_Dim_Symbols; @@ -2669,6 +2682,7 @@ package body Sem_Dim is for Position in Dimension_Type'Range loop Dim_Power := Dims (Position); + if Dim_Power /= Zero then if First_Dim then @@ -2682,6 +2696,7 @@ package body Sem_Dim is -- Positive dimension case if Dim_Power.Numerator > 0 then + -- Integer case if Dim_Power.Denominator = 1 then @@ -2956,4 +2971,5 @@ package body Sem_Dim is return Null_System; end System_Of; + end Sem_Dim; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index c4dd8ede6ba..988a78f5781 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -493,8 +493,34 @@ package body Sem_Disp is procedure Check_Dispatching_Context is Subp : constant Entity_Id := Entity (Name (N)); + Typ : constant Entity_Id := Etype (Subp); Par : Node_Id; + procedure Abstract_Context_Error; + -- Error for abstract call dispatching on result is not dispatching + + ---------------------------- + -- Abstract_Context_Error -- + ---------------------------- + + procedure Abstract_Context_Error is + begin + if Ekind (Subp) = E_Function then + Error_Msg_N + ("call to abstract function must be dispatching", N); + + -- This error can occur for a procedure in the case of a call to + -- an abstract formal procedure with a statically tagged operand. + + else + Error_Msg_N + ("call to abstract procedure must be dispatching", + N); + end if; + end Abstract_Context_Error; + + -- Start of processing for Check_Dispatching_Context + begin if Is_Abstract_Subprogram (Subp) and then No (Controlling_Argument (N)) @@ -510,38 +536,85 @@ package body Sem_Disp is return; else + -- We need to determine whether the context of the call + -- provides a tag to make the call dispatching. This requires + -- the call to be the actual in an enclosing call, and that + -- actual must be controlling. If the call is an operand of + -- equality, the other operand must not ve abstract. + + if not Is_Tagged_Type (Typ) + and then not + (Ekind (Typ) = E_Anonymous_Access_Type + and then Is_Tagged_Type (Designated_Type (Typ))) + then + Abstract_Context_Error; + return; + end if; + Par := Parent (N); + + if Nkind (Par) = N_Parameter_Association then + Par := Parent (Par); + end if; + while Present (Par) loop if Nkind_In (Par, N_Function_Call, - N_Procedure_Call_Statement, - N_Assignment_Statement, - N_Op_Eq, - N_Op_Ne) - and then Is_Tagged_Type (Etype (Subp)) + N_Procedure_Call_Statement) + and then Is_Entity_Name (Name (Par)) then - return; + declare + A : Node_Id; + F : Entity_Id; + + begin + -- Find formal for which call is the actual. + + F := First_Formal (Entity (Name (Par))); + A := First_Actual (Par); + while Present (F) loop + if Is_Controlling_Formal (F) + and then (N = A or else Parent (N) = A) + then + return; + end if; - elsif Nkind (Par) = N_Qualified_Expression - or else Nkind (Par) = N_Unchecked_Type_Conversion - then - Par := Parent (Par); + Next_Formal (F); + Next_Actual (A); + end loop; - else - if Ekind (Subp) = E_Function then Error_Msg_N ("call to abstract function must be dispatching", N); + return; + end; - -- This error can occur for a procedure in the case of a - -- call to an abstract formal procedure with a statically - -- tagged operand. + -- For equalitiy operators, one of the operands must be + -- statically or dynamically tagged. - else - Error_Msg_N - ("call to abstract procedure must be dispatching", - N); + elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then + if N = Right_Opnd (Par) + and then Is_Tag_Indeterminate (Left_Opnd (Par)) + then + Abstract_Context_Error; + + elsif N = Left_Opnd (Par) + and then Is_Tag_Indeterminate (Right_Opnd (Par)) + then + Abstract_Context_Error; end if; return; + + elsif Nkind (Par) = N_Assignment_Statement then + return; + + elsif Nkind (Par) = N_Qualified_Expression + or else Nkind (Par) = N_Unchecked_Type_Conversion + then + Par := Parent (Par); + + else + Abstract_Context_Error; + return; end if; end loop; end if; @@ -591,17 +664,17 @@ package body Sem_Disp is -- If the call doesn't have a controlling actual but does have an -- indeterminate actual that requires dispatching treatment, then an - -- object is needed that will serve as the controlling argument for a - -- dispatching call on the indeterminate actual. This can only occur - -- in the unusual situation of a default actual given by a - -- tag-indeterminate call and where the type of the call is an + -- object is needed that will serve as the controlling argument for + -- a dispatching call on the indeterminate actual. This can only + -- occur in the unusual situation of a default actual given by + -- a tag-indeterminate call and where the type of the call is an -- ancestor of the type associated with a containing call to an -- inherited operation (see AI-239). - -- Rather than create an object of the tagged type, which would be - -- problematic for various reasons (default initialization, - -- discriminants), the tag of the containing call's associated tagged - -- type is directly used to control the dispatching. + -- Rather than create an object of the tagged type, which would + -- be problematic for various reasons (default initialization, + -- discriminants), the tag of the containing call's associated + -- tagged type is directly used to control the dispatching. if No (Control) and then Indeterm_Ancestor_Call @@ -640,8 +713,8 @@ package body Sem_Disp is -- The tag is inherited from the enclosing call (the node -- we are currently analyzing). Explicitly expand the -- actual, since the previous call to Expand (from - -- Resolve_Call) had no way of knowing about the required - -- dispatching. + -- Resolve_Call) had no way of knowing about the + -- required dispatching. Propagate_Tag (Control, Actual); @@ -958,16 +1031,16 @@ package body Sem_Disp is Decl_Item : Node_Id; begin - -- ??? The checks here for whether the type has been - -- frozen prior to the new body are not complete. It's - -- not simple to check frozenness at this point since - -- the body has already caused the type to be prematurely - -- frozen in Analyze_Declarations, but we're forced to - -- recheck this here because of the odd rule interpretation - -- that allows the overriding if the type wasn't frozen - -- prior to the body. The freezing action should probably - -- be delayed until after the spec is seen, but that's - -- a tricky change to the delicate freezing code. + -- ??? The checks here for whether the type has been frozen + -- prior to the new body are not complete. It's not simple + -- to check frozenness at this point since the body has + -- already caused the type to be prematurely frozen in + -- Analyze_Declarations, but we're forced to recheck this + -- here because of the odd rule interpretation that allows + -- the overriding if the type wasn't frozen prior to the + -- body. The freezing action should probably be delayed + -- until after the spec is seen, but that's a tricky + -- change to the delicate freezing code. -- Look at each declaration following the type up until the -- new subprogram body. If any of the declarations is a body @@ -1005,7 +1078,7 @@ package body Sem_Disp is elsif Is_Frozen (Subp) then -- The subprogram body declares a primitive operation. - -- if the subprogram is already frozen, we must update + -- If the subprogram is already frozen, we must update -- its dispatching information explicitly here. The -- information is taken from the overridden subprogram. -- We must also generate a cross-reference entry because @@ -1073,8 +1146,8 @@ package body Sem_Disp is -- (3.2.3(6)). Only report cases where the type and subprogram are -- in the same declaration list (by checking the enclosing parent -- declarations), to avoid spurious warnings on subprograms in - -- instance bodies when the type is declared in the instance spec but - -- hasn't been frozen by the instance body. + -- instance bodies when the type is declared in the instance spec + -- but hasn't been frozen by the instance body. elsif not Is_Frozen (Tagged_Type) and then In_Same_List (Parent (Tagged_Type), Parent (Parent (Subp))) @@ -1567,12 +1640,12 @@ package body Sem_Disp is then Set_Alias (Old_Subp, Alias (Subp)); - -- The derived subprogram should inherit the abstractness - -- of the parent subprogram (except in the case of a function + -- The derived subprogram should inherit the abstractness of + -- the parent subprogram (except in the case of a function -- returning the type). This sets the abstractness properly - -- for cases where a private extension may have inherited - -- an abstract operation, but the full type is derived from - -- a descendant type and inherits a nonabstract version. + -- for cases where a private extension may have inherited an + -- abstract operation, but the full type is derived from a + -- descendant type and inherits a nonabstract version. if Etype (Subp) /= Tagged_Type then Set_Is_Abstract_Subprogram @@ -1696,7 +1769,9 @@ package body Sem_Disp is Ctrl_Type : Entity_Id; begin - if Present (DTC_Entity (Subp)) then + if Ekind_In (Subp, E_Function, E_Procedure) + and then Present (DTC_Entity (Subp)) + then return Scope (DTC_Entity (Subp)); -- For subprograms internally generated by derivations of tagged types @@ -1868,9 +1943,9 @@ package body Sem_Disp is E := Homonym (E); end loop; - -- Search in the list of primitives of the type. Required to locate the - -- covering primitive if the covering primitive is not visible (for - -- example, non-visible inherited primitive of private type). + -- Search in the list of primitives of the type. Required to locate + -- the covering primitive if the covering primitive is not visible + -- (for example, non-visible inherited primitive of private type). El := First_Elmt (Primitive_Operations (Tagged_Type)); while Present (El) loop @@ -2197,8 +2272,8 @@ package body Sem_Disp is and then Has_Interfaces (Tagged_Type) then -- Ada 2005 (AI-251): Update the attribute alias of all the aliased - -- entities of the overridden primitive to reference New_Op, and also - -- propagate the proper value of Is_Abstract_Subprogram. Verify + -- entities of the overridden primitive to reference New_Op, and + -- also propagate the proper value of Is_Abstract_Subprogram. Verify -- that the new operation is subtype conformant with the interface -- operations that it implements (for operations inherited from the -- parent itself, this check is made when building the derived type). diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 4a98db6f1d9..d1b5f7c6b55 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -325,11 +325,13 @@ package body Sem_Elab is -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one -- of its contained scopes, False otherwise. - function Within_Elaborate_All (E : Entity_Id) return Boolean; - -- Before emitting a warning on a scope E for a missing elaborate_all, - -- check whether E may be in the context of a directly visible unit U to - -- which the pragma applies. This prevents spurious warnings when the - -- called entity is renamed within U. + function Within_Elaborate_All + (Unit : Unit_Number_Type; + E : Entity_Id) return Boolean; + -- Return True if we are within the scope of an Elaborate_All for E, or if + -- we are within the scope of an Elaborate_All for some other unit U, and U + -- with's E. This prevents spurious warnings when the called entity is + -- renamed within U, or in case of generic instances. -------------------------------------- -- Activate_Elaborate_All_Desirable -- @@ -831,7 +833,7 @@ package body Sem_Elab is end loop; end if; - if Within_Elaborate_All (E_Scope) then + if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then return; end if; @@ -1229,9 +1231,8 @@ package body Sem_Elab is P := Parent (N); while Present (P) loop - if Nkind (P) = N_Parameter_Specification - or else - Nkind (P) = N_Component_Declaration + if Nkind_In (P, N_Parameter_Specification, + N_Component_Declaration) then return; @@ -3282,46 +3283,121 @@ package body Sem_Elab is -- Within_Elaborate_All -- -------------------------- - function Within_Elaborate_All (E : Entity_Id) return Boolean is - Item : Node_Id; - Item2 : Node_Id; - Elab_Id : Entity_Id; - Par : Node_Id; + function Within_Elaborate_All + (Unit : Unit_Number_Type; + E : Entity_Id) return Boolean + is + type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; + pragma Pack (Unit_Number_Set); - begin - Item := First (Context_Items (Cunit (Current_Sem_Unit))); - while Present (Item) loop - if Nkind (Item) = N_Pragma - and then Pragma_Name (Item) = Name_Elaborate_All - then - -- Return if some previous error on the pragma itself + Seen : Unit_Number_Set := (others => False); + -- Seen (X) is True after we have seen unit X in the walk. This is used + -- to prevent processing the same unit more than once. - if Error_Posted (Item) then - return False; + Result : Boolean := False; + + procedure Helper (Unit : Unit_Number_Type); + -- This helper procedure does all the work for Within_Elaborate_All. It + -- walks the dependency graph, and sets Result to True if it finds an + -- appropriate Elaborate_All. + + ------------ + -- Helper -- + ------------ + + procedure Helper (Unit : Unit_Number_Type) is + CU : constant Node_Id := Cunit (Unit); + + Item : Node_Id; + Item2 : Node_Id; + Elab_Id : Entity_Id; + Par : Node_Id; + + begin + if Seen (Unit) then + return; + else + Seen (Unit) := True; + end if; + + -- First, check for Elaborate_Alls on this unit + + Item := First (Context_Items (CU)); + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Pragma_Name (Item) = Name_Elaborate_All + then + -- Return if some previous error on the pragma itself + + if Error_Posted (Item) then + return; + end if; + + Elab_Id := + Entity + (Expression (First (Pragma_Argument_Associations (Item)))); + + if E = Elab_Id then + Result := True; + return; + end if; + + Par := Parent (Unit_Declaration_Node (Elab_Id)); + + Item2 := First (Context_Items (Par)); + while Present (Item2) loop + if Nkind (Item2) = N_With_Clause + and then Entity (Name (Item2)) = E + and then not Limited_Present (Item2) + then + Result := True; + return; + end if; + + Next (Item2); + end loop; end if; - Elab_Id := - Entity - (Expression (First (Pragma_Argument_Associations (Item)))); + Next (Item); + end loop; - Par := Parent (Unit_Declaration_Node (Elab_Id)); + -- Second, recurse on with's. We could do this as part of the above + -- loop, but it's probably more efficient to have two loops, because + -- the relevant Elaborate_All is likely to be on the initial unit. In + -- other words, we're walking the with's breadth-first. This part is + -- only necessary in the dynamic elaboration model. - Item2 := First (Context_Items (Par)); - while Present (Item2) loop - if Nkind (Item2) = N_With_Clause - and then Entity (Name (Item2)) = E + if Dynamic_Elaboration_Checks then + Item := First (Context_Items (CU)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then not Limited_Present (Item) then - return True; + -- Note: the following call to Get_Cunit_Unit_Number does a + -- linear search, which could be slow, but it's OK because + -- we're about to give a warning anyway. Also, there might + -- be hundreds of units, but not millions. If it turns out + -- to be a problem, we could store the Get_Cunit_Unit_Number + -- in each N_Compilation_Unit node, but that would involve + -- rearranging N_Compilation_Unit_Aux to make room. + + Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); + + if Result then + return; + end if; end if; - Next (Item2); + Next (Item); end loop; end if; + end Helper; - Next (Item); - end loop; + -- Start of processing for Within_Elaborate_All - return False; + begin + Helper (Unit); + return Result; end Within_Elaborate_All; end Sem_Elab; diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index 3d1bd14eb7c..fdf9ba354c8 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -832,8 +832,8 @@ package body Sem_Elim is function OK_Selected_Component (N : Node_Id) return Boolean; -- Test if N is a selected component with all identifiers, or a selected - -- component whose selector is an operator symbol. As a side effect if - -- result is True, sets Num_Names to the number of names present + -- component whose selector is an operator symbol. As a side effect + -- if result is True, sets Num_Names to the number of names present -- (identifiers, and operator if any). --------------------------- diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index cecdbef46ab..8553ce62875 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -214,6 +214,16 @@ package body Sem_Eval is -- e.g. in the two operand case below, for string comparison, the result -- is not static even though the two operands are static. In such cases, -- the caller must reset the Is_Static_Expression flag in N. + -- + -- If Fold and Stat are both set to False then this routine performs also + -- the following extra actions: + -- + -- If either operand is Any_Type then propagate it to result to + -- prevent cascaded errors. + -- + -- If some operand raises constraint error, then replace the node N + -- with the raise constraint error node. This replacement inherits the + -- Is_Static_Expression flag from the operands. procedure Test_Expression_Is_Foldable (N : Node_Id; @@ -2702,8 +2712,6 @@ package body Sem_Eval is Typ : constant Entity_Id := Etype (Left); Otype : Entity_Id := Empty; Result : Boolean; - Stat : Boolean; - Fold : Boolean; begin -- One special case to deal with first. If we can tell that the result @@ -2919,128 +2927,144 @@ package body Sem_Eval is end Length_Mismatch; end if; - -- Test for expression being foldable - - Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); - - -- Only comparisons of scalars can give static results. In particular, - -- comparisons of strings never yield a static result, even if both - -- operands are static strings. - - if not Is_Scalar_Type (Typ) then - Stat := False; - Set_Is_Static_Expression (N, False); - end if; + declare + Is_Static_Expression : Boolean; + Is_Foldable : Boolean; + pragma Unreferenced (Is_Foldable); - -- For operators on universal numeric types called as functions with - -- an explicit scope, determine appropriate specific numeric type, and - -- diagnose possible ambiguity. + begin + -- Initialize the value of Is_Static_Expression. The value of + -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed + -- since, even when some operand is a variable, we can still perform + -- the static evaluation of the expression in some cases (for + -- example, for a variable of a subtype of Integer we statically + -- know that any value stored in such variable is smaller than + -- Integer'Last). + + Test_Expression_Is_Foldable + (N, Left, Right, Is_Static_Expression, Is_Foldable); + + -- Only comparisons of scalars can give static results. In + -- particular, comparisons of strings never yield a static + -- result, even if both operands are static strings. + + if not Is_Scalar_Type (Typ) then + Is_Static_Expression := False; + Set_Is_Static_Expression (N, False); + end if; - if Is_Universal_Numeric_Type (Etype (Left)) - and then - Is_Universal_Numeric_Type (Etype (Right)) - then - Otype := Find_Universal_Operator_Type (N); - end if; + -- For operators on universal numeric types called as functions with + -- an explicit scope, determine appropriate specific numeric type, + -- and diagnose possible ambiguity. - -- For static real type expressions, we cannot use Compile_Time_Compare - -- since it worries about run-time results which are not exact. + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) + then + Otype := Find_Universal_Operator_Type (N); + end if; - if Stat and then Is_Real_Type (Typ) then - declare - Left_Real : constant Ureal := Expr_Value_R (Left); - Right_Real : constant Ureal := Expr_Value_R (Right); + -- For static real type expressions, we cannot use + -- Compile_Time_Compare since it worries about run-time + -- results which are not exact. - begin - case Nkind (N) is - when N_Op_Eq => Result := (Left_Real = Right_Real); - when N_Op_Ne => Result := (Left_Real /= Right_Real); - when N_Op_Lt => Result := (Left_Real < Right_Real); - when N_Op_Le => Result := (Left_Real <= Right_Real); - when N_Op_Gt => Result := (Left_Real > Right_Real); - when N_Op_Ge => Result := (Left_Real >= Right_Real); + if Is_Static_Expression and then Is_Real_Type (Typ) then + declare + Left_Real : constant Ureal := Expr_Value_R (Left); + Right_Real : constant Ureal := Expr_Value_R (Right); - when others => - raise Program_Error; - end case; + begin + case Nkind (N) is + when N_Op_Eq => Result := (Left_Real = Right_Real); + when N_Op_Ne => Result := (Left_Real /= Right_Real); + when N_Op_Lt => Result := (Left_Real < Right_Real); + when N_Op_Le => Result := (Left_Real <= Right_Real); + when N_Op_Gt => Result := (Left_Real > Right_Real); + when N_Op_Ge => Result := (Left_Real >= Right_Real); + + when others => + raise Program_Error; + end case; - Fold_Uint (N, Test (Result), True); - end; + Fold_Uint (N, Test (Result), True); + end; - -- For all other cases, we use Compile_Time_Compare to do the compare + -- For all other cases, we use Compile_Time_Compare to do the compare - else - declare - CR : constant Compare_Result := - Compile_Time_Compare (Left, Right, Assume_Valid => False); + else + declare + CR : constant Compare_Result := + Compile_Time_Compare + (Left, Right, Assume_Valid => False); - begin - if CR = Unknown then - return; - end if; + begin + if CR = Unknown then + return; + end if; - case Nkind (N) is - when N_Op_Eq => - if CR = EQ then - Result := True; - elsif CR = NE or else CR = GT or else CR = LT then - Result := False; - else - return; - end if; + case Nkind (N) is + when N_Op_Eq => + if CR = EQ then + Result := True; + elsif CR = NE or else CR = GT or else CR = LT then + Result := False; + else + return; + end if; - when N_Op_Ne => - if CR = NE or else CR = GT or else CR = LT then - Result := True; - elsif CR = EQ then - Result := False; - else - return; - end if; + when N_Op_Ne => + if CR = NE or else CR = GT or else CR = LT then + Result := True; + elsif CR = EQ then + Result := False; + else + return; + end if; - when N_Op_Lt => - if CR = LT then - Result := True; - elsif CR = EQ or else CR = GT or else CR = GE then - Result := False; - else - return; - end if; + when N_Op_Lt => + if CR = LT then + Result := True; + elsif CR = EQ or else CR = GT or else CR = GE then + Result := False; + else + return; + end if; - when N_Op_Le => - if CR = LT or else CR = EQ or else CR = LE then - Result := True; - elsif CR = GT then - Result := False; - else - return; - end if; + when N_Op_Le => + if CR = LT or else CR = EQ or else CR = LE then + Result := True; + elsif CR = GT then + Result := False; + else + return; + end if; - when N_Op_Gt => - if CR = GT then - Result := True; - elsif CR = EQ or else CR = LT or else CR = LE then - Result := False; - else - return; - end if; + when N_Op_Gt => + if CR = GT then + Result := True; + elsif CR = EQ or else CR = LT or else CR = LE then + Result := False; + else + return; + end if; - when N_Op_Ge => - if CR = GT or else CR = EQ or else CR = GE then - Result := True; - elsif CR = LT then - Result := False; - else - return; - end if; + when N_Op_Ge => + if CR = GT or else CR = EQ or else CR = GE then + Result := True; + elsif CR = LT then + Result := False; + else + return; + end if; - when others => - raise Program_Error; - end case; - end; + when others => + raise Program_Error; + end case; + end; - Fold_Uint (N, Test (Result), Stat); - end if; + Fold_Uint (N, Test (Result), Is_Static_Expression); + end if; + end; -- For the case of a folded relational operator on a specific numeric -- type, freeze operand type now. @@ -4130,7 +4154,7 @@ package body Sem_Eval is -- Never in range if both types are not scalar. Don't know if this can -- actually happen, but just in case. - elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then + elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T2) then return False; -- If T1 has infinities but T2 doesn't have infinities, then T1 is diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 6e70021db29..a2f69feac33 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -225,7 +225,7 @@ package Sem_Eval is -- are statically matching subtypes (RM 4.9.1(1-2)). function Compile_Time_Known_Value (Op : Node_Id) return Boolean; - -- Returns true if Op is an expression not raising constraint error whose + -- Returns true if Op is an expression not raising Constraint_Error whose -- value is known at compile time. This is true if Op is a static -- expression, but can also be true for expressions which are technically -- non-static but which are in fact known at compile time, such as the @@ -236,9 +236,12 @@ package Sem_Eval is function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean; -- Similar to Compile_Time_Known_Value, but also returns True if the value - -- is a compile time known aggregate, i.e. an aggregate all of whose - -- constituent expressions are either compile time known values or compile - -- time known aggregates. + -- is a compile-time-known aggregate, i.e. an aggregate all of whose + -- constituent expressions are either compile-time-known values (based on + -- calling Compile_Time_Known_Value) or compile-time-known aggregates. + -- Note that the aggregate could still involve run-time checks that might + -- fail (such as for subtype checks in component associations), but the + -- evaluation of the expressions themselves will not raise an exception. function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean; -- If T is an array whose index bounds are all known at compile time, then diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index d21e6ae6fa5..6bd498ef9fc 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2012, 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- -- @@ -352,13 +352,13 @@ package body Sem_Mech is -- Access parameters (RM B.3(68)) -- Access to subprogram types (RM B.3(71)) - -- Note: in the case of access parameters, it is the - -- pointer that is passed by value. In GNAT access - -- parameters are treated as IN parameters of an - -- anonymous access type, so this falls out free. + -- Note: in the case of access parameters, it is the pointer + -- that is passed by value. In GNAT access parameters are + -- treated as IN parameters of an anonymous access type, so + -- this falls out free. - -- The bottom line is that all IN elementary types - -- are passed by copy in GNAT. + -- The bottom line is that all IN elementary types are + -- passed by copy in GNAT. if Is_Elementary_Type (Typ) then if Ekind (Formal) = E_In_Parameter then @@ -385,10 +385,21 @@ package body Sem_Mech is if Convention (Typ) /= Convention_C then Set_Mechanism (Formal, By_Reference); - -- If convention C_Pass_By_Copy was specified for - -- the record type, then we pass by copy. + -- OUT and IN OUT parameters of record types are passed + -- by reference regardless of pragmas (RM B.3 (69/2)). - elsif C_Pass_By_Copy (Typ) then + elsif Ekind_In (Formal, E_Out_Parameter, + E_In_Out_Parameter) + then + Set_Mechanism (Formal, By_Reference); + + -- IN parameters of record types are passed by copy only + -- when the related type has convention C_Pass_By_Copy + -- (RM B.3 (68.1/2)). + + elsif Ekind (Formal) = E_In_Parameter + and then C_Pass_By_Copy (Typ) + then Set_Mechanism (Formal, By_Copy); -- Otherwise, for a C convention record, we set the diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8b2eb1c908c..4d377585e5f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2011,8 +2011,7 @@ package body Sem_Prag is --------------- procedure Chain_PPC (PO : Node_Id) is - S : Entity_Id; - P : Node_Id; + S : Entity_Id; begin if Nkind (PO) = N_Abstract_Subprogram_Declaration then @@ -2060,60 +2059,6 @@ package body Sem_Prag is S := Defining_Unit_Name (Specification (PO)); end if; - -- Make sure we do not have the case of a precondition pragma when - -- the Pre'Class aspect is present. - - -- We do this by looking at pragmas already chained to the entity - -- since the aspect derived pragma will be put on this list first. - - if Pragma_Name (N) = Name_Precondition then - if not From_Aspect_Specification (N) then - P := Spec_PPC_List (Contract (S)); - while Present (P) loop - if Pragma_Name (P) = Name_Precondition - and then From_Aspect_Specification (P) - and then Class_Present (P) - then - Error_Msg_Sloc := Sloc (P); - Error_Pragma - ("pragma% not allowed, `Pre''Class` aspect given#"); - end if; - - P := Next_Pragma (P); - end loop; - end if; - end if; - - -- Similarly check for Pre with inherited Pre'Class. Note that - -- we cover the aspect case as well here. - - if Pragma_Name (N) = Name_Precondition - and then not Class_Present (N) - then - declare - Inherited : constant Subprogram_List := - Inherited_Subprograms (S); - P : Node_Id; - - begin - for J in Inherited'Range loop - P := Spec_PPC_List (Contract (Inherited (J))); - while Present (P) loop - if Pragma_Name (P) = Name_Precondition - and then Class_Present (P) - then - Error_Msg_Sloc := Sloc (P); - Error_Pragma - ("pragma% not allowed, `Pre''Class` " - & "aspect inherited from#"); - end if; - - P := Next_Pragma (P); - end loop; - end loop; - end; - end if; - -- Note: we do not analyze the pragma at this point. Instead we -- delay this analysis until the end of the declarative part in -- which the pragma appears. This implements the required delay @@ -4610,10 +4555,12 @@ package body Sem_Prag is null; -- Verify that the homonym is in the same declarative part (not - -- just the same scope). + -- just the same scope). If the pragma comes from an aspect + -- specification we know that it is part of the declaration. elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux + and then not From_Aspect_Specification (N) then exit; @@ -4745,6 +4692,12 @@ package body Sem_Prag is Get_Pragma_Arg (Arg2)); end if; + if Etype (Def_Id) /= Def_Id + and then not Is_CPP_Class (Root_Type (Def_Id)) + then + Error_Msg_N ("root type must be a 'C'P'P type", Arg1); + end if; + Set_Is_CPP_Class (Def_Id); -- Imported CPP types must not have discriminants (because C++ @@ -4988,6 +4941,15 @@ package body Sem_Prag is then Error_Msg_N ("Inline cannot apply to a formal subprogram", N); + + -- If Subp is a renaming, it is the renamed entity that + -- will appear in any call, and be inlined. However, for + -- ASIS uses it is convenient to indicate that the renaming + -- itself is an inlined subprogram, so that some gnatcheck + -- rules can be applied in the absence of expansion. + + elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then + Set_Inline_Flags (Subp); end if; end if; @@ -5523,9 +5485,9 @@ package body Sem_Prag is -- affected by this processing). if R_Id = No_Exceptions and then not Warn then - for J in Scope_Suppress'Range loop + for J in Scope_Suppress.Suppress'Range loop if J /= Atomic_Synchronization then - Scope_Suppress (J) := True; + Scope_Suppress.Suppress (J) := True; end if; end loop; end if; @@ -5667,9 +5629,7 @@ package body Sem_Prag is -- If this is a first subtype, and the base type is distinct, -- then also set the suppress flags on the base type. - if Is_First_Subtype (E) - and then Etype (E) /= E - then + if Is_First_Subtype (E) and then Etype (E) /= E then Suppress_Unsuppress_Echeck (Etype (E), C); end if; end Suppress_Unsuppress_Echeck; @@ -5681,9 +5641,7 @@ package body Sem_Prag is -- user code: we want to generate checks for analysis purposes, as -- set respectively by -gnatC and -gnatd.F - if (CodePeer_Mode or Alfa_Mode) - and then Comes_From_Source (N) - then + if (CodePeer_Mode or Alfa_Mode) and then Comes_From_Source (N) then return; end if; @@ -5706,10 +5664,17 @@ package body Sem_Prag is ("argument of pragma% is not valid check name", Arg1); end if; - if not Suppress_Case - and then (C = All_Checks or else C = Overflow_Check) - then - Opt.Overflow_Checks_Unsuppressed := True; + -- Special processing for overflow check case + + if C = All_Checks or else C = Overflow_Check then + if Suppress_Case then + Scope_Suppress.Overflow_Checks_General := Suppress; + Scope_Suppress.Overflow_Checks_Assertions := Suppress; + else + Scope_Suppress.Overflow_Checks_General := Check_All; + Scope_Suppress.Overflow_Checks_Assertions := Check_All; + Opt.Overflow_Checks_Unsuppressed := True; + end if; end if; if Arg_Count = 1 then @@ -5727,11 +5692,12 @@ package body Sem_Prag is -- Atomic_Synchronization is also not affected, since this is -- not a real check. - for J in Scope_Suppress'Range loop + for J in Scope_Suppress.Suppress'Range loop if J /= Elaboration_Check - and then J /= Atomic_Synchronization + and then + J /= Atomic_Synchronization then - Scope_Suppress (J) := Suppress_Case; + Scope_Suppress.Suppress (J) := Suppress_Case; end if; end loop; @@ -5744,7 +5710,7 @@ package body Sem_Prag is and then (not Comes_From_Source (N) or else C /= Atomic_Synchronization) then - Scope_Suppress (C) := Suppress_Case; + Scope_Suppress.Suppress (C) := Suppress_Case; end if; -- Also make an entry in the Local_Entity_Suppress table @@ -7706,109 +7672,27 @@ package body Sem_Prag is -- pragma CPP_Class ([Entity =>] local_NAME) when Pragma_CPP_Class => CPP_Class : declare - Arg : Node_Id; - Typ : Entity_Id; - begin - if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("'G'N'A'T pragma cpp'_class is now obsolete; replace it" & - " by pragma import?", N); - end if; - GNAT_Pragma; - Check_Arg_Count (1); - Check_Optional_Identifier (Arg1, Name_Entity); - Check_Arg_Is_Local_Name (Arg1); - - Arg := Get_Pragma_Arg (Arg1); - Analyze (Arg); - if Etype (Arg) = Any_Type then - return; - end if; - - if not Is_Entity_Name (Arg) - or else not Is_Type (Entity (Arg)) - then - Error_Pragma_Arg ("pragma% requires a type mark", Arg1); - end if; - - Typ := Entity (Arg); - - if not Is_Tagged_Type (Typ) then - Error_Pragma_Arg ("pragma% applicable to tagged types ", Arg1); - end if; - - -- Types treated as CPP classes must be declared limited (note: - -- this used to be a warning but there is no real benefit to it - -- since we did effectively intend to treat the type as limited - -- anyway). - - if not Is_Limited_Type (Typ) then - Error_Msg_N - ("imported 'C'P'P type must be limited", - Get_Pragma_Arg (Arg1)); - end if; - - Set_Is_CPP_Class (Typ); - Set_Convention (Typ, Convention_CPP); - - -- Imported CPP types must not have discriminants (because C++ - -- classes do not have discriminants). - - if Has_Discriminants (Typ) then + if Warn_On_Obsolescent_Feature then + -- Following message is obsolete ??? Error_Msg_N - ("imported 'C'P'P type cannot have discriminants", - First (Discriminant_Specifications - (Declaration_Node (Typ)))); + ("'G'N'A'T pragma cpp'_class is now obsolete and has no " & + "effect; replace it by pragma import?", N); end if; - -- Components of imported CPP types must not have default - -- expressions because the constructor (if any) is in the - -- C++ side. - - if Is_Incomplete_Or_Private_Type (Typ) - and then No (Underlying_Type (Typ)) - then - -- It should be an error to apply pragma CPP to a private - -- type if the underlying type is not visible (as it is - -- for any representation item). For now, for backward - -- compatibility we do nothing but we cannot check components - -- because they are not available at this stage. All this code - -- will be removed when we cleanup this obsolete GNAT pragma??? - - null; - - else - declare - Tdef : constant Node_Id := - Type_Definition (Declaration_Node (Typ)); - Clist : Node_Id; - Comp : Node_Id; - - begin - if Nkind (Tdef) = N_Record_Definition then - Clist := Component_List (Tdef); - else - pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); - Clist := Component_List (Record_Extension_Part (Tdef)); - end if; - - if Present (Clist) then - Comp := First (Component_Items (Clist)); - while Present (Comp) loop - if Present (Expression (Comp)) then - Error_Msg_N - ("component of imported 'C'P'P type cannot have" & - " default expression", Expression (Comp)); - end if; + Check_Arg_Count (1); - Next (Comp); - end loop; - end if; - end; - end if; + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Import, + Pragma_Argument_Associations => + New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_CPP)), + New_Copy (First (Pragma_Argument_Associations (N)))))); + Analyze (N); end CPP_Class; --------------------- @@ -7857,6 +7741,12 @@ package body Sem_Prag is and then Is_CPP_Class (Root_Type (Etype (Def_Id))))) then + if Scope (Def_Id) /= Scope (Etype (Def_Id)) then + Error_Msg_N + ("'C'P'P constructor must be defined in the scope of " & + "its returned type", Arg1); + end if; + if Arg_Count >= 2 then Set_Imported (Def_Id); Set_Is_Public (Def_Id); @@ -7865,6 +7755,7 @@ package body Sem_Prag is Set_Has_Completion (Def_Id); Set_Is_Constructor (Def_Id); + Set_Convention (Def_Id, Convention_CPP); -- Imported C++ constructors are not dispatching primitives -- because in C++ they don't have a dispatch table slot. @@ -7876,8 +7767,8 @@ package body Sem_Prag is if Is_Tagged_Type (Etype (Def_Id)) and then not Is_Class_Wide_Type (Etype (Def_Id)) + and then Is_Dispatching_Operation (Def_Id) then - pragma Assert (Is_Dispatching_Operation (Def_Id)); Tag_Typ := Etype (Def_Id); Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); @@ -11145,8 +11036,7 @@ package body Sem_Prag is Arg := Get_Pragma_Arg (Arg1); Val := Is_True (Static_Boolean (Arg)); - -- Zero argument. In this case the expression is considered to - -- be True. + -- No arguments (expression is considered to be True) else Val := True; @@ -11159,7 +11049,7 @@ package body Sem_Prag is Record_Rep_Item (Ent, N); Set_Uses_Lock_Free (Ent, Val); - -- Anything else is incorrect + -- Anything else is incorrect placement else Pragma_Misplaced; @@ -11177,6 +11067,7 @@ package body Sem_Prag is range First_Locking_Policy_Name .. Last_Locking_Policy_Name; LP_Val : LP_Range; LP : Character; + begin Check_Ada_83_Warning; Check_Arg_Count (1); @@ -11186,9 +11077,12 @@ package body Sem_Prag is LP_Val := Chars (Get_Pragma_Arg (Arg1)); case LP_Val is - when Name_Ceiling_Locking => LP := 'C'; - when Name_Inheritance_Locking => LP := 'I'; - when Name_Concurrent_Readers_Locking => LP := 'R'; + when Name_Ceiling_Locking => + LP := 'C'; + when Name_Inheritance_Locking => + LP := 'I'; + when Name_Concurrent_Readers_Locking => + LP := 'R'; end case; if Locking_Policy /= ' ' diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 28832237997..21d3e145d33 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -334,21 +334,20 @@ package body Sem_Res is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; Analyze_And_Resolve (N, Typ); Scope_Suppress := Svg; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); - + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Analyze_And_Resolve (N, Typ); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; @@ -375,27 +374,24 @@ package body Sem_Res is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; Analyze_And_Resolve (N); Scope_Suppress := Svg; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); - + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Analyze_And_Resolve (N); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; - if Current_Scope /= Scop - and then Scope_Is_Transient - then + if Current_Scope /= Scop and then Scope_Is_Transient then Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := Scope_Suppress; end if; @@ -2904,20 +2900,20 @@ package body Sem_Res is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Array := Scope_Suppress; + Svg : constant Suppress_Record := Scope_Suppress; begin - Scope_Suppress := (others => True); + Scope_Suppress := Suppress_All; Resolve (N, Typ); Scope_Suppress := Svg; end; else declare - Svg : constant Boolean := Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); begin - Scope_Suppress (Suppress) := True; + Scope_Suppress.Suppress (Suppress) := True; Resolve (N, Typ); - Scope_Suppress (Suppress) := Svg; + Scope_Suppress.Suppress (Suppress) := Svg; end; end if; end Resolve; @@ -5839,9 +5835,9 @@ package body Sem_Res is Check_Restriction (No_Relative_Delay, N); end if; - -- Issue an error for a call to an eliminated subprogram. - -- The routine will not perform the check if the call appears within - -- a default expression. + -- Issue an error for a call to an eliminated subprogram. This routine + -- will not perform the check if the call appears within a default + -- expression. Check_For_Eliminated_Subprogram (Subp, Nam); @@ -7057,26 +7053,48 @@ package body Sem_Res is Loc : constant Source_Ptr := Sloc (N); New_N : Node_Id; P : constant Node_Id := Prefix (N); + + P_Typ : Entity_Id; + -- The candidate prefix type, if overloaded + I : Interp_Index; It : Interp; begin Check_Fully_Declared_Prefix (Typ, P); + P_Typ := Empty; if Is_Overloaded (P) then -- Use the context type to select the prefix that has the correct - -- designated type. + -- designated type. Keep the first match, which will be the inner- + -- most. Get_First_Interp (P, I, It); + while Present (It.Typ) loop - exit when Is_Access_Type (It.Typ) - and then Covers (Typ, Designated_Type (It.Typ)); + if Is_Access_Type (It.Typ) + and then Covers (Typ, Designated_Type (It.Typ)) + then + if No (P_Typ) then + P_Typ := It.Typ; + end if; + + -- Remove access types that do not match, but preserve access + -- to subprogram interpretations, in case a further dereference + -- is needed (see below). + + elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then + Remove_Interp (I); + end if; + Get_Next_Interp (I, It); end loop; - if Present (It.Typ) then - Resolve (P, It.Typ); + if Present (P_Typ) then + Resolve (P, P_Typ); + Set_Etype (N, Designated_Type (P_Typ)); + else -- If no interpretation covers the designated type of the prefix, -- this is the pathological case where not all implementations of @@ -7107,7 +7125,7 @@ package body Sem_Res is return; end if; - Set_Etype (N, Designated_Type (It.Typ)); + -- If not overloaded, resolve P with its own type else Resolve (P); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f42c7547816..9d095309f82 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4500,7 +4500,8 @@ package body Sem_Util is Pos : Uint; Loc : Source_Ptr) return Node_Id is - Lit : Node_Id; + Btyp : Entity_Id := Base_Type (T); + Lit : Node_Id; begin -- In the case where the literal is of type Character, Wide_Character @@ -4522,7 +4523,11 @@ package body Sem_Util is -- else - Lit := First_Literal (Base_Type (T)); + if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then + Btyp := Full_View (Btyp); + end if; + + Lit := First_Literal (Btyp); for J in 1 .. UI_To_Int (Pos) loop Next_Literal (Lit); end loop; @@ -6306,16 +6311,17 @@ package body Sem_Util is end In_Parameter_Specification; ------------------------------------- - -- In_Reverse_Storage_Order_Record -- + -- In_Reverse_Storage_Order_Object -- ------------------------------------- - function In_Reverse_Storage_Order_Record (N : Node_Id) return Boolean is + function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is Pref : Node_Id; - begin - Pref := N; + Btyp : Entity_Id := Empty; + begin -- Climb up indexed components + Pref := N; loop case Nkind (Pref) is when N_Selected_Component => @@ -6331,10 +6337,15 @@ package body Sem_Util is end case; end loop; - return Present (Pref) - and then Is_Record_Type (Etype (Pref)) - and then Reverse_Storage_Order (Etype (Pref)); - end In_Reverse_Storage_Order_Record; + if Present (Pref) then + Btyp := Base_Type (Etype (Pref)); + end if; + + return + Present (Btyp) + and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) + and then Reverse_Storage_Order (Btyp); + end In_Reverse_Storage_Order_Object; -------------------------------------- -- In_Subprogram_Or_Concurrent_Unit -- @@ -12822,6 +12833,47 @@ package body Sem_Util is end if; end Subprogram_Access_Level; + ------------------------------- + -- Support_Atomic_Primitives -- + ------------------------------- + + function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is + Size : Int; + + begin + -- Verify the alignment of Typ is known + + if not Known_Alignment (Typ) then + return False; + end if; + + if Known_Static_Esize (Typ) then + Size := UI_To_Int (Esize (Typ)); + + -- If the Esize (Object_Size) is unknown at compile-time, look at the + -- RM_Size (Value_Size) since it may have been set by an explicit rep + -- item. + + elsif Known_Static_RM_Size (Typ) then + Size := UI_To_Int (RM_Size (Typ)); + + -- Otherwise, the size is considered to be unknown. + + else + return False; + end if; + + -- Check that the size of the component is 8, 16, 32 or 64 bits and that + -- Typ is properly aligned. + + case Size is + when 8 | 16 | 32 | 64 => + return Size = UI_To_Int (Alignment (Typ)) * 8; + when others => + return False; + end case; + end Support_Atomic_Primitives; + ----------------- -- Trace_Scope -- ----------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index d6e0770b364..8d1f7cfadb2 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -742,9 +742,9 @@ package Sem_Util is function In_Parameter_Specification (N : Node_Id) return Boolean; -- Returns True if node N belongs to a parameter specification - function In_Reverse_Storage_Order_Record (N : Node_Id) return Boolean; - -- Returns True if N denotes a component or subcomponent in a record object - -- that has Reverse_Storage_Order. + function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean; + -- Returns True if N denotes a component or subcomponent in a record or + -- array that has Reverse_Storage_Order. function In_Subprogram_Or_Concurrent_Unit return Boolean; -- Determines if the current scope is within a subprogram compilation unit @@ -1477,6 +1477,10 @@ package Sem_Util is function Subprogram_Access_Level (Subp : Entity_Id) return Uint; -- Return the accessibility level of the view denoted by Subp + function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean; + -- Return True if Typ supports the GCC built-in atomic operations (i.e. if + -- Typ is properly sized and aligned). + procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String); -- Print debugging information on entry to each unit being analyzed diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index d1c1480858a..d2413ad2c1b 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -2844,14 +2844,6 @@ package body Sinfo is return List3 (N); end Statements; - function Static_Processing_OK - (N : Node_Id) return Boolean is - begin - pragma Assert (False - or else NT (N).Nkind = N_Aggregate); - return Flag4 (N); - end Static_Processing_OK; - function Storage_Pool (N : Node_Id) return Node_Id is begin @@ -5905,14 +5897,6 @@ package body Sinfo is Set_List3_With_Parent (N, Val); end Set_Statements; - procedure Set_Static_Processing_OK - (N : Node_Id; Val : Boolean) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Aggregate); - Set_Flag4 (N, Val); - end Set_Static_Processing_OK; - procedure Set_Storage_Pool (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index cfaa82842c9..560d6c24b95 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -669,8 +669,8 @@ package Sinfo is -- Present in N_Aggregate nodes. Set for aggregates which can be fully -- evaluated at compile time without raising constraint error. Such -- aggregates can be passed as is to Gigi without any expansion. See - -- Sem_Aggr for the specific conditions under which an aggregate has this - -- flag set. See also the flag Static_Processing_OK. + -- Exp_Aggr for the specific conditions under which an aggregate has this + -- flag set. -- Componentwise_Assignment (Flag14-Sem) -- Present in N_Assignment_Statement nodes. Set for a record assignment @@ -1725,17 +1725,6 @@ package Sinfo is -- This flag is set in both the N_Aspect_Specification node itself, -- and in the pragma which is generated from this node. - -- Static_Processing_OK (Flag4-Sem) - -- Present in N_Aggregate nodes. When the Compile_Time_Known_Aggregate - -- flag is set, the full value of the aggregate can be determined at - -- compile time and the aggregate can be passed as is to the back-end. - -- In this event it is irrelevant whether this flag is set or not. - -- However, if the flag Compile_Time_Known_Aggregate is not set but - -- Static_Processing_OK is set, the aggregate can (but need not) be - -- converted into a compile time known aggregate by the expander. See - -- Sem_Aggr for the specific conditions under which an aggregate has its - -- Static_Processing_OK flag set. - -- Storage_Pool (Node1-Sem) -- Present in N_Allocator, N_Free_Statement, N_Simple_Return_Statement, -- and N_Extended_Return_Statement nodes. References the entity for the @@ -3391,7 +3380,6 @@ package Sinfo is -- Null_Record_Present (Flag17) -- Aggregate_Bounds (Node3-Sem) -- Associated_Node (Node4-Sem) - -- Static_Processing_OK (Flag4-Sem) -- Compile_Time_Known_Aggregate (Flag18-Sem) -- Expansion_Delayed (Flag11-Sem) -- Has_Self_Reference (Flag13-Sem) @@ -4119,7 +4107,7 @@ package Sinfo is -- Then_Statements (List2) -- Elsif_Parts (List3) (set to No_List if none present) -- Else_Statements (List4) (set to No_List if no else part present) - -- End_Span (Uint5) (set to No_Uint if expander generated) + -- End_Span (Uint5) (set to Uint_0 if expander generated) -- N_Elsif_Part -- Sloc points to ELSIF @@ -4151,7 +4139,7 @@ package Sinfo is -- Sloc points to CASE -- Expression (Node3) -- Alternatives (List4) - -- End_Span (Uint5) (set to No_Uint if expander generated) + -- End_Span (Uint5) (set to Uint_0 if expander generated) -- Note: Before Ada 2012, a pragma in a statement sequence is always -- followed by a statement, and this is true in the tree even in Ada @@ -5796,9 +5784,11 @@ package Sinfo is -- Unreferenced_In_Spec (Flag7-Sem) -- No_Entities_Ref_In_Spec (Flag8-Sem) - -- Note: Limited_Present and Limited_View_Installed give support to - -- Ada 2005 (AI-50217). - -- Similarly, Private_Present gives support to AI-50262. + -- Note: Limited_Present and Limited_View_Installed are used to support + -- the implementation of Ada 2005 (AI-50217). + + -- Similarly, Private_Present is used to support the implementation of + -- Ada 2005 (AI-50262). ---------------------- -- With_Type clause -- @@ -5806,8 +5796,9 @@ package Sinfo is -- This is a GNAT extension, used to implement mutually recursive -- types declared in different packages. + -- Note: this is now obsolete. The functionality of this construct - -- is now implemented by the Ada 2005 Limited_with_Clause. + -- is now implemented by the Ada 2005 limited_with_clause. --------------------- -- 10.2 Body stub -- @@ -8966,9 +8957,6 @@ package Sinfo is function Statements (N : Node_Id) return List_Id; -- List3 - function Static_Processing_OK - (N : Node_Id) return Boolean; -- Flag4 - function Storage_Pool (N : Node_Id) return Node_Id; -- Node1 @@ -9941,9 +9929,6 @@ package Sinfo is procedure Set_Statements (N : Node_Id; Val : List_Id); -- List3 - procedure Set_Static_Processing_OK - (N : Node_Id; Val : Boolean); -- Flag4 - procedure Set_Storage_Pool (N : Node_Id; Val : Node_Id); -- Node1 @@ -12071,7 +12056,6 @@ package Sinfo is pragma Inline (Specification); pragma Inline (Split_PPC); pragma Inline (Statements); - pragma Inline (Static_Processing_OK); pragma Inline (Storage_Pool); pragma Inline (Subpool_Handle_Name); pragma Inline (Strval); @@ -12391,7 +12375,6 @@ package Sinfo is pragma Inline (Set_Specification); pragma Inline (Set_Split_PPC); pragma Inline (Set_Statements); - pragma Inline (Set_Static_Processing_OK); pragma Inline (Set_Storage_Pool); pragma Inline (Set_Subpool_Handle_Name); pragma Inline (Set_Strval); diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index 4ac3c220549..05d427743a8 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -127,7 +127,15 @@ package body Snames is function Get_Attribute_Id (N : Name_Id) return Attribute_Id is begin - return Attribute_Id'Val (N - First_Attribute_Name); + if N = Name_CPU then + return Attribute_CPU; + elsif N = Name_Dispatching_Domain then + return Attribute_Dispatching_Domain; + elsif N = Name_Interrupt_Priority then + return Attribute_Interrupt_Priority; + else + return Attribute_Id'Val (N - First_Attribute_Name); + end if; end Get_Attribute_Id; ----------------------- @@ -392,6 +400,16 @@ package body Snames is or else N not in Ada_2012_Reserved_Words); end Is_Keyword_Name; + -------------------------------- + -- Is_Internal_Attribute_Name -- + -------------------------------- + + function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is + begin + return + N in First_Internal_Attribute_Name .. Last_Internal_Attribute_Name; + end Is_Internal_Attribute_Name; + ---------------------------- -- Is_Locking_Policy_Name -- ---------------------------- diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index bffc4207619..d0c20153b0a 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -766,6 +766,7 @@ package Snames is Name_Asm_Input : constant Name_Id := N + $; -- GNAT Name_Asm_Output : constant Name_Id := N + $; -- GNAT Name_AST_Entry : constant Name_Id := N + $; -- VMS + Name_Atomic_Always_Lock_Free : constant Name_Id := N + $; -- GNAT Name_Bit : constant Name_Id := N + $; -- GNAT Name_Bit_Order : constant Name_Id := N + $; Name_Bit_Position : constant Name_Id := N + $; -- GNAT @@ -779,7 +780,6 @@ package Snames is Name_Constant_Indexing : constant Name_Id := N + $; -- GNAT Name_Constrained : constant Name_Id := N + $; Name_Count : constant Name_Id := N + $; - Name_CPU : constant Name_Id := N + $; -- Ada 12 Name_Default_Bit_Order : constant Name_Id := N + $; -- GNAT Name_Default_Iterator : constant Name_Id := N + $; -- GNAT Name_Definite : constant Name_Id := N + $; @@ -787,7 +787,6 @@ package Snames is Name_Denorm : constant Name_Id := N + $; Name_Descriptor_Size : constant Name_Id := N + $; Name_Digits : constant Name_Id := N + $; - Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12 Name_Elaborated : constant Name_Id := N + $; -- GNAT Name_Emax : constant Name_Id := N + $; -- Ada 83 Name_Enabled : constant Name_Id := N + $; -- GNAT @@ -809,7 +808,6 @@ package Snames is Name_Img : constant Name_Id := N + $; -- GNAT Name_Implicit_Dereference : constant Name_Id := N + $; -- GNAT Name_Integer_Value : constant Name_Id := N + $; -- GNAT - Name_Interrupt_Priority : constant Name_Id := N + $; -- Ada 12 Name_Invalid_Value : constant Name_Id := N + $; -- GNAT Name_Iterator_Element : constant Name_Id := N + $; -- GNAT Name_Large : constant Name_Id := N + $; -- Ada 83 @@ -955,6 +953,27 @@ package Snames is Last_Entity_Attribute_Name : constant Name_Id := N + $; Last_Attribute_Name : constant Name_Id := N + $; + -- Names of internal attributes. They are not real attributes but special + -- names used internally by GNAT in order to deal with delayed aspects + -- (Aspect_CPU, Aspect_Dispatching_Domain, Aspect_Interrupt_Priority) that + -- don't have corresponding pragmas or user-referencable attributes. + + -- It is convenient to have these internal attributes available for + -- processing the aspects, since the normal approach is to convert an + -- aspect into its corresponding pragma or attribute specification. + + -- These attributes do have Attribute_Id values so that case statements + -- on Attribute_Id include these cases, but they are NOT included in the + -- Attribute_Name subtype defined above, which is typically used in the + -- front end for checking syntax of submitted programs (where the use of + -- internal attributes is not permitted). + + First_Internal_Attribute_Name : constant Name_Id := N + $; + Name_CPU : constant Name_Id := N + $; + Name_Dispatching_Domain : constant Name_Id := N + $; + Name_Interrupt_Priority : constant Name_Id := N + $; + Last_Internal_Attribute_Name : constant Name_Id := N + $; + -- Names of recognized locking policy identifiers First_Locking_Policy_Name : constant Name_Id := N + $; @@ -1345,6 +1364,7 @@ package Snames is Attribute_Asm_Input, Attribute_Asm_Output, Attribute_AST_Entry, + Attribute_Atomic_Always_Lock_Free, Attribute_Bit, Attribute_Bit_Order, Attribute_Bit_Position, @@ -1358,7 +1378,6 @@ package Snames is Attribute_Constant_Indexing, Attribute_Constrained, Attribute_Count, - Attribute_CPU, Attribute_Default_Bit_Order, Attribute_Default_Iterator, Attribute_Definite, @@ -1366,7 +1385,6 @@ package Snames is Attribute_Denorm, Attribute_Descriptor_Size, Attribute_Digits, - Attribute_Dispatching_Domain, Attribute_Elaborated, Attribute_Emax, Attribute_Enabled, @@ -1388,7 +1406,6 @@ package Snames is Attribute_Img, Attribute_Implicit_Dereference, Attribute_Integer_Value, - Attribute_Interrupt_Priority, Attribute_Invalid_Value, Attribute_Iterator_Element, Attribute_Large, @@ -1518,7 +1535,18 @@ package Snames is Attribute_Base, Attribute_Class, - Attribute_Stub_Type); + Attribute_Stub_Type, + + -- The internal attributes are on their own, out of order, because of + -- the special processing required to deal with the fact that their + -- names are not attribute names. + + Attribute_CPU, + Attribute_Dispatching_Domain, + Attribute_Interrupt_Priority); + + subtype Internal_Attribute_Id is Attribute_Id range + Attribute_CPU .. Attribute_Interrupt_Priority; type Attribute_Class_Array is array (Attribute_Id) of Boolean; -- Type used to build attribute classification flag arrays @@ -1826,6 +1854,10 @@ package Snames is -- Test to see if the name N is the name of a recognized entity attribute, -- i.e. an attribute reference that returns an entity. + function Is_Internal_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of an INT attribute (Name_CPU, + -- Name_Dispatching_Domain, Name_Interrupt_Priority). + function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean; -- Test to see if the name N is the name of a recognized attribute that -- designates a procedure (and can therefore appear as a statement). @@ -1885,7 +1917,9 @@ package Snames is function Get_Attribute_Id (N : Name_Id) return Attribute_Id; -- Returns Id of attribute corresponding to given name. It is an error to - -- call this function with a name that is not the name of a attribute. + -- call this function with a name that is not the name of a attribute. Note + -- that the function also works correctly for internal attribute names even + -- though there are not included in the main list of attribute Names. function Get_Convention_Id (N : Name_Id) return Convention_Id; -- Returns Id of language convention corresponding to given name. It is diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 51cec6e02c4..4815c097302 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -443,7 +443,8 @@ package body Switch.C is -- -gnated switch (disable atomic synchronization) when 'd' => - Suppress_Options (Atomic_Synchronization) := True; + Suppress_Options.Suppress (Atomic_Synchronization) := + True; -- -gnateD switch (preprocessing symbol definition) @@ -754,7 +755,9 @@ package body Switch.C is when 'o' => Ptr := Ptr + 1; - Suppress_Options (Overflow_Check) := False; + Suppress_Options.Suppress (Overflow_Check) := False; + Suppress_Options.Overflow_Checks_General := Check_All; + Suppress_Options.Overflow_Checks_Assertions := Check_All; Opt.Enable_Overflow_Checks := True; -- Processing for O switch @@ -782,12 +785,16 @@ package body Switch.C is -- exclude Atomic_Synchronization, since this is not a real -- check. - for J in Suppress_Options'Range loop + for J in Suppress_Options.Suppress'Range loop if J /= Elaboration_Check - and then J /= Atomic_Synchronization + and then + J /= Atomic_Synchronization then - Suppress_Options (J) := True; + Suppress_Options.Suppress (J) := True; end if; + + Suppress_Options.Overflow_Checks_General := Suppress; + Suppress_Options.Overflow_Checks_Assertions := Suppress; end loop; Validity_Checks_On := False; diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index 3dbecc31cc9..d082c905f86 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2012, 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- -- @@ -236,9 +236,9 @@ package body Switch.M is -- One-letter switches when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' | - 'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'n' | 'N' | - 'o' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 'S' | - 't' | 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' => + 'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'N' | 'o' | + 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 'S' | 't' | + 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' => Storing (First_Stored) := C; Add_Switch_Component (Storing (Storing'First .. First_Stored)); @@ -423,6 +423,24 @@ package body Switch.M is return; end if; + -- -gnatn may be -gnatn, -gnatn1, or -gnatn2 + + when 'n' => + Last_Stored := First_Stored; + Storing (Last_Stored) := 'n'; + Ptr := Ptr + 1; + + if Ptr <= Max + and then Switch_Chars (Ptr) in '1' .. '2' + then + Last_Stored := Last_Stored + 1; + Storing (Last_Stored) := Switch_Chars (Ptr); + Ptr := Ptr + 1; + end if; + + Add_Switch_Component + (Storing (Storing'First .. Last_Stored)); + -- -gnatR may be followed by '0', '1', '2' or '3', -- then by 's' diff --git a/gcc/ada/system-aix.ads b/gcc/ada/system-aix.ads index 3f91af51ecc..19d65bdfcdd 100644 --- a/gcc/ada/system-aix.ads +++ b/gcc/ada/system-aix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (AIX/PPC Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-aix64.ads b/gcc/ada/system-aix64.ads index 4ad3756042b..568c24f2569 100644 --- a/gcc/ada/system-aix64.ads +++ b/gcc/ada/system-aix64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (PPC/AIX64 Version) -- -- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2012, 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 -- diff --git a/gcc/ada/system-darwin-ppc.ads b/gcc/ada/system-darwin-ppc.ads index 79894e5c360..d45ab4ee846 100644 --- a/gcc/ada/system-darwin-ppc.ads +++ b/gcc/ada/system-darwin-ppc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Darwin/PPC Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-darwin-ppc64.ads b/gcc/ada/system-darwin-ppc64.ads index 6d4c61651d8..feaff2ed3ea 100644 --- a/gcc/ada/system-darwin-ppc64.ads +++ b/gcc/ada/system-darwin-ppc64.ads @@ -137,6 +137,7 @@ private Stack_Check_Limits : constant Boolean := False; Support_64_Bit_Divides : constant Boolean := True; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-darwin-x86.ads b/gcc/ada/system-darwin-x86.ads index efd93f63c20..908cf50de15 100644 --- a/gcc/ada/system-darwin-x86.ads +++ b/gcc/ada/system-darwin-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Darwin/x86 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -158,6 +158,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-darwin-x86_64.ads b/gcc/ada/system-darwin-x86_64.ads index 27f1241616d..0e5e8c02727 100644 --- a/gcc/ada/system-darwin-x86_64.ads +++ b/gcc/ada/system-darwin-x86_64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Darwin/x86_64 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -158,6 +158,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-freebsd-x86.ads b/gcc/ada/system-freebsd-x86.ads index cb03d56d434..57bff62938b 100644 --- a/gcc/ada/system-freebsd-x86.ads +++ b/gcc/ada/system-freebsd-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (FreeBSD/x86 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -132,6 +132,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-freebsd-x86_64.ads b/gcc/ada/system-freebsd-x86_64.ads index 8f523a20ff8..e99578d97f6 100644 --- a/gcc/ada/system-freebsd-x86_64.ads +++ b/gcc/ada/system-freebsd-x86_64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (FreeBSD/x86_64 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -132,6 +132,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-hpux-ia64.ads b/gcc/ada/system-hpux-ia64.ads index c9cf952e806..c1f2f94962b 100644 --- a/gcc/ada/system-hpux-ia64.ads +++ b/gcc/ada/system-hpux-ia64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (HP-UX/ia64 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -132,12 +132,13 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; Always_Compatible_Rep : constant Boolean := True; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/system-hpux.ads b/gcc/ada/system-hpux.ads index f32ea6f4948..47793e55f67 100644 --- a/gcc/ada/system-hpux.ads +++ b/gcc/ada/system-hpux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (HP-UX Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-linux-alpha.ads b/gcc/ada/system-linux-alpha.ads index 154c01bf6c5..5d845020446 100644 --- a/gcc/ada/system-linux-alpha.ads +++ b/gcc/ada/system-linux-alpha.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/alpha Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-linux-hppa.ads b/gcc/ada/system-linux-hppa.ads index 3b4bb270036..5ec908708bb 100644 --- a/gcc/ada/system-linux-hppa.ads +++ b/gcc/ada/system-linux-hppa.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU/Linux-HPPA Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-linux-ia64.ads b/gcc/ada/system-linux-ia64.ads index 11be8491d27..c0cb6643c92 100644 --- a/gcc/ada/system-linux-ia64.ads +++ b/gcc/ada/system-linux-ia64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/ia64 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -140,6 +140,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-linux-ppc.ads b/gcc/ada/system-linux-ppc.ads index cbd814341ed..fac85a52fe5 100644 --- a/gcc/ada/system-linux-ppc.ads +++ b/gcc/ada/system-linux-ppc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/PPC Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-linux-s390.ads b/gcc/ada/system-linux-s390.ads index 19ad00025ad..28107a0b464 100644 --- a/gcc/ada/system-linux-s390.ads +++ b/gcc/ada/system-linux-s390.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/s390 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-linux-s390x.ads b/gcc/ada/system-linux-s390x.ads index 6ed5749aafd..135b5a3b174 100644 --- a/gcc/ada/system-linux-s390x.ads +++ b/gcc/ada/system-linux-s390x.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/s390x Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-linux-sh4.ads b/gcc/ada/system-linux-sh4.ads index 344b7ef541e..8ee07e374db 100644 --- a/gcc/ada/system-linux-sh4.ads +++ b/gcc/ada/system-linux-sh4.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/sh4 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-linux-sparc.ads b/gcc/ada/system-linux-sparc.ads index 1f4f2207d45..ff93463cf86 100644 --- a/gcc/ada/system-linux-sparc.ads +++ b/gcc/ada/system-linux-sparc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU/Linux-SPARC Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-linux-x86.ads b/gcc/ada/system-linux-x86.ads index c0bd494d020..270ed06cae6 100644 --- a/gcc/ada/system-linux-x86.ads +++ b/gcc/ada/system-linux-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/x86 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -140,6 +140,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-linux-x86_64.ads b/gcc/ada/system-linux-x86_64.ads index 1fd23fc4a12..4c315d11cc0 100644 --- a/gcc/ada/system-linux-x86_64.ads +++ b/gcc/ada/system-linux-x86_64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (GNU-Linux/x86-64 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -140,6 +140,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-lynxos-ppc.ads b/gcc/ada/system-lynxos-ppc.ads index 8d718c83fe8..3f701b2dcf9 100644 --- a/gcc/ada/system-lynxos-ppc.ads +++ b/gcc/ada/system-lynxos-ppc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (LynxOS PPC Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-lynxos-x86.ads b/gcc/ada/system-lynxos-x86.ads index 18a4a3606b0..70adfa98e19 100644 --- a/gcc/ada/system-lynxos-x86.ads +++ b/gcc/ada/system-lynxos-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (LynxOS x86 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -146,6 +146,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-mingw-x86_64.ads b/gcc/ada/system-mingw-x86_64.ads index 9464259f68f..b0b122216a8 100644 --- a/gcc/ada/system-mingw-x86_64.ads +++ b/gcc/ada/system-mingw-x86_64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Windows Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -132,6 +132,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-mingw.ads b/gcc/ada/system-mingw.ads index 9753650e918..dfb485208cf 100644 --- a/gcc/ada/system-mingw.ads +++ b/gcc/ada/system-mingw.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Windows Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-solaris-sparc.ads b/gcc/ada/system-solaris-sparc.ads index 1afb18b1f47..ac695c543fe 100644 --- a/gcc/ada/system-solaris-sparc.ads +++ b/gcc/ada/system-solaris-sparc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (SUN Solaris Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-solaris-sparcv9.ads b/gcc/ada/system-solaris-sparcv9.ads index 4929c75a1db..6c059244e97 100644 --- a/gcc/ada/system-solaris-sparcv9.ads +++ b/gcc/ada/system-solaris-sparcv9.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Solaris Sparcv9 Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-solaris-x86.ads b/gcc/ada/system-solaris-x86.ads index cd722e349fb..3987ea87ea1 100644 --- a/gcc/ada/system-solaris-x86.ads +++ b/gcc/ada/system-solaris-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (x86 Solaris Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -132,6 +132,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-solaris-x86_64.ads b/gcc/ada/system-solaris-x86_64.ads index 4f336780791..ed78923483f 100644 --- a/gcc/ada/system-solaris-x86_64.ads +++ b/gcc/ada/system-solaris-x86_64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (x86-64 Solaris Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -132,6 +132,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-vms-ia64.ads b/gcc/ada/system-vms-ia64.ads index 010de3d13de..f8ed51afad8 100644 --- a/gcc/ada/system-vms-ia64.ads +++ b/gcc/ada/system-vms-ia64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -150,6 +150,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/system-vms_64.ads b/gcc/ada/system-vms_64.ads index 11f2853ad2d..946f0341d1c 100644 --- a/gcc/ada/system-vms_64.ads +++ b/gcc/ada/system-vms_64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-vxworks-arm.ads b/gcc/ada/system-vxworks-arm.ads index 484d40d95c7..ae8ddd51065 100644 --- a/gcc/ada/system-vxworks-arm.ads +++ b/gcc/ada/system-vxworks-arm.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (VxWorks Version ARM) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-vxworks-m68k.ads b/gcc/ada/system-vxworks-m68k.ads index 429ca5d5a57..d747792a56e 100644 --- a/gcc/ada/system-vxworks-m68k.ads +++ b/gcc/ada/system-vxworks-m68k.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (VxWorks version M68K) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-vxworks-mips.ads b/gcc/ada/system-vxworks-mips.ads index 3dbb835704d..47b46fa2f7d 100644 --- a/gcc/ada/system-vxworks-mips.ads +++ b/gcc/ada/system-vxworks-mips.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (VxWorks Version Mips) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-vxworks-ppc.ads b/gcc/ada/system-vxworks-ppc.ads index 6c24b971db3..62d604f6319 100644 --- a/gcc/ada/system-vxworks-ppc.ads +++ b/gcc/ada/system-vxworks-ppc.ads @@ -115,8 +115,14 @@ package System is private - pragma Linker_Options ("-crtbe"); - -- Required by ZCX on VxWorks kernel + -- Note: we now more closely rely on the VxWorks mechanisms to register + -- exception tables for ZCX support in kernel mode, thanks to crt objects + -- featuring dedicated constructors triggered by linker options below. + + -- Commenting the pragma for the sjlj runtimes is performed automatically + -- by our Makefiles, so this line needs to be manipulated with care. + + pragma Linker_Options ("-crtbe" & ASCII.NUL & "-auto-register"); type Address is mod Memory_Size; Null_Address : constant Address := 0; diff --git a/gcc/ada/system-vxworks-sparcv9.ads b/gcc/ada/system-vxworks-sparcv9.ads index 856161f1006..96601676a24 100644 --- a/gcc/ada/system-vxworks-sparcv9.ads +++ b/gcc/ada/system-vxworks-sparcv9.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (VxWorks Version Sparc/64) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- diff --git a/gcc/ada/system-vxworks-x86.ads b/gcc/ada/system-vxworks-x86.ads index 14388d87207..a2df22b038c 100644 --- a/gcc/ada/system-vxworks-x86.ads +++ b/gcc/ada/system-vxworks-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (VxWorks 5 Version x86) -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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 -- @@ -145,6 +145,7 @@ private Stack_Check_Probes : constant Boolean := False; Stack_Check_Limits : constant Boolean := True; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 193858ac898..ae801555d0b 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -57,6 +57,7 @@ package body Targparm is PAS, -- Preallocated_Stacks RTX, -- RTX_RTSS_Kernel_Module SAG, -- Support_Aggregates + SAP, -- Support_Atomic_Primitives SCA, -- Support_Composite_Assign SCC, -- Support_Composite_Compare SCD, -- Stack_Check_Default @@ -93,6 +94,7 @@ package body Targparm is PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks"; RTX_Str : aliased constant Source_Buffer := "RTX_RTSS_Kernel_Module"; SAG_Str : aliased constant Source_Buffer := "Support_Aggregates"; + SAP_Str : aliased constant Source_Buffer := "Support_Atomic_Primitives"; SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign"; SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare"; SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default"; @@ -129,6 +131,7 @@ package body Targparm is PAS_Str'Access, RTX_Str'Access, SAG_Str'Access, + SAP_Str'Access, SCA_Str'Access, SCC_Str'Access, SCD_Str'Access, @@ -586,6 +589,7 @@ package body Targparm is when PAS => Preallocated_Stacks_On_Target := Result; when RTX => RTX_RTSS_Kernel_Module_On_Target := Result; when SAG => Support_Aggregates_On_Target := Result; + when SAP => Support_Atomic_Primitives_On_Target := Result; when SCA => Support_Composite_Assign_On_Target := Result; when SCC => Support_Composite_Compare_On_Target := Result; when SCD => Stack_Check_Default_On_Target := Result; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index be1c9af0218..e3210c93664 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -408,6 +408,14 @@ package Targparm is -- are available. If any of these routines is not available, then -- this flag is False, and the use of aggregates is not permitted. + Support_Atomic_Primitives_On_Target : Boolean := False; + -- If this flag is True, then the back-end support GCC built-in atomic + -- operations for memory model such as atomic load or atomic compare + -- exchange (see the GCC manual for more information). If the flag is + -- False, then the back-end doesn't provide this support. Note this flag is + -- set to True only if the target supports all atomic primitives up to 64 + -- bits. ??? To be modified. + Support_Composite_Assign_On_Target : Boolean := True; -- The assignment of composite objects other than small records and -- arrays whose size is 64-bits or less and is set by an explicit diff --git a/gcc/ada/tb-gcc.c b/gcc/ada/tb-gcc.c index 7b7c27ad24c..737f29a479b 100644 --- a/gcc/ada/tb-gcc.c +++ b/gcc/ada/tb-gcc.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2004-2011, Free Software Foundation, Inc. * + * Copyright (C) 2004-2012, 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- * @@ -64,7 +64,7 @@ trace_callback (struct _Unwind_Context * uw_context, uw_data_t * uw_data) { char * pc; -#if defined (__ia64__) && defined (__hpux__) +#if defined (__ia64__) && defined (__hpux__) && defined (USE_LIBUNWIND_EXCEPTIONS) /* Work around problem with _Unwind_GetIP on ia64 HP-UX. */ uwx_get_reg ((struct uwx_env *) uw_context, UWX_REG_IP, (uint64_t *) &pc); #else diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index ff2a3b6cfdb..2c8335de68b 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2000-2011, Free Software Foundation, Inc. * + * Copyright (C) 2000-2012, 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- * @@ -106,6 +106,76 @@ extern void (*Unlock_Task) (void); #include "tb-ivms.c" +#elif defined (_WIN64) && defined (__SEH__) + +#include <windows.h> + +int +__gnat_backtrace (void **array, + int size, + void *exclude_min, + void *exclude_max, + int skip_frames) +{ + CONTEXT context; + UNWIND_HISTORY_TABLE history; + int i; + + /* Get the context. */ + RtlCaptureContext (&context); + + /* Setup unwind history table (a cached to speed-up unwinding). */ + memset (&history, 0, sizeof (history)); + + i = 0; + while (1) + { + PRUNTIME_FUNCTION RuntimeFunction; + KNONVOLATILE_CONTEXT_POINTERS NvContext; + ULONG64 ImageBase; + VOID *HandlerData; + ULONG64 EstablisherFrame; + + /* Get function metadata. */ + RuntimeFunction = RtlLookupFunctionEntry + (context.Rip, &ImageBase, &history); + + if (!RuntimeFunction) + { + /* In case of failure, assume this is a leaf function. */ + context.Rip = *(ULONG64 *) context.Rsp; + context.Rsp += 8; + } + else + { + /* Unwind. */ + memset (&NvContext, 0, sizeof (KNONVOLATILE_CONTEXT_POINTERS)); + RtlVirtualUnwind (0, ImageBase, context.Rip, RuntimeFunction, + &context, &HandlerData, &EstablisherFrame, + &NvContext); + } + + /* 0 means bottom of the stack. */ + if (context.Rip == 0) + break; + + /* Skip frames. */ + if (skip_frames > 1) + { + skip_frames--; + continue; + } + /* Excluded frames. */ + if ((void *)context.Rip >= exclude_min + && (void *)context.Rip <= exclude_max) + continue; + + array[i++] = (void *)(context.Rip - 2); + if (i >= size) + break; + } + return i; +} #else /* No target specific implementation. */ diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads index 12c1ae545fe..9fa2121f4cd 100644 --- a/gcc/ada/tree_io.ads +++ b/gcc/ada/tree_io.ads @@ -47,7 +47,7 @@ package Tree_IO is Tree_Format_Error : exception; -- Raised if a format error is detected in the input file - ASIS_Version_Number : constant := 28; + ASIS_Version_Number : constant := 29; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees and an ASIS application that is reading the -- trees. It must be incremented whenever a change is made to the tree @@ -56,6 +56,8 @@ package Tree_IO is -- -- 27 Changes in the tree structures for expression functions -- 28 Changes in Snames + -- 29 Changes in Sem_Ch3 (tree copying in case of discriminant constraint + -- for concurrent types). procedure Tree_Read_Initialize (Desc : File_Descriptor); -- Called to initialize reading of a tree file. This call must be made diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index ed827ccdfcf..0f61b04c291 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads index 6e9541a8e9f..212c49155b5 100644 --- a/gcc/ada/treepr.ads +++ b/gcc/ada/treepr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 011afda0868..03370cff666 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -646,9 +646,9 @@ package Types is TS : out Time_Stamp_Type); -- Given the components of a time stamp, initialize the value - ----------------------------------------------- - -- Types used for Pragma Suppress Management -- - ----------------------------------------------- + ------------------------------------- + -- Types used for Check Management -- + ------------------------------------- type Check_Id is new Nat; -- Type used to represent a check id @@ -703,6 +703,56 @@ package Types is -- 4. Add a new Do_xxx_Check flag to Sinfo (if required) -- 5. Add appropriate checks for the new test + -- The following provides precise details on the mode used to check + -- intermediate overflows in expressions for signed integer arithmetic. + + type Overflow_Check_Type is + (Suppress, + -- Intermediate overflow suppressed. If an arithmetic operation creates + -- an overflow, no exception is raised, and the program is erroneous. + + Check_All, + -- All intermediate operations are checked. If the result of any + -- arithmetic operation gives a result outside the range of the base + -- type, then a Constraint_Error exception is raised. + + Minimize, + -- Where appropriate, arithmetic operations are performed with an + -- extended range, using Long_Long_Integer if necessary. As long as + -- the result fits in this extended range, then no exception is raised + -- and computation continues with the extended result. The final value + -- of an expression must fit in the base type of the whole expression. + -- If an intermediate result is outside the range of Long_Long_Integer + -- then a Constraint_Error exception is raised. + + Eliminate); + -- In this mode arbitrary precision arithmetic is used as needed to + -- ensure that it is impossible for intermediate arithmetic to cause + -- an overflow. Again the final value of an expression must fit in + -- the base type of the whole expression. + + -- The following structure captures the state of check suppression or + -- activation at a particular point in the program execution. + + type Suppress_Record is record + Suppress : Suppress_Array; + -- Indicates suppression status of each possible check + + Overflow_Checks_General : Overflow_Check_Type; + -- This field is relevant only if Suppress (Overflow_Check) is False. + -- It indicates the mode of overflow checking to be applied to general + -- expressions outside assertions. + + Overflow_Checks_Assertions : Overflow_Check_Type; + -- This field is relevant only if Suppress (Overflow_Check) is False. + -- It indicates the mode of overflow checking to be applied to any + -- expressions occuring inside assertions. + end record; + + Suppress_All : constant Suppress_Record := + ((others => True), Suppress, Suppress); + -- Constant used to initialize Suppress_Record value to all suppressed. + ----------------------------------- -- Global Exception Declarations -- ----------------------------------- diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index 9901b8477a0..29c4ee0f21e 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -84,6 +84,8 @@ gcc -c ^ GNAT COMPILE -gnatm ^ /ERROR_LIMIT -gnatm2 ^ /ERROR_LIMIT=2 -gnatn ^ /INLINE=PRAGMA +-gnatn1 ^ /INLINE=PRAGMA_LEVEL_1 +-gnatn2 ^ /INLINE=PRAGMA_LEVEL_2 -gnatN ^ /INLINE=FULL -gnato ^ /CHECKS=OVERFLOW -gnatp ^ /CHECKS=SUPPRESS_ALL diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index ca7127970d0..a98bd9f376b 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -1188,7 +1188,7 @@ package body Uintp is if D > Int_1 then - -- Multiply Dividend by D + -- Multiply Dividend by d Carry := 0; for J in reverse Dividend'Range loop @@ -2213,6 +2213,8 @@ package body Uintp is ---------------- function UI_To_Int (Input : Uint) return Int is + pragma Assert (Input /= No_Uint); + begin if Direct (Input) then return Direct_Val (Input); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index f95e318e3af..59a5899a658 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -298,8 +298,8 @@ begin -- Line for -gnatn switch - Write_Switch_Char ("n[1|2]"); - Write_Line ("Enable pragma Inline (both within and across units)"); + Write_Switch_Char ("n[?]"); + Write_Line ("Enable pragma Inline (both within and across units, ?=1/2)"); -- Line for -gnatN switch diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 01525b76d4b..80c6eaf641c 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -1789,6 +1789,10 @@ package VMS_Data is S_GCC_Inline : aliased constant S := "/INLINE=" & "PRAGMA " & "-gnatn " & + "PRAGMA_LEVEL_1 " & + "-gnatn1 " & + "PRAGMA_LEVEL_2 " & + "-gnatn2 " & "FULL " & "-gnatN " & "SUPPRESS " & @@ -1822,6 +1826,14 @@ package VMS_Data is -- (/OPTIMIZE=SOME) or higher (/OPTIMIZE=UNROLL_LOOPS) -- levels of optimization. -- + -- PRAGMA_LEVEL_1 + -- Direct control of the level of "Inline" pragmas + -- optimization with moderate inlining across modules. + -- + -- PRAGMA_LEVEL_2 + -- Direct control of the level of "Inline" pragmas + -- optimization with full inlining across modules. + -- -- FULL Front end inlining. The front end inlining activated -- by this switch is generally more extensive, and quite -- often more effective than the standard PRAGMA inlining diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb index 56ea8a877d9..c740aa25383 100644 --- a/gcc/ada/xoscons.adb +++ b/gcc/ada/xoscons.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2012, 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- -- @@ -45,7 +45,7 @@ pragma Warnings (On); with GNAT.Table; -with XUtil; use XUtil; +with XUtil; use XUtil; procedure XOSCons is @@ -73,13 +73,18 @@ procedure XOSCons is type Asm_Info_Kind is (CND, -- Named number (decimal) + CNU, -- Named number (decimal, unsigned) CNS, -- Named number (freeform text) C, -- Constant object TXT); -- Literal text -- Recognized markers found in assembly file. These markers are produced by -- the same-named macros from the C template. + subtype Asm_Int_Kind is Asm_Info_Kind range CND .. CNU; + -- Asm_Info_Kind values with int values in input + subtype Named_Number is Asm_Info_Kind range CND .. CNS; + -- Asm_Info_Kind values with named numbers in output type Asm_Info (Kind : Asm_Info_Kind := TXT) is record Line_Number : Integer; @@ -98,7 +103,7 @@ procedure XOSCons is -- Value for CNS / C constant Int_Value : Int_Value_Type; - -- Value for CND constant + -- Value for CND / CNU constant Comment : String_Access; -- Additional descriptive comment for constant, or free-form text (TXT) @@ -116,6 +121,9 @@ procedure XOSCons is Max_Constant_Type_Len : Natural := 0; -- Lengths of longest name and longest value + Size_Of_Unsigned_Int : Integer := 0; + -- Size of unsigned int on target + type Language is (Lang_Ada, Lang_C); procedure Output_Info @@ -170,10 +178,12 @@ procedure XOSCons is Put (OFile, S); end Put; + -- Start of processing for Output_Info + begin - if Info.Kind /= TXT then - -- TXT case is handled by the common code below + -- Case of non-TXT case (TXT case handled by common code below) + if Info.Kind /= TXT then case Lang is when Lang_Ada => Put (" " & Info.Constant_Name.all); @@ -195,21 +205,26 @@ procedure XOSCons is - Info.Constant_Name'Length)); end case; - if Info.Kind = CND then + if Info.Kind in Asm_Int_Kind then if not Info.Int_Value.Positive then Put ("-"); end if; + Put (Trim (Info.Int_Value.Abs_Value'Img, Side => Left)); + else declare Is_String : constant Boolean := Info.Kind = C and then Info.Constant_Type.all = "String"; + begin if Is_String then Put (""""); end if; + Put (Info.Text_Value.all); + if Is_String then Put (""""); end if; @@ -246,7 +261,7 @@ procedure XOSCons is procedure Find_Colon (Index : in out Integer); -- Increment Index until the next colon in Line - function Parse_Int (S : String) return Int_Value_Type; + function Parse_Int (S : String; K : Asm_Int_Kind) return Int_Value_Type; -- Parse a decimal number, preceded by an optional '$' or '#' character, -- and return its value. @@ -275,9 +290,13 @@ procedure XOSCons is -- Parse_Int -- --------------- - function Parse_Int (S : String) return Int_Value_Type is + function Parse_Int + (S : String; + K : Asm_Int_Kind) return Int_Value_Type + is First : Integer := S'First; - Positive : Boolean; + Result : Int_Value_Type; + begin -- On some platforms, immediate integer values are prefixed with -- a $ or # character in assembly output. @@ -287,17 +306,29 @@ procedure XOSCons is end if; if S (First) = '-' then - Positive := False; - First := First + 1; + Result.Positive := False; + First := First + 1; else - Positive := True; + Result.Positive := True; + end if; + + Result.Abs_Value := Long_Unsigned'Value (S (First .. S'Last)); + + if not Result.Positive and then K = CNU then + + -- Negative value, but unsigned expected: take 2's complement + -- reciprocical value. + + Result.Abs_Value := ((not Result.Abs_Value) + 1) + and + (Shift_Left (1, Size_Of_Unsigned_Int) - 1); + Result.Positive := True; end if; - return (Positive => Positive, - Abs_Value => Long_Unsigned'Value (S (First .. S'Last))); + return Result; exception - when E : others => + when others => Put_Line (Standard_Error, "can't parse decimal value: " & S); raise; end Parse_Int; @@ -315,14 +346,15 @@ procedure XOSCons is Find_Colon (Index2); Info.Line_Number := - Integer (Parse_Int (Line (Index1 .. Index2 - 1)).Abs_Value); + Integer (Parse_Int (Line (Index1 .. Index2 - 1), CNU).Abs_Value); case Info.Kind is - when CND | CNS | C => + when CND | CNU | CNS | C => Index1 := Index2 + 1; Find_Colon (Index2); Info.Constant_Name := Field_Alloc; + if Info.Constant_Name'Length > Max_Constant_Name_Len then Max_Constant_Name_Len := Info.Constant_Name'Length; end if; @@ -332,6 +364,7 @@ procedure XOSCons is if Info.Kind = C then Info.Constant_Type := Field_Alloc; + if Info.Constant_Type'Length > Max_Constant_Type_Len then Max_Constant_Type_Len := Info.Constant_Type'Length; end if; @@ -340,15 +373,25 @@ procedure XOSCons is Find_Colon (Index2); end if; - if Info.Kind = CND then - Info.Int_Value := Parse_Int (Line (Index1 .. Index2 - 1)); - Info.Value_Len := Index2 - Index1 - 1; + if Info.Kind = CND or else Info.Kind = CNU then + Info.Int_Value := + Parse_Int (Line (Index1 .. Index2 - 1), Info.Kind); + Info.Value_Len := Info.Int_Value.Abs_Value'Img'Length - 1; + + if not Info.Int_Value.Positive then + Info.Value_Len := Info.Value_Len + 1; + end if; else Info.Text_Value := Field_Alloc; Info.Value_Len := Info.Text_Value'Length; end if; + if Info.Constant_Name.all = "sizeof_unsigned_int" then + Size_Of_Unsigned_Int := + 8 * Integer (Info.Int_Value.Abs_Value); + end if; + when others => null; end case; @@ -371,12 +414,13 @@ procedure XOSCons is Asm_Infos.Append (Info); end; + exception when E : others => - Put_Line (Standard_Error, - "can't parse " & Line); - Put_Line (Standard_Error, - "exception raised: " & Exception_Information (E)); + Put_Line + (Standard_Error, "can't parse " & Line); + Put_Line + (Standard_Error, "exception raised: " & Exception_Information (E)); end Parse_Asm_Line; ------------ @@ -401,8 +445,8 @@ procedure XOSCons is -- Output files - Ada_File_Name : constant String := Unit_Name & ".ads"; - C_File_Name : constant String := Unit_Name & ".h"; + Ada_File_Name : constant String := Unit_Name & ".ads"; + C_File_Name : constant String := Unit_Name & ".h"; Asm_File : Ada.Text_IO.File_Type; Tmpl_File : Ada.Text_IO.File_Type; @@ -424,7 +468,6 @@ begin -- Load values from assembly file Open (Asm_File, In_File, Asm_File_Name); - while not End_Of_File (Asm_File) loop Get_Line (Asm_File, Line, Last); if Last > 2 and then Line (1 .. 2) = "->" then @@ -450,8 +493,10 @@ begin if Last >= 2 and then Line (1 .. 2) = "# " then declare - Index : Integer := 3; + Index : Integer; + begin + Index := 3; while Index <= Last and then Line (Index) in '0' .. '9' loop Index := Index + 1; end loop; |