diff options
author | Thomas Koenig <tkoenig@gcc.gnu.org> | 2020-10-28 18:41:24 +0100 |
---|---|---|
committer | Thomas Koenig <tkoenig@gcc.gnu.org> | 2020-10-28 18:41:24 +0100 |
commit | bf6dad60c338a42a7fb85f7b2a5870c0fb2e20f8 (patch) | |
tree | e513781ef717465e7db0358e987a5a6cbef5665c /gcc/ada | |
parent | 0c261d5b5c931d9e9214d06531bdc7e9e16aeaab (diff) | |
parent | 47d13acbda9a5d8eb57ff169ba74857cd54108e4 (diff) | |
download | gcc-bf6dad60c338a42a7fb85f7b2a5870c0fb2e20f8.zip gcc-bf6dad60c338a42a7fb85f7b2a5870c0fb2e20f8.tar.gz gcc-bf6dad60c338a42a7fb85f7b2a5870c0fb2e20f8.tar.bz2 |
Merge branch 'master' into devel/coarray_native.
Merge into devel/coarray_native to prepare for later merging of
coarray_native with master.
Diffstat (limited to 'gcc/ada')
704 files changed, 44574 insertions, 12528 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 280b834..4b4e760 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,2672 @@ +2020-10-23 Iain Sandoe <iain@sandoe.co.uk> + + * adaint.c: On Darwin platforms, define st_atim to + st_atimespec. Likwise st_mtim to st_mtimespec. + +2020-10-23 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (EXTRA_GNATRTL_NONTASKING_OBJS) [IA64/Linux]: Fix typo. + +2020-10-23 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (EXTRA_GNATRTL_NONTASKING_OBJS) [IA64/Linux]: Fix typo. + +2020-10-23 Alexandre Oliva <oliva@adacore.com> + + PR ada/97504 + * Makefile.rtl (LIBGNAT_TARGET_PAIRS): Select wraplf version + of Aux_Long_Long_Float for s390 and remaining sparc and + powerpc targets. + +2020-10-23 Dmitriy Anisimkov <anisimko@adacore.com> + + * Makefile.rtl (GNATRTL_SOCKETS_OBJS): New object + g-socpol$(objext) New source files noted: g-socpol.adb, + g-socpol.ads, g-socpol__dummy.adb, g-socpol__dummy.ads, + g-sopowa.adb, g-sopowa__posix.adb, g-sopowa__mingw.adb, + g-spogwa.adb, g-spogwa.ads. + * impunit.adb (Non_Imp_File_Names_95): New base filename + g-socpol in "GNAT Library Units" section for GNAT.Sockets.Poll + unit. + * libgnat/g-socket.ads, libgnat/g-socket.adb: + (Raise_Socket_Error): Moved from body to private part of + specification to use in GNAT.Sockets.Poll. + * libgnat/g-socpol.ads, libgnat/g-socpol.adb: Main unit of the + implementation. + * libgnat/g-socpol__dummy.ads, libgnat/g-socpol__dummy.adb: + Empty unit for the systems without sockets support. + * libgnat/g-spogwa.ads, libgnat/g-spogwa.adb: Generic unit + implementing sockets poll on top of select system call. + * libgnat/g-sopowa.adb (Wait): Separate implementation for + operation systems with poll system call support. + * libgnat/g-sopowa__posix.adb (Wait): Separate implementation + for POSIX select system call. + * libgnat/g-sopowa__mingw.adb (Wait): Separate implementation + for Windows select system call. + * gsocket.h (_WIN32_WINNT): Increase to 0x0600 for winsock2.h to + allow WSAPoll related definitions. + * s-oscons-tmplt.c: Fix comment next to #endif for + #if defined (__linux__) || defined (__ANDROID__) line. Include + <poll.h> for all except VxWorks and Windows. + (SIZEOF_nfds_t): New definition. + (SIZEOF_fd_type): New definition. + (SIZEOF_pollfd_events): New definition. + (POLLIN, POLLPRI, POLLOUT, POLLERR, POLLHUP, POLLNVAL): New + definitions for VxWorks to be able to emulate poll on top of + select in it. Define POLLPRI as zero on Windows as it is not + supported there. + (Poll_Linkname): New definition, because the poll system call + has different name in Windows and POSIX. + +2020-10-23 Justin Squirek <squirek@adacore.com> + + * checks.adb (Apply_Accessibility_Check): Skip checks against + the extra accessibility of a function result when in Ada 2005 + mode or earlier. + * exp_ch3.adb (Build_Initialization_Call): Modify accessibility + level calls to use Accessibility_Level. + (Expand_N_Object_Declaration): Modify accessibility level calls + to use Accessibility_Level. + * exp_ch4.adb (Expand_Allocator_Expression): Add static check + for anonymous access discriminants. Remove unneeded propagation + of accessibility actual. + (Expand_N_In): Modify accessibility level calls to use + Accessibility_Level. + (Expand_N_Type_Conversion): Modify accessibility level calls to + use Accessibility_Level. + * exp_ch5.adb (Expand_N_Assignment_Statement): Modify + accessibility level calls to use Accessibility_Level. + * exp_ch6.adb (Expand_Call_Helper): Rewrite accessibility + calculation for the extra accessibility of result actual in + function calls, and modify accessibility level calls to use + Accessibility_Level. + (Check_Against_Result_Level): Removed. + * exp_ch9.adb (Expand_N_Requeue_Statement): Add dynamic + accessibility check for requeues + * sem_attr.adb (Resolve_Attribute): Modify accessibility level + calls to use Accessibility_Level. + * sem_ch13.adb (Associate_Storage_Pool): Modify accessibility + level calls to use Accessibility_Level. + * sem_ch4.adb (Analyze_Call): Add static check for explicitly + aliased formals in function calls within return statements. + * sem_ch6.adb (Check_Return_Construct_Accessibility): Rewrite + routine to account for non-aggregate return objects. + (Generate_Minimum_Accessibility): Created. + (Analyze_Call): Modify accessibility level calls to use + Accessibility_Level. + (Analyze_Subprogram_Body_Helper): Add generation of minimum + accessibility for the extra accessibility of the function + result. + * sem_ch9.adb (Analyze_Requeue): Modify accessibility level + calls to use Accessibility_Level. + * sem_res.adb: (Check_Aliased_Parameters): Modify accessibility + level calls to use Accessibility_Level. + (Valid_Conversion): Modify accessibility level calls to use + Accessibility_Level. + * sem_util.adb, sem_util.ads (Accessibility_Level_Helper): + Renamed to Accessibility_Level, add detection for functions in + prefix notation, and add cases where to return zero when + specified. Modified to take new, more descriptive, parameters. + (Accessibility_Level): Created. + (Function_Call_Level): Removed. + (Function_Call_Or_Allocator_Level): Created to centralize the + calculation accessibility levels for function calls and + allocators. + (Static_Accessibility_Level): Removed. + (Dynamic_Accessibility_Level): Removed. + (Get_Dynamic_Accessibility): Renamed from Get_Accessibility. + (In_Return_Value): Created to determine if a given expression + contributes to the current function's return value. + (Is_Master): Created. + (Is_Explicitly_Aliased): Created + +2020-10-23 Bob Duff <duff@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Document + --no-comments-fill. + +2020-10-23 Piotr Trojanek <trojanek@adacore.com> + + * contracts.adb (Analyze_Entry_Or_Subprogram_Contract, + Analyze_Subprogram_Body_Stub_Contract): Fix missing references + to Subprogram_Variant where similar references to Contract_Cases + are present. + * sem_prag.adb (Analyze_Contract_Case, Analyze_Variant): Check + that aggregate parameter has no expressions. + (Analyze_Pragma): Replace Contract_Cases with Subprogram_Variant + in a copy-pasted comment. + +2020-10-23 Philippe Gil <gil@adacore.com> + + * libgnat/g-socket.ads: Fix comment typo. + +2020-10-23 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst (VFA): Remove uage + restrictions in conjunction with Atomic and Aliased. + * gnat_rm.texi: Regenerate. + * aspects.ads (Aspect_Id): Add Aspect_Full_Access_Only. + (Is_Representation_Aspect): Likewise. + (Aspect_Names): Likewise. + (Aspect_Delay): Likewise. + * einfo.ads (Is_Atomic_Or_VFA): Rename into... + (Is_Full_Access): ...this. + (Is_Volatile_Full_Access): Document new usage for Full_Access_Only. + * einfo.adb (Is_Atomic_Or_VFA): Rename into... + (Is_Full_Access): ...this. + * freeze.ads (Is_Atomic_VFA_Aggregate): Rename into... + (Is_Full_Access_Aggregate): ...this. + * freeze.adb (Is_Atomic_VFA_Aggregate): Rename into... + (Is_Full_Access_Aggregate): ...this. Adjust to above renaming. + (Freeze_Array_Type): Likewise. + (Freeze_Entity): Likewise. + * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Likewise. + (Expand_Record_Aggregate): Likewise. + * exp_ch4.adb (Expand_N_Op_Eq): Likewise. + * exp_ch5.adb (Expand_Assign_Array): Likewise. + * exp_ch8.adb (Evaluation_Required): Likewise. + * layout.adb (Layout_Type): Likewise. + (Set_Composite_Alignment): Likewise. + * sem_aux.ads (Has_Rep_Item): Delete. + * sem_aux.adb (Has_Rep_Item): Likewise. + * sem_attr.adb (Resolve_Attribute) <Attribute_Access>: Implement + new legality rules in C.6(12). + * sem_ch12.adb (Instantiate_Object): Likewise. + * sem_res.adb (Resolve_Actuals): Likewise. + * sem_ch13.adb (Inherit_Delayed_Rep_Aspects): Deal with aspect + Full_Access_Only. + (Check_False_Aspect_For_Derived_Type): Likewise. + (Make_Pragma_From_Boolean_Aspect): Test for the presence of Expr. + Deal with aspect Full_Access_Only. + (Analyze_Aspects_At_Freeze_Point): Likewise. + (Analyze_One_Aspect): Do not set Delay_Required to true even for + Always_Delay boolean aspects if they have no expression. Force + Delay_Required to true for aspect Full_Access_Only in all cases. + Reject aspect Full_Access_Only if not in Ada 2020 mode. + (Check_Aspect_At_End_Of_Declarations): Deal with empty expression. + (Check_Aspect_At_Freeze_Point): Likewise. + (Rep_Item_Entity): Delete. + (Inherit_Aspects_At_Freeze_Point): Align handling for Bit_Order + with that for Scalar_Storage_Order. + * sem_prag.adb (Check_Atomic_VFA): Delete. + (Check_VFA_Conflicts): Likewise. + (Check_Full_Access_Only): New procedure. + (Process_Atomic_Independent_Shared_Volatile): Call to implement + the new legality checks in C.6(8/2) and mark the entity last. + (Analyze_Pragma) <Pragma_Atomic_Components>: Remove obsolete check. + * sem_util.ads (Is_Atomic_Or_VFA_Object): Rename into... + (Is_Full_Access_Object): ...this. + (Is_Subcomponent_Of_Atomic_Object): Rename into... + (Is_Subcomponent_Of_Full_Access_Object): ...this. + * sem_util.adb (Inherit_Rep_Item_Chain): Use Present_In_Rep_Item. + (Is_Atomic_Or_VFA_Object): Rename into... + (Is_Full_Access_Object): ...this. + (Is_Subcomponent_Of_Atomic_Object): Rename into... + (Is_Subcomponent_Of_Full_Access_Object): ...this and adjust. + * snames.ads-tmpl (Name_Full_Access_Only): New name of aspect. + * gcc-interface/decl.c (gnat_to_gnu_entity): Adjust for renaming. + (promote_object_alignment): Likewise. + (gnat_to_gnu_field): Likewise. Rename local variable and use + specific qualifier in error message for Volatile_Full_Access. + * gcc-interface/trans.c (lvalue_required_p): Likewise. + +2020-10-23 Arnaud Charlet <charlet@adacore.com> + + * lib-writ.ads, lib-writ.adb (Write_ALI): No longer read + existing ALI files in -gnatc mode. + +2020-10-23 Arnaud Charlet <charlet@adacore.com> + + * libgnat/g-socthi__mingw.adb (C_Select): Fix logic in code and + make it explicit that we are checking against null values before + dereferencing them. + +2020-10-23 Eric Botcazou <ebotcazou@adacore.com> + + * exp_imgv.adb (Expand_Image_Attribute): For an enumeration type + subject to pragma Discard_Names, convert 'Pos to Long_Long_Integer + before applying 'Img to the result. + +2020-10-23 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_Type_Refs): Add guard on freezing of the + designated type of an access type appearing in the expression, + when expression includes an explicit dereference whose prefix + includes a function call. + +2020-10-23 Piotr Trojanek <trojanek@adacore.com> + + * exp_spark.adb (Expand_SPARK_Delta_Or_Update): Handle + subtype_indication; do not apply range checks for ranges; add + comment saying that others_choices is not allowed. + +2020-10-23 Piotr Trojanek <trojanek@adacore.com> + + * exp_spark.adb (Expand_SPARK_N_Aggregate, + Expand_SPARK_Delta_Or_Update): Expand + Iterated_Component_Association occurring within delta + aggregates. + (Expand_SPARK): Apply SPARK-specific expansion to ordinary + aggregates. + +2020-10-23 Johannes Kanig <kanig@adacore.com> + + * exp_util.adb, exp_util.ads + (Containing_Package_With_Ext_Axioms, + Has_Annotate_Pragma_For_External_Axiomatizations): Removed. + * sem_ch8.adb (Analyze_Subprogram_Renaming): Removed code + related to external axiomatizations. + * einfo.ads + (Is_Generic_Actual_Subprogram): Removed comment about external + axiomatization. + +2020-10-23 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb (Resolve_Aggregate): Do not call + Resolve_Container_Aggregate if compilation version is earlier + than Ada_2020. + +2020-10-23 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Improve + documentation of pragma Abort_Defer. + * gnat_rm.texi: Regenerate. + +2020-10-23 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_prag.adb (Etype_Or_Dim3): New function. + (Expand_Pragma_Cuda_Execute): Use Etype_Or_Dim3 for temporary + decls. + +2020-10-23 Arnaud Charlet <charlet@adacore.com> + + * libgnat/s-fileio.adb (Open): Fix setting of Tempfile. + +2020-10-23 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_prag.adb (Get_Launch_Kernel_Arg_Type): Renamed to + Get_Nth_Arg_Type and made more generic. + (Build_Dim3_Declaration): Now builds a CUDA.Internal.Dim3 + instead of a CUDA.Vector_Types.Dim3. + (Build_Shared_Memory_Declaration): Now infers needed type from + Launch_Kernel instead of using a hard-coded type. + (Expand_Pragma_CUDA_Execute): Build additional temporaries to + store Grids and Blocks. + * rtsfind.ads: Move Launch_Kernel from public to internal + package. + +2020-10-23 Arnaud Charlet <charlet@adacore.com> + + * sem_ch4.adb (Complete_Object_Operation): Only mark entities + referenced if we are compiling the extended main unit. + * sem_attr.adb (Analyze_Attribute [Attribute_Tag]): Record a + reference on the type and its scope. + +2020-10-23 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Is_Uninitialized_Aggregate): Recognize an array + aggregate with box initialization, scalar components, and no + component default values. + (Freeze_Entity, Check_Address_Clause): Call it, and simplify + freeze code for entity by removing useless assignment. + +2020-10-23 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Check_Abstract_Overriding): Subprogram renamings + cannot be overridden. + (Derive_Subprogram): Enable setting attribute + Requires_Overriding on functions with controlling access results + of record extensions with a null extension part require + overriding (AI95-00391/06). + +2020-10-23 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Delta_Array_Aggregate): Push scope of + the implicit loop before entering name of the index parameter, + not after; enter name no matter if the identifier has been + decorated before. + +2020-10-23 Gary Dismukes <dismukes@adacore.com> + + * sem_ch4.adb (Analyze_Call): In the case where the call is not + overloaded, check for a call to an abstract nondispatching + operation and flag an error. + +2020-10-23 Eric Botcazou <ebotcazou@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Rewrite again code enabling + or disabling the support for 128-bit integer types. + +2020-10-23 Arnaud Charlet <charlet@adacore.com> + + * alloc.ads, aspects.adb, aspects.ads, atree.adb, atree.ads, + casing.adb, casing.ads, csets.adb, csets.ads, debug.adb, debug.ads, + einfo.adb, einfo.ads, elists.adb, elists.ads, fname.adb, fname.ads, + gnatvsn.adb, gnatvsn.ads, hostparm.ads, indepsw-aix.adb, + indepsw-darwin.adb, indepsw-gnu.adb, indepsw.adb, indepsw.ads, + krunch.adb, krunch.ads, lib-list.adb, lib-sort.adb, lib.adb, lib.ads, + namet-sp.adb, namet-sp.ads, namet.adb, namet.ads, nlists.adb, + nlists.ads, opt.adb, opt.ads, output.adb, output.ads, rident.ads, + scans.adb, scans.ads, scil_ll.adb, scil_ll.ads, sem_aux.ads, + sem_aux.adb, sfn_scan.adb, sinfo.adb, sinfo.ads, sinput.adb, + sinput.ads, snames.adb-tmpl, snames.ads-tmpl, stand.ads, + stringt.adb, stringt.ads, table.adb, table.ads, types.adb, + types.ads, uintp.adb, uintp.ads, uname.adb, uname.ads, + urealp.adb, urealp.ads, vast.adb, vast.ads, widechar.adb, + widechar.ads: Update header. + +2020-10-23 Arnaud Charlet <charlet@adacore.com> + + * libgnat/a-nbnbin.adb (From_String): Take advantage of + Long_Long_Long_Integer. + * libgnat/s-genbig.ads, libgnat/s-genbig.adb (To_Bignum): New + function taking a Long_Long_Long_Integer. + +2020-10-23 Justin Squirek <squirek@adacore.com> + + * sem_util.adb (Accessibility_Call_Helper): In the selected + component case, test if a prefix is a function call and whether + the subprogram call is not being used in its entirety and use + the Innermost_Master_Scope_Depth in that case. + (Innermost_Master_Scope_Depth): Test against the node_par + instead of its identifier to avoid misattributing unnamed blocks + as not being from source. + (Function_Call_Level): Add calculation for whether a subprogram + call is initializing an object in its entirety. + (Subprogram_Call_Level): Renamed to Function_Call_Level. + +2020-10-23 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Check_External_Properties): Rewrite to match the + SPARK RM description. + +2020-10-23 Piotr Trojanek <trojanek@adacore.com> + + * contracts.adb (Check_Type_Or_Object_External_Properties): + Cleanup. + +2020-10-23 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_External_Property_In_Decl_Part): Set the + output parameter Expr_Val to the (implicit) pragma argument even + when returning early. + +2020-10-22 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (GNATRTL_128BIT_PAIRS): Add i-cexten.ads. + * debug.adb (d.H): Document new usage. + * doc/gnat_rm/representation_clauses_and_pragmas.rst (Size Clauses): + Document new limit on 64-bit platforms. + (Component_Size Clauses): Likewise. + (Pragma Pack for Arrays): Likewise. + (Pragma Pack for Records): Likewise. + (Record Representation Clauses): Likewise. + * gnat_rm.texi: Regenerate. + * gnat1drv.adb (Adjust_Global_Switches): Rewrite code enabling or + disabling the support for 128-bit integer types. + * switch-c.adb (Scan_Front_End_Switches): Do not deal with e128. + * usage.adb (Write_Switch_Char): Do not print -gnate128 switch. + * libgnat/i-cexten__128.ads: New file. + +2020-10-22 Javier Miranda <miranda@adacore.com> + + * einfo.ads (Has_Limited_View): New synthesized attribute. + * einfo.adb (Has_Limited_View): New synthesized attribute. + (Set_Limited_View): Complete assertion. + * sem_ch10.ads (Is_Visible_Through_Renamings): Make this routine + public to invoke it from Find_Expanded_Name and avoid reporting + spurious errors on renamings of limited-with packages. + (Load_Needed_Body): Moved to have this spec alphabetically + ordered. + * sem_ch10.adb (Is_Visible_Through_Renamings): Moved to library + level. + (Is_Limited_Withed_Unit): New subprogram. + * sem_ch3.adb (Access_Type_Declaration): Adding protection to + avoid reading attribute Entity() when not available. + * sem_ch8.adb (Analyze_Package_Renaming): Report error on + renamed package not visible through context clauses. + (Find_Expanded_Name): Report error on renamed package not + visible through context clauses; handle special case where the + prefix is a renaming of a (now visible) shadow package. + +2020-10-22 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_prag.adb (Get_Launch_Kernel_Arg_Type): New function. + (Build_Shared_Memory_Declaration): Use + Get_Launch_Kernel_Arg_Type. + (Build_Stream_Declaration): Use Get_Launch_Kernel_Arg_Type. + * rtsfind.ads: Remove RO_IC_Unsigned_Long_Long. + +2020-10-22 Arnaud Charlet <charlet@adacore.com> + + * libgnat/s-imenne.adb, libgnat/s-imgrea.adb: Add assertions. + +2020-10-22 Arnaud Charlet <charlet@adacore.com> + + * libgnat/s-imgrea.adb (Set_Image_Real): Update annotations. + +2020-10-22 Steve Baird <baird@adacore.com> + + * aspects.ads: Introduce the subtype Nonoverridable_Aspect_Id, + whose Static_Predicate reflects the list of nonoverridable + aspects given in Ada RM 13.1.1(18.7). + * sem_util.ads, sem_util.adb: Add two new visible subprograms, + Check_Inherited_Nonoverridable_Aspects and Is_Confirming. The + former is used to check the consistency of inherited + nonoverridable aspects from multiple sources. The latter + indicates whether two aspect specifications for a nonoverridable + aspect are confirming. Because of compatibility concerns in + compiling QGen, Is_Confirming always returns True if + Relaxed_RM_Semantics (i.e., -gnatd.M) is specified. + * sem_ch3.adb (Derived_Type_Declaration): Call new + Check_Inherited_Nonoverridable_Aspects procedure if interface + list is non-empty. + * sem_ch9.adb (Check_Interfaces): Call new + Check_Inherited_Nonoverridable_Aspects procedure if interface + list is non-empty. + * sem_ch13.adb (Analyze_Aspect_Specifications): When an explicit + aspect specification overrides an inherited nonoverridable + aspect, check that the explicit specification is confirming. + +2020-10-22 Eric Botcazou <ebotcazou@adacore.com> + + * freeze.ads (Check_Compile_Time_Size): Adjust size limit. + +2020-10-22 Richard Kenner <kenner@adacore.com> + + * sprint.adb (pg, po, ps): Use {Push,Pop}_Output. + * treepr.adb (pl, pn): Likewise. + +2020-10-22 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_advice.rst: Minor fix. + * gnat_rm.texi: Regenerate. + +2020-10-22 Steve Baird <baird@adacore.com> + + * sem_util.adb (Is_Container_Aggregate): A new local predicates + which indicates whether a given expression is a container + aggregate. The implementation of this function is incomplete; in + the unusual case of a record aggregate (i.e., not a container + aggregate) of a type whose Aggregate aspect is specified, the + function will incorrectly return True. + (Immediate_Context_Implies_Is_Potentially_Unevaluated): Improve + handling of aggregate components. + (Is_Repeatedly_Evaluated): Test for container aggregate + components along with existing test for array aggregate + components. + +2020-10-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_fixd.adb (Fpt_Value): Fold if-then-else with identical arms. + +2020-10-22 Ed Schonberg <schonberg@adacore.com> + + * par-ch4.adb (P_Iterated_Component_Association): If the + construct includes an iterator filter it corresponds to an + Iterated_Element_Association, so build the proper node for it. + * exp_aggr.adb (Expand_Container_Aggregate, Aggregate_Size): If + the component is an Iterated_Element_Association, treat it as + having a non-static size. + +2020-10-22 Ghjuvan Lacambre <lacambre@adacore.com> + + * scng.adb (Scan): Check if any letter of the token is + uppercase. + +2020-10-22 Justin Squirek <squirek@adacore.com> + + * sem_util.adb (Accessibility_Level_Helper): Conversions to + named access types get the level associated with the named + access type. + +2020-10-22 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Has_Constrained_Partial_View): Add "base type" marker. + +2020-10-22 Gary Dismukes <dismukes@adacore.com> + + * einfo.adb (Has_Constrained_Partial_View): Apply Base_Type to Id. + * sem_res.adb (Resolve_Actuals.Check_Aliased_Parameter): Remove + "not Is_Generic_Type" test and call + Object_Type_Has_Constrained_Partial_View instead of + Has_Constrained_Partial_View. Improve related error message to + say "does not statically match" instead of just "does not + match". + +2020-10-22 Steve Baird <baird@adacore.com> + + * sem_util.ads, sem_util.adb: Declare and implement a new + predicate, Derivation_Too_Early_To_Inherit. This function + indicates whether a given derived type fails to inherit a given + streaming-related attribute from its parent type because the + declaration of the derived type precedes the corresponding + attribute_definition_clause of the parent. + * exp_tss.adb (Find_Inherited_TSS): Call + Derivation_Too_Early_To_Inherit instead of unconditionally + assuming that a parent type's streaming attribute is available + for inheritance by an immediate descendant type. + * sem_attr.adb (Stream_Attribute_Available): Call + Derivation_Too_Early_To_Inherit instead of unconditionally + assuming that a parent type's streaming attribute is available + for inheritance by an immediate descendant type. + * exp_attr.adb (Default_Streaming_Unavailable): A new predicate; + given a type, indicates whether predefined (as opposed to + user-defined) streaming operations for the type should be + implemented by raising Program_Error. + (Expand_N_Attribute_Reference): For each of the 4 + streaming-related attributes (i.e., Read, Write, Input, Output), + after determining that no user-defined implementation is + available (including a Stream_Convert pragma), call + Default_Streaming_Unavailable; if that call returns True, then + implement the streaming operation as "raise Program_Error;". + +2020-10-22 Eric Botcazou <ebotcazou@adacore.com> + + * checks.adb (Apply_Float_Conversion_Check): Saturate the bounds + of the check to those of the base type of the expression. + +2020-10-22 Justin Squirek <squirek@adacore.com> + + * checks.adb (Apply_Accessibility_Check): Modify condition to + avoid flawed optimization and use Get_Accessibility over + Extra_Accessibility. + * exp_attr.adb: Remove inclusion of Exp_Ch2.adb. + * exp_ch2.adb, exp_ch2.ads (Param_Entity): Moved to sem_util. + * exp_ch3.ads (Init_Proc_Level_Formal): New function. + * exp_ch3.adb (Build_Init_Procedure): Add extra accessibility + formal for init procs when the associated type is a limited + record. + (Build_Initialization_Call): Add condition to handle propagation + of the new extra accessibility paramter actual needed for init + procs. + (Init_Proc_Level_Formal): Created to fetch a the extra + accessibility parameter associated with init procs if one + exists. + * exp_ch4.adb (Build_Attribute_Reference): Modify static check + to be dynamic. + * exp_ch6.adb (Add_Cond_Expression_Extra_Actual): Move logic + used to expand conditional expressions used as actuals for + anonymous access formals. + (Expand_Call_Helper): Remove extranious accessibility + calculation logic. + * exp_util.adb: Remove inclusion of Exp_Ch2.adb. + * par-ch3.adb (P_Array_Type_Definition): Properly set + Aliased_Present on access definitions + * sem_attr.adb (Resolve_Attribute): Replace instances for + Object_Access_Level with Static_Accessibility_Level. + * sem_ch13.adb (Storage_Pool): Replace instances for + Object_Access_Level with Static_Accessibility_Level. + * sem_ch6.adb (Check_Return_Construct_Accessibility): Replace + instances for Object_Access_Level with + Static_Accessibility_Level. + * sem_ch9.adb (Analyze_Requeue): Replace instances for + Object_Access_Level with Static_Accessibility_Level. + * sem_res.adb (Check_Aliased_Parameter, + Check_Allocator_Discrim_Accessibility, Valid_Conversion): + Replace instances for Object_Access_Level with + Static_Accessibility_Level. + * sem_util.adb, sem_util.ads (Accessibility_Level_Helper): + Created to centralize calculation of accessibility levels. + (Build_Component_Subtype): Replace instances for + Object_Access_Level with Static_Accessibility_Level. + (Defining_Entity): Add extra parameter to dictate whether an + error is raised or empty is return in the case of an irrelevant + N. + (Dynamic_Accessibility_Level): Rewritten to use + Accessibility_Level_Helper. + (Is_View_Conversion): Check membership against Etype to capture + nodes like explicit dereferences which have types but are not + expanded names or identifers. + (Object_Access_LeveL): Removed. + (Param_Entity): Moved from sem_util. + (Static_Accessibility_Level): Created as a replacement to + Object_Access_Level, it also uses Accessibility_Level_Helper for + its implementation. + * snames.ads-tmpl: Added new name for extra accessibility + parameter in init procs. + +2020-10-22 Piotr Trojanek <trojanek@adacore.com> + + * exp_prag.adb (Expand_Pragma_Contract_Cases, + Expand_Pragma_Loop_Variant): Reuse Append_New_To. + * sem_prag.adb (Analyze_Contract_Cases_In_Decl_Part): Fix typo. + (Analyze_Pre_Post_Condition): Refactor repeated calls to + Defining_Entity. + +2020-10-22 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_defined_characteristics.rst: Minor + fixes. + * gnat_rm.texi: Regenerate. + +2020-10-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_warn.adb (Check_Unused_Withs): Move local variables from + to a nested procedure; Lunit is passed as a parameter to + Check_System_Aux and its type is refined from Node_Id to + Entity_Id; Cnode is now a constant. + +2020-10-22 Patrick Bernardi <bernardi@adacore.com> + + * libgnat/s-rident.ads (Profile_Info): Use a common profile + definition for Jorvik and GNAT Extended Ravenscar, using the + GNAT Extended Ravenscar definition. + +2020-10-22 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (64-bit platforms): Add GNATRTL_128BIT_PAIRS to + the LIBGNAT_TARGET_PAIRS list and also GNATRTL_128BIT_OBJS to + the EXTRA_GNATRTL_NONTASKING_OBJS list. + +2020-10-22 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_prag.adb (Process_Convention, + Process_Import_Or_Interface): Fix error message. + +2020-10-22 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_ch13.adb (Make_Aitem_Pragma): Turn into function. This + removes a side-effect on the Aitem variable. + (Analyze_Aspect_Specifications): Handle Suppress and Unsuppress + aspects differently from the Linker_Section aspect. + (Ceck_Aspect_At_Freeze_Point): Don't expect Suppress/Unsuppress + to be delayed anymore. + +2020-10-22 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb: (Resolve_Container_Aggregate): For an indexed + container, verify that expressions and component associations + are not both present. + * exp_aggr.adb: Code reorganization, additional comments. + (Expand_Container_Aggregate): Use Aggregate_Size for Iterated_ + Component_Associations for indexed aggregates. If present, the + default value of the formal in the constructor function is used + when the size of the aggregate cannot be determined statically. + +2020-10-22 Eric Botcazou <ebotcazou@adacore.com> + + * sem_attr.adb (Eval_Attribute): Fix oversight for Bit_Position. + +2020-10-22 Ed Schonberg <schonberg@adacore.com> + + * sem_util.ads, sem_util.adb (Check_Ambiguous_Aggregate): When a + subprogram call is found to be ambiguous, check whether + ambiguity is caused by an aggregate actual. and indicate that + it should carry a type qualification. + * sem_ch4.adb (Traverse_Hoonyms, Try_Primitive_Operation): Call + it. + * sem_res.adb (Report_Ambiguous_Argument): Call it. + +2020-10-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_warn.adb (Check_One_Unit): Avoid repeated calls by using a + local variable Lunit; remove local constant Eitem, which was + identical to Lunit. + +2020-10-22 Alexandre Oliva <oliva@adacore.com> + + * Makefile.rtl (LIBGNAT_TARGET_PAIRS) <x86*-vxworks*>: Select + nolibm and wraplf variants like other vxworks ports. + +2020-10-22 Martin Liska <mliska@suse.cz> + + PR c/94722 + * gcc-interface/utils.c (handle_no_stack_protect_attribute): + New. + (handle_stack_protect_attribute): Add error message for a + no_stack_protector function. + +2020-10-22 Alexandre Oliva <oliva@adacore.com> + + * Makefile.rtl (LIBGNAT_TARGET_PAIRS) <lynxos178>: Rely on + Aux_Long_Float for all real types. + +2020-10-22 Alexandre Oliva <oliva@adacore.com> + + * Makefile.rtl (LIBGNAT_TARGET_PAIRS): Use Long Float-based + variant of Aux_Short_Float and Aux_Float on vxworks targets. + * libgnat/a-nashfl__wraplf.ads: New. + * libgnat/a-nuaufl__wraplf.ads: New. + +2020-10-22 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + * Makefile.rtl (LIBGNAT_TARGET_PAIRS) <sparc*-sun-solaris>: + Use wraplf version of a-nallfl. + +2020-10-22 Alexandre Oliva <oliva@adacore.com> + + * Makefile.rtl (LIBGNAT_TARGET_PAIRS): Use + a-nallfl__wraplf.ads on aarch64-* and ppc*-linux-gnu targets. + * libgnat/a-nallfl__wraplf.ads: New. + +2020-10-22 Jan Hubicka <hubicka@ucw.cz> + + * gcc-interface/trans.c: Include tree-nested.h + (walk_nesting_tree): Update for new nested function info. + +2020-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add a-llltio, a-lllwti, + a-lllzti and remove a-timoau, a-wtmoau and a-ztmoau. + (GNATRTL_128BIT_PAIRS): Add a-tiinio.adb, a-timoio.adb, a-wtinio.adb, + a-wtmoio.adb, a-ztinio.adb and a-ztmoio.adb. + * impunit.adb (Non_Imp_File_Names_95): Add a-llltio, a-lllwti and + a-lllzti. + * krunch.ads: Document trick for Ada.Long_Long_Long_Integer_*_IO. + * krunch.adb (Krunch): Add trick for Ada.Long_Long_Long_Integer_*_IO. + * libgnat/a-llltio.ads: Instantiate Ada.Text_IO.Integer_IO. + * libgnat/a-lllwti.ads: Instantiate Ada.Wide_Text_IO.Integer_IO. + * libgnat/a-lllzti.ads: Instantiate Ada.Wide_Wide_Text_IO.Integer_IO. + * libgnat/a-tigeau.ads (Load_Integer): New procedure. + * libgnat/a-tigeau.adb (Load_Integer): Likewise. + * libgnat/a-tiinau.ads, libgnat/a-tiinau.adb: Change to generic + package. + * libgnat/a-tiinio.adb: Instantiate it. + * libgnat/a-tiinio__128.adb: Likewise. + * libgnat/a-timoau.ads, libgnat/a-timoau.adb: Change to generic + package. + * libgnat/a-timoio.adb: Instantiate it. + * libgnat/a-timoio__128.adb: Likewise. + * libgnat/a-wtgeau.ads (Load_Integer): New procedure. + * libgnat/a-wtgeau.adb (Load_Integer): Likewise. + * libgnat/a-wtinau.ads, libgnat/a-wtinau.adb: Change to generic + package. + * libgnat/a-wtinio.adb: Instantiate it. + * libgnat/a-wtinio__128.adb: Likewise. + * libgnat/a-wtmoau.ads, libgnat/a-wtmoau.adb: Change to generic + package. + * libgnat/a-wtmoio.adb: Instantiate it. + * libgnat/a-wtmoio__128.adb: Likewise. + * libgnat/a-ztgeau.ads (Load_Integer): New procedure. + * libgnat/a-ztgeau.adb (Load_Integer): Likewise. + * libgnat/a-ztinau.ads, libgnat/a-ztinau.adb: Change to generic + package. + * libgnat/a-ztinio.adb: Instantiate it. + * libgnat/a-ztinio__128.adb: Likewise. + * libgnat/a-ztmoau.ads, libgnat/a-ztmoau.adb: Change to generic + package. + * libgnat/a-ztmoio.adb: Instantiate it. + * libgnat/a-ztmoio__128.adb: Likewise. + +2020-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch12.adb (Freeze_Subprogram_Body): Do not move the freeze + node of the package body enclosing the instance when its parent + is in the same declarative part as the freeze node of the parent. + +2020-10-21 Steve Baird <baird@adacore.com> + + * exp_ch6.adb (Insert_Post_Call_Actions): When a function's + result type requires finalization and we decide to make copy of + a call to the function and subsequently refer only to the copy, + then don't forget to finalize the original function result + object. + +2020-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add s-widint, + s-widthi, s-widuns, s-widuns. + (GNATRTL_128BIT_OBJS): Add s-imglllb, s-imgllli, s-imglllu, s-imglllw, + s-valllli, s-vallllu, s-widllli, s-widlllu. + * exp_imgv.adb (Expand_Image_Attribute): Deal with 128-bit types. + (Expand_Value_Attribute): Likewise. + (Expand_Width_Attribute): Likewise. + * exp_put_image.adb (Build_Elementary_Put_Image_Call): Likewise. + * krunch.adb (Krunch): Deal with s-img, s-val and s-wid prefixes. + * rtsfind.ads (RTU_Id): Add System_Img_LLLI, System_Img_LLLU, + System_Val_LLLI, System_Val_LLL, System_Wid_Int, System_Wid_LLLI, + System_Wid_LLLU, System_Wid_Uns). + (RE_Id): Add RE_Image_Long_Long_Long_Integer, + RE_Image_Long_Long_Long_Unsigned, + RE_Put_Image_Long_Long_Long_Integer, + RE_Put_Image_Long_Long_Long_Unsigned, + RE_Long_Long_Long_Unsigned, RE_Value_Long_Long_Long_Integer, + RE_Value_Long_Long_Long_Unsigned, RE_Width_Integer, + RE_Width_Long_Long_Long_Integer, RE_Width_Long_Long_Long_Unsigned, + RE_Width_Unsigned, RE_Image_Long_Long_Long_Integer, + RE_Image_Long_Long_Long_Unsigned, RE_Put_Image_Long_Long_Long_Integer, + RE_Put_Image_Long_Long_Long_Unsigned, RE_Long_Long_Long_Unsigned, + RE_Value_Long_Long_Long_Integer, RE_Value_Long_Long_Long_Unsigned, + RE_Width_Integer, RE_Width_Long_Long_Long_Integer, + RE_Width_Long_Long_Long_Unsigned, RE_Width_Unsigned. + * libgnat/s-imageb.ads, libgnat/s-imageb.adb: New generic + package. + * libgnat/s-imagei.ads, libgnat/s-imagei.adb: Likewise. + * libgnat/s-imageu.ads, libgnat/s-imageu.adb: Likewise. + * libgnat/s-imagew.ads, libgnat/s-imagew.adb: Likewise. + * libgnat/s-imgbiu.ads: Instantiate System.Image_B. + * libgnat/s-imgbiu.adb: Add pragma No_Body. + * libgnat/s-imgint.ads: Instantiate System.Image_I. + * libgnat/s-imgint.adb: Add pragma No_Body. + * libgnat/s-imgllb.ads: Instantiate System.Image_B. + * libgnat/s-imgllb.adb: Add pragma No_Body0 + * libgnat/s-imglli.ads: Instantiate System.Image_I. + * libgnat/s-imglli.adb: Add pragma No_Body. + * libgnat/s-imglllb.ads: Instantiate System.Image_B. + * libgnat/s-imgllli.ads: Instantiate System.Image_I. + * libgnat/s-imglllu.ads: Instantiate System.Image_U. + * libgnat/s-imglllw.ads: Instantiate System.Image_W. + * libgnat/s-imgllu.ads: Instantiate System.Image_U. + * libgnat/s-imgllu.adb: Add pragma No_Body. + * libgnat/s-imgllw.ads: Instantiate System.Image_W. + * libgnat/s-imgllw.adb: Add pragma No_Body. + * libgnat/s-imgrea.adb: Remove clauses for System.Unsigned_Types. + * libgnat/s-imguns.ads: Instantiate System.Image_U. + * libgnat/s-imguns.adb: Add pragma No_Body. + * libgnat/s-imgwiu.ads: Instantiate System.Image_W. + * libgnat/s-imgwiu.adb: Add pragma No_Body. + * libgnat/s-putima.ads (Long_Long_Long_Unsigned): New subtype. + (Put_Image_Long_Long_Long_Unsigned): New procedure. + * libgnat/s-putima.adb (Small): Rename to Integer_Images. + (Large): Rename to LL_Integer_Images. + (LLL_Integer_Images): New instantiation. + (Put_Image_Long_Long_Long_Integer): New renaming. + (Put_Image_Long_Long_Long_Unsigned): Likewise. + * libgnat/s-valint.ads: Instantiate System.Value_I. + * libgnat/s-valint.adb: Add pragma No_Body. + * libgnat/s-vallli.ads: Instantiate System.Value_I. + * libgnat/s-vallli.adb: Add pragma No_Body. + * libgnat/s-valllli.ads: Instantiate System.Value_I. + * libgnat/s-vallllu.ads: Instantiate System.Value_U. + * libgnat/s-valllu.ads: Instantiate System.Value_U. + * libgnat/s-valllu.adb: Add pragma No_Body. + * libgnat/s-valuei.ads, libgnat/s-valuei.adb: New generic + package. + * libgnat/s-valueu.ads, libgnat/s-valueu.adb: Likewise. + * libgnat/s-valuns.ads: Instantiate System.Value_U. + * libgnat/s-valuns.adb: Add pragma No_Body. + * libgnat/s-widint.ads: Instantiate System.Width_I. + * libgnat/s-widlli.ads: Likewise. + * libgnat/s-widlli.adb: Add pragma No_Body. + * libgnat/s-widllli.ads: Instantiate System.Width_I. + * libgnat/s-widlllu.ads: Instantiate System.Width_U. + * libgnat/s-widllu.ads: Likewise. + * libgnat/s-widllu.adb: Add pragma No_Body. + * libgnat/s-widthi.ads, libgnat/s-widthi.adb: New generic + package. + * libgnat/s-widthu.ads, libgnat/s-widthu.adb: Likewise. + * libgnat/s-widuns.ads: Instantiate System.Width_U. + +2020-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * set_targ.adb (DTN): Fix oversight. + (Read_Target_Dependent_Values): Do not error out on missing + Long_Long_Long_Size entry and reuse Long_Long_Size for it. + +2020-10-21 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Gen_Loop): Analyze copy of the expression in the + scope of the implicit loop with name of the index parameter + visible. + +2020-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (GNATRTL_128BIT_PAIRS): New variable. + (GNATRTL_128BIT_OBJS): Likewise. + (Windows): In 64-bit mode, add the former to LIBGNAT_TARGET_PAIRS and + the latter to EXTRA_GNATRTL_NONTASKING_OBJS. + (x86_64/linux): Likewise, but unconditionally. + (GNATRTL_NONTASKING_OBJS): Add s-aridou, s-exponn, s-expont, + s-exponu. + * ada_get_targ.adb (Get_Long_Long_Long_Size): New function. + * checks.adb (Apply_Arithmetic_Overflow_Strict): Use Integer_Type_For + to find an appropriate integer type; if it does not exist and the max + integer size is larger than 64, use the 128-bit arithmetic routines. + * cstand.adb (Create_Standard): Build Standard_Long_Long_Long_Integer + and its base type. Use it for Etype of Any_Integer, Any_Modular and + Any_Numeric. Use its size for Build Standard_Long_Long_Long_Unsigned + and Universal_Integer. + (Print_Standard): Print Long_Long_Long_Integer. + * exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_Mod>: Adjust + comment. + * exp_ch3.adb (Simple_Init_Initialize_Scalars_Type): Deal with 128-bit + types. + * exp_ch4.adb (Expand_Array_Comparison): Likewise. + (Expand_N_Op_Expon): Likewise. + (Narrow_Large_Operation): Likewise. + * exp_dbug.adb (Bounds_Match_Size): Handle 128-bit size. + * exp_fixd.adb (Build_Double_Divide_Code): Use RE_Double_Divide64. + * exp_intr.adb (Expand_Binary_Operator_Call): Handle 128-bit size. + * exp_pakd.ads (E_Array): Extend range to 127. + (Bits_Id): Fill in up to 127. + (Get_Id): Likewise. + (GetU_Id): Likewise. + (Set_Id): Likewise. + (SetU_Id): Likewise. + * exp_pakd.adb (Revert_Storage_Order): Handle 128-bit size. + * exp_util.adb (Integer_Type_For): Likewise. + (Small_Integer_Type_For): Likewise. + * fname.adb (Is_Predefined_File_Name): Do not return False for names + larger than 12 characters if they start with "s-". + * freeze.adb (Adjust_Esize_For_Alignment): Change the maximum value + to System_Max_Integer_Size. + (Check_Suspicious_Modulus): Adjust comment. + (Freeze_Entity): Likewise. + * get_targ.ads (Get_Long_Long_Long_Size): New function. + * get_targ.adb (Get_Long_Long_Long_Size): Likewise. + (Width_From_Size): Deal with 128-bit size. + * gnat1drv.adb (Adjust_Global_Switches): Deal with 128-bit types. + * impunit.adb (Get_Kind_Of_File): Bump buffer size. Accept files with + 13 characters if they start with 's'. Compare slice of Buffer. + (Not_Impl_Defined_Unit): Accept files with 13 characters if they start + with 's'. + * krunch.ads: Document length for 128-bit support units. + * krunch.adb (Krunch): Set length to 9 for 128-bit support units. + * layout.adb (Layout_Type): Use System_Max_Integer_Size as alignment + limit. + * rtsfind.ads (RTU_Id): Add System_Arith_128, + System_Compare_Array_Signed_128, System_Compare_Array_Unsigned_128, + System_Exn_LLLI, System_Exp_LLLU, System_Pack_[65..127]. + (RE_Id): Add RE_Integer_128, RE_Unsigned_128, RE_Add_With_Ovflo_Check128 + RE_Multiply_With_Ovflo_Check128, RE_Subtract_With_Ovflo_Check128, + RE_Bswap_128, RE_Compare_Array_S128, RE_Compare_Array_U128, + RE_Exn_Long_Long_Long_Integer, RE_Exp_Long_Long_Long_Integer, + RE_Exp_Long_Long_Long_Unsigned, RE_Bits_[65-127], RE_Get_[65-127], + RE_Set_[65-127], RE_IS_Is16, RE_IS_Iu16, RE_Integer_128 and + RE_Unsigned_128. Rename RE_Add_With_Ovflo_Check, RE_Double_Divide, + RE_Multiply_With_Ovflo_Check, RE_Scaled_Divide and + RE_Subtract_With_Ovflo_Check. Remove RE_IS_Iz1, RE_IS_Iz2, RE_IS_Iz4, + RE_IS_Iz8, RE_Long_Unsigned, RE_Short_Unsigned, RE_Short_Short_Unsigned + (RE_Unit_Table): Likewise. + * sem_aux.adb (Corresponding_Unsigned_Type): Deal with a size equal to + that of Standard_Long_Long_Long_Integer. + (First_Subtype): Deal with Standard_Long_Long_Long_Integer'Base. + * sem_ch13.adb (Analyze_Attribute_Definition_Clause) <Attribute_Size>: + Check the size against powers of 2 and System_Max_Integer_Size for + objects as well. + (Set_Enum_Esize): Deal with 128-bit bounds. + * sem_ch3.adb (Set_Modular_Size): Handle 128-bit size. + (Modular_Type_Declaration): Deal with 128-bit types. + (Signed_Integer_Type_Declaration): Support derivation from + Standard_Long_Long_Long_Integer. + * sem_ch4.adb (Analyze_Mod): Handle 128-bit modulus. + * sem_intr.adb: Add with and use clauses for Ttypes. + (Check_Shift): Handle 128-bit size and modulus. + * sem_prag.adb (Analyze_Pragma) <Pragma_Initialize_Scalars>: Deal + with Signed_128 and Unsigned_128. + (Analyze_Integer_Value): Handle 128-bit size. + * sem_util.ads (Addressable): Adjust description. + * sem_util.adb (Addressable): Return true for 128 if the system + supports 128 bits. + (Set_Invalid_Binder_Values): Deal with Signed_128 and Unsigned_128. + * set_targ.ads (Long_Long_Long_Size): New variable. + * set_targ.adb (S_Long_Long_Long_Size): New constant. + (DTN): Add entry for S_Long_Long_Long_Size. + (DTV): Add entry for Long_Long_Long_Size. + (Set_Targ): Set Long_Long_Long_Size. + * snames.ads-tmpl (Name_Max_Integer_Size): New attribute name. + (Name_Signed_128): New scalar name. + (Name_Unsigned_128): Likewise. + (Scalar_Id): Adjust. + (Integer_Scalar_Id): Likewise. + (Attribute_Id): Add Attribute_Max_Integer_Size. + * stand.ads (Standard_Entity_Type): Add S_Long_Long_Long_Integer. + (Standard_Long_Long_Long_Integer): New renaming. + (Universal_Integer): Adjust description. + (Standard_Long_Long_Long_Unsigned): New variable. + * switch-c.adb (Scan_Front_End_Switches): Deal with -gnate128. + * ttypes.ads (Standard_Long_Long_Long_Integer_Size): New variable. + (Standard_Long_Long_Long_Integer_Width): Likewise. + (System_Max_Integer_Size): Turn into variable. + (System_Max_Binary_Modulus_Power): Likewise. + * uintp.ads (Uint_127): New constant. + * uintp.adb (UI_Power_2): Extednd to 128. + (UI_Power_10): Likewise. + (UI_Expon): Deal with exponent up to 128 specially. + * usage.adb (Write_Switch_Char): Print -gnate128 switch. + * libgnat/a-tifiio.adb (Put_Scaled): Call Scaled_Divide64. + * libgnat/interfac__2020.ads (Integer_128): New integer type. + (Unsigned_128): New modular type. + (Shift_Left, Shift_Right, Shift_Right_Arithmetic, Rotate_Left, + Rotate_Right): New intrinsic functions operating on it. + * libgnat/s-aridou.ads, libgnat/s-aridou.adb: New generic + package. + * libgnat/s-arit64.ads, libgnat/s-arit64.adb: Instantiate + System.Arithmetic_Double. + * libgnat/s-arit128.ads, libgnat/s-arit128.adb: Likewise. + * libgnat/s-bytswa.ads: Add with clause for Interfaces, use subtypes + of unsigned types defined in Interfaces and add Bswap_128. + * libgnat/s-casi128.ads, libgnat/s-casi128.adb: New package. + * libgnat/s-caun128.ads, libgnat/s-caun128.adb: Likewise. + * libgnat/s-exnint.ads: Instantiate System.Exponn. + * libgnat/s-exnint.adb: Add pragma No_Body. + * libgnat/s-exnlli.ads: Instantiate System.Exponn. + * libgnat/s-exnlli.adb: Add pragma No_Body. + * libgnat/s-exnllli.ads: Instantiate System.Exponn. + * libgnat/s-expint.ads: Likewise. + * libgnat/s-expint.adb: Add pragma No_Body. + * libgnat/s-explli.ads: Instantiate System.Exponn. + * libgnat/s-explli.adb: Add pragma No_Body. + * libgnat/s-expllli.ads: Instantiate System.Exponn. + * libgnat/s-explllu.ads: Instantiate System.Exponu. + * libgnat/s-expllu.ads: Likewise. + * libgnat/s-expllu.adb: Add pragma No_Body. + * libgnat/s-exponn.ads, libgnat/s-exponn.adb: New generic + function. + * libgnat/s-expont.ads, libgnat/s-expont.adb: Likewise. + * libgnat/s-exponu.ads, libgnat/s-exponu.adb: Likewise. + * libgnat/s-expuns.ads, libgnat/s-expuns.adb: Likewise. + * libgnat/s-pack65.ads, libgnat/s-pack65.adb: New package. + * libgnat/s-pack66.ads, libgnat/s-pack66.adb: New package. + * libgnat/s-pack67.ads, libgnat/s-pack67.adb: New package. + * libgnat/s-pack68.ads, libgnat/s-pack68.adb: New package. + * libgnat/s-pack69.ads, libgnat/s-pack69.adb: New package. + * libgnat/s-pack70.ads, libgnat/s-pack70.adb: New package. + * libgnat/s-pack71.ads, libgnat/s-pack71.adb: New package. + * libgnat/s-pack72.ads, libgnat/s-pack72.adb: New package. + * libgnat/s-pack73.ads, libgnat/s-pack73.adb: New package. + * libgnat/s-pack74.ads, libgnat/s-pack74.adb: New package. + * libgnat/s-pack75.ads, libgnat/s-pack75.adb: New package. + * libgnat/s-pack76.ads, libgnat/s-pack76.adb: New package. + * libgnat/s-pack77.ads, libgnat/s-pack77.adb: New package. + * libgnat/s-pack78.ads, libgnat/s-pack78.adb: New package. + * libgnat/s-pack79.ads, libgnat/s-pack79.adb: New package. + * libgnat/s-pack80.ads, libgnat/s-pack80.adb: New package. + * libgnat/s-pack81.ads, libgnat/s-pack81.adb: New package. + * libgnat/s-pack82.ads, libgnat/s-pack82.adb: New package. + * libgnat/s-pack83.ads, libgnat/s-pack83.adb: New package. + * libgnat/s-pack84.ads, libgnat/s-pack84.adb: New package. + * libgnat/s-pack85.ads, libgnat/s-pack85.adb: New package. + * libgnat/s-pack86.ads, libgnat/s-pack86.adb: New package. + * libgnat/s-pack87.ads, libgnat/s-pack87.adb: New package. + * libgnat/s-pack88.ads, libgnat/s-pack88.adb: New package. + * libgnat/s-pack89.ads, libgnat/s-pack89.adb: New package. + * libgnat/s-pack90.ads, libgnat/s-pack90.adb: New package. + * libgnat/s-pack91.ads, libgnat/s-pack91.adb: New package. + * libgnat/s-pack92.ads, libgnat/s-pack92.adb: New package. + * libgnat/s-pack93.ads, libgnat/s-pack93.adb: New package. + * libgnat/s-pack94.ads, libgnat/s-pack94.adb: New package. + * libgnat/s-pack95.ads, libgnat/s-pack95.adb: New package. + * libgnat/s-pack96.ads, libgnat/s-pack96.adb: New package. + * libgnat/s-pack97.ads, libgnat/s-pack97.adb: New package. + * libgnat/s-pack98.ads, libgnat/s-pack98.adb: New package. + * libgnat/s-pack99.ads, libgnat/s-pack99.adb: New package. + * libgnat/s-pack100.ads, libgnat/s-pack100.adb: New package. + * libgnat/s-pack101.ads, libgnat/s-pack101.adb: New package. + * libgnat/s-pack102.ads, libgnat/s-pack102.adb: New package. + * libgnat/s-pack103.ads, libgnat/s-pack103.adb: New package. + * libgnat/s-pack104.ads, libgnat/s-pack104.adb: New package. + * libgnat/s-pack105.ads, libgnat/s-pack105.adb: New package. + * libgnat/s-pack106.ads, libgnat/s-pack106.adb: New package. + * libgnat/s-pack107.ads, libgnat/s-pack107.adb: New package. + * libgnat/s-pack108.ads, libgnat/s-pack108.adb: New package. + * libgnat/s-pack109.ads, libgnat/s-pack109.adb: New package. + * libgnat/s-pack110.ads, libgnat/s-pack110.adb: New package. + * libgnat/s-pack111.ads, libgnat/s-pack111.adb: New package. + * libgnat/s-pack112.ads, libgnat/s-pack112.adb: New package. + * libgnat/s-pack113.ads, libgnat/s-pack113.adb: New package. + * libgnat/s-pack114.ads, libgnat/s-pack114.adb: New package. + * libgnat/s-pack115.ads, libgnat/s-pack115.adb: New package. + * libgnat/s-pack116.ads, libgnat/s-pack116.adb: New package. + * libgnat/s-pack117.ads, libgnat/s-pack117.adb: New package. + * libgnat/s-pack118.ads, libgnat/s-pack118.adb: New package. + * libgnat/s-pack119.ads, libgnat/s-pack119.adb: New package. + * libgnat/s-pack120.ads, libgnat/s-pack120.adb: New package. + * libgnat/s-pack121.ads, libgnat/s-pack121.adb: New package. + * libgnat/s-pack122.ads, libgnat/s-pack122.adb: New package. + * libgnat/s-pack123.ads, libgnat/s-pack123.adb: New package. + * libgnat/s-pack124.ads, libgnat/s-pack124.adb: New package. + * libgnat/s-pack125.ads, libgnat/s-pack125.adb: New package. + * libgnat/s-pack126.ads, libgnat/s-pack126.adb: New package. + * libgnat/s-pack127.ads, libgnat/s-pack127.adb: New package. + * libgnat/s-rannum.ads (Random): New function returning 128-bit. + * libgnat/s-rannum.adb (Random): Implement it. + * libgnat/s-scaval.ads: Add with clause for Interfaces, use subtypes + of unsigned types defined in Interfaces. + * libgnat/s-scaval.adb: Add use clause for Interfaces. + * libgnat/s-scaval__128.ads, libgnat/s-scaval__128.adb: New + package. + * libgnat/s-unstyp.ads (Long_Long_Long_Unsigned): New modular type. + (Shift_Left, Shift_Right, Shift_Right_Arithmetic, Rotate_Left, + Rotate_Right): New intrinsic functions operating on it. + +2020-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_defined_characteristics.rst: Add + Long_Long_Long_Integer to the list of predefined integer types. + * gnat_rm.texi: Regenerate. + +2020-10-21 Yannick Moy <moy@adacore.com> + + * ada_get_targ.adb (Width_From_Size): Add case for 128 bits. + Reorder declarations in the same order as get_targ.adb to + facilitate diffs. + +2020-10-21 Piotr Trojanek <trojanek@adacore.com> + + * exp_aggr.adb (Expand_N_Aggregate): Refactor repeated calls to + Etype (N). + (Build_Array_Aggr_Code): Fix whitespace. + +2020-10-21 Dmitriy Anisimkov <anisimko@adacore.com> + + * adaint.c (__gnat_file_time): Use regular arithmetic instead of + __builtin_*_overflow routines if GCC version 4 or less and + compiler is g++. + +2020-10-21 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Array_Aggregate): Use Choice_List, which + internally calls either Choice or Discrete_Choices, depending on + the context. + +2020-10-21 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Iterated_Component_Association): Use + existing defining identifier for index parameter. + +2020-10-21 Javier Miranda <miranda@adacore.com> + + * exp_ch9.adb (Build_Task_Activation_Call): Do not generate a + call to activate tasks if we are within the scope of a protected + type and pragma Detect_Blocking is active. + +2020-10-21 Liaiss Merzougue <merzougue@adacore.com> + + * libgnat/s-carsi8.adb (Compare_Array_S8): Add pragma Assert to + avoid warning concerning Left_Len and RighLen value regarding + Bytes_Compared_As_Words. + * libgnat/s-carun8.adb (Compare_Array_U8): Likewise. + * libgnat/s-geveop.adb (Binary_Operation, Unary_Operation): Add + pragma Assert concerning divide by 0 warning. + * libgnat/s-imgcha.adb (Image_Character): Code update to prevent + constant operation warning. + (Image_Character): Add pragma Assert concerning the unchecked + String size. + * libgnat/s-imgdec.adb + (Round): Upate loop code to prevent warning concerning + Digs'First access. + (Round): Add pragma assert. + (Set): Add pragma Assert for the unchecked string size. + (Set_Digits): Add pragma Assert for the input range. + (Set_Decimal_Digits): Add pragma Assert. + (Set_Blank_And_Sign): Add pragma Assert for the input range. + * libgnat/s-arit64.adb (DoubleDivide): Add pragma Assert + concerning Du /= 0. + (Multiply_With_Ovflo_Check): Add pragma Annotate to avoid + warning concerning unsigned -> signed conversion. + * libgnat/s-imguns.adb (Set_Image_Unsigned): Add pragma Assert + to prevent overflow check warning. Add pragma Assert for + controlling S'First = 1. + * libgnat/s-imgrea.adb (Image_Floating_Point, Set, Set_Digs, + Set_Special_Fill, Convert_Integer): Add pragma Annotate to + prevent overflow check warning. + (Set_Image_Real): Add pragma Annotate to avoid dead code warning + on float check. Add pragma Assert to prevent overflow check + warning. + * libgnat/s-imgwiu.adb (Set_Digits, Set_Image_Width_Unsigned): + Add pragma assert to prevent overflow check warning. + * libgnat/s-imgllu.adb (Set_Image_Long_Long_Unsigned): Add + pragma assert to prevent overflow check warning. + * libgnat/s-imgint.adb (Set_Digits): Add Assert for input + constraint and to prevent overflow check warning, create + Non_Positive subtype, and change the T parameter as Non_Positive + instead Integer. + (Set_Image_Integer): Add pragma assert to prevent overflow check + warning. + * libgnat/s-imglli.adb (Set_Digits): Add Assert for input + constraint and to prevent overflow check warning, create + Non_Positive subtype, and change the T parameter as Non_Positive + instead Integer. + (Set_Image_Long_Long_Integer): Add pragma assert to prevent + overflow check warning. + * libgnat/s-fatgen.adb (Decompose, Pred, Succ): Add pragma + Annotate to prevent dead code due to invalid float check. + * libgnat/s-imenne.adb (Image_Enumeration_8, + Image_Enumeration_16, Image_Enumeration_32): Add pragma Assert + to prevent overflow check warning. Add Names_Index subtype for + restricting Index_table content. + +2020-10-21 Gary Dismukes <dismukes@adacore.com> + + * exp_ch6.adb (Insert_Post_Call_Actions): Test for + N_Explicit_Dereference as part of the existing test for function + calls. + +2020-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * freeze.adb (Check_Strict_Alignment): Do not set the flag for + a bit-packed array type, even if it is a by-reference type. + +2020-10-21 Dmitriy Anisimkov <anisimko@adacore.com> + + * adaint.c (__gnat_file_time): New routine. + (__gnat_copy_attribs): Copy timestamps in nanoseconds. + * libgnat/a-direct.adb (C_Modification_Time): Bind to + __gnat_file_time. + (Modification_Time): Call to C_Modification_Time. + +2020-10-21 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Iterated_Component_Association): + Expression's copy and now has the same parent as the original + expression. + (Resolve_Array_Aggregate): Add ??? comment about a still + existing minor issue that led to discovery of the above crash. + +2020-10-21 Javier Miranda <miranda@adacore.com> + + * sem_ch12.adb (Install_Parents_Of_Generic_Context): Simplify + functionality; collect and install parents of generic child + package. + (Remove_Parents_Of_Generic_Context): Code cleanup. + (Instantiate_Package_Body): Hide parents of generic context from + visibility before installing the parent instance; restore their + visibility when the instance is analyzed + +2020-10-21 Doug Rupp <rupp@adacore.com> + + * libgnarl/s-osinte__lynxos178e.ads: Remove -mthreads switch. + +2020-10-21 Patrick Bernardi <bernardi@adacore.com> + + * env.c (__gnat_setenv): call setenv for VxWorks 7 kernel mode. + (__gnat_environ): envGet takes an int instead of a NULL pointer. + (__gnat_unsetenv): call unsetenv for VxWorks 7 kernel mode. + (__gnat_clearenv): use __gnat_unsetenv to clear environment + variables. + +2020-10-21 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch12.adb (Freeze_Subprogram_Body): Call + Package_Freeze_Node to retrieve the freeze node for the + enclosing body of the generic. + +2020-10-21 Justin Squirek <squirek@adacore.com> + + * exp_ch6.adb (Expand_Call_Helper): Modify calls to + Add_Extra_Actual to use Extra_Accessibility instead of + Get_Accessibility for the EF parameter. + +2020-10-21 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch6.adb (Expand_Actuals): Whitespace cleanup. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Make minimum + accessibility a constant object. + +2020-10-21 Patrick Bernardi <bernardi@adacore.com> + + * env.c (__gnat_environ): For VxWorks kernel simply return the + result of the envGet call. Do this for VxWorks 6 and 7 as they + both support the same API. + +2020-10-21 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_ch7.adb (Build_Finalizer): Disable warnings on referenced + entity. + +2020-10-21 Piotr Trojanek <trojanek@adacore.com> + + * einfo.ads, sem_ch3.adb, sem_util.adb: Fix comments. + +2020-10-21 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Build_Derived_Type): Propagate convention of + class-wide parent. + +2020-10-21 Claire Dross <dross@adacore.com> + + * libgnat/a-cofove.adb (Copy): Add explanation in case of + Capacity_Error. + (Insert_Space): Raise Capacity_Error if the new length is + greater than the capacity. + (Reserve_Capacity): Raise Capacity_Error instead of + Constraint_Error. + +2020-10-20 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Constrain_Decimal, Constrain_Enumeration, + Constrain_Float, Constrain_Integer, Constrain_Ordinary_Fixed): + Refine parameter type from Node_Id to Entity_Id. + +2020-10-20 Piotr Trojanek <trojanek@adacore.com> + + * sprint.adb (po): Set Dump_Freeze_Null to False; align colons. + (ps): Likewise. + +2020-10-20 Ed Schonberg <schonberg@adacore.com> + + * sinfo.ads, sinfo.adb: The flag Box_Present can appear in + Iterated_Element_Association nodes. + * sem_aggr.adb (Resolve_Aggregate): Call + Resolve_Container_Aggregate when type of context has + corresponding aspect. + * sem_type.adb (Covers): In Ada_2020 an aggregate is compatible + with a type that carries the corresponding aspect. + * exp_ch3.adb (Make_Controlling_Function_Wrappers): Do not + create declarations and bodies for inherited primitive functions + of null extensions that dispatch on result, when current scope + includes an immediately visible non-overloadable homonym of the + function. + * libgnat/a-cborse.adb, libgnat/a-cborse.ads, + libgnat/a-cbhase.ads, libgnat/a-cbhase.adb, + libgnat/a-cborma.adb, libgnat/a-cborma.ads, + libgnat/a-cbhama.adb, libgnat/a-cbhama.ads, + libgnat/a-cbdlli.adb, libgnat/a-cbdlli.ads, + libgnat/a-convec.ads, libgnat/a-ciorse.ads, + libgnat/a-cihase.ads, libgnat/a-cihase.adb, + libgnat/a-ciorma.ads, libgnat/a-cihama.ads, + libgnat/a-cihama.adb, libgnat/a-cidlli.ads, + libgnat/a-cidlli.adb, libgnat/a-coinve.adb, + libgnat/a-cobove.adb, libgnat/a-cobove.ads, + libgnat/a-convec.adb, libgnat/a-coinve.ads, + libgnat/a-coorse.ads, libgnat/a-cohase.adb, + libgnat/a-cohase.ads, libgnat/a-coorma.ads, + libgnat/a-cohama.adb, libgnat/a-cohama.ads, + libgnat/a-cdlili.ads: Add primitive function Empty for use in + aspect Aggregate, and add corresponding body or expression + function. + +2020-10-20 Arnaud Charlet <charlet@adacore.com> + + * aspects.adb (Has_Aspect_Specifications_Flag): Add + N_Parameter_Specification. + * par-ch13.adb (Aspect_Specifications_Present): Also handle case + of an unknown aspect on the last formal parameter (terminated by + a Tok_Right_Paren). Minor reformatting. + * par-ch6.adb (P_Formal_Part): Scan aspects on formal + parameters. + * par.adb: Fix typos. + * sem_ch6.adb (Process_Formals): Add processing of aspects and + in particular Unreferenced aspect for now. + * sinfo.ads: Allow ASPECT_SPECIFICATIONS on a + PARAMETER_SPECIFICATION. + * doc/gnat_rm/implementation_defined_aspects.rst + (Aspect Unreferenced): Update documentation. + * gnat_rm.texi: Regenerate. + +2020-10-20 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.ads, sem_util.adb (Get_Accessibility): Refine result + type from Node_Id to Entity_Id. + +2020-10-20 Piotr Trojanek <trojanek@adacore.com> + + * einfo.adb, exp_attr.adb, sem_ch13.adb, sem_util.adb: Use + Is_Formal where possible. + +2020-10-20 Steve Baird <baird@adacore.com> + + * sem_util.ads: Declare a new package, Old_Attr_Util, which in + turn declares two more packages, Conditional_Evaluation and + Indirect_Temps. Conditional_Evaluation provides a predicate for + deciding whether a given 'Old attribute reference is eligible + for conditional evaluation and, in the case where it is + eligible, a function that constructs the Boolean-valued + condition that is to be evaluated at run time in deciding + whether to evaluate the attribute prefix. Indirect_Temps + provides support for declaring a temporary which is only + initialized conditionally; more specifically, an access type and + a variable of that type are declared (unconditionally) and then + the variable is (conditionally) initialized with an allocator. + The existence of the access type and the pointer variable is + hidden from clients, except that a predicate, + Is_Access_Type_For_Indirect_Temp, is provided for identifying + such access types. This is needed because we want such an access + type to be treated like a "normal" access type (specifically + with respect to finalization of allocated objects). Other parts + of the compiler treat access types differently if + Comes_From_Source is False, or if the secondary stack storage + pool is used; this predicate is used to disable this special + treatment. + * sem_attr.adb (Uneval_Old_Msg): Improve message text to reflect + Ada202x changes. + (Analyze_Attribute): A previously-illegal 'Old attribute + reference is accepted in Ada2020 if it is eligible for + conditional evaluation. + * sem_res.adb (Valid_Conversion): Do not treat a rewritten 'Old + attribute like other rewrite substitutions. This makes a + difference, for example, in the case where we are generating the + expansion of a membership test of the form "Saooaaat'Old in + Named_Access_Type"; in this case Valid_Conversion needs to + return True (otherwise the expansion will be False - see the + call site in exp_ch4.adb). + * exp_attr.adb (Expand_N_Attribute_Reference): When expanding a + 'Old attribute reference, test for the case where the reference + is eligible for conditional evaluation. In that case, use the + new "indirect temporary" mechanism provided by Sem_Util. + * exp_prag.adb + (Expand_Attributes_In_Consequence.Expand_Attributes): If + Sem_Util.Indirect_Temp_Needed indicates that there could be + correctness problems associated with the old expansion scheme + for dealing with 'Old attributes in contract cases consequences, + then we use the new "indirect temporary" mechanism provided by + Sem_Util instead. We do not want to do this unconditionally. + * sem_util.adb: Provide a body for the new Old_Attr_Util + package. Further work is needed in several areas for + correctness: + - The function Is_Repeatedly_Evaluated does not deal with + container aggregates yet. + - The function Is_Known_On_Entry does not deal with interactions + with the Global aspect. + Each area where more work is needed is indicated with a "???" + comment in the code; a more detailed description can be found + there. Some optimization opportunties are similarly indicated + with a "???" comment. + * exp_ch3.adb (Freeze_Type): In deciding whether to generate + expansion for the list controller of an access type, take the + predicate Is_Access_Type_For_Indirect_Temp into account. If the + predicate yields True, then generate the expansion. + * exp_util.adb (Build_Allocate_Deallocate_Proc): We don't + normally finalize allocated objects that are allocated on the + secondary stack. Add an exception to this rule if the predicate + Is_Access_Type_For_Indirect_Temp yields True. As a result of + this exception, we have to deal with the fact that gigi expects + a different parameter profile if we are using the secondary + stack pool; the Pool and Alignment parameters must be omitted in + this case. + +2020-10-20 Javier Miranda <miranda@adacore.com> + + * sem_ch12.adb (Install_Parents_Of_Generic_Context, + Remove_Parents_Of_Generic_Context): New subprograms. + (Instantiate_Package_Body): Adding assertions to ensure that + installed parents are properly removed. + +2020-10-20 Claire Dross <dross@adacore.com> + + * sem_attr.adb (Analyze_Attribute): Emit a warning on 'Update + when Warn_On_Obsolescent_Feature is set to True. + +2020-10-20 Richard Kenner <kenner@adacore.com> + + * gnat_cuda.adb (Build_Register_Function_Call): Make procedure + call instead of function, rename to + Build_Register_Procedure_Call. + (Build_CUDA_Init_Proc): Make procedure call instead of function. + +2020-10-20 Justin Squirek <squirek@adacore.com> + + * exp_ch6.adb (Expand_Branch): Properly anticipate expansion of + conditional expressions producing object declarations in + addition to assignment statements, and rename formal. + +2020-10-20 Yannick Moy <moy@adacore.com> + + * errout.adb (Write_Source_Code_Line): Adopt display closer to + GCC format. + (Output_Messages): Deal specially with info messages. + * erroutc.adb (Prescan_Message): Fix bug leading to check + messages being considered as error messages in pretty output + mode. + +2020-10-20 Justin Squirek <squirek@adacore.com> + + * exp_ch6.adb (Expand_Call_Helper): Properly handle the case + where the condition of a conditional expression has been + optimized out when calculating the value of an extra + accessibility parameter. + +2020-10-20 Bob Duff <duff@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Change "_" to "-". + +2020-10-20 Arnaud Charlet <charlet@adacore.com> + + * sem_aggr.adb (Resolve_Aggregate): Warn on not fully + initialized box aggregate. + * sem_aggr.ads: Fix typo. + * sem_res.adb (Resolve_Actuals): Fix typo in error message + format marking it incorrectly as a continuation message. + * sem_elab.adb (Check_Internal_Call_Continue): Similarly, add + missing primary message in case of a call to an actual generic + subprogram. + * sem_warn.adb (Check_References): Do not warn on read but never + assigned variables if the type is partially initialized. + * libgnat/a-except.ads, libgnat/a-ststun.ads, + libgnat/g-sechas.ads, libgnat/a-cbdlli.ads, + libgnat/a-cfdlli.ads, libgnat/a-cobove.ads, + libgnat/a-cohata.ads, libgnat/a-crbltr.ads, + libgnat/a-cbmutr.ads, libgnat/a-crdlli.ads, + libgnat/a-cbsyqu.ads: Address new warning. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Update doc on -gnatwv. + * gnat_ugn.texi: Regenerate. + +2020-10-20 Gary Dismukes <dismukes@adacore.com> + + * sem_ch6.adb (Analyze_Expression_Function): Mark static + expression functions as inlined. + +2020-10-20 Arnaud Charlet <charlet@adacore.com> + + * contracts.adb (Is_Prologue_Renaming): This function was + missing support for E_Constant which can also be generated in + protected objects. + +2020-10-20 Arnaud Charlet <charlet@adacore.com> + + * bindgen.adb (Gen_Bind_Env_String): Generate Ada 2012 compatible + strings. Code cleanup. + +2020-10-20 Yannick Moy <moy@adacore.com> + + * sem_util.adb, sem_util.ads: Comment fix. + +2020-10-20 Arnaud Charlet <charlet@adacore.com> + + * sem_ch8.adb (Check_Constrained_Object): Suppress discriminant + checks when the type has default discriminants and comes from + expansion of a "for of" loop. + +2020-10-20 Bob Duff <duff@adacore.com> + + * atree.ads: Make Default_Node a constant. Remove the + modification of Comes_From_Source, and use a separate flag for + that. Change Sloc to 0; it always overwritten, and never left + as the No_Location value. + (Print_Statistics): Move to spec so we can call it from + gnat1drv. + (Num_Nodes): Rename to clarify that this is approximate. + Correct comment: nodes and entities are never deleted, the count + is never decremented, and this is not used by Xref. + (Initialize): Correct comment: Error_List is not created here. + Other minor naming and comment changes. + * atree.adb (Extend_Node, New_Copy, New_Entity, New_Node): + Streamline these. Simplify and improve efficiency. Move code + from Allocate_Initialize_Node to these, where it can be executed + unconditionally. Take advantage of automatic zeroing of the + Nodes table. + (Allocate_Initialize_Node): Remove this. It was an efficiency + bottleneck, and somewhat complicated, because it was called from + 4 places, and had all sorts of conditionals to check where it + was called from. Better to move most of that code to the call + sites, where it can be executed (or not) unconditionally. + (Allocate_New_Node): New procedure to partly replace + Allocate_Initialize_Node (called from just 2 of those 4 places). + (Comes_From_Source_Default): New flag written/read by + Set_Comes_From_Source_Default/Get_Comes_From_Source_Default. + This allows us to make Default_Node into a constant with + all-zeros value. + (Set_Paren_Count_Of_Copy): New procedure to avoid duplicated + code. + (Report): New procedure to encapsulate the call to the reporting + procedure. + (Atree_Private_Part): We now need a body for this package, to + contain package body Nodes. + (Approx_Num_Nodes_And_Entities): Was Num_Nodes. For efficiency, + compute the answer from Nodes.Last. That way we don't need to + increment a counter on every node creation. Other minor naming + and comment changes. + * gnat1drv.adb: Call Atree.Print_Statistics if -gnatd.A switch + was given. Add comment documenting the new order dependency (we + must process the command line before calling Atree.Initialize). + * debug.adb: Document -gnatd.A. + * einfo.adb, sinfo.adb: Remove useless Style_Checks pragmas. + * nlists.ads (Allocate_List_Tables): Inline makes node creation + a little faster. + * nlists.adb (Initialize): Remove local constant E, which didn't + seem to add clarity. + * treepr.adb (Print_Init): Use renamed + Approx_Num_Nodes_And_Entities function. + * types.ads: Change the Low and High bounds as described above. + * types.h: Change Low and High bounds to match types.ads. + * sem_ch8.adb, namet.adb, namet.ads: Move the computation of + Last_Name_Id from sem_ch8 to namet, and correct it to not assume + Name_Ids are positive. + * ali.adb, ali-util.adb, bindo-writers.adb, exp_dist.adb, + fmap.adb, fname-uf.adb, osint.adb: Fix various hash functions to + avoid assuming the various ranges are positive. Note that "mod" + returns a nonnegative result when the second operand is + positive. "rem" can return negative values in that case (in + particular, if the first operand is negative, which it now is). + * switch-c.adb: Allow switch -gnaten to control the value of + Nodes_Size_In_Meg. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Remove traling whitespaces. + * opt.ads (Nodes_Size_In_Meg): New Variable. + +2020-10-20 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.adb (Remove_Side_Effects): Always generate a renaming + that is handled by the front-end in the case of an indexed or a + selected component whose prefix has a nonstandard representation. + +2020-10-20 Pat Rogers <rogers@adacore.com> + + * doc/gnat_rm/the_gnat_library.rst: Add Ada.Task_Initialization. + * gnat_rm.texi: Regenerate. + +2020-10-20 Yannick Moy <moy@adacore.com> + + * errout.adb: (Error_Msg-Internal): Pass the location for a line + insertion if any in the message. + (Output_Messages: Add display of source code lines if -gnatdF is + set. + (Write_Source_Code_Line): Code clean up. + * erroutc.adb (Prescan_Message): Apply prescan for continuation + lines when -gnatdF is set, and record presence of line + insertion. + * erroutc.ads (Has_Insertion_Line): New global for prescan. + (Error_Msg_Object): Add field to record line insertion if + present. + * errutil.adb (Error_Msg): Pass no location for Insertion_Sloc. + +2020-10-20 Arnaud Charlet <charlet@adacore.com> + + * exp_ch5.adb (Expand_N_Case_Statement): Do not generate + validity check when possible. + +2020-10-20 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Expand_Iterated_Component): Reorganize code to + ensure that Loop_Id is properly initialized on all paths, and + remove code duplication. + +2020-10-20 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Analyze_Subtype_Declaration): Propagate predicate + function to full view of the created type as well, if it was + created. + +2020-10-20 Arnaud Charlet <charlet@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Merge handling of + Simple_Storage_Pool and Storage_Pool. + +2020-10-20 Piotr Trojanek <trojanek@adacore.com> + + * aspects.ads: Introduce Subprogram_Variant aspect with the + following properties: GNAT-specific, with mandatory expression, + not a representation aspect, never delayed. + * contracts.adb (Expand_Subprogram_Contract): Mention new aspect + in the comment. + (Add_Contract_Item): Support addition of pragma + Subprogram_Variant to N_Contract node. + (Analyze_Entry_Or_Subprogram_Contract): Mention new aspect in + the comment; add pragma Subprogram_Variant to N_Contract node. + (Build_Postconditions_Procedure): Adapt call to + Insert_Before_First_Source_Declaration, which is now reused in + expansion of new aspect. + (Process_Contract_Cases_For): Also process Subprogram_Variant, + which is stored in N_Contract node together with Contract_Cases. + * contracts.ads (Analyze_Entry_Or_Subprogram_Contract): Mention + new aspect in the comment. + (Analyze_Entry_Or_Subprogram_Body_Contract): Likewise. + * einfo.adb (Get_Pragma): Support retrieval of new pragma. + * einfo.ads (Get_Pragma): Likewise. + * exp_ch6.adb (Check_Subprogram_Variant): New routine for + emitting call to check Subprogram_Variant expressions at run + time. + (Expand_Call_Helper): Check Subprogram_Variant expressions at + recursive calls. + * exp_prag.adb (Make_Op): Moved from expansion of pragma + Loop_Variant to Exp_Util, so it is now reused for expansion of + pragma Subprogram_Variant. + (Process_Variant): Adapt call to Make_Op after moving it to + Exp_Util. + (Expand_Pragma_Subprogram_Variant): New routine. + * exp_prag.ads (Expand_Pragma_Subprogram_Variant): Likewise. + * exp_util.adb (Make_Variant_Comparison): Moved from Exp_Prag + (see above). + * exp_util.ads (Make_Variant_Comparison): Likewise. + * inline.adb (Remove_Aspects_And_Pragmas): Handle aspect/pragma + Subprogram_Variant just like similar contracts. + * par-prag.adb (Prag): Likewise. + * sem.adb (Insert_Before_First_Source_Declaration): Moved from + Contracts (see above). + * sem.ads (Insert_Before_First_Source_Declaration): Likewise. + * sem_ch12.adb: Mention new aspect in the comment about + "Implementation of Generic Contracts", just like similar aspects + are mentioned there. + * sem_ch13.adb (Insert_Pragma): Mention new aspect in the + comment, because this routine is now used for Subprogram_Variant + just like for other similar aspects. + (Analyze_Aspect_Specifications): Mention new aspect in comments; + it is handled just like aspect Contract_Cases. + (Check_Aspect_At_Freeze_Point): Do not expect aspect + Subprogram_Variant just like we don't expect aspect + Contract_Cases. + * sem_prag.adb (Ensure_Aggregate_Form): Now also used for pragma + Subprogram_Variant, so update comment. + (Analyze_Pragma): Add initial checks for pragma + Subprogram_Variant. + (Analyze_Subprogram_Variant_In_Decl_Part): New routine with + secondary checks on the new pragma. + (Sig_Flags): Handle references within pragma Subprogram_Variant + expression just like references in similar pragma + Contract_Cases. + (Is_Valid_Assertion_Kind): Handle Subprogram_Variant just like + other similar contracts. + * sem_prag.ads (Analyze_Subprogram_Variant_In_Decl_Part): New + routine. + * sem_res.adb (Same_Or_Aliased_Subprograms): Moved to Sem_Util, + so it can be reused for detection of recursive calls where + Subprogram_Variant needs to be verified. + * sem_util.adb (Is_Subprogram_Contract_Annotation): Handle new + Subprogram_Variant annotation just like other similar + annotations. + (Same_Or_Aliased_Subprograms): Moved from Sem_Res (see above). + * sem_util.ads (Is_Subprogram_Contract_Annotation): Mention new + aspect in the comment. + (Same_Or_Aliased_Subprograms): Moved from Sem_Res (see above). + * sinfo.ads (N_Contract): Document handling of + Subprogram_Variant. + * snames.ads-tmpl: Add name for the internally generated + procedure with checks for Subprogram_Variant expression, name + for the new aspect and new pragma corresponding to aspect + Subprogram_Variant. + +2020-10-20 Piotr Trojanek <trojanek@adacore.com> + + * exp_util.ads: Reorder declaration. + +2020-10-19 Ed Schonberg <schonberg@adacore.com> + + * par-ch4.adb: (P_Aggregate_Or_Paren_Expr): Recognize + Iterated_Element_Component. + (P_Iterated_Component_Association): Rebuild node as an Iterated_ + Element_Association when Key_Expression is present, and attach + either the Loop_Parameter_Specification or the + Iterator_Specification to the new node. + * sem_aggr.adb: (Resolve_Container_Aggregate): + Resolve_Iterated_Association handles bota Iterated_Component_ + and Iterated_Element_Associations, in which case it analyzes and + resoles the orresponding Key_Expression. + * exp_aggr.adb (Expand_Iterated_Component): If a Key_Expression + is present, use it as the required parameter in the call to the + insertion routine for the destination container aggregate. Call + this routine for both kinds of Iterated_Associations. + +2020-10-19 Arnaud Charlet <charlet@adacore.com> + + * exp_ch4.adb (Expand_Concatenate): Enable needed range checks. + +2020-10-19 Bob Duff <duff@adacore.com> + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): + Set the Warnings_Off flag on the pointer object used in the + expansion of iterators and similar. + +2020-10-19 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (PowerPC/Linux): Use s-taspri__posix.ads instead + of s-taspri__posix-noaltstack.ads for s-taspri.ads. + +2020-10-19 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch13.adb (Add_Call): Remove excessive condition and + unnecessary call to Set_Has_Predicates. + +2020-10-19 Yannick Moy <moy@adacore.com> + + * debug.adb: Use debug switch -gnatdF for this alternative + display of messages. + * errout.adb (Output_Messages): Alternative display when -gnatdF + is used. + * erroutc.adb (Output_Msg_Text): Likewise. + +2020-10-19 Arnaud Charlet <charlet@adacore.com> + + * sem_ch6.adb (Check_Untagged_Equality): Check for AI12-0352. + +2020-10-19 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Add_View_Conversion_Invariants): Do not insert + generated invariant checks when the call is a function call. + These tests are properly inserted in the code in procedure + Insert_Post_Call_Actions, which takes care of finding the proper + insertion point for the checks. + (Insert_Post_Call_Actions): Add question marks to indicate + possible gap in handling function calls that appear as aggregate + components. + +2020-10-19 Arnaud Charlet <charlet@adacore.com> + + * contracts.adb (Process_Preconditions_For): Do not exclude + instances. + * sem_ch4.adb (Analyze_Quantified_Expression): Disable spurious + warning on internally generated variables. + +2020-10-19 Ghjuvan Lacambre <lacambre@adacore.com> + + * debug.adb: Document -gnatd_c flag as being used for CUDA. + * gnat_cuda.ads: New file. + * gnat_cuda.adb: New file. + * rtsfind.ads: Add Interfaces_C_Strings package and + RE_Fatbin_Wrapper, RE_Register_Fat_Binary, + RE_Register_Fat_Binary_End, RE_Register_Function, RE_Chars_Ptr, + RE_New_Char_Array entities. + * rtsfind.adb: Create new Interfaces_C_Descendant subtype, + handle it. + * sem_ch7.adb (Analyze_Package_Body_Helper): Call CUDA init + procedure. + * sem_prag.adb (Analyze_Pragma): Call Add_Cuda_Kernel procedure. + * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add gnat_cuda.o. + +2020-10-19 Bob Duff <duff@adacore.com> + + * ghost.adb (Whole_Object_Ref): New function to compute the name + of the whole object. + (Mark_And_Set_Ghost_Assignment): Rewrite to use + Whole_Object_Ref. We need to partly analyze the left-hand side + in order to distinguish expanded names and record components. + * lib-xref.ads, lib-xref.adb (Deferred_References): Move table + to body, and add Defer_Reference to update the table, avoiding + duplicates. + (Generate_Reference): Avoid duplicates. + * sem_ch8.ads, sem_ch8.adb (Find_Direct_Name): Remove _OK + parameters, which are no longer needed. Ignore errors in + Ignore_Errors mode. + * sem_util.ads, sem_util.adb (Preanalyze_Without_Errors): Make + this public, so we can call it from Ghost. + * errout.ads, scng.adb, sem_prag.adb: Minor. + +2020-10-19 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Check if type + depends on discriminant. + +2020-10-19 Bob Duff <duff@adacore.com> + + * libgnat/a-coinve.adb, libgnat/a-cidlli.adb (Put_Image): Call + Iterate. + +2020-10-19 Arnaud Charlet <charlet@adacore.com> + + * sem_aggr.adb (Resolve_Record_Aggregate): Properly apply + subtype constraints when using a Default_Value. + * freeze.adb: Fix typo. + +2020-10-19 Yannick Moy <moy@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Relaxed_Initialization): Fix bug + where a call to Error_Msg_N leads to crash due to + Error_Msg_Name_1 being removed by the call, while a subsequent + call to Error_Msg_N tries to use it. The variable + Error_Msg_Name_1 should be restored prior to the next call. Also + add checking for the new rules. + +2020-10-19 Arnaud Charlet <charlet@adacore.com> + + * checks.adb (Apply_Type_Conversion_Checks): Minor code clean + up. + * exp_ch4.adb (Discrete_Range_Check): Optimize range checks. + Update comments. + (Expand_N_Type_Conversion): Generate range check when rewriting + a type conversion if needed. Add assertion. + * exp_ch6.adb (Expand_Simple_Function_Return): Minor code clean + up. + * sem_res.adb (Resolve_Type_Conversion): Apply range check when + needed. Update comments. + +2020-10-19 Yannick Moy <moy@adacore.com> + + * libgnat/a-textio.ads: Update top-level comment. + +2020-10-19 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Contract_Cases_In_Decl_Part): Fix typo. + +2020-10-19 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch6.adb (Expand_Actuals): Simplify condition for by-copy + types. + +2020-10-19 Yannick Moy <moy@adacore.com> + + * errout.ads: Add comment regarding lack of preservation of + Errout state across successive calls to the API. + +2020-10-19 Bob Duff <duff@adacore.com> + + * exp_put_image.adb (Build_Elementary_Put_Image_Call): Use the + base type to recognize various cases of access types. + * libgnat/a-cbdlli.adb, libgnat/a-cbdlli.ads, libgnat/a-cbhama.adb, + libgnat/a-cbhama.ads, libgnat/a-cbhase.adb, libgnat/a-cbhase.ads, + libgnat/a-cbmutr.adb, libgnat/a-cbmutr.ads, libgnat/a-cborma.adb, + libgnat/a-cborma.ads, libgnat/a-cborse.adb, libgnat/a-cborse.ads, + libgnat/a-cdlili.adb, libgnat/a-cdlili.ads, libgnat/a-cidlli.adb, + libgnat/a-cidlli.ads, libgnat/a-cihama.adb, libgnat/a-cihama.ads, + libgnat/a-cihase.adb, libgnat/a-cihase.ads, libgnat/a-cimutr.adb, + libgnat/a-cimutr.ads, libgnat/a-ciorma.adb, libgnat/a-ciorma.ads, + libgnat/a-ciormu.adb, libgnat/a-ciormu.ads, libgnat/a-ciorse.adb, + libgnat/a-ciorse.ads, libgnat/a-coboho.adb, libgnat/a-coboho.ads, + libgnat/a-cobove.adb, libgnat/a-cobove.ads, libgnat/a-cohama.adb, + libgnat/a-cohama.ads, libgnat/a-cohase.adb, libgnat/a-cohase.ads, + libgnat/a-coinho.adb, libgnat/a-coinho.ads, + libgnat/a-coinho__shared.adb, libgnat/a-coinho__shared.ads, + libgnat/a-coinve.adb, libgnat/a-coinve.ads, libgnat/a-comutr.adb, + libgnat/a-comutr.ads, libgnat/a-coorma.adb, libgnat/a-coorma.ads, + libgnat/a-coormu.adb, libgnat/a-coormu.ads, libgnat/a-coorse.adb, + libgnat/a-coorse.ads, libgnat/a-strunb.adb, libgnat/a-strunb.ads, + libgnat/a-strunb__shared.adb, libgnat/a-strunb__shared.ads: + Implement Put_Image attibute. + * libgnat/a-stteou.ads, libgnat/s-putima.ads, + libgnat/a-stouut.ads, libgnat/a-stoubu.adb: Make + Ada.Strings.Text_Output, Ada.Strings.Text_Output.Utils, and + System.Put_Images Pure, so they can be with'ed by Pure units + that should have Put_Image defined. + * libgnat/a-stouut.adb: Add missing column adjustments, and + remove a redundant one. + * libgnat/s-putima.adb (Put_Arrow): New routine to print an + arrow. Avoids adding a with clause to some containers. + +2020-10-19 Bob Duff <duff@adacore.com> + + * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Require matching + parens or brackets. + * par.adb, par-tchk.adb (T_Right_Bracket): New procedure to give + an error on missing ]. + +2020-10-19 Javier Miranda <miranda@adacore.com> + + * sem_ch8.adb (Find_Direct_Name): Do not trust in the decoration + of the Entity attribute in constants associated with + discriminals of protected types. + +2020-10-19 Gary Dismukes <dismukes@adacore.com> + + * sem_disp.adb (Check_Dispatching_Context): When the enclosing + subprogram is abstract, bypass early return if the call is + tag-indeterminate, to continue with the later error checking. + +2020-10-19 Javier Miranda <miranda@adacore.com> + + * sem_ch7.adb (Uninstall_Declarations): Uninstall the + declaration of a subtype declaration defined in the private part + of a package. + +2020-10-19 Arnaud Charlet <charlet@adacore.com> + + * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Simplify code since + we are always under -gnatX if we encounter a Tok_Left_Bracket. + * scng.adb (Scan): [] is an aggregate under -gnatX and a wide + character otherwise. + +2020-10-19 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch6.adb (Expand_Call_Helper): Cleanup. + +2020-10-19 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch6.adb (Is_Direct_Deep_Call): Refine type from Node_Id to + Entity_Id. + +2020-10-19 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch6.adb (May_Fold): Detect all operators, i.e. both binary + and unary ones. + +2020-10-19 Piotr Trojanek <trojanek@adacore.com> + + * inline.adb (Expand_Inlined_Call): Simplify repeated calls to + Nkind. + +2020-10-18 Alexandre Oliva <oliva@adacore.com> + + * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Compile Ada.Numerics + child units Aux_Generic_Float, Aux_Long_Long_Float, Aux_Long_Float, + Aux_Float, Aux_Short_Float, Aux_Compat, and Aux_Linker_Options. + (X86_TARGET_PAIRS): Drop dummy body for Aux. Use x86 version + of Aux_Compat. + (X86_64_TARGET_PAIRS): Likewise. + (LIBGNAT_TARGET_PAIRS): On VxWorks, select the nolibm + variants. Drop the darwin version of Aux. Drop the redundant + libc-x86 numaux variants on x86* kfreebsd variants. + * libgnat/a-nagefl.ads: New Aux_Generic_Float. + * libgnat/a-naliop.ads: New Aux_Linker_Options. + * libgnat/a-naliop__nolibm.ads: New. + * libgnat/a-nallfl.ads: New Aux_Long_Long_Float. + * libgnat/a-nalofl.ads: New Aux_Long_Float. + * libgnat/a-nuaufl.ads: New Aux_Float. + * libgnat/a-nashfl.ads: New Aux_Short_Float. + * libgnat/a-ngcefu.adb (Exp): Factor out the Im (X) passed to + Sin and Cos in the Complex variant too. + * libgnat/a-ngcoty.adb: Switch to Aux_Generic_Float. Drop + redundant conversions. + * libgnat/a-ngelfu.adb: Likewise. + * libgnat/a-nuauco.ads: New Aux_Compat. + * libgnat/a-nuauco__x86.ads: New. + * libgnat/a-numaux.ads: Replace with Compat wrapper. + * libgnat/a-numaux__darwin.adb: Remove. + * libgnat/a-numaux__darwin.ads: Remove. + * libgnat/a-numaux__dummy.adb: Remove. + * libgnat/a-numaux__libc-x86.ads: Remove. + * libgnat/a-numaux__vxworks.ads: Remove. + +2020-10-16 Piotr Trojanek <trojanek@adacore.com> + + * checks.adb, exp_aggr.adb, exp_attr.adb, exp_ch6.adb, + freeze.adb, sem_aggr.adb, sem_attr.adb, sem_ch13.adb, + sem_ch13.ads, sem_ch6.adb, sem_eval.adb, sem_util.adb: Fix style + and typos. + +2020-10-16 Arnaud Charlet <charlet@adacore.com> + + * sem_cat.adb (Is_Primary): Handle N_Range properly. + +2020-10-16 Ghjuvan Lacambre <lacambre@adacore.com> + + * elists.ads (New_Elmt_List): New functions. + * elists.adb (New_Elmt_List): New functions. + * exp_prag.adb: Add dependency on Elists. + (Expand_Pragma_CUDA_Execute): New function. + (Expand_N_Pragma): Add call to Expand_Pragma_CUDA_Execute. + * rtsfind.ads: Add CUDA.Internal, CUDA.Runtime, System.C + packages and RE_Push_Call_Configuration, + RE_Pop_Call_Configuration, RE_Launch_Kernel, RO_IC_Unsigned, + RO_IC_Unsigned_Long_Long entities. + * rtsfind.adb: Extend Interfaces_Descendant to include + Interfaces_C. + +2020-10-16 Bob Duff <duff@adacore.com> + + * par-ch4.adb (P_Name): Allow Tok_Left_Bracket in two places to + call P_Qualified_Expression. We don't need to modify other + places that call P_Qualified_Expression, because a + qualified_expression is a name in Ada 2012 and higher, so P_Name + is the right place. The parser already parses aggregates with + brackets; we just need to allow that in qualified expressions. + +2020-10-16 Javier Miranda <miranda@adacore.com> + + * sem_ch12.adb (Check_Generic_Child_Unit): When the child unit + is a renaming of a generic child unit then traverse the scope + containing the renaming declaration to locate the instance of + its parent. Otherwise the parent is not installed and the + frontend cannot process the instantiation. + +2020-10-16 Bob Duff <duff@adacore.com> + + * libgnat/a-numeri.ads: Remove the greek letter. + +2020-10-16 Ed Schonberg <schonberg@adacore.com> + + * exp_imgv.adb (Expand_Image_Attribute): Refine previous patch + to use root type (and not base type) on enumeration types. + +2020-10-16 Ed Schonberg <schonberg@adacore.com> + + * exp_imgv.adb (Expand_Image_Attribute): Use the base type + instead of the root type when type of object is private. Remove + Ada_2020 guard, because it has been checked during prior + analysis. Use Underlying_Type in all cases, as it is a no-op on + types that are not private. + +2020-10-16 Arnaud Charlet <charlet@adacore.com> + + * aspects.ads, snames.ads-tmpl: Add support for + Exclusive_Functions aspect. + * sem_ch13.adb (Analyze_Aspect_Specifications): Ditto. + * exp_ch9.adb (Build_Protected_Subprogram_Body): Take aspect + Exclusive_Functions into account. + +2020-10-16 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Update dependencies on system.ads, + add gnatbind switch -t to avoid timestamp inconsistencies during + build. + * libgnat/system.ads: Move... + * gcc-interface/system.ads: ... here. + +2020-10-16 Gary Dismukes <dismukes@adacore.com> + + * sem_eval.adb (Subtypes_Statically_Match): Retrieve + discriminant constraints from the two types via new function + Original_Discriminant_Constraint rather than + Discriminant_Constraint. + (Original_Discriminant_Constraint): New function to locate the + nearest explicit discriminant constraint associated with a type + that may possibly have inherited a constraint from an ancestor + type. + +2020-10-16 Bob Duff <duff@adacore.com> + + * exp_ch6.adb (Expand_Simple_Function_Return): Remove obsolete + comment and code. + +2020-10-16 Arnaud Charlet <charlet@adacore.com> + + PR ada/95953 + * libgnat/a-suenco.adb (Convert): Fix handling of third UTF-8 + byte. + +2020-10-16 Steve Baird <baird@adacore.com> + + * exp_util.adb (Is_Related_To_Func_Return): Cope with the case + where the FE introduces a type conversion. + +2020-10-16 Chris Martin <cmartin@adacore.com> + + * sem_util.ads, sem_util.adb (Is_Access_Variable): New function. + (Is_Synchronized_Object): Call new function when determining if + a constant can be regarded as synchronized. + +2020-10-16 Arnaud Charlet <charlet@adacore.com> + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): + Call Set_BIP_Initialization_Call systematically. + * exp_ch7.adb (Process_Transient_In_Scope): Take + BIP_Initialization_Call into account to decide where to insert + the Hook. + +2020-10-16 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Is_View_Conversion): Detect qualified types. + * sem_util.ads (Is_Actual_In_Out_Parameter): Fix style in + comment. + +2020-10-16 Arnaud Charlet <charlet@adacore.com> + + * scil_ll.adb, sem_scil.adb: Update assertions. + +2020-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Min_Max): Handle the case where attribute + name (qualified by required type) appears as the reducer of a + 'Reduce attribute reference. + (Resolve_Attribute) <Reduce>: Handle properly the presence of a + procedure or an attribute reference Min/Max as a reducer. + * exp_attr.adb (Expand_Attribute_Reference) <Reduce>: New + subprogram Build_Stat, to construct the combining statement + which appears in the generated loop for Reduce, and which is + either a function call when the reducer is a function or an + attribute, or a procedure call when reducer is an appropriate + procedure. BuilD_Stat is used both when the prefix of 'Reduce + is a value sequence and when it is an object + +2020-10-16 Arnaud Charlet <charlet@adacore.com> + + * exp_ch4.adb (Expand_Concatenate): Allocate result of string + concatenation on secondary stack when relevant. + +2020-10-16 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Declare_Expression): Retrieve the created + block entity that is the scope of the local declarations, from + either a local object declaration or an object renaming + declaration. The block entity does not have an explicit + declaration, but appears as the scope of all locally declared + objects. + +2020-10-16 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/system-aix.ads: Likewise. + * libgnat/system-darwin-arm.ads: Likewise. + * libgnat/system-darwin-ppc.ads: Likewise. + * libgnat/system-darwin-x86.ads: Likewise. + * libgnat/system-djgpp.ads: Likewise. + * libgnat/system-dragonfly-x86_64.ads: Likewise. + * libgnat/system-freebsd.ads: Likewise. + * libgnat/system-hpux-ia64.ads: Likewise. + * libgnat/system-hpux.ads: Likewise. + * libgnat/system-linux-alpha.ads: Likewise. + * libgnat/system-linux-arm.ads: Likewise. + * libgnat/system-linux-hppa.ads: Likewise. + * libgnat/system-linux-ia64.ads: Likewise. + * libgnat/system-linux-m68k.ads: Likewise. + * libgnat/system-linux-mips.ads: Likewise. + * libgnat/system-linux-ppc.ads: Likewise. + * libgnat/system-linux-riscv.ads: Likewise. + * libgnat/system-linux-s390.ads: Likewise. + * libgnat/system-linux-sh4.ads: Likewise. + * libgnat/system-linux-sparc.ads: Likewise. + * libgnat/system-linux-x86.ads: Likewise. + * libgnat/system-lynxos178-ppc.ads: Likewise. + * libgnat/system-lynxos178-x86.ads: Likewise. + * libgnat/system-mingw.ads: Likewise. + * libgnat/system-qnx-aarch64.ads: Likewise. + * libgnat/system-rtems.ads: Likewise. + * libgnat/system-solaris-sparc.ads: Likewise. + * libgnat/system-solaris-x86.ads: Likewise. + * libgnat/system-vxworks-arm-rtp-smp.ads: Likewise. + * libgnat/system-vxworks-arm-rtp.ads: Likewise. + * libgnat/system-vxworks-arm.ads: Likewise. + * libgnat/system-vxworks-e500-kernel.ads: Likewise. + * libgnat/system-vxworks-e500-rtp-smp.ads: Likewise. + * libgnat/system-vxworks-e500-rtp.ads: Likewise. + * libgnat/system-vxworks-e500-vthread.ads: Likewise. + * libgnat/system-vxworks-ppc-kernel.ads: Likewise. + * libgnat/system-vxworks-ppc-ravenscar.ads: Likewise. + * libgnat/system-vxworks-ppc-rtp-smp.ads: Likewise. + * libgnat/system-vxworks-ppc-rtp.ads: Likewise. + * libgnat/system-vxworks-ppc-vthread.ads: Likewise. + * libgnat/system-vxworks-ppc.ads: Likewise. + * libgnat/system-vxworks-x86-kernel.ads: Likewise. + * libgnat/system-vxworks-x86-rtp-smp.ads: Likewise. + * libgnat/system-vxworks-x86-rtp.ads: Likewise. + * libgnat/system-vxworks-x86-vthread.ads: Likewise. + * libgnat/system-vxworks-x86.ads: Likewise. + * libgnat/system-vxworks7-aarch64-rtp-smp.ads: Likewise. + * libgnat/system-vxworks7-aarch64.ads: Likewise. + * libgnat/system-vxworks7-arm-rtp-smp.ads: Likewise. + * libgnat/system-vxworks7-arm.ads: Likewise. + * libgnat/system-vxworks7-e500-kernel.ads: Likewise. + * libgnat/system-vxworks7-e500-rtp-smp.ads: Likewise. + * libgnat/system-vxworks7-e500-rtp.ads: Likewise. + * libgnat/system-vxworks7-ppc-kernel.ads: Likewise. + * libgnat/system-vxworks7-ppc-rtp-smp.ads: Likewise. + * libgnat/system-vxworks7-ppc-rtp.ads: Likewise. + * libgnat/system-vxworks7-ppc64-kernel.ads: Likewise. + * libgnat/system-vxworks7-ppc64-rtp-smp.ads: Likewise. + * libgnat/system-vxworks7-x86-kernel.ads: Likewise. + * libgnat/system-vxworks7-x86-rtp-smp.ads: Likewise. + * libgnat/system-vxworks7-x86-rtp.ads: Likewise. + * libgnat/system-vxworks7-x86_64-kernel.ads: Likewise. + * libgnat/system-vxworks7-x86_64-rtp-smp.ads: Likewise. + +2020-10-16 Arnaud Charlet <charlet@adacore.com> + + * Makefile.rtl, gnat1drv.adb, expander.adb + doc/gnat_rm/implementation_defined_pragmas.rst, + doc/gnat_ugn/building_executable_programs_with_gnat.rst, + doc/gnat_ugn/the_gnat_compilation_model.rst, exp_ch5.ads, + exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_util.adb, + exp_util.ads, libgnarl/s-osinte__aix.adb, + libgnarl/s-osinte__android.adb, libgnarl/s-osinte__darwin.adb, + libgnarl/s-osinte__gnu.adb, libgnarl/s-osinte__hpux-dce.adb, + libgnarl/s-osinte__lynxos178.adb, libgnarl/s-osinte__posix.adb, + libgnarl/s-osinte__qnx.adb, libgnarl/s-osinte__rtems.adb, + libgnarl/s-osinte__solaris.adb, libgnarl/s-osinte__vxworks.adb, + libgnarl/s-osinte__x32.adb, libgnarl/s-solita.adb, + libgnarl/s-taasde.adb, libgnarl/s-taprob.adb, + libgnarl/s-taprop__dummy.adb, libgnarl/s-taprop__hpux-dce.adb, + libgnarl/s-taprop__linux.adb, libgnarl/s-taprop__mingw.adb, + libgnarl/s-taprop__posix.adb, libgnarl/s-taprop__qnx.adb, + libgnarl/s-taprop__solaris.adb, libgnarl/s-taprop__vxworks.adb, + libgnarl/s-tarest.adb, libgnarl/s-tasini.adb, + libgnarl/s-taskin.adb, libgnarl/s-taspri__dummy.ads, + libgnarl/s-taspri__hpux-dce.ads, libgnarl/s-taspri__lynxos.ads, + libgnarl/s-taspri__mingw.ads, + libgnarl/s-taspri__posix-noaltstack.ads, + libgnarl/s-taspri__posix.ads, libgnarl/s-taspri__solaris.ads, + libgnarl/s-taspri__vxworks.ads, libgnarl/s-tassta.adb, + libgnarl/s-tasuti.adb, libgnarl/s-tposen.adb, + libgnat/a-except.adb, libgnat/a-except.ads, + libgnat/s-dwalin.adb, libgnat/s-dwalin.ads, + libgnat/s-mastop.ads, libgnat/s-soflin.adb, + libgnat/s-stalib.adb, libgnat/s-stalib.ads, + libgnat/s-stchop.adb, libgnat/s-stchop.ads, + libgnat/s-stchop__limit.ads, libgnat/s-traceb.ads, + libgnat/s-traent.adb, libgnat/s-traent.ads, + libgnat/s-trasym.adb, libgnat/s-trasym.ads, + libgnat/s-trasym__dwarf.adb, opt.adb, opt.ads, par-prag.adb, + sem_prag.adb, snames.ads-tmpl, switch-c.adb, targparm.adb, + targparm.ads, usage.adb: Remove support for -gnatP and pragma + Polling. + * gnat_ugn.texi: Regenerate. + * libgnat/a-excpol.adb, libgnat/a-excpol__abort.adb: Removed. + +2020-10-16 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Array_Type_Declaration): Create itype with unique + name. + +2020-10-16 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Limit scope of a + local object by hiding it from local subprograms; simplify + nested if-then-if-then condition for an Ada 83 restriction. + (Array_Type_Declaration): Confirm with assertion when the else + branch is executed. + (Find_Type_Of_Object): Simplify membership test with a subtype + range. + +2020-10-16 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Analyze_Global_In_Decl_Part): Update check to + reject volatile object for reading. + * sem_res.adb (Resolve_Actuals, Resolve_Entity_Name): Update + check to reject volatile object for reading. + * sem_util.adb, sem_util.ads + (Check_Nonvolatile_Function_Profile, + Has_Effectively_Volatile_Profile): Detect use of volatile object + for reading. + (Has_Enabled_Property): Accept constants as well. + (Is_Effectively_Volatile_For_Reading): New function based on + existing Is_Effectively_Volatile. + (Is_Effectively_Volatile_Object_For_Reading): Adapted from the + existing Is_Effectively_Volatile_Object, using a shared + implementation in Is_Effectively_Volatile_Object_Shared. + +2020-10-16 Gary Dismukes <dismukes@adacore.com> + + * exp_ch7.adb (Check_Unnesting_In_Decls_Or_Stmts): In the case + of an if-statement, call Unnest_If_Statement to determine + whether there are nested subprograms in any of the statement + lists of the "if" parts that require a wrapping procedure to + handle possible up-level refeferences. + (Unnest_Block): Call Check_Unnesting_In_Handlers to do unnesting + of subprograms in exception handlers of the block statement. + (Unnest_If_Statement): New procedure to traverse the parts of an + if-statement and create wrapper procedures as needed to + encapsulate nested subprograms that may make up-level + references. + (Check_Stmts_For_Subp_Unnesting): New support procedure in + Unnest_If_Statement to traverse a statement list looking for + top-level subprogram bodies that require wrapping inside a + procedure (via Unnest_Statement_List) as well as possibly having + other statements (block, loop, if) that may themselves require + an unnesting transformation (via + Check_Unnesting_In_Decls_Or_Stmts). + (Unnest_Statement_List): New support procedure to traverse the + statements of a statement list that contains subprogram bodies + at the top level and replace the statement list with a wrapper + procedure body encapsulating the statements and a call to the + procedure. + +2020-10-16 Arnaud Charlet <charlet@adacore.com> + + * sem_prag.adb (Check_OK_Stream_Convert_Function): Check for + abstract subprograms. + +2020-10-16 Piotr Trojanek <trojanek@adacore.com> + + * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst + (No_Local_Timing_Events): Package Timing_Events is a child of + Ada.Real_Time, not of Ada. + * gnat_rm.texi: Regenerate. + +2020-10-16 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_defined_attributes.rst: Document the + new Max_Integer_Size attribute. + * gnat_rm.texi: Regenerate. + * exp_attr.adb (Get_Integer_Type): Call Small_Integer_Type_For. + (Expand_N_Attribute_Reference) <Attribute_Pred>: Replace selection + code with call to Integer_Type_For. + <Attribute_Succ>: Likewise. + <Attribute_Val>: Likewise. + <Attribute_Valid>: Likewise. + <Attribute_Max_Integer_Size>: Raise Program_Error. + * exp_ch3.adb (Expand_Freeze_Enumeration_Type): Replace selection + code with call to Integer_Type_For. + (Simple_Init_Initialize_Scalars_Type): Use Long_Long_Unsigned and + System_Max_Integer_Size to size the largest integer type. + * exp_pakd.adb (Compute_Linear_Subscript): Minor tweak. + (Create_Packed_Array_Impl_Type): Use Small_Integer_Type_For. + * exp_util.ads (Integer_Type_For): New function. + (Small_Integer_Type_For): Likewise. + * exp_util.adb (Adjust_Condition): Use Integer_Type_For. + (Component_May_Be_Bit_Aligned): Use System_Max_Integer_Size. + (Integer_Type_For): New function. + (Small_Integer_Type_For): Likewise. + (Matching_Standard_Type): Use Small_Integer_Type_For. + (Needs_Constant_Address): Replace 64 with System_Max_Integer_Size. + * freeze.adb (Set_Small_Size): Likewise. + (Size_Known): Likewise. + (Check_Suspicious_Modulus): Likewise. + (Check_Large_Modular_Array): Likewise. + (Freeze_Entity): Likewise. + * layout.adb (Layout_Type): Likewise. + * sem_aggr.adb: Add with and use clauses for Ttypes. + (Resolve_Aggregate): Replace 64 with System_Max_Integer_Size. + * sem_attr.ads (Attribute_Impl_Def): Add Attribute_Max_Integer_Size. + * sem_attr.adb (Analyze_Attribute) <Attribute_Max_Integer_Size>: New + (Eval_Attribute): Likewise. + * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Change max + scalar size to System_Max_Integer_Size. + (Check_Array_Type): Replace 64 with System_Max_Integer_Size and + remove superfluous test. + (OK_Component): Likewise. + * sem_ch5.adb: Add with and use clauses for Ttypes. + (Analyze_Assignment): Replace 64 with System_Max_Integer_Size. + * snames.ads-tmpl (Name_Max_Integer_Size): New attribute name. + (Attribute_Id): Add Attribute_Max_Integer_Size. + * ttypes.ads (System_Max_Integer_Size): New constant. + +2020-10-15 Arnaud Charlet <charlet@adacore.com> + + * sem_ch10.adb (Install_With_Clause): Fix implementation of Ada + 2005 AI-262 by taking into account generic packages. Minor + reformatting. + * libgnat/a-cbhase.ads, libgnat/a-cbhase.adb: Remove use clause + on runtime unit spec. + +2020-10-15 Arnaud Charlet <charlet@adacore.com> + + * einfo.ads, einfo.adb (Scope_Depth_Value, + Set_Scope_Depth_Value): Add assertions on valid nodes and update + documentation accordingly. + (Write_Field22_Name): Sync with change in Scope_Depth_Value. + * sem_ch8.adb (Find_Direct_Name): Fix call to Scope_Depth_Value. + +2020-10-15 Javier Miranda <miranda@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Adding semantic support of + Standard to Default_Storage_Pool. + * freeze.adb (Freeze_Entity): If pragma Default_Storage_Pool + applies and it is set to Standard then use the global pool as + the associated storage pool of the access type. + +2020-10-15 Javier Miranda <miranda@adacore.com> + + * exp_ch6.ads (Might_Have_Tasks): Update documentation. + * exp_ch6.adb (Might_Have_Tasks): Return also true when the type + has tasks. + (Make_Build_In_Place_Call_In_Allocator): Code cleanup. + * exp_ch3.adb (Ensure_Activation_Chain_And_Master, + Expand_N_Full_Type_Declaration, Expand_N_Object_Declaration): + Code cleanup. + +2020-10-15 Steve Baird <baird@adacore.com> + + * checks.adb (Apply_Predicate_Check): Generate "infinite + recursion" warning message even if run-time predicate checking + is disabled. + * exp_ch6.adb (Expand_Simple_Function_Return): In testing + whether the returned expression is a function call, look for the + case where the call has been transformed into a dereference of + an access value that designates the result of a function call. + * sem_ch3.adb (Analyze_Object_Declaration): Legality checking + for a static expression is unaffected by assertion policy (and, + in particular, enabling/disabling of subtype predicates. To get + the right legality checking, we need to call + Check_Expression_Against_Static_Predicate for a static + expression even if predicate checking is disabled for the given + predicate-bearing subtype. On the other hand, we don't want to + call Make_Predicate_Check unless predicate checking is enabled. + * sem_ch7.adb (Uninstall_Declarations.Preserve_Full_Attributes): + Preserve the Predicates_Ignored attribute. + * sem_eval.adb (Check_Expression_Against_Static_Predicate): + Previously callers ensured that this procedure was only called + if predicate checking was enabled; that is no longer the case, + so predicates-disabled case must be handled. + * sem_prag.adb (Analyze_Pragma): Fix bug in setting + Predicates_Ignored attribute in Predicate pragma case. + +2020-10-15 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_Fixed_Point_Type): Do not scale the bounds + of a declared subtype using the 'Small of the type; this is + done during resolution of the bound itself, unlike what is done + for the bounds of the base type, which are used to determine its + required size. Previous code performed this scaling twice, + leading to meaningless values for such a subtype. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Bad_Predicated_Subtype_Use): Emit an + unconditional error, not a conditional warning. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Process_Subtype): Combine guards for + Null_Exclusion_Present in May_Have_Null_Exclusion; use this + combined guard when checking AI-231. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Process_Subtype): Sync May_Have_Null_Exclusion + with assertion in Null_Exclusion_Present; clarify the scope of + local variables. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Analyze_Subtype_Declaration): Fix style. + (Make_Index): Refactor to avoid repeated detection of subtype + indication; add comment. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Is_Acceptable_Dim3): Use Is_RTE to not pull CUDA + package unless necessary; rename local Tmp variable; iterate + with procedural Next. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Array_Type_Declaration): Refine type of a local + variable. + (Make_Index): Simplify to avoid assignment with a type entity + and then backtracking by reassigning to Empty; remove excessive + whitespace. + * sem_ch9.adb (Analyze_Entry_Body): Remove extra parens. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Access_Subprogram_Declaration): Remove extra + parens. + (Make_Index): Remove excessive calls to Is_Type. + +2020-10-15 Arnaud Charlet <charlet@adacore.com> + + * sem_util.adb (Enter_Name): Remove unnecessary conditions in + Enter_Name that come from the beginning of times. + +2020-10-15 Bob Duff <duff@adacore.com> + + * exp_ch6.adb (Expand_Simple_Function_Return): Remove DSP part + of comment, and reformat. + +2020-10-15 Boris Yakobowski <yakobowski@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): Do not expand + 'Initialized in CodePeer mode. + +2020-10-15 Arnaud Charlet <charlet@adacore.com> + + * sem_ch12.adb (Reset_Entity): Protect against malformed tree. + +2020-10-15 Arnaud Charlet <charlet@adacore.com> + + * sem_ch13.adb (Add_Predicates): Prevent analyzing twice the + same pragma in case an inner package references the type with a + predicate (as opposed to defining the type). + +2020-10-15 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/a-cfinve.adb (Int): Use subtype of Long_Long_Integer. + * libgnat/a-cofove.adb (Int): Likewise. + * libgnat/a-cgcaso.adb (T): Likewise. + * libgnat/a-cogeso.adb (T): Likewise. + * libgnat/g-debpoo.ads (Byte_Count): Use Long_Long_Integer'Size. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch12.adb: Replace list of N_Defining_... enumerations with + N_Entity. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.ads, sem_ch3.adb (Make_Index): Refined type of + parameter. + (Constrain_Index): Likewise. + (Array_Type_Declaration): Refine type of a local counter + variable; remove a trivially useless initialization. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Analyze_Subtype_Declaration): Recognize both + identifiers and expanded names; use high-level Is_Scalar_Type + instead of low-level membership test. + +2020-10-15 Arnaud Charlet <charlet@adacore.com> + + * sem_eval.adb (Eval_Intrinsic_Call, Fold_Shift): Add support + for Shift_Right_Arithmetic and for signed integers. + * exp_ch4.adb (Expand_N_Op_Rotate_Left, + Expand_N_Op_Rotate_Right, Expand_N_Op_Shift_Left, + Expand_N_Op_Shift_Right_Arithmetic): Minor reformatting and code + cleanup to ensure a consistent handling. Update comments and add + assertion. + +2020-10-15 Bob Duff <duff@adacore.com> + + * sem_ch13.adb (Visible_Component): Enable this code for task + and protected types, as well as record and private types. + * sem_ch13.ads (Replace_Type_References_Generic): Update + comment. Move the efficiency comment into the body, because + it's about the implementation. + +2020-10-15 Arnaud Charlet <charlet@adacore.com> + + * par-ch13.adb (Get_Aspect_Specifications): Generate a warning + rather than an error on unknown aspects unless -gnatd2 is used. + (Aspect_Specifications_Present): Improve detection of unknown + aspects. + * debug.adb (Debug_Flag_2): Update document. + +2020-10-15 Arnaud Charlet <charlet@adacore.com> + + * sem_res.adb (Resolve_Call): Do not try to inline intrinsic + calls. + +2020-10-15 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Expand_N_Aggregate): A record aggregate requires + a non-private type. + * sem_ch13.adb (Valid_Assign_Indexed): New subprogram local to + Resolve_Aspect_Aggregate, to handle the case when the + corresponding name appearing in the aspect specification for an + indexed aggregate is an overloaded operation. + * libgnat/a-convec.ads, libgnat/a-convec.adb, + libgnat/a-coinve.ads, libgnat/a-coinve.adb, + libgnat/a-cobove.ads, libgnat/a-cobove.adb, + libgnat/a-cdlili.ads, libgnat/a-cdlili.adb, + libgnat/a-cbdlli.ads, libgnat/a-cbdlli.adb, + libgnat/a-cohama.ads, libgnat/a-cihama.ads, + libgnat/a-cbhama.ads, libgnat/a-cborma.ads, + libgnat/a-ciorma.ads, libgnat/a-coorma.ads, + libgnat/a-cihase.ads, libgnat/a-cohase.ads, + libgnat/a-cbhase.ads, libgnat/a-cborse.ads, + libgnat/a-ciorse.ads, libgnat/a-coorse.ads: Add Ada_2020 aspect + Aggregate to types declared in standard containers, as well as + new subprograms where required. + +2020-10-15 Arnaud Charlet <charlet@adacore.com> + + * libgnat/g-arrspl.ads, libgnat/g-arrspl.adb (Create, + First_Cursor, Advance, Has_Element): New. + +2020-10-15 Arnaud Charlet <charlet@adacore.com> + + * Makefile.rtl: Add target pair for interfac.ads. + * libgnat/interfac.ads: Add a comment. + * libgnat/interfac__2020.ads: New, used for bootstrap purposes. + * sem_util.adb (Is_Static_Function): Always return False for pre + Ada 2020 to e.g. ignore the Static aspect in Interfaces for + Ada < 2020. + +2020-10-15 Piotr Trojanek <trojanek@adacore.com> + + * exp_util.adb (Remove_Side_Effects): Move special-casing for + GNATprove to be applied to all object declarations. + +2020-10-12 Alexandre Oliva <oliva@adacore.com> + + * libgnat/a-ngelfu.ads (Sin, Cos): Make the single-argument + functions inline. + +2020-10-11 Alexandre Oliva <oliva@adacore.com> + + * libgnat/a-numaux.ads: Make all imports Intrinsic. + * libgnat/a-numaux__darwin.ads: Likewise. + * libgnat/a-numaux__libc-x86.ads: Likewise. + * libgnat/a-numaux__vxworks.ads: Likewise. + +2020-09-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Subprogram_Body_to_gnu): Set the end locus + of body and declaration earlier. + +2020-09-28 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (maybe_saturate_size): Add ALIGN parameter + and round down the result to ALIGN. + (gnat_to_gnu_entity): Adjust calls to maybe_saturate_size. + 2020-09-14 Jakub Jelinek <jakub@redhat.com> * gcc-interface/trans.c (gigi): Adjust build_optimization_node diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index fc978a2..7b5b334 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -206,6 +206,9 @@ GNATRTL_NONTASKING_OBJS= \ a-llitio$(objext) \ a-lliwti$(objext) \ a-llizti$(objext) \ + a-llltio$(objext) \ + a-lllwti$(objext) \ + a-lllzti$(objext) \ a-locale$(objext) \ a-nbnbin$(objext) \ a-nbnbre$(objext) \ @@ -234,6 +237,13 @@ GNATRTL_NONTASKING_OBJS= \ a-nudira$(objext) \ a-nuelfu$(objext) \ a-nuflra$(objext) \ + a-nagefl$(objext) \ + a-nallfl$(objext) \ + a-nalofl$(objext) \ + a-nuaufl$(objext) \ + a-nashfl$(objext) \ + a-nuauco$(objext) \ + a-naliop$(objext) \ a-numaux$(objext) \ a-numeri$(objext) \ a-nurear$(objext) \ @@ -340,7 +350,6 @@ GNATRTL_NONTASKING_OBJS= \ a-tigeau$(objext) \ a-tiinau$(objext) \ a-tiinio$(objext) \ - a-timoau$(objext) \ a-timoio$(objext) \ a-tiocst$(objext) \ a-tirsfi$(objext) \ @@ -368,7 +377,6 @@ GNATRTL_NONTASKING_OBJS= \ a-wtgeau$(objext) \ a-wtinau$(objext) \ a-wtinio$(objext) \ - a-wtmoau$(objext) \ a-wtmoio$(objext) \ a-wttest$(objext) \ a-wwboio$(objext) \ @@ -392,7 +400,6 @@ GNATRTL_NONTASKING_OBJS= \ a-ztgeau$(objext) \ a-ztinau$(objext) \ a-ztinio$(objext) \ - a-ztmoau$(objext) \ a-ztmoio$(objext) \ a-zttest$(objext) \ a-zzboio$(objext) \ @@ -511,6 +518,7 @@ GNATRTL_NONTASKING_OBJS= \ s-aoinar$(objext) \ s-aomoar$(objext) \ s-aotase$(objext) \ + s-aridou$(objext) \ s-arit64$(objext) \ s-assert$(objext) \ s-atacco$(objext) \ @@ -575,6 +583,9 @@ GNATRTL_NONTASKING_OBJS= \ s-explli$(objext) \ s-expllu$(objext) \ s-expmod$(objext) \ + s-exponn$(objext) \ + s-expont$(objext) \ + s-exponu$(objext) \ s-expuns$(objext) \ s-fatflt$(objext) \ s-fatgen$(objext) \ @@ -593,6 +604,10 @@ GNATRTL_NONTASKING_OBJS= \ s-geveop$(objext) \ s-gloloc$(objext) \ s-htable$(objext) \ + s-imageb$(objext) \ + s-imagei$(objext) \ + s-imageu$(objext) \ + s-imagew$(objext) \ s-imenne$(objext) \ s-imgbiu$(objext) \ s-imgboo$(objext) \ @@ -727,6 +742,8 @@ GNATRTL_NONTASKING_OBJS= \ s-vallli$(objext) \ s-valllu$(objext) \ s-valrea$(objext) \ + s-valuei$(objext) \ + s-valueu$(objext) \ s-valuns$(objext) \ s-valuti$(objext) \ s-valwch$(objext) \ @@ -741,8 +758,12 @@ GNATRTL_NONTASKING_OBJS= \ s-widboo$(objext) \ s-widcha$(objext) \ s-widenu$(objext) \ + s-widint$(objext) \ s-widlli$(objext) \ s-widllu$(objext) \ + s-widthi$(objext) \ + s-widthu$(objext) \ + s-widuns$(objext) \ s-widwch$(objext) \ s-wwdcha$(objext) \ s-wwdenu$(objext) \ @@ -799,7 +820,7 @@ GNATLIB_SHARED = gnatlib # to LIBGNAT_TARGET_PAIRS. GNATRTL_SOCKETS_OBJS = g-soccon$(objext) g-socket$(objext) g-socthi$(objext) \ - g-soliop$(objext) g-sothco$(objext) + g-soliop$(objext) g-sothco$(objext) g-socpol$(objext) DUMMY_SOCKETS_TARGET_PAIRS = \ g-socket.adb<libgnat/g-socket__dummy.adb \ @@ -807,7 +828,9 @@ DUMMY_SOCKETS_TARGET_PAIRS = \ g-socthi.adb<libgnat/g-socthi__dummy.adb \ g-socthi.ads<libgnat/g-socthi__dummy.ads \ g-sothco.adb<libgnat/g-sothco__dummy.adb \ - g-sothco.ads<libgnat/g-sothco__dummy.ads + g-sothco.ads<libgnat/g-sothco__dummy.ads \ + g-socpol.adb<libgnat/g-socpol__dummy.adb \ + g-socpol.ads<libgnat/g-socpol__dummy.ads # On platforms where atomic increment/decrement operations are supported, # special version of Ada.Strings.Unbounded package can be used. @@ -834,13 +857,11 @@ ATOMICS_BUILTINS_TARGET_PAIRS = \ # Special version of units for x86 and x86-64 platforms. X86_TARGET_PAIRS = \ - a-numaux.ads<libgnat/a-numaux__libc-x86.ads \ - a-numaux.adb<libgnat/a-numaux__dummy.adb \ + a-nuauco.ads<libgnat/a-nuauco__x86.ads \ s-atocou.adb<libgnat/s-atocou__x86.adb X86_64_TARGET_PAIRS = \ - a-numaux.ads<libgnat/a-numaux__libc-x86.ads \ - a-numaux.adb<libgnat/a-numaux__dummy.adb \ + a-nuauco.ads<libgnat/a-nuauco__x86.ads \ s-atocou.adb<libgnat/s-atocou__builtin.adb # Implementation of symbolic traceback based on dwarf @@ -862,6 +883,97 @@ TRASYM_DWARF_UNIX_OBJS = $(TRASYM_DWARF_COMMON_OBJS) s-mmauni$(objext) TRASYM_DWARF_MINGW_OBJS = $(TRASYM_DWARF_COMMON_OBJS) +GNATRTL_128BIT_PAIRS = \ + a-tiinio.adb<libgnat/a-tiinio__128.adb \ + a-timoio.adb<libgnat/a-timoio__128.adb \ + a-wtinio.adb<libgnat/a-wtinio__128.adb \ + a-wtmoio.adb<libgnat/a-wtmoio__128.adb \ + a-ztinio.adb<libgnat/a-ztinio__128.adb \ + a-ztmoio.adb<libgnat/a-ztmoio__128.adb \ + i-cexten.ads<libgnat/i-cexten__128.ads \ + s-scaval.ads<libgnat/s-scaval__128.ads \ + s-scaval.adb<libgnat/s-scaval__128.adb + +# Objects needed for 128-bit types +GNATRTL_128BIT_OBJS = \ + s-arit128$(objext) \ + s-casi128$(objext) \ + s-caun128$(objext) \ + s-exnllli$(objext) \ + s-expllli$(objext) \ + s-explllu$(objext) \ + s-imglllb$(objext) \ + s-imgllli$(objext) \ + s-imglllu$(objext) \ + s-imglllw$(objext) \ + s-pack65$(objext) \ + s-pack66$(objext) \ + s-pack67$(objext) \ + s-pack68$(objext) \ + s-pack69$(objext) \ + s-pack70$(objext) \ + s-pack71$(objext) \ + s-pack72$(objext) \ + s-pack73$(objext) \ + s-pack74$(objext) \ + s-pack75$(objext) \ + s-pack76$(objext) \ + s-pack77$(objext) \ + s-pack78$(objext) \ + s-pack79$(objext) \ + s-pack80$(objext) \ + s-pack81$(objext) \ + s-pack82$(objext) \ + s-pack83$(objext) \ + s-pack84$(objext) \ + s-pack85$(objext) \ + s-pack86$(objext) \ + s-pack87$(objext) \ + s-pack88$(objext) \ + s-pack89$(objext) \ + s-pack90$(objext) \ + s-pack91$(objext) \ + s-pack92$(objext) \ + s-pack93$(objext) \ + s-pack94$(objext) \ + s-pack95$(objext) \ + s-pack96$(objext) \ + s-pack97$(objext) \ + s-pack98$(objext) \ + s-pack99$(objext) \ + s-pack100$(objext) \ + s-pack101$(objext) \ + s-pack102$(objext) \ + s-pack103$(objext) \ + s-pack104$(objext) \ + s-pack105$(objext) \ + s-pack106$(objext) \ + s-pack107$(objext) \ + s-pack108$(objext) \ + s-pack109$(objext) \ + s-pack110$(objext) \ + s-pack111$(objext) \ + s-pack112$(objext) \ + s-pack113$(objext) \ + s-pack114$(objext) \ + s-pack115$(objext) \ + s-pack116$(objext) \ + s-pack117$(objext) \ + s-pack118$(objext) \ + s-pack119$(objext) \ + s-pack120$(objext) \ + s-pack121$(objext) \ + s-pack122$(objext) \ + s-pack123$(objext) \ + s-pack124$(objext) \ + s-pack125$(objext) \ + s-pack126$(objext) \ + s-pack127$(objext) \ + s-valllli$(objext) \ + s-vallllu$(objext) \ + s-widllli$(objext) \ + s-widlllu$(objext) + # Shared library version LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(GNAT_SRC)/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/')) @@ -916,7 +1028,9 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7% vxworks7spe LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__vxworks.ads \ - a-numaux.ads<libgnat/a-numaux__vxworks.ads \ + a-naliop.ads<libgnat/a-naliop__nolibm.ads \ + a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \ + a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ s-intman.ads<libgnarl/s-intman__vxworks.ads \ s-intman.adb<libgnarl/s-intman__vxworks.adb \ @@ -931,6 +1045,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7% vxworks7spe s-vxwork.ads<libgnarl/s-vxwork__ppc.ads \ g-socthi.ads<libgnat/g-socthi__vxworks.ads \ g-socthi.adb<libgnat/g-socthi__vxworks.adb \ + g-sopowa.adb<libgnat/g-sopowa__posix.adb \ g-stsifd.adb<libgnat/g-stsifd__sockets.adb \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) @@ -949,6 +1064,11 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7% vxworks7spe EXTRA_GNATRTL_NONTASKING_OBJS+=s-stchop.o endif + ifeq ($(strip $(filter-out powerpc64, $(target_cpu))),) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + TOOLS_TARGET_PAIRS=indepsw.adb<indepsw-gnu.adb ifeq ($(strip $(filter-out rtp,$(THREAD_KIND))),) @@ -1039,7 +1159,9 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae vxworksaespe,$(target_cpu) $(t LIBGNAT_TARGET_PAIRS = \ a-elchha.adb<libgnat/a-elchha__vxworks-ppc-full.adb \ a-intnam.ads<libgnarl/a-intnam__vxworks.ads \ - a-numaux.ads<libgnat/a-numaux__vxworks.ads \ + a-naliop.ads<libgnat/a-naliop__nolibm.ads \ + a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \ + a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ g-io.adb<hie/g-io__vxworks-cert.adb \ s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ s-interr.adb<libgnarl/s-interr__vxworks.adb \ @@ -1084,6 +1206,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae vxworksaespe,$(target_cpu) $(t LIBGNAT_TARGET_PAIRS += \ g-socthi.ads<libgnat/g-socthi__vxworks.ads \ g-socthi.adb<libgnat/g-socthi__vxworks.adb \ + g-sopowa.adb<libgnat/g-sopowa__posix.adb \ g-stsifd.adb<libgnat/g-stsifd__sockets.adb endif @@ -1095,7 +1218,9 @@ ifeq ($(strip $(filter-out %86 wrs vxworksae,$(target_cpu) $(target_vendor) $(ta LIBGNAT_TARGET_PAIRS = \ a-elchha.adb<libgnat/a-elchha__vxworks-ppc-full.adb \ a-intnam.ads<libgnarl/a-intnam__vxworks.ads \ - a-numaux.ads<libgnat/a-numaux__vxworks.ads \ + a-naliop.ads<libgnat/a-naliop__nolibm.ads \ + a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \ + a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ g-io.adb<hie/g-io__vxworks-cert.adb \ s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ s-interr.adb<libgnarl/s-interr__vxworks.adb \ @@ -1140,6 +1265,7 @@ ifeq ($(strip $(filter-out %86 wrs vxworksae,$(target_cpu) $(target_vendor) $(ta LIBGNAT_TARGET_PAIRS += \ g-socthi.ads<libgnat/g-socthi__vxworks.ads \ g-socthi.adb<libgnat/g-socthi__vxworks.adb \ + g-sopowa.adb<libgnat/g-sopowa__posix.adb \ g-stsifd.adb<libgnat/g-stsifd__sockets.adb endif @@ -1148,22 +1274,12 @@ endif # x86/x86_64 VxWorks ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(target_vendor) $(target_os))),) - EH_MECHANISM=-gcc - - VX=$(strip $(if $(filter vxworks7%, $(target_os)), vxworks7, vxworks)) - SVX=system-$(VX) - - ifeq ($(strip $(filter-out x86_64, $(target_cpu))),) - X86CPU=x86_64 - LIBGNAT_TARGET_PAIRS=$(X86_64_TARGET_PAIRS) - else - X86CPU=x86 - LIBGNAT_TARGET_PAIRS=$(X86_TARGET_PAIRS) - endif - - LIBGNAT_TARGET_PAIRS+= \ + LIBGNAT_TARGET_PAIRS= \ a-intnam.ads<libgnarl/a-intnam__vxworks.ads \ i-vxwork.ads<libgnat/i-vxwork__x86.ads \ + a-naliop.ads<libgnat/a-naliop__nolibm.ads \ + a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \ + a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ s-osinte.adb<libgnarl/s-osinte__vxworks.adb \ s-osinte.ads<libgnarl/s-osinte__vxworks.ads \ s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ @@ -1180,11 +1296,27 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(targ s-vxwork.ads<libgnarl/s-vxwork__x86.ads \ g-socthi.ads<libgnat/g-socthi__vxworks.ads \ g-socthi.adb<libgnat/g-socthi__vxworks.adb \ + g-sopowa.adb<libgnat/g-sopowa__posix.adb \ g-stsifd.adb<libgnat/g-stsifd__sockets.adb \ $(ATOMICS_TARGET_PAIRS) + VX=$(strip $(if $(filter vxworks7%, $(target_os)), vxworks7, vxworks)) + SVX=system-$(VX) + + ifeq ($(strip $(filter-out x86_64, $(target_cpu))),) + X86CPU=x86_64 + LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + else + X86CPU=x86 + LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS) + endif + TOOLS_TARGET_PAIRS=indepsw.adb<indepsw-gnu.adb + EH_MECHANISM=-gcc + # The CPU setting for VxSim varies with the # host (Windows or Linux) # target (VxWorks6 or VxWorks7) @@ -1264,7 +1396,7 @@ ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(targ endif endif - EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o + EXTRA_GNATRTL_NONTASKING_OBJS += i-vxwork.o i-vxwoio.o endif endif @@ -1288,11 +1420,38 @@ endif # ARM and Aarch64 VxWorks ifeq ($(strip $(filter-out aarch64 arm% coff wrs vx%,$(target_cpu) $(target_vendor) $(target_os))),) + LIBGNAT_TARGET_PAIRS = \ + a-intnam.ads<libgnarl/a-intnam__vxworks.ads \ + a-naliop.ads<libgnat/a-naliop__nolibm.ads \ + a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \ + a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ + s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ + s-interr.adb<libgnarl/s-interr__vxworks.adb \ + s-intman.ads<libgnarl/s-intman__vxworks.ads \ + s-intman.adb<libgnarl/s-intman__vxworks.adb \ + s-osinte.adb<libgnarl/s-osinte__vxworks.adb \ + s-osinte.ads<libgnarl/s-osinte__vxworks.ads \ + s-osprim.adb<libgnat/s-osprim__vxworks.adb \ + s-parame.ads<libgnat/s-parame__vxworks.ads \ + s-parame.adb<libgnat/s-parame__vxworks.adb \ + s-stchop.ads<libgnat/s-stchop__limit.ads \ + s-stchop.adb<libgnat/s-stchop__vxworks.adb \ + s-taprop.adb<libgnarl/s-taprop__vxworks.adb \ + s-tasinf.ads<libgnarl/s-tasinf__vxworks.ads \ + s-taspri.ads<libgnarl/s-taspri__vxworks.ads \ + g-socthi.ads<libgnat/g-socthi__vxworks.ads \ + g-socthi.adb<libgnat/g-socthi__vxworks.adb \ + g-sopowa.adb<libgnat/g-sopowa__posix.adb \ + g-stsifd.adb<libgnat/g-stsifd__sockets.adb + ifeq ($(strip $(filter-out aarch64, $(target_cpu))),) ARCH_STR=aarch64 VX=vxworks7 EH_MECHANISM=-gcc SIGTRAMP_OBJ=sigtramp-vxworks.o + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) else ifeq ($(strip $(filter-out arm%, $(target_cpu))),) ARCH_STR=arm @@ -1310,29 +1469,9 @@ ifeq ($(strip $(filter-out aarch64 arm% coff wrs vx%,$(target_cpu) $(target_vend endif endif - SVX=system-$(VX) + LIBGNAT_TARGET_PAIRS += s-vxwork.ads<libgnarl/s-vxwork__$(ARCH_STR).ads - LIBGNAT_TARGET_PAIRS = \ - a-intnam.ads<libgnarl/a-intnam__vxworks.ads \ - a-numaux.ads<libgnat/a-numaux__vxworks.ads \ - s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \ - s-interr.adb<libgnarl/s-interr__vxworks.adb \ - s-intman.ads<libgnarl/s-intman__vxworks.ads \ - s-intman.adb<libgnarl/s-intman__vxworks.adb \ - s-osinte.adb<libgnarl/s-osinte__vxworks.adb \ - s-osinte.ads<libgnarl/s-osinte__vxworks.ads \ - s-osprim.adb<libgnat/s-osprim__vxworks.adb \ - s-parame.ads<libgnat/s-parame__vxworks.ads \ - s-parame.adb<libgnat/s-parame__vxworks.adb \ - s-stchop.ads<libgnat/s-stchop__limit.ads \ - s-stchop.adb<libgnat/s-stchop__vxworks.adb \ - s-taprop.adb<libgnarl/s-taprop__vxworks.adb \ - s-tasinf.ads<libgnarl/s-tasinf__vxworks.ads \ - s-taspri.ads<libgnarl/s-taspri__vxworks.ads \ - s-vxwork.ads<libgnarl/s-vxwork__$(ARCH_STR).ads \ - g-socthi.ads<libgnat/g-socthi__vxworks.ads \ - g-socthi.adb<libgnat/g-socthi__vxworks.adb \ - g-stsifd.adb<libgnat/g-stsifd__sockets.adb + SVX=system-$(VX) TOOLS_TARGET_PAIRS=indepsw.adb<indepsw-gnu.adb @@ -1377,9 +1516,8 @@ ifeq ($(strip $(filter-out aarch64 arm% coff wrs vx%,$(target_cpu) $(target_vend endif endif - EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o \ - s-stchop.o - EXTRA_GNATRTL_TASKING_OBJS=i-vxinco.o s-vxwork.o s-vxwext.o + EXTRA_GNATRTL_NONTASKING_OBJS += i-vxwork.o i-vxwoio.o s-stchop.o + EXTRA_GNATRTL_TASKING_OBJS += i-vxinco.o s-vxwork.o s-vxwext.o EXTRA_LIBGNAT_OBJS+=vx_stack_info.o @@ -1429,6 +1567,7 @@ endif ifeq ($(strip $(filter-out aarch64 %qnx,$(target_cpu) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__qnx.ads \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-intman.adb<libgnarl/s-intman__qnx.adb \ s-osinte.adb<libgnarl/s-osinte__qnx.adb \ @@ -1441,10 +1580,12 @@ ifeq ($(strip $(filter-out aarch64 %qnx,$(target_cpu) $(target_os))),) g-soliop.ads<libgnat/g-soliop__qnx.ads \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) \ system.ads<libgnat/system-qnx-aarch64.ads TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb + EXTRA_GNATRTL_NONTASKING_OBJS = $(GNATRTL_128BIT_OBJS) EXTRA_GNATRTL_TASKING_OBJS=s-qnx.o EXTRA_LIBGNAT_OBJS+=sigtramp-qnx.o EXTRA_LIBGNAT_SRCS+=sigtramp.h @@ -1457,10 +1598,11 @@ ifeq ($(strip $(filter-out aarch64 %qnx,$(target_cpu) $(target_os))),) LIBRARY_VERSION := $(LIB_VERSION) endif -# Sparc Solaris +# SPARC Solaris ifeq ($(strip $(filter-out sparc% sun solaris%,$(target_cpu) $(target_vendor) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__solaris.ads \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-intman.adb<libgnarl/s-intman__solaris.adb \ s-mudido.adb<libgnarl/s-mudido__affinity.adb \ @@ -1480,6 +1622,18 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(target_cpu) $(target_vendor) $( EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS) + ifeq ($(strip $(filter-out sparc64 sparcv9,$(target_cpu))),) + ifneq ($(strip $(MULTISUBDIR)),/sparcv8plus) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + else + ifeq ($(strip $(MULTISUBDIR)),/sparcv9) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + endif + EH_MECHANISM=-gcc THREADSLIB = -lposix4 -lthread MISCLIB = -lposix4 -lnsl -lsocket @@ -1489,7 +1643,7 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(target_cpu) $(target_vendor) $( LIBRARY_VERSION := $(LIB_VERSION) endif -# x86 and x86-64 solaris +# x86 and x86-64 Solaris ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(target_cpu) $(target_os))),) LIBGNAT_TARGET_PAIRS_COMMON = \ a-intnam.ads<libgnarl/a-intnam__solaris.ads \ @@ -1513,6 +1667,8 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(target_cpu) $(target_os))),) ifeq ($(strip $(MULTISUBDIR)),/amd64) LIBGNAT_TARGET_PAIRS = \ $(LIBGNAT_TARGET_PAIRS_COMMON) $(X86_64_TARGET_PAIRS) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) else LIBGNAT_TARGET_PAIRS = \ $(LIBGNAT_TARGET_PAIRS_COMMON) $(X86_TARGET_PAIRS) @@ -1524,6 +1680,8 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(target_cpu) $(target_os))),) else LIBGNAT_TARGET_PAIRS = \ $(LIBGNAT_TARGET_PAIRS_COMMON) $(X86_64_TARGET_PAIRS) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) endif endif @@ -1559,6 +1717,8 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),) ifeq ($(strip $(MULTISUBDIR)),/64) LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) else LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS) endif @@ -1648,8 +1808,6 @@ endif ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__freebsd.ads \ - a-numaux.ads<libgnat/a-numaux__libc-x86.ads \ - a-numaux.adb<libgnat/a-numaux__dummy.adb \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-intman.adb<libgnarl/s-intman__posix.adb \ s-osinte.adb<libgnarl/s-osinte__posix.adb \ @@ -1658,8 +1816,13 @@ ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),) s-taprop.adb<libgnarl/s-taprop__posix.adb \ s-taspri.ads<libgnarl/s-taspri__posix.ads \ s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \ + $(ATOMICS_TARGET_PAIRS) \ + $(X86_64_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) \ system.ads<libgnat/system-freebsd.ads + EXTRA_GNATRTL_NONTASKING_OBJS = $(GNATRTL_128BIT_OBJS) + TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb EH_MECHANISM=-gcc @@ -1673,6 +1836,7 @@ endif ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__freebsd.ads \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-intman.adb<libgnarl/s-intman__posix.adb \ s-mudido.adb<libgnarl/s-mudido__affinity.adb \ @@ -1684,8 +1848,11 @@ ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),) s-tpopsp.adb<libgnarl/s-tpopsp__posix.adb \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) \ system.ads<libgnat/system-freebsd.ads + EXTRA_GNATRTL_NONTASKING_OBJS = $(GNATRTL_128BIT_OBJS) + GNATLIB_SHARED = gnatlib-shared-dual EH_MECHANISM=-gcc @@ -1741,12 +1908,14 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(target_cpu) $(target_os))),) $(TRASYM_DWARF_UNIX_PAIRS) \ $(ATOMICS_TARGET_PAIRS) \ $(X86_64_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) \ system.ads<libgnat/system-freebsd.ads GNATLIB_SHARED = gnatlib-shared-dual EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) EH_MECHANISM=-gcc THREADSLIB= -lpthread @@ -1770,11 +1939,13 @@ ifeq ($(strip $(filter-out %86_64 dragonfly%,$(target_cpu) $(target_os))),) s-tpopsp.adb<libgnarl/s-tpopsp__posix.adb \ $(ATOMICS_TARGET_PAIRS) \ $(X86_64_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) \ system.ads<libgnat/system-dragonfly-x86_64.ads GNATLIB_SHARED = gnatlib-shared-dual - EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) EH_MECHANISM=-gcc THREADSLIB= -lpthread @@ -1787,6 +1958,7 @@ endif ifeq ($(strip $(filter-out s390% linux%,$(target_cpu) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-intman.adb<libgnarl/s-intman__posix.adb \ s-linux.ads<libgnarl/s-linux.ads \ @@ -1800,6 +1972,18 @@ ifeq ($(strip $(filter-out s390% linux%,$(target_cpu) $(target_os))),) s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \ system.ads<libgnat/system-linux-s390.ads + ifeq ($(strip $(filter-out s390x,$(target_cpu))),) + ifneq ($(strip $(MULTISUBDIR)),/32) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + else + ifeq ($(strip $(MULTISUBDIR)),/64) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + endif + TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb EXTRA_GNATRTL_TASKING_OBJS=s-linux.o @@ -1812,7 +1996,6 @@ endif # HP/PA HP-UX 10 ifeq ($(strip $(filter-out hppa% hp hpux10%,$(target_cpu) $(target_vendor) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ - a-excpol.adb<libgnat/a-excpol__abort.adb \ a-intnam.ads<libgnarl/a-intnam__hpux.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-interr.adb<libgnarl/s-interr__sigaction.adb \ @@ -1897,6 +2080,9 @@ ifeq ($(strip $(filter-out lynxos178%,$(target_os))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__lynxos.ads \ + a-nuaufl.ads<libgnat/a-nuaufl__wraplf.ads \ + a-nashfl.ads<libgnat/a-nashfl__wraplf.ads \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ g-soliop.ads<libgnat/g-soliop__lynxos.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-intman.adb<libgnarl/s-intman__lynxos.adb \ @@ -1988,11 +2174,11 @@ ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),) else LIBGNAT_TARGET_PAIRS = \ g-socthi.ads<libgnat/g-socthi__mingw.ads \ - g-socthi.adb<libgnat/g-socthi__mingw.adb + g-socthi.adb<libgnat/g-socthi__mingw.adb \ + g-sopowa.adb<libgnat/g-sopowa__mingw.adb endif LIBGNAT_TARGET_PAIRS += \ a-dirval.adb<libgnat/a-dirval__mingw.adb \ - a-excpol.adb<libgnat/a-excpol__abort.adb \ s-gloloc.adb<libgnat/s-gloloc__mingw.adb \ s-inmaop.adb<libgnarl/s-inmaop__dummy.adb \ s-taspri.ads<libgnarl/s-taspri__mingw.ads \ @@ -2022,12 +2208,14 @@ ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),) LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS) SO_OPTS= -m32 -Wl,-soname, else - LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS) + LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS) $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) SO_OPTS = -m64 -Wl,-soname, endif else ifeq ($(strip $(MULTISUBDIR)),/64) - LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS) + LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS) $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) SO_OPTS = -m64 -Wl,-soname, else LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS) @@ -2086,10 +2274,11 @@ endif # PowerPC and e500v2 Linux ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),) - LIBGNAT_TARGET_PAIRS_COMMON = \ + LIBGNAT_TARGET_PAIRS = \ a-exetim.adb<libgnarl/a-exetim__posix.adb \ a-exetim.ads<libgnarl/a-exetim__default.ads \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ a-synbar.adb<libgnarl/a-synbar__posix.adb \ a-synbar.ads<libgnarl/a-synbar__posix.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -2097,21 +2286,30 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),) s-linux.ads<libgnarl/s-linux.ads \ s-osinte.adb<libgnarl/s-osinte__posix.adb \ s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \ + s-mudido.adb<libgnarl/s-mudido__affinity.adb \ + s-osinte.ads<libgnarl/s-osinte__linux.ads \ + s-osprim.adb<libgnat/s-osprim__posix.adb \ + s-taprop.adb<libgnarl/s-taprop__linux.adb \ + s-tasinf.ads<libgnarl/s-tasinf__linux.ads \ + s-tasinf.adb<libgnarl/s-tasinf__linux.adb \ + s-taspri.ads<libgnarl/s-taspri__posix.ads \ $(TRASYM_DWARF_UNIX_PAIRS) \ s-tsmona.adb<libgnat/s-tsmona__linux.adb \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ system.ads<libgnat/system-linux-ppc.ads - LIBGNAT_TARGET_PAIRS = \ - $(LIBGNAT_TARGET_PAIRS_COMMON) \ - s-mudido.adb<libgnarl/s-mudido__affinity.adb \ - s-osinte.ads<libgnarl/s-osinte__linux.ads \ - s-osprim.adb<libgnat/s-osprim__posix.adb \ - s-taprop.adb<libgnarl/s-taprop__linux.adb \ - s-tasinf.ads<libgnarl/s-tasinf__linux.ads \ - s-tasinf.adb<libgnarl/s-tasinf__linux.adb \ - s-taspri.ads<libgnarl/s-taspri__posix-noaltstack.ads + ifeq ($(strip $(filter-out powerpc64,$(target_cpu))),) + ifneq ($(strip $(MULTISUBDIR)),/32) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + else + ifeq ($(strip $(MULTISUBDIR)),/64) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + endif TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb @@ -2161,6 +2359,7 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),) a-exetim.adb<libgnarl/a-exetim__posix.adb \ a-exetim.ads<libgnarl/a-exetim__default.ads \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ a-synbar.adb<libgnarl/a-synbar__posix.adb \ a-synbar.ads<libgnarl/a-synbar__posix.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -2177,10 +2376,12 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),) s-taspri.ads<libgnarl/s-taspri__posix.ads \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) \ system.ads<libgnat/system-linux-arm.ads TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb + EXTRA_GNATRTL_NONTASKING_OBJS = $(GNATRTL_128BIT_OBJS) EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o EH_MECHANISM=-gcc THREADSLIB=-lpthread -lrt @@ -2189,10 +2390,11 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),) LIBRARY_VERSION := $(LIB_VERSION) endif -# Sparc Linux +# SPARC Linux ifeq ($(strip $(filter-out sparc% linux%,$(target_cpu) $(target_os))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ s-intman.adb<libgnarl/s-intman__posix.adb \ s-linux.ads<libgnarl/s-linux__sparc.ads \ @@ -2206,6 +2408,18 @@ ifeq ($(strip $(filter-out sparc% linux%,$(target_cpu) $(target_os))),) s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \ system.ads<libgnat/system-linux-sparc.ads + ifeq ($(strip $(filter-out sparc64 sparcv9,$(target_cpu))),) + ifneq ($(strip $(MULTISUBDIR)),/32) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + else + ifeq ($(strip $(MULTISUBDIR)),/64) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + endif + TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb EXTRA_GNATRTL_TASKING_OBJS=s-linux.o @@ -2304,7 +2518,7 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(target_cpu) $(target_os))),) a-exetim.adb<libgnarl/a-exetim__posix.adb \ a-exetim.ads<libgnarl/a-exetim__default.ads \ a-intnam.ads<libgnarl/a-intnam__linux.ads \ - a-numaux.ads<libgnat/a-numaux__libc-x86.ads \ + a-nuauco.ads<libgnat/a-nuauco__x86.ads \ a-synbar.adb<libgnarl/a-synbar__posix.adb \ a-synbar.ads<libgnarl/a-synbar__posix.ads \ s-inmaop.adb<libgnarl/s-inmaop__posix.adb \ @@ -2323,11 +2537,13 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(target_cpu) $(target_os))),) s-tsmona.adb<libgnat/s-tsmona__linux.adb \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) \ system.ads<libgnat/system-linux-ia64.ads TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o EH_MECHANISM=-gcc THREADSLIB=-lpthread -lrt @@ -2352,9 +2568,11 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(target_cpu) $(target_vendor) $(targe $(TRASYM_DWARF_UNIX_PAIRS) \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) \ system.ads<libgnat/system-hpux-ia64.ads EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) MISCLIB= EH_MECHANISM=-gcc @@ -2383,10 +2601,12 @@ ifeq ($(strip $(filter-out alpha% linux%,$(target_cpu) $(target_os))),) s-taspri.ads<libgnarl/s-taspri__posix-noaltstack.ads \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) \ system.ads<libgnat/system-linux-alpha.ads TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb + EXTRA_GNATRTL_NONTASKING_OBJS = $(GNATRTL_128BIT_OBJS) EXTRA_GNATRTL_TASKING_OBJS=s-linux.o EH_MECHANISM=-gcc MISCLIB= @@ -2419,12 +2639,14 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),) s-tsmona.adb<libgnat/s-tsmona__linux.adb \ $(ATOMICS_TARGET_PAIRS) \ $(X86_64_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) \ system.ads<libgnat/system-linux-x86.ads TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o EXTRA_GNATRTL_NONTASKING_OBJS += $(TRASYM_DWARF_UNIX_OBJS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o EH_MECHANISM=-gcc @@ -2488,6 +2710,18 @@ ifeq ($(strip $(filter-out riscv% linux%,$(target_cpu) $(target_os))),) s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \ system.ads<libgnat/system-linux-riscv.ads + ifeq ($(strip $(filter-out riscv64,$(target_cpu))),) + ifneq ($(strip $(MULTISUBDIR)),/lib32) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + else + ifeq ($(strip $(MULTISUBDIR)),/lib64) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) + endif + endif + TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb EXTRA_GNATRTL_TASKING_OBJS=s-linux.o @@ -2521,11 +2755,13 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),) ifeq ($(strip $(MULTISUBDIR)),/x86_64) SO_OPTS += -m64 LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) else LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS) endif - EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o endif ifeq ($(strip $(filter-out %x86_64,$(target_cpu))),) @@ -2542,18 +2778,19 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),) LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS) else LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS) + LIBGNAT_TARGET_PAIRS += $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) endif - EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o EXTRA_GNATRTL_TASKING_OBJS=a-exetim.o endif ifeq ($(strip $(filter-out powerpc%,$(target_cpu))),) LIBGNAT_TARGET_PAIRS += \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ s-intman.adb<libgnarl/s-intman__posix.adb \ s-osprim.adb<libgnat/s-osprim__posix.adb \ - a-numaux.ads<libgnat/a-numaux__darwin.ads \ - a-numaux.adb<libgnat/a-numaux__darwin.adb \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ system.ads<libgnat/system-darwin-ppc.ads @@ -2576,11 +2813,14 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),) ifeq ($(strip $(filter-out arm64 aarch64,$(target_cpu))),) LIBGNAT_TARGET_PAIRS += \ + a-nallfl.ads<libgnat/a-nallfl__wraplf.ads \ s-intman.adb<libgnarl/s-intman__susv3.adb \ s-osprim.adb<libgnat/s-osprim__darwin.adb \ $(ATOMICS_TARGET_PAIRS) \ - $(ATOMICS_BUILTINS_TARGET_PAIRS) + $(ATOMICS_BUILTINS_TARGET_PAIRS) \ + $(GNATRTL_128BIT_PAIRS) + EXTRA_GNATRTL_NONTASKING_OBJS += $(GNATRTL_128BIT_OBJS) EXTRA_LIBGNAT_OBJS+=sigtramp-ios.o EXTRA_LIBGNAT_SRCS+=sigtramp.h LIBGNAT_TARGET_PAIRS += \ @@ -2618,6 +2858,9 @@ ifeq ($(strip $(filter-out linux%,$(target_os))),) g-sercom.adb<libgnat/g-sercom__linux.adb endif +LIBGNAT_TARGET_PAIRS += \ + interfac.ads<libgnat/interfac__2020.ads + # LIBGNAT_SRCS is the list of all C files (including headers) of the runtime # library. LIBGNAT_OBJS is the list of object files for libgnat. # thread.c is special as put into GNATRTL_TASKING_OBJS diff --git a/gcc/ada/ada_get_targ.adb b/gcc/ada/ada_get_targ.adb index cb2d81f..ddaca1a 100644 --- a/gcc/ada/ada_get_targ.adb +++ b/gcc/ada/ada_get_targ.adb @@ -100,6 +100,15 @@ package body Get_Targ is return 64; end Get_Long_Long_Size; + ----------------------------- + -- Get_Long_Long_Long_Size -- + ----------------------------- + + function Get_Long_Long_Long_Size return Pos is + begin + return 64; + end Get_Long_Long_Long_Size; + ---------------------- -- Get_Pointer_Size -- ---------------------- @@ -118,15 +127,6 @@ package body Get_Targ is return 4; end Get_Maximum_Alignment; - ------------------------------------ - -- Get_System_Allocator_Alignment -- - ------------------------------------ - - function Get_System_Allocator_Alignment return Nat is - begin - return 1; - end Get_System_Allocator_Alignment; - ------------------------ -- Get_Float_Words_BE -- ------------------------ @@ -181,6 +181,15 @@ package body Get_Targ is return 1; end Get_Strict_Alignment; + ------------------------------------ + -- Get_System_Allocator_Alignment -- + ------------------------------------ + + function Get_System_Allocator_Alignment return Nat is + begin + return 1; + end Get_System_Allocator_Alignment; + -------------------------------- -- Get_Double_Float_Alignment -- -------------------------------- @@ -199,15 +208,6 @@ package body Get_Targ is return 0; end Get_Double_Scalar_Alignment; - ----------------------------- - -- Get_Max_Unaligned_Field -- - ----------------------------- - - function Get_Max_Unaligned_Field return Pos is - begin - return 64; -- Can be different on some targets (e.g., AAMP) - end Get_Max_Unaligned_Field; - ---------------------- -- Digits_From_Size -- ---------------------- @@ -225,6 +225,15 @@ package body Get_Targ is end Digits_From_Size; ----------------------------- + -- Get_Max_Unaligned_Field -- + ----------------------------- + + function Get_Max_Unaligned_Field return Pos is + begin + return 64; -- Can be different on some targets (e.g., AAMP) + end Get_Max_Unaligned_Field; + + ----------------------------- -- Register_Back_End_Types -- ----------------------------- @@ -255,13 +264,14 @@ package body Get_Targ is -- Width_From_Size -- --------------------- - function Width_From_Size (Size : Pos) return Pos is + function Width_From_Size (Size : Pos) return Pos is begin case Size is - when 8 => return 4; - when 16 => return 6; - when 32 => return 11; - when 64 => return 21; + when 8 => return 4; + when 16 => return 6; + when 32 => return 11; + when 64 => return 21; + when 128 => return 40; when others => raise Program_Error; end case; end Width_From_Size; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index c44d193..560f352 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -60,6 +60,7 @@ /* We want to use the POSIX variants of include files. */ #define POSIX #include "vxWorks.h" +#include <sys/time.h> #if defined (__mips_vxworks) #include "cacheLib.h" @@ -236,6 +237,11 @@ UINT __gnat_current_ccs_encoding; #include "adaint.h" +#if defined (__APPLE__) && defined (st_mtime) +#define st_atim st_atimespec +#define st_mtim st_mtimespec +#endif + /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not defined in the current system. On DOS-like systems these flags control whether the file is opened/created in text-translation mode (CR/LF in @@ -1474,6 +1480,84 @@ __gnat_file_time_fd (int fd) return __gnat_file_time_fd_attr (fd, &attr); } +extern long long __gnat_file_time(char* name) +{ + long long result; + + if (name == NULL) { + return LLONG_MIN; + } + /* Number of seconds between <Jan 1st 1970> and <Jan 1st 2150>. */ + static const long long ada_epoch_offset = (136 * 365 + 44 * 366) * 86400LL; +#if defined(_WIN32) + + /* Number of 100 nanoseconds between <Jan 1st 1601> and <Jan 1st 2150>. */ + static const long long w32_epoch_offset = + (11644473600LL + ada_epoch_offset) * 1E7; + + WIN32_FILE_ATTRIBUTE_DATA fad; + union + { + FILETIME ft_time; + long long ll_time; + } t_write; + + if (!GetFileAttributesExA(name, GetFileExInfoStandard, &fad)) { + return LLONG_MIN; + } + + t_write.ft_time = fad.ftLastWriteTime; + +#if defined(__GNUG__) && __GNUG__ <= 4 + result = (t_write.ll_time - w32_epoch_offset) * 100; +#else + /* Next code similar to (t_write.ll_time - w32_epoch_offset) * 100 + but on overflow returns LLONG_MIN value. */ + + if (__builtin_ssubll_overflow(t_write.ll_time, w32_epoch_offset, &result)) { + return LLONG_MIN; + } + + if (__builtin_smulll_overflow(result, 100, &result)) { + return LLONG_MIN; + } +#endif + +#else + + struct stat sb; + if (stat(name, &sb) != 0) { + return LLONG_MIN; + } + +#if defined(__GNUG__) && __GNUG__ <= 4 + result = (sb.st_mtime - ada_epoch_offset) * 1E9; +#if defined(st_mtime) + result += sb.st_mtim.tv_nsec; +#endif +#else + /* Next code similar to + (sb.st_mtime - ada_epoch_offset) * 1E9 + sb.st_mtim.tv_nsec + but on overflow returns LLONG_MIN value. */ + + if (__builtin_ssubll_overflow(sb.st_mtime, ada_epoch_offset, &result)) { + return LLONG_MIN; + } + + if (__builtin_smulll_overflow(result, 1E9, &result)) { + return LLONG_MIN; + } + +#if defined(st_mtime) + if (__builtin_saddll_overflow(result, sb.st_mtim.tv_nsec, &result)) { + return LLONG_MIN; + } +#endif +#endif +#endif + return result; +} + /* Set the file time stamp. */ void @@ -3173,22 +3257,45 @@ __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED, char *to ATTRIBUTE_UNUSED, #else GNAT_STRUCT_STAT fbuf; - struct utimbuf tbuf; if (GNAT_STAT (from, &fbuf) == -1) { return -1; } - /* Do we need to copy timestamp ? */ +#if _POSIX_C_SOURCE >= 200809L + struct timespec tbuf[2]; + if (mode != 2) { - tbuf.actime = fbuf.st_atime; - tbuf.modtime = fbuf.st_mtime; + tbuf[0] = fbuf.st_atim; + tbuf[1] = fbuf.st_mtim; - if (utime (to, &tbuf) == -1) { + if (utimensat (AT_FDCWD, to, tbuf, 0) == -1) { return -1; } } +#else + struct timeval tbuf[2]; + /* Do we need to copy timestamp ? */ + + if (mode != 2) { + tbuf[0].tv_sec = fbuf.st_atime; + tbuf[1].tv_sec = fbuf.st_mtime; + + #if defined(st_mtime) + tbuf[0].tv_usec = fbuf.st_atim.tv_nsec / 1000; + tbuf[1].tv_usec = fbuf.st_mtim.tv_nsec / 1000; + #else + tbuf[0].tv_usec = 0; + tbuf[1].tv_usec = 0; + #endif + + if (utimes (to, tbuf) == -1) { + return -1; + } + } +#endif + /* Do we need to copy file permissions ? */ if (mode != 0 && (chmod (to, fbuf.st_mode) == -1)) { return -1; diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index ec7ec2f..9dcc656 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -179,7 +179,7 @@ package body ALI.Util is function Hash (F : File_Name_Type) return Header_Num is begin - return Header_Num (Int (F) rem Header_Num'Range_Length); + return Header_Num (Int (F) mod Header_Num'Range_Length); end Hash; --------------------------- diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 6b0d6c7..3bf1257 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -590,7 +590,8 @@ package body ALI is -- scope__name__line_column__locations -- -- * The String is converted into a Name_Id - -- * The Name_Id is used as the hash + -- + -- * The absolute value of the Name_Id is used as the hash Append (Buffer, IS_Rec.Scope); Append (Buffer, "__"); @@ -606,7 +607,7 @@ package body ALI is end if; IS_Nam := Name_Find (Buffer); - return Bucket_Range_Type (IS_Nam); + return Bucket_Range_Type (abs IS_Nam); end Hash; -------------------- diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index 4578d56..e7b5bca 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index c222c33..37bbcae 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -455,6 +449,7 @@ package body Aspects is N_Package_Instantiation => True, N_Package_Specification => True, N_Package_Renaming_Declaration => True, + N_Parameter_Specification => True, N_Private_Extension_Declaration => True, N_Private_Type_Declaration => True, N_Procedure_Instantiation => True, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 0394106..1470efe 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -153,6 +147,7 @@ package Aspects is Aspect_Storage_Size, Aspect_Stream_Size, Aspect_String_Literal, + Aspect_Subprogram_Variant, -- GNAT Aspect_Suppress, Aspect_Synchronization, Aspect_Test_Case, -- GNAT @@ -190,8 +185,10 @@ package Aspects is Aspect_Disable_Controlled, -- GNAT Aspect_Discard_Names, Aspect_CUDA_Global, -- GNAT + Aspect_Exclusive_Functions, Aspect_Export, Aspect_Favor_Top_Level, -- GNAT + Aspect_Full_Access_Only, Aspect_Independent, Aspect_Independent_Components, Aspect_Import, @@ -227,6 +224,16 @@ package Aspects is Aspect_Id range Aspect_Id'Succ (No_Aspect) .. Aspect_Id'Last; -- Aspect_Id's excluding No_Aspect + subtype Nonoverridable_Aspect_Id is Aspect_Id with + Static_Predicate => Nonoverridable_Aspect_Id in + Aspect_Default_Iterator | Aspect_Iterator_Element | + Aspect_Implicit_Dereference | Aspect_Constant_Indexing | + Aspect_Variable_Indexing | Aspect_Aggregate | + Aspect_Max_Entry_Queue_Length + -- | Aspect_No_Controlled_Parts + -- ??? No_Controlled_Parts not yet in Aspect_Id enumeration + ; -- see RM 13.1.1(18.7) + -- The following array indicates aspects that accept 'Class Class_Aspect_OK : constant array (Aspect_Id) of Boolean := @@ -425,6 +432,7 @@ package Aspects is Aspect_Storage_Size => Expression, Aspect_Stream_Size => Expression, Aspect_String_Literal => Name, + Aspect_Subprogram_Variant => Expression, Aspect_Suppress => Name, Aspect_Synchronization => Name, Aspect_Test_Case => Expression, @@ -472,6 +480,7 @@ package Aspects is Aspect_Dynamic_Predicate => False, Aspect_Effective_Reads => False, Aspect_Effective_Writes => False, + Aspect_Exclusive_Functions => False, Aspect_Extensions_Visible => False, Aspect_External_Name => False, Aspect_External_Tag => False, @@ -524,6 +533,7 @@ package Aspects is Aspect_Storage_Size => True, Aspect_Stream_Size => True, Aspect_String_Literal => False, + Aspect_Subprogram_Variant => False, Aspect_Suppress => False, Aspect_Synchronization => False, Aspect_Test_Case => False, @@ -545,6 +555,7 @@ package Aspects is Aspect_Discard_Names => True, Aspect_Export => True, Aspect_Favor_Top_Level => False, + Aspect_Full_Access_Only => True, Aspect_Independent => True, Aspect_Independent_Components => True, Aspect_Import => True, @@ -619,11 +630,13 @@ package Aspects is Aspect_Effective_Reads => Name_Effective_Reads, Aspect_Effective_Writes => Name_Effective_Writes, Aspect_Elaborate_Body => Name_Elaborate_Body, + Aspect_Exclusive_Functions => Name_Exclusive_Functions, Aspect_Export => Name_Export, Aspect_Extensions_Visible => Name_Extensions_Visible, Aspect_External_Name => Name_External_Name, Aspect_External_Tag => Name_External_Tag, Aspect_Favor_Top_Level => Name_Favor_Top_Level, + Aspect_Full_Access_Only => Name_Full_Access_Only, Aspect_Ghost => Name_Ghost, Aspect_Global => Name_Global, Aspect_Implicit_Dereference => Name_Implicit_Dereference, @@ -697,6 +710,7 @@ package Aspects is Aspect_Storage_Size => Name_Storage_Size, Aspect_Stream_Size => Name_Stream_Size, Aspect_String_Literal => Name_String_Literal, + Aspect_Subprogram_Variant => Name_Subprogram_Variant, Aspect_Suppress => Name_Suppress, Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info, Aspect_Suppress_Initialization => Name_Suppress_Initialization, @@ -851,6 +865,7 @@ package Aspects is Aspect_Dispatching_Domain => Always_Delay, Aspect_Dynamic_Predicate => Always_Delay, Aspect_Elaborate_Body => Always_Delay, + Aspect_Exclusive_Functions => Always_Delay, Aspect_External_Name => Always_Delay, Aspect_External_Tag => Always_Delay, Aspect_Favor_Top_Level => Always_Delay, @@ -951,6 +966,7 @@ package Aspects is Aspect_Relaxed_Initialization => Never_Delay, Aspect_SPARK_Mode => Never_Delay, Aspect_Static => Never_Delay, + Aspect_Subprogram_Variant => Never_Delay, Aspect_Synchronization => Never_Delay, Aspect_Test_Case => Never_Delay, Aspect_Unimplemented => Never_Delay, @@ -963,6 +979,7 @@ package Aspects is Aspect_Atomic_Components => Rep_Aspect, Aspect_Bit_Order => Rep_Aspect, Aspect_Component_Size => Rep_Aspect, + Aspect_Full_Access_Only => Rep_Aspect, Aspect_Machine_Radix => Rep_Aspect, Aspect_Object_Size => Rep_Aspect, Aspect_Pack => Rep_Aspect, diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 7e05a48..d3d40d9 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -57,7 +51,8 @@ package body Atree is -- assertions this lock has no effect. Reporting_Proc : Report_Proc := null; - -- Record argument to last call to Set_Reporting_Proc + -- Set_Reporting_Proc sets this. Set_Reporting_Proc must be called only + -- once. Rewriting_Proc : Rewrite_Proc := null; -- This soft link captures the procedure invoked during a node rewrite @@ -113,16 +108,11 @@ package body Atree is procedure Node_Debug_Output (Op : String; N : Node_Id); -- Called by nnd; writes Op followed by information about N - procedure Print_Statistics; - pragma Export (Ada, Print_Statistics); - -- Print various statistics on the tables maintained by the package - ----------------------------- -- Local Objects and Types -- ----------------------------- - Node_Count : Nat; - -- Count allocated nodes for Num_Nodes function + Comes_From_Source_Default : Boolean := False; use Unchecked_Access; -- We are allowed to see these from within our own body @@ -504,7 +494,7 @@ package body Atree is -- Note: eventually, this should be a field in the Node directly, but -- for now we do not want to disturb the efficiency of a power of 2 - -- for the node size + -- for the node size. ????We are planning to get rid of power-of-2. package Orig_Nodes is new Table.Table ( Table_Component_Type => Node_Id, @@ -541,15 +531,19 @@ package body Atree is Table_Increment => 200, Table_Name => "Paren_Counts"); + procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id); + pragma Inline (Set_Paren_Count_Of_Copy); + -- Called when copying a node. Makes sure the Paren_Count of the copy is + -- correct. + ----------------------- -- Local Subprograms -- ----------------------- - function Allocate_Initialize_Node - (Src : Node_Id; - With_Extension : Boolean) return Node_Id; - -- Allocate a new node or node extension. If Src is not empty, the - -- information for the newly-allocated node is copied from it. + function Allocate_New_Node return Node_Id; + pragma Inline (Allocate_New_Node); + -- Allocate a new node or first part of a node extension. Initialize the + -- Nodes.Table entry, Flags, Orig_Nodes, and List tables. procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id); -- Fix up parent pointers for the syntactic children of Fix_Node after a @@ -559,79 +553,28 @@ package body Atree is -- Mark arbitrary node or entity N as Ghost when it is created within a -- Ghost region. - ------------------------------ - -- Allocate_Initialize_Node -- - ------------------------------ + procedure Report (Target, Source : Node_Id); + pragma Inline (Report); + -- Invoke the reporting procedure if available - function Allocate_Initialize_Node - (Src : Node_Id; - With_Extension : Boolean) return Node_Id - is - New_Id : Node_Id; + ----------------------- + -- Allocate_New_Node -- + ----------------------- + function Allocate_New_Node return Node_Id is + New_Id : Node_Id; begin - if Present (Src) - and then not Has_Extension (Src) - and then With_Extension - and then Src = Nodes.Last - then - New_Id := Src; - - -- We are allocating a new node, or extending a node other than - -- Nodes.Last. - - else - if Present (Src) then - Nodes.Append (Nodes.Table (Src)); - Flags.Append (Flags.Table (Src)); - else - Nodes.Append (Default_Node); - Flags.Append (Default_Flags); - end if; - - New_Id := Nodes.Last; - Orig_Nodes.Append (New_Id); - Node_Count := Node_Count + 1; - end if; - - -- Clear Check_Actuals to False - - Set_Check_Actuals (New_Id, False); - - -- Specifically copy Paren_Count to deal with creating new table entry - -- if the parentheses count is at the maximum possible value already. - - if Present (Src) and then Nkind (Src) in N_Subexpr then - Set_Paren_Count (New_Id, Paren_Count (Src)); - end if; - - -- Set extension nodes if required - - if With_Extension then - if Present (Src) and then Has_Extension (Src) then - for J in 1 .. Num_Extension_Nodes loop - Nodes.Append (Nodes.Table (Src + J)); - Flags.Append (Flags.Table (Src + J)); - end loop; - else - for J in 1 .. Num_Extension_Nodes loop - Nodes.Append (Default_Node_Extension); - Flags.Append (Default_Flags); - end loop; - end if; - end if; - - Orig_Nodes.Set_Last (Nodes.Last); + Nodes.Append (Default_Node); + New_Id := Nodes.Last; + Flags.Append (Default_Flags); + Orig_Nodes.Append (New_Id); + Nodes.Table (Nodes.Last).Comes_From_Source := + Comes_From_Source_Default; Allocate_List_Tables (Nodes.Last); - - -- Invoke the reporting procedure (if available) - - if Reporting_Proc /= null then - Reporting_Proc.all (Target => New_Id, Source => Src); - end if; + Report (Target => New_Id, Source => Empty); return New_Id; - end Allocate_Initialize_Node; + end Allocate_New_Node; -------------- -- Analyzed -- @@ -762,12 +705,7 @@ package body Atree is Flags.Table (Destination) := Flags.Table (Source); - -- Specifically set Paren_Count to make sure auxiliary table entry - -- gets correctly made if the parentheses count is at the max value. - - if Nkind (Destination) in N_Subexpr then - Set_Paren_Count (Destination, Paren_Count (Source)); - end if; + Set_Paren_Count_Of_Copy (Target => Destination, Source => Source); -- Deal with copying extension nodes if present. No need to copy flags -- table entries, since they are always zero for extending components. @@ -1056,12 +994,14 @@ package body Atree is -- Extend_Node -- ----------------- - function Extend_Node (Node : Node_Id) return Entity_Id is - Result : Entity_Id; + function Extend_Node (Source : Node_Id) return Entity_Id is + pragma Assert (Present (Source)); + pragma Assert (not Has_Extension (Source)); + New_Id : Entity_Id; procedure Debug_Extend_Node; pragma Inline (Debug_Extend_Node); - -- Debug routine for debug flag N + -- Debug routine for -gnatdn ----------------------- -- Debug_Extend_Node -- @@ -1071,13 +1011,13 @@ package body Atree is begin if Debug_Flag_N then Write_Str ("Extend node "); - Write_Int (Int (Node)); + Write_Int (Int (Source)); - if Result = Node then + if New_Id = Source then Write_Str (" in place"); else Write_Str (" copied to "); - Write_Int (Int (Result)); + Write_Int (Int (New_Id)); end if; -- Write_Eol; @@ -1087,12 +1027,34 @@ package body Atree is -- Start of processing for Extend_Node begin - pragma Assert (not (Has_Extension (Node))); + -- Optimize the case where Source happens to be the last node; in that + -- case, we don't need to move it. + + if Source = Nodes.Last then + New_Id := Source; + else + Nodes.Append (Nodes.Table (Source)); + Flags.Append (Flags.Table (Source)); + New_Id := Nodes.Last; + Orig_Nodes.Append (New_Id); + end if; + + Set_Check_Actuals (New_Id, False); + + -- Set extension nodes + + for J in 1 .. Num_Extension_Nodes loop + Nodes.Append (Default_Node_Extension); + Flags.Append (Default_Flags); + end loop; + + Orig_Nodes.Set_Last (Nodes.Last); + Allocate_List_Tables (Nodes.Last); + Report (Target => New_Id, Source => Source); - Result := Allocate_Initialize_Node (Node, With_Extension => True); pragma Debug (Debug_Extend_Node); - return Result; + return New_Id; end Extend_Node; ----------------- @@ -1100,6 +1062,8 @@ package body Atree is ----------------- procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id) is + pragma Assert (Nkind (Ref_Node) = Nkind (Fix_Node)); + procedure Fix_Parent (Field : Union_Id); -- Fix up one parent pointer. Field is checked to see if it points to -- a node, list, or element list that has a parent that points to @@ -1157,7 +1121,7 @@ package body Atree is function Get_Comes_From_Source_Default return Boolean is begin - return Default_Node.Comes_From_Source; + return Comes_From_Source_Default; end Get_Comes_From_Source_Default; ----------------- @@ -1188,7 +1152,6 @@ package body Atree is pragma Warnings (Off, Dummy); begin - Node_Count := 0; Atree_Private_Part.Nodes.Init; Atree_Private_Part.Flags.Init; Orig_Nodes.Init; @@ -1252,9 +1215,8 @@ package body Atree is -- We used to Release the tables, as in the comments below, but that is -- a waste of time. We're only wasting virtual memory here, and the -- release calls copy large amounts of data. + -- ???Get rid of Release? - -- Nodes.Release; - Nodes.Locked := True; -- Flags.Release; Flags.Locked := True; -- Orig_Nodes.Release; @@ -1314,38 +1276,60 @@ package body Atree is -------------- function New_Copy (Source : Node_Id) return Node_Id is - New_Id : Node_Id := Source; - + New_Id : Node_Id; begin - if Source > Empty_Or_Error then - New_Id := Allocate_Initialize_Node (Source, Has_Extension (Source)); + if Source <= Empty_Or_Error then + return Source; + end if; - Nodes.Table (New_Id).In_List := False; - Nodes.Table (New_Id).Link := Empty_List_Or_Node; + Nodes.Append (Nodes.Table (Source)); + Flags.Append (Flags.Table (Source)); + New_Id := Nodes.Last; + Orig_Nodes.Append (New_Id); + Set_Check_Actuals (New_Id, False); + Set_Paren_Count_Of_Copy (Target => New_Id, Source => Source); - -- If the original is marked as a rewrite insertion, then unmark the - -- copy, since we inserted the original, not the copy. + -- Set extension nodes if required - Nodes.Table (New_Id).Rewrite_Ins := False; - pragma Debug (New_Node_Debugging_Output (New_Id)); + if Has_Extension (Source) then + for J in 1 .. Num_Extension_Nodes loop + Nodes.Append (Nodes.Table (Source + J)); + Flags.Append (Flags.Table (Source + J)); + end loop; + Orig_Nodes.Set_Last (Nodes.Last); + else + pragma Assert (Orig_Nodes.Table (Orig_Nodes.Last) = Nodes.Last); + end if; - -- Clear Is_Overloaded since we cannot have semantic interpretations - -- of this new node. + Allocate_List_Tables (Nodes.Last); + Report (Target => New_Id, Source => Source); - if Nkind (Source) in N_Subexpr then - Set_Is_Overloaded (New_Id, False); - end if; + Nodes.Table (New_Id).In_List := False; + Nodes.Table (New_Id).Link := Empty_List_Or_Node; - -- Always clear Has_Aspects, the caller must take care of copying - -- aspects if this is required for the particular situation. + -- If the original is marked as a rewrite insertion, then unmark the + -- copy, since we inserted the original, not the copy. - Set_Has_Aspects (New_Id, False); + Nodes.Table (New_Id).Rewrite_Ins := False; + pragma Debug (New_Node_Debugging_Output (New_Id)); - -- Mark the copy as Ghost depending on the current Ghost region + -- Clear Is_Overloaded since we cannot have semantic interpretations + -- of this new node. - Mark_New_Ghost_Node (New_Id); + if Nkind (Source) in N_Subexpr then + Set_Is_Overloaded (New_Id, False); end if; + -- Always clear Has_Aspects, the caller must take care of copying + -- aspects if this is required for the particular situation. + + Set_Has_Aspects (New_Id, False); + + -- Mark the copy as Ghost depending on the current Ghost region + + Mark_New_Ghost_Node (New_Id); + + pragma Assert (New_Id /= Source); return New_Id; end New_Copy; @@ -1357,30 +1341,35 @@ package body Atree is (New_Node_Kind : Node_Kind; New_Sloc : Source_Ptr) return Entity_Id is - Ent : Entity_Id; - - begin pragma Assert (New_Node_Kind in N_Entity); + New_Id : constant Entity_Id := Allocate_New_Node; + begin + -- Set extension nodes - Ent := Allocate_Initialize_Node (Empty, With_Extension => True); + for J in 1 .. Num_Extension_Nodes loop + Nodes.Append (Default_Node_Extension); + Flags.Append (Default_Flags); + end loop; + + Orig_Nodes.Set_Last (Nodes.Last); -- If this is a node with a real location and we are generating -- source nodes, then reset Current_Error_Node. This is useful -- if we bomb during parsing to get a error location for the bomb. - if Default_Node.Comes_From_Source and then New_Sloc > No_Location then - Current_Error_Node := Ent; + if New_Sloc > No_Location and then Comes_From_Source_Default then + Current_Error_Node := New_Id; end if; - Nodes.Table (Ent).Nkind := New_Node_Kind; - Nodes.Table (Ent).Sloc := New_Sloc; - pragma Debug (New_Node_Debugging_Output (Ent)); + Nodes.Table (New_Id).Nkind := New_Node_Kind; + Nodes.Table (New_Id).Sloc := New_Sloc; + pragma Debug (New_Node_Debugging_Output (New_Id)); -- Mark the new entity as Ghost depending on the current Ghost region - Mark_New_Ghost_Node (Ent); + Mark_New_Ghost_Node (New_Id); - return Ent; + return New_Id; end New_Entity; -------------- @@ -1391,29 +1380,27 @@ package body Atree is (New_Node_Kind : Node_Kind; New_Sloc : Source_Ptr) return Node_Id is - Nod : Node_Id; - - begin pragma Assert (New_Node_Kind not in N_Entity); - - Nod := Allocate_Initialize_Node (Empty, With_Extension => False); - Nodes.Table (Nod).Nkind := New_Node_Kind; - Nodes.Table (Nod).Sloc := New_Sloc; - pragma Debug (New_Node_Debugging_Output (Nod)); + New_Id : constant Node_Id := Allocate_New_Node; + pragma Assert (Orig_Nodes.Table (Orig_Nodes.Last) = Nodes.Last); + begin + Nodes.Table (New_Id).Nkind := New_Node_Kind; + Nodes.Table (New_Id).Sloc := New_Sloc; + pragma Debug (New_Node_Debugging_Output (New_Id)); -- If this is a node with a real location and we are generating source -- nodes, then reset Current_Error_Node. This is useful if we bomb -- during parsing to get an error location for the bomb. - if Default_Node.Comes_From_Source and then New_Sloc > No_Location then - Current_Error_Node := Nod; + if Comes_From_Source_Default and then New_Sloc > No_Location then + Current_Error_Node := New_Id; end if; -- Mark the new node as Ghost depending on the current Ghost region - Mark_New_Ghost_Node (Nod); + Mark_New_Ghost_Node (New_Id); - return Nod; + return New_Id; end New_Node; ------------------------- @@ -1494,14 +1481,18 @@ package body Atree is return Nodes.Table (First_Node_Id)'Address; end Nodes_Address; - --------------- - -- Num_Nodes -- - --------------- + ----------------------------------- + -- Approx_Num_Nodes_And_Entities -- + ----------------------------------- - function Num_Nodes return Nat is + function Approx_Num_Nodes_And_Entities return Nat is begin - return Node_Count; - end Num_Nodes; + -- This is an overestimate, because entities take up more space, but + -- that really doesn't matter; it's not worth subtracting out the + -- "extra". + + return Nat (Nodes.Last - First_Node_Id); + end Approx_Num_Nodes_And_Entities; ------------------- -- Original_Node -- @@ -1763,6 +1754,17 @@ package body Atree is end if; end Replace; + ------------ + -- Report -- + ------------ + + procedure Report (Target, Source : Node_Id) is + begin + if Reporting_Proc /= null then + Reporting_Proc.all (Target, Source); + end if; + end Report; + ------------- -- Rewrite -- ------------- @@ -1895,7 +1897,7 @@ package body Atree is procedure Set_Comes_From_Source_Default (Default : Boolean) is begin - Default_Node.Comes_From_Source := Default; + Comes_From_Source_Default := Default; end Set_Comes_From_Source_Default; --------------- @@ -1983,6 +1985,8 @@ package body Atree is Nodes.Table (N).Pflag1 := True; Nodes.Table (N).Pflag2 := True; + -- Search for existing table entry + for J in Paren_Counts.First .. Paren_Counts.Last loop if N = Paren_Counts.Table (J).Nod then Paren_Counts.Table (J).Count := Val; @@ -1990,10 +1994,30 @@ package body Atree is end if; end loop; + -- No existing table entry; make a new one + Paren_Counts.Append ((Nod => N, Count => Val)); end if; end Set_Paren_Count; + ----------------------------- + -- Set_Paren_Count_Of_Copy -- + ----------------------------- + + procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id) is + begin + -- We already copied the two Pflags. We need to update the Paren_Counts + -- table only if greater than 2. + + if Nkind (Source) in N_Subexpr + and then Paren_Count (Source) > 2 + then + Set_Paren_Count (Target, Paren_Count (Source)); + end if; + + pragma Assert (Paren_Count (Target) = Paren_Count (Source)); + end Set_Paren_Count_Of_Copy; + ---------------- -- Set_Parent -- ---------------- @@ -8756,7 +8780,6 @@ package body Atree is procedure Unlock is begin - Nodes.Locked := False; Flags.Locked := False; Orig_Nodes.Locked := False; end Unlock; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index e958a9b..f84ff45 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -70,7 +64,7 @@ package Atree is -- Currently entities are composed of 7 sequentially allocated 32-byte -- nodes, considered as a single record. The following definition gives - -- the number of extension nodes. + -- the number of extension nodes. ????We plan to change this. Num_Extension_Nodes : Node_Id := 6; -- This value is increased by one if debug flag -gnatd.N is set. This is @@ -81,6 +75,10 @@ package Atree is -- 2.01 for the nodes/entities ratio and a 2% increase in compilation time -- on average for the GCC-based compiler at -O0 on a 32-bit x86 host. + procedure Print_Statistics; + pragma Export (Ada, Print_Statistics); + -- Print various statistics on the tables maintained by the package + ---------------------------------------- -- Definitions of Fields in Tree Node -- ---------------------------------------- @@ -231,12 +229,9 @@ package Atree is function Flags_Address return System.Address; -- Return address of Flags table (used in Back_End for Gigi call) - function Num_Nodes return Nat; - -- Total number of nodes allocated, where an entity counts as a single - -- node. This count is incremented every time a node or entity is - -- allocated, and decremented every time a node or entity is deleted. - -- This value is used by Xref and by Treepr to allocate hash tables of - -- suitable size for hashing Node_Id values. + function Approx_Num_Nodes_And_Entities return Nat; + -- This is an approximation to the number of nodes and entities allocated, + -- used to determine sizes of hash tables. ----------------------- -- Use of Empty Node -- @@ -404,9 +399,8 @@ package Atree is -- place, and then for subsequent modifications as required. procedure Initialize; - -- Called at the start of compilation to initialize the allocation of - -- the node and list tables and make the standard entries for Empty, - -- Error and Error_List. + -- Called at the start of compilation to initialize the allocation of the + -- node and list tables and make the entries for Empty and Error. procedure Lock; -- Called before the back end is invoked to lock the nodes table @@ -551,7 +545,7 @@ package Atree is -- semantic chains: Homonym and Next_Entity: the corresponding links must -- be adjusted by the caller, according to context. - function Extend_Node (Node : Node_Id) return Entity_Id; + function Extend_Node (Source : Node_Id) return Entity_Id; -- This function returns a copy of its input node with an extension added. -- The fields of the extension are set to Empty. Due to the way extensions -- are handled (as four consecutive array elements), it may be necessary @@ -3843,7 +3837,8 @@ package Atree is -- Field6-11 Holds Field36-Field41 end case; - end record; + end record; -- Node_Record + pragma Suppress_Initialization (Node_Record); -- see package Nodes below pragma Pack (Node_Record); for Node_Record'Size use 8 * 32; @@ -3855,7 +3850,7 @@ package Atree is -- Default value used to initialize default nodes. Note that some of the -- fields get overwritten, and in particular, Nkind always gets reset. - Default_Node : Node_Record := ( + Default_Node : constant Node_Record := ( Is_Extension => False, Pflag1 => False, Pflag2 => False, @@ -3864,7 +3859,6 @@ package Atree is Rewrite_Ins => False, Analyzed => False, Comes_From_Source => False, - -- modified by Set_Comes_From_Source_Default Error_Posted => False, Flag4 => False, @@ -3886,7 +3880,7 @@ package Atree is Nkind => N_Unused_At_Start, - Sloc => No_Location, + Sloc => 0, Link => Empty_List_Or_Node, Field1 => Empty_List_Or_Node, Field2 => Empty_List_Or_Node, @@ -3938,17 +3932,18 @@ package Atree is Field11 => Empty_List_Or_Node, Field12 => Empty_List_Or_Node); - -- The following defines the extendable array used for the nodes table - -- Nodes with extensions use six consecutive entries in the array - - package Nodes is new Table.Table ( - Table_Component_Type => Node_Record, - Table_Index_Type => Node_Id'Base, - Table_Low_Bound => First_Node_Id, - Table_Initial => Alloc.Nodes_Initial, - Table_Increment => Alloc.Nodes_Increment, - Release_Threshold => Alloc.Nodes_Release_Threshold, - Table_Name => "Nodes"); + -- The following defines the extendable array used for the nodes table. + -- Nodes with extensions use multiple consecutive entries in the array + -- (see Num_Extension_Nodes). + + package Nodes is new Table.Table + (Table_Component_Type => Node_Record, + Table_Index_Type => Node_Id'Base, + Table_Low_Bound => First_Node_Id, + Table_Initial => Alloc.Nodes_Initial, + Table_Increment => Alloc.Nodes_Increment, + Release_Threshold => Alloc.Nodes_Release_Threshold, + Table_Name => "Nodes"); -- The following is a parallel table to Nodes, which provides 8 more -- bits of space that logically belong to the corresponding node. This diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 91b4cb3..ed0df1b 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -33,7 +33,6 @@ with Osint; use Osint; with Osint.B; use Osint.B; with Output; use Output; with Rident; use Rident; -with Stringt; use Stringt; with Table; with Targparm; use Targparm; with Types; use Types; @@ -1161,19 +1160,18 @@ package body Bindgen is procedure Write_Name_With_Len (Nam : Name_Id) is begin Get_Name_String (Nam); - - Start_String; - Store_String_Char (Character'Val (Name_Len)); - Store_String_Chars (Name_Buffer (1 .. Name_Len)); - - Write_String_Table_Entry (End_String); + Write_Str ("Character'Val ("); + Write_Int (Int (Name_Len)); + Write_Str (") & """); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Char ('"'); end Write_Name_With_Len; -- Local variables - Amp : Character; - KN : Name_Id := No_Name; - VN : Name_Id := No_Name; + First : Boolean := True; + KN : Name_Id := No_Name; + VN : Name_Id := No_Name; -- Start of processing for Gen_Bind_Env_String @@ -1187,21 +1185,26 @@ package body Bindgen is Set_Special_Output (Write_Bind_Line'Access); WBI (" Bind_Env : aliased constant String :="); - Amp := ' '; + while VN /= No_Name loop - Write_Str (" " & Amp & ' '); + if First then + Write_Str (" "); + else + Write_Str (" & "); + end if; + Write_Name_With_Len (KN); Write_Str (" & "); Write_Name_With_Len (VN); Write_Eol; Bind_Environment.Get_Next (KN, VN); - Amp := '&'; + First := False; end loop; + WBI (" & ASCII.NUL;"); Cancel_Special_Output; - Bind_Env_String_Built := True; end Gen_Bind_Env_String; diff --git a/gcc/ada/bindo-writers.adb b/gcc/ada/bindo-writers.adb index 88c8b25..cca6687 100644 --- a/gcc/ada/bindo-writers.adb +++ b/gcc/ada/bindo-writers.adb @@ -1561,7 +1561,7 @@ package body Bindo.Writers is begin pragma Assert (Present (Nam)); - return Bucket_Range_Type (Nam); + return Bucket_Range_Type (abs Nam); end Hash_File_Name; --------------------- diff --git a/gcc/ada/casing.adb b/gcc/ada/casing.adb index b5020d5..db551d7 100644 --- a/gcc/ada/casing.adb +++ b/gcc/ada/casing.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/casing.ads b/gcc/ada/casing.ads index b40faaa..fe0e2f2 100644 --- a/gcc/ada/casing.ads +++ b/gcc/ada/casing.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 9de21d6..b389da5 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -30,7 +30,6 @@ with Einfo; use Einfo; with Elists; use Elists; with Eval_Fat; use Eval_Fat; with Exp_Ch11; use Exp_Ch11; -with Exp_Ch2; use Exp_Ch2; with Exp_Ch4; use Exp_Ch4; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; @@ -590,7 +589,6 @@ package body Checks is then Param_Ent := Entity (N); while Present (Renamed_Object (Param_Ent)) loop - -- Renamed_Object must return an Entity_Name here -- because of preceding "Present (E_E_A (...))" test. @@ -602,32 +600,45 @@ package body Checks is return; -- Only apply the run-time check if the access parameter has an - -- associated extra access level parameter and when the level of the - -- type is less deep than the level of the access parameter, and - -- accessibility checks are not suppressed. + -- associated extra access level parameter and when accessibility checks + -- are enabled. elsif Present (Param_Ent) - and then Present (Extra_Accessibility (Param_Ent)) - and then UI_Gt (Object_Access_Level (N), - Deepest_Type_Access_Level (Typ)) + and then Present (Get_Dynamic_Accessibility (Param_Ent)) and then not Accessibility_Checks_Suppressed (Param_Ent) and then not Accessibility_Checks_Suppressed (Typ) then + -- Obtain the parameter's accessibility level + Param_Level := - New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc); + New_Occurrence_Of (Get_Dynamic_Accessibility (Param_Ent), Loc); -- Use the dynamic accessibility parameter for the function's result -- when one has been created instead of statically referring to the -- deepest type level so as to appropriatly handle the rules for -- RM 3.10.2 (10.1/3). - if Ekind (Scope (Param_Ent)) - in E_Function | E_Operator | E_Subprogram_Type - and then Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) + if Ekind (Scope (Param_Ent)) = E_Function + and then In_Return_Value (N) + and then Ekind (Typ) = E_Anonymous_Access_Type then - Type_Level := - New_Occurrence_Of - (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc); + -- Associate the level of the result type to the extra result + -- accessibility parameter belonging to the current function. + + if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then + Type_Level := + New_Occurrence_Of + (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc); + + -- In Ada 2005 and earlier modes, a result extra accessibility + -- parameter is not generated and no dynamic check is performed. + + else + return; + end if; + + -- Otherwise get the type's accessibility level normally + else Type_Level := Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ)); @@ -1013,8 +1024,7 @@ package body Checks is -- Now see if an overflow check is required declare - Siz : constant Int := UI_To_Int (Esize (Rtyp)); - Dsiz : constant Int := Siz * 2; + Dsiz : constant Uint := 2 * Esize (Rtyp); Opnod : Node_Id; Ctyp : Entity_Id; Opnd : Node_Id; @@ -1050,33 +1060,47 @@ package body Checks is -- an integer type of sufficient length to hold the largest possible -- result. - -- If the size of check type exceeds the size of Long_Long_Integer, + -- If the size of the check type exceeds the maximum integer size, -- we use a different approach, expanding to: - -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y))) + -- typ (xxx_With_Ovflo_Check (Integer_NN (x), Integer_NN (y))) -- where xxx is Add, Multiply or Subtract as appropriate -- Find check type if one exists - if Dsiz <= Standard_Integer_Size then - Ctyp := Standard_Integer; - - elsif Dsiz <= Standard_Long_Long_Integer_Size then - Ctyp := Standard_Long_Long_Integer; + if Dsiz <= System_Max_Integer_Size then + Ctyp := Integer_Type_For (Dsiz, Uns => False); -- No check type exists, use runtime call else + if System_Max_Integer_Size = 64 then + Ctyp := RTE (RE_Integer_64); + else + Ctyp := RTE (RE_Integer_128); + end if; + if Nkind (N) = N_Op_Add then - Cent := RE_Add_With_Ovflo_Check; + if System_Max_Integer_Size = 64 then + Cent := RE_Add_With_Ovflo_Check64; + else + Cent := RE_Add_With_Ovflo_Check128; + end if; - elsif Nkind (N) = N_Op_Multiply then - Cent := RE_Multiply_With_Ovflo_Check; + elsif Nkind (N) = N_Op_Subtract then + if System_Max_Integer_Size = 64 then + Cent := RE_Subtract_With_Ovflo_Check64; + else + Cent := RE_Subtract_With_Ovflo_Check128; + end if; - else - pragma Assert (Nkind (N) = N_Op_Subtract); - Cent := RE_Subtract_With_Ovflo_Check; + else pragma Assert (Nkind (N) = N_Op_Multiply); + if System_Max_Integer_Size = 64 then + Cent := RE_Multiply_With_Ovflo_Check64; + else + Cent := RE_Multiply_With_Ovflo_Check128; + end if; end if; Rewrite (N, @@ -1084,8 +1108,8 @@ package body Checks is Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (Cent), Loc), Parameter_Associations => New_List ( - OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)), - OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N)))))); + OK_Convert_To (Ctyp, Left_Opnd (N)), + OK_Convert_To (Ctyp, Right_Opnd (N)))))); Analyze_And_Resolve (N, Typ); return; @@ -2140,6 +2164,15 @@ package body Checks is Lo_OK := (Lo >= UR_From_Uint (Ifirst)); end if; + -- Saturate the lower bound to that of the expression's type, because + -- we do not want to create an out-of-range value but we still need to + -- do a comparison to catch NaNs. + + if Lo < Expr_Value_R (Type_Low_Bound (Expr_Type)) then + Lo := Expr_Value_R (Type_Low_Bound (Expr_Type)); + Lo_OK := True; + end if; + if Lo_OK then -- Lo_Chk := (X >= Lo) @@ -2174,6 +2207,15 @@ package body Checks is Hi_OK := (Hi <= UR_From_Uint (Ilast)); end if; + -- Saturate the higher bound to that of the expression's type, because + -- we do not want to create an out-of-range value but we still need to + -- do a comparison to catch NaNs. + + if Hi > Expr_Value_R (Type_High_Bound (Expr_Type)) then + Hi := Expr_Value_R (Type_High_Bound (Expr_Type)); + Hi_OK := True; + end if; + if Hi_OK then -- Hi_Chk := (X <= Hi) @@ -2744,13 +2786,9 @@ package body Checks is Par : Node_Id; S : Entity_Id; + Check_Disabled : constant Boolean := (not Predicate_Enabled (Typ)) + or else not Predicate_Check_In_Scope (N); begin - if not Predicate_Enabled (Typ) - or else not Predicate_Check_In_Scope (N) - then - return; - end if; - S := Current_Scope; while Present (S) and then not Is_Subprogram (S) loop S := Scope (S); @@ -2759,7 +2797,9 @@ package body Checks is -- If the check appears within the predicate function itself, it means -- that the user specified a check whose formal is the predicated -- subtype itself, rather than some covering type. This is likely to be - -- a common error, and thus deserves a warning. + -- a common error, and thus deserves a warning. We want to emit this + -- warning even if predicate checking is disabled (in which case the + -- warning is still useful even if it is not strictly accurate). if Present (S) and then S = Predicate_Function (Typ) then Error_Msg_NE @@ -2774,9 +2814,15 @@ package body Checks is Parent (N), Typ); end if; - Insert_Action (N, - Make_Raise_Storage_Error (Sloc (N), - Reason => SE_Infinite_Recursion)); + if not Check_Disabled then + Insert_Action (N, + Make_Raise_Storage_Error (Sloc (N), + Reason => SE_Infinite_Recursion)); + return; + end if; + end if; + + if Check_Disabled then return; end if; @@ -3586,7 +3632,7 @@ package body Checks is elsif Is_Scalar_Type (Target_Type) then declare - Conv_OK : constant Boolean := Conversion_OK (N); + Conv_OK : constant Boolean := Conversion_OK (N); -- If the Conversion_OK flag on the type conversion is set and no -- floating-point type is involved in the type conversion then -- fixed-point values must be read as integral values. @@ -3642,14 +3688,10 @@ package body Checks is (Entity (High_Bound (Scalar_Range (Enum_T)))); end if; - if Last_E <= Last_I then - null; - - else + if Last_E > Last_I then Activate_Overflow_Check (N); end if; end; - else Activate_Overflow_Check (N); end if; @@ -3662,7 +3704,6 @@ package body Checks is and then not GNATprove_Mode then Apply_Float_Conversion_Check (Expr, Target_Type); - else -- Conversions involving fixed-point types are expanded -- separately, and do not need a Range_Check flag, except diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 9d3e9e9..9e328e2 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -69,8 +69,8 @@ package body Contracts is procedure Expand_Subprogram_Contract (Body_Id : Entity_Id); -- Expand the contracts of a subprogram body and its correspoding spec (if -- any). This routine processes all [refined] pre- and postconditions as - -- well as Contract_Cases, invariants and predicates. Body_Id denotes the - -- entity of the subprogram body. + -- well as Contract_Cases, Subprogram_Variant, invariants and predicates. + -- Body_Id denotes the entity of the subprogram body. ----------------------- -- Add_Contract_Item -- @@ -200,7 +200,10 @@ package body Contracts is then Add_Classification; - elsif Prag_Nam in Name_Contract_Cases | Name_Test_Case then + elsif Prag_Nam in Name_Contract_Cases + | Name_Subprogram_Variant + | Name_Test_Case + then Add_Contract_Test_Case; elsif Prag_Nam in Name_Postcondition | Name_Precondition then @@ -550,8 +553,8 @@ package body Contracts is end if; -- Deal with preconditions, [refined] postconditions, Contract_Cases, - -- invariants and predicates associated with body and its spec. Do not - -- expand the contract of subprogram body stubs. + -- Subprogram_Variant, invariants and predicates associated with body + -- and its spec. Do not expand the contract of subprogram body stubs. if Nkind (Body_Decl) = N_Subprogram_Body then Expand_Subprogram_Contract (Body_Id); @@ -665,7 +668,7 @@ package body Contracts is end; end if; - -- Analyze contract-cases and test-cases + -- Analyze contract-cases, subprogram-variant and test-cases Prag := Contract_Test_Cases (Items); while Present (Prag) loop @@ -686,6 +689,10 @@ package body Contracts is else Analyze_Contract_Cases_In_Decl_Part (Prag, Freeze_Id); end if; + + elsif Prag_Nam = Name_Subprogram_Variant then + Analyze_Subprogram_Variant_In_Decl_Part (Prag); + else pragma Assert (Prag_Nam = Name_Test_Case); Analyze_Test_Case_In_Decl_Part (Prag); @@ -788,13 +795,13 @@ package body Contracts is -- Local variables - AR_Val : Boolean := False; - AW_Val : Boolean := False; - ER_Val : Boolean := False; - EW_Val : Boolean := False; - Seen : Boolean := False; - Prag : Node_Id; - Obj_Typ : Entity_Id; + AR_Val : Boolean := False; + AW_Val : Boolean := False; + ER_Val : Boolean := False; + EW_Val : Boolean := False; + Seen : Boolean := False; + Prag : Node_Id; + Obj_Typ : Entity_Id; -- Start of processing for Check_Type_Or_Object_External_Properties @@ -931,7 +938,7 @@ package body Contracts is -- with its type (SPARK RM 7.1.3(2)). if not Is_Type_Id then - if Is_Effectively_Volatile (Obj_Typ) then + if Is_Effectively_Volatile (Obj_Typ) then Check_Volatility_Compatibility (Type_Or_Obj_Id, Obj_Typ, "volatile object", "its type", @@ -1425,6 +1432,7 @@ package body Contracts is -- Global -- Postcondition -- Precondition + -- Subprogram_Variant -- Test_Case else @@ -1941,49 +1949,6 @@ package body Contracts is Stmts : List_Id; Result : Entity_Id) is - procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id); - -- Insert node Stmt before the first source declaration of the - -- related subprogram's body. If no such declaration exists, Stmt - -- becomes the last declaration. - - -------------------------------------------- - -- Insert_Before_First_Source_Declaration -- - -------------------------------------------- - - procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id) is - Decls : constant List_Id := Declarations (Body_Decl); - Decl : Node_Id; - - begin - -- Inspect the declarations of the related subprogram body looking - -- for the first source declaration. - - if Present (Decls) then - Decl := First (Decls); - while Present (Decl) loop - if Comes_From_Source (Decl) then - Insert_Before (Decl, Stmt); - return; - end if; - - Next (Decl); - end loop; - - -- If we get there, then the subprogram body lacks any source - -- declarations. The body of _Postconditions now acts as the - -- last declaration. - - Append (Stmt, Decls); - - -- Ensure that the body has a declaration list - - else - Set_Declarations (Body_Decl, New_List (Stmt)); - end if; - end Insert_Before_First_Source_Declaration; - - -- Local variables - Loc : constant Source_Ptr := Sloc (Body_Decl); Params : List_Id := No_List; Proc_Bod : Node_Id; @@ -1991,8 +1956,6 @@ package body Contracts is Proc_Id : Entity_Id; Proc_Spec : Node_Id; - -- Start of processing for Build_Postconditions_Procedure - begin -- Nothing to do if there are no actions to check on exit @@ -2051,7 +2014,8 @@ package body Contracts is -- order reference. The body of _Postconditions must be placed after -- the declaration of Temp to preserve correct visibility. - Insert_Before_First_Source_Declaration (Proc_Decl); + Insert_Before_First_Source_Declaration + (Proc_Decl, Declarations (Body_Decl)); Analyze (Proc_Decl); -- Set an explicit End_Label to override the sloc of the implicit @@ -2092,14 +2056,20 @@ package body Contracts is if Present (Items) then Prag := Contract_Test_Cases (Items); while Present (Prag) loop - if Pragma_Name (Prag) = Name_Contract_Cases - and then Is_Checked (Prag) - then - Expand_Pragma_Contract_Cases - (CCs => Prag, - Subp_Id => Subp_Id, - Decls => Declarations (Body_Decl), - Stmts => Stmts); + if Is_Checked (Prag) then + if Pragma_Name (Prag) = Name_Contract_Cases then + Expand_Pragma_Contract_Cases + (CCs => Prag, + Subp_Id => Subp_Id, + Decls => Declarations (Body_Decl), + Stmts => Stmts); + + elsif Pragma_Name (Prag) = Name_Subprogram_Variant then + Expand_Pragma_Subprogram_Variant + (Prag => Prag, + Subp_Id => Subp_Id, + Body_Decls => Declarations (Body_Decl)); + end if; end if; Prag := Next_Pragma (Prag); @@ -2364,7 +2334,7 @@ package body Contracts is -- A renamed private component is just a component of -- _object, with an arbitrary name. - elsif Ekind (Obj) = E_Variable + elsif Ekind (Obj) in E_Variable | E_Constant and then Nkind (Pref) = N_Identifier and then Chars (Pref) = Name_uObject and then Nkind (Sel) = N_Identifier @@ -2590,8 +2560,7 @@ package body Contracts is and then Sloc (Body_Id) /= Sloc (Subp_Id) and then In_Same_Source_Unit (Body_Id, Subp_Id) and then List_Containing (Body_Decl) /= - List_Containing (Subp_Decl) - and then not In_Instance; + List_Containing (Subp_Decl); if Present (Items) then Prag := Pre_Post_Conditions (Items); diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads index 9e7b955..4782ef5 100644 --- a/gcc/ada/contracts.ads +++ b/gcc/ada/contracts.ads @@ -69,15 +69,16 @@ package Contracts is -- subprogram body Body_Id as if they appeared at the end of a declarative -- region. Pragmas in question are: -- - -- Contract_Cases (stand alone subprogram body) - -- Depends (stand alone subprogram body) - -- Global (stand alone subprogram body) - -- Postcondition (stand alone subprogram body) - -- Precondition (stand alone subprogram body) + -- Contract_Cases (stand alone subprogram body) + -- Depends (stand alone subprogram body) + -- Global (stand alone subprogram body) + -- Postcondition (stand alone subprogram body) + -- Precondition (stand alone subprogram body) -- Refined_Depends -- Refined_Global -- Refined_Post - -- Test_Case (stand alone subprogram body) + -- Subprogram_Variant (stand alone subprogram body) + -- Test_Case (stand alone subprogram body) procedure Analyze_Entry_Or_Subprogram_Contract (Subp_Id : Entity_Id; @@ -91,6 +92,7 @@ package Contracts is -- Global -- Postcondition -- Precondition + -- Subprogram_Variant -- Test_Case -- -- Freeze_Id is the entity of a [generic] package body or a [generic] diff --git a/gcc/ada/csets.adb b/gcc/ada/csets.adb index ed3166b..0b77b65 100644 --- a/gcc/ada/csets.adb +++ b/gcc/ada/csets.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/csets.ads b/gcc/ada/csets.ads index 1fdff40..ee24926 100644 --- a/gcc/ada/csets.ads +++ b/gcc/ada/csets.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 71d40e9..fa335c1 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -719,6 +719,11 @@ package body CStand is (Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size); Set_Is_Implementation_Defined (Standard_Long_Long_Integer); + Build_Signed_Integer_Type + (Standard_Long_Long_Long_Integer, + Standard_Long_Long_Long_Integer_Size); + Set_Is_Implementation_Defined (Standard_Long_Long_Long_Integer); + Create_Unconstrained_Base_Type (Standard_Short_Short_Integer, E_Signed_Integer_Subtype); @@ -734,6 +739,9 @@ package body CStand is Create_Unconstrained_Base_Type (Standard_Long_Long_Integer, E_Signed_Integer_Subtype); + Create_Unconstrained_Base_Type + (Standard_Long_Long_Long_Integer, E_Signed_Integer_Subtype); + Create_Float_Types; -- Create type definition node for type Character. Note that we do not @@ -1238,11 +1246,11 @@ package body CStand is Set_Elem_Alignment (Any_Fixed); Any_Integer := New_Standard_Entity ("an integer type"); - Set_Ekind (Any_Integer, E_Signed_Integer_Type); - Set_Scope (Any_Integer, Standard_Standard); - Set_Etype (Any_Integer, Standard_Long_Long_Integer); - Init_Size (Any_Integer, Standard_Long_Long_Integer_Size); - Set_Elem_Alignment (Any_Integer); + Set_Ekind (Any_Integer, E_Signed_Integer_Type); + Set_Scope (Any_Integer, Standard_Standard); + Set_Etype (Any_Integer, Standard_Long_Long_Long_Integer); + Init_Size (Any_Integer, Standard_Long_Long_Long_Integer_Size); + Set_Elem_Alignment (Any_Integer); Set_Integer_Bounds (Any_Integer, @@ -1251,19 +1259,19 @@ package body CStand is Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); Any_Modular := New_Standard_Entity ("a modular type"); - Set_Ekind (Any_Modular, E_Modular_Integer_Type); - Set_Scope (Any_Modular, Standard_Standard); - Set_Etype (Any_Modular, Standard_Long_Long_Integer); - Init_Size (Any_Modular, Standard_Long_Long_Integer_Size); - Set_Elem_Alignment (Any_Modular); - Set_Is_Unsigned_Type (Any_Modular); + Set_Ekind (Any_Modular, E_Modular_Integer_Type); + Set_Scope (Any_Modular, Standard_Standard); + Set_Etype (Any_Modular, Standard_Long_Long_Long_Integer); + Init_Size (Any_Modular, Standard_Long_Long_Long_Integer_Size); + Set_Elem_Alignment (Any_Modular); + Set_Is_Unsigned_Type (Any_Modular); Any_Numeric := New_Standard_Entity ("a numeric type"); - Set_Ekind (Any_Numeric, E_Signed_Integer_Type); - Set_Scope (Any_Numeric, Standard_Standard); - Set_Etype (Any_Numeric, Standard_Long_Long_Integer); - Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size); - Set_Elem_Alignment (Any_Numeric); + Set_Ekind (Any_Numeric, E_Signed_Integer_Type); + Set_Scope (Any_Numeric, Standard_Standard); + Set_Etype (Any_Numeric, Standard_Long_Long_Long_Integer); + Init_Size (Any_Numeric, Standard_Long_Long_Long_Integer_Size); + Set_Elem_Alignment (Any_Numeric); Any_Real := New_Standard_Entity ("a real type"); Set_Ekind (Any_Real, E_Floating_Point_Type); @@ -1339,11 +1347,17 @@ package body CStand is Build_Unsigned_Integer_Type (Standard_Long_Unsigned, Standard_Long_Integer_Size); - Standard_Long_Long_Unsigned - := New_Standard_Entity ("long_long_unsigned"); + Standard_Long_Long_Unsigned := + New_Standard_Entity ("long_long_unsigned"); Build_Unsigned_Integer_Type (Standard_Long_Long_Unsigned, Standard_Long_Long_Integer_Size); + Standard_Long_Long_Long_Unsigned := + New_Standard_Entity ("long_long_long_unsigned"); + Build_Unsigned_Integer_Type + (Standard_Long_Long_Long_Unsigned, + Standard_Long_Long_Long_Integer_Size); + -- Standard_Unsigned_64 is not user visible, but is used internally. It -- is an unsigned type mod 2**64 with 64 bits size. @@ -1358,16 +1372,16 @@ package body CStand is -- Note: universal integer and universal real are constructed as fully -- formed signed numeric types, with parameters corresponding to the - -- longest runtime types (Long_Long_Integer and Long_Long_Float). This - -- allows Gigi to properly process references to universal types that - -- are not folded at compile time. + -- longest runtime types (Long_Long_Long_Integer and Long_Long_Float). + -- This allows Gigi to properly process references to universal types + -- that are not folded at compile time. Universal_Integer := New_Standard_Entity ("universal_integer"); Decl := New_Node (N_Full_Type_Declaration, Stloc); Set_Defining_Identifier (Decl, Universal_Integer); Set_Scope (Universal_Integer, Standard_Standard); Build_Signed_Integer_Type - (Universal_Integer, Standard_Long_Long_Integer_Size); + (Universal_Integer, Standard_Long_Long_Long_Integer_Size); Universal_Real := New_Standard_Entity ("universal_real"); Decl := New_Node (N_Full_Type_Declaration, Stloc); @@ -1955,6 +1969,13 @@ package body CStand is P (";"); Write_Eol; + Write_Str (" type Long_Long_Long_Integer"); + P_Int_Range (Standard_Long_Long_Long_Integer_Size); + Write_Str (" for Long_Long_Long_Integer'Size use "); + Write_Int (Standard_Long_Long_Long_Integer_Size); + P (";"); + Write_Eol; + -- Floating point types P_Float_Type (Standard_Short_Float); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 0e4a530..f57b148 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -69,7 +63,7 @@ package body Debug is -- dC Output debugging information on check suppression -- dD Delete elaboration checks in inner level routines -- dE Apply elaboration checks to predefined units - -- dF + -- dF Alternative display for messages over multiple lines -- dG Generate all warnings including those normally suppressed -- dH Hold (kill) call to gigi -- dI Inhibit internal name numbering in gnatG listing @@ -118,14 +112,14 @@ package body Debug is -- d.y Disable implicit pragma Elaborate_All on task bodies -- d.z Restore previous support for frontend handling of Inline_Always - -- d.A + -- d.A Print Atree statistics -- d.B Generate a bug box on abort_statement -- d.C Generate concatenation call, do not generate inline code -- d.D Disable errors on use of overriding keyword in Ada 95 mode -- d.E Turn selected errors into warnings -- d.F Debug mode for GNATprove -- d.G Ignore calls through generic formal parameters for elaboration - -- d.H + -- d.H Disable the support for 128-bit integer types on 64-bit platforms -- d.I Do not ignore enum representation clauses in CodePeer mode -- d.J Relaxed rules for pragma No_Return -- d.K Do not reject components in extensions overlapping with parent @@ -147,7 +141,7 @@ package body Debug is -- d_a Stop elaboration checks on accept or select statement -- d_b - -- d_c + -- d_c CUDA compilation : compile for the host -- d_d -- d_e Ignore entry calls and requeue statements for elaboration -- d_f Issue info messages related to GNATprove usage @@ -841,6 +835,8 @@ package body Debug is -- handling of Inline_Always by the front end on such targets. For the -- targets that do not use the GCC back end, this switch is ignored. + -- d.A Print Atree statistics + -- d.B Generate a bug box when we see an abort_statement, even though -- there is no bug. Useful for testing Comperr.Compiler_Abort: write -- some code containing an abort_statement, and compile it with @@ -881,6 +877,10 @@ package body Debug is -- now fixed, but we provide this debug flag to revert to the previous -- situation of ignoring such calls to aid in transition. + -- d.H Disable the support for 128-bit integer types on 64-bit platforms. + -- This makes it easier to mimic the behavior of the current compiler + -- on 32-bit platforms or of older compilers on 64-bit platforms. + -- d.I Do not ignore enum representation clauses in CodePeer mode. -- The default of ignoring representation clauses for enumeration -- types in CodePeer is good for the majority of Ada code, but in some @@ -1032,6 +1032,9 @@ package body Debug is -- flag also suppresses the additional messages explaining why a -- non-static expression is non-static (see Sem_Eval.Why_Not_Static). -- This avoids having to worry about these messages in ACATS testing. + -- Finally, this flag is also used for strict legality check, in + -- particular it will generate an error instead a warning when + -- encountering an unknown pragma. -- d3 Causes Comperr to dump the contents of the node for which an abort -- was detected (normally only the Node_Id of the node is output). diff --git a/gcc/ada/debug.ads b/gcc/ada/debug.ads index ccc9d11..83ad187 100644 --- a/gcc/ada/debug.ads +++ b/gcc/ada/debug.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/doc/gnat_rm/implementation_advice.rst b/gcc/ada/doc/gnat_rm/implementation_advice.rst index 998d0c5..e86ad0a 100644 --- a/gcc/ada/doc/gnat_rm/implementation_advice.rst +++ b/gcc/ada/doc/gnat_rm/implementation_advice.rst @@ -199,11 +199,11 @@ former provides improved compatibility with other implementations supporting this type. The latter corresponds to the highest precision floating-point type supported by the hardware. On most machines, this will be the same as ``Long_Float``, but on some machines, it will -correspond to the IEEE extended form. The notable case is all ia32 -(x86) implementations, where ``Long_Long_Float`` corresponds to -the 80-bit extended precision format supported in hardware on this -processor. Note that the 128-bit format on SPARC is not supported, -since this is a software rather than a hardware format. +correspond to the IEEE extended form. The notable case is all x86 +implementations, where ``Long_Long_Float`` corresponds to the 80-bit +extended precision format supported in hardware on this processor. +Note that the 128-bit format on SPARC is not supported, since this +is a software rather than a hardware format. .. index:: Multidimensional arrays diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst index 736710d..de5efea 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst @@ -564,9 +564,11 @@ Aspect Unreferenced =================== .. index:: Unreferenced -This boolean aspect is equivalent to :ref:`pragma Unreferenced<Pragma-Unreferenced>`. Note that -in the case of formal parameters, it is not permitted to have aspects for -a formal parameter, so in this case the pragma form must be used. +This boolean aspect is equivalent to :ref:`pragma Unreferenced<Pragma-Unreferenced>`. + +When using the ``-gnatX`` switch, this aspect is also supported on formal +parameters, which is in particular the only form possible for expression +functions. Aspect Unreferenced_Objects =========================== diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index 967e9d9..f98a427 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -657,6 +657,14 @@ target. This is a static value that can be used to specify the alignment for an object, guaranteeing that it is properly aligned in all cases. +Attribute Max_Integer_Size +========================== +.. index:: Max_Integer_Size + +``Standard'Max_Integer_Size`` (``Standard`` is the only permissible +prefix) provides the size of the largest supported integer type for +the target. The result is a static constant. + Attribute Mechanism_Code ======================== .. index:: Return values, passing mechanism diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst index a5425da..71e1834 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst @@ -13,8 +13,7 @@ Manual, and are summarized in Annex M. A requirement for conforming Ada compilers is that they provide documentation describing how the implementation deals with each of these issues. In this chapter you will find each point in Annex M listed, -followed by a description of how GNAT -handles the implementation dependence. +followed by a description of how GNAT handles the implementation dependence. You can use this chapter as a guide to minimizing implementation dependent features in your programs if portability to other compilers @@ -100,17 +99,19 @@ further details. "The predefined integer types declared in ``Standard``. See 3.5.4(25)." -====================== ======================================= -Type Representation -====================== ======================================= -*Short_Short_Integer* 8 bit signed -*Short_Integer* (Short) 16 bit signed -*Integer* 32 bit signed -*Long_Integer* 64 bit signed (on most 64 bit targets, - depending on the C definition of long). - 32 bit signed (all other targets) -*Long_Long_Integer* 64 bit signed -====================== ======================================= +========================= ======================================= +Type Representation +========================= ======================================= +*Short_Short_Integer* 8-bit signed +*Short_Integer* 16-bit signed +*Integer* 32-bit signed +*Long_Integer* 64-bit signed (on most 64-bit targets, + depending on the C definition of long) + 32-bit signed (on all other targets) +*Long_Long_Integer* 64-bit signed +*Long_Long_Long_Integer* 128-bit signed (on 64-bit targets) + 64-bit signed (on 32-bit targets) +========================= ======================================= * "Any nonstandard integer types and the operators defined @@ -155,7 +156,7 @@ Type Representation Any combinations are permitted that do not result in a small less than ``Fine_Delta`` and do not result in a mantissa larger than 63 bits. If the mantissa is larger than 53 bits on machines where Long_Long_Float -is 64 bits (true of all architectures except ia32), then the output from +is 64 bits (true of all architectures except x86), then the output from Text_IO is accurate to only 53 bits, rather than the full mantissa. This is because floating-point conversions are used to convert fixed point. @@ -1220,7 +1221,7 @@ is converted to the target type. The result is only defined to be in the perfect result set if the result can be computed by a single scaling operation involving a scale factor -representable in 64-bits. +representable in 64 bits. * "The result of a fixed point arithmetic operation in diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 737bc60..e1e6853 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -37,7 +37,21 @@ This pragma must appear at the start of the statement sequence of a handled sequence of statements (right after the ``begin``). It has the effect of deferring aborts for the sequence of statements (but not for the declarations or handlers, if any, associated with this statement -sequence). +sequence). This can also be useful for adding a polling point in Ada code, +where asynchronous abort of tasks is checked when leaving the statement +sequence, and is lighter than, for example, using ``delay 0.0;``, since with +zero-cost exception handling, propagating exceptions (implicitly used to +implement task abort) cannot be done reliably in an asynchronous way. + +An example of usage would be: + +.. code-block:: ada + + -- Add a polling point to check for task aborts + + begin + pragma Abort_Defer; + end; .. _Pragma-Abstract_State: @@ -4525,48 +4539,6 @@ type is potentially persistent. If this pragma is used on a target where this feature is not supported, then the pragma will be ignored. See also ``pragma Linker_Section``. -Pragma Polling -============== - -Syntax: - - -.. code-block:: ada - - pragma Polling (ON | OFF); - - -This pragma controls the generation of polling code. This is normally off. -If ``pragma Polling (ON)`` is used then periodic calls are generated to -the routine ``Ada.Exceptions.Poll``. This routine is a separate unit in the -runtime library, and can be found in file :file:`a-excpol.adb`. - -Pragma ``Polling`` can appear as a configuration pragma (for example it -can be placed in the :file:`gnat.adc` file) to enable polling globally, or it -can be used in the statement or declaration sequence to control polling -more locally. - -A call to the polling routine is generated at the start of every loop and -at the start of every subprogram call. This guarantees that the ``Poll`` -routine is called frequently, and places an upper bound (determined by -the complexity of the code) on the period between two ``Poll`` calls. - -The primary purpose of the polling interface is to enable asynchronous -aborts on targets that cannot otherwise support it (for example Windows -NT), but it may be used for any other purpose requiring periodic polling. -The standard version is null, and can be replaced by a user program. This -will require re-compilation of the ``Ada.Exceptions`` package that can -be found in files :file:`a-except.ads` and :file:`a-except.adb`. - -A standard alternative unit (in file :file:`4wexcpol.adb` in the standard GNAT -distribution) is used to enable the asynchronous abort capability on -targets that do not normally support the capability. The version of -``Poll`` in this file makes a call to the appropriate runtime routine -to test for an abort condition. - -Note that polling can also be enabled by use of the *-gnatP* switch. -See the section on switches for gcc in the :title:`GNAT User's Guide`. - Pragma Post =========== .. index:: Post @@ -7313,12 +7285,6 @@ there is no guarantee that all the bits will be accessed if the reference is not to the whole object; the compiler is allowed (and generally will) access only part of the object in this case. -It is not permissible to specify ``Atomic`` and ``Volatile_Full_Access`` for -the same type or object. - -It is not permissible to specify ``Volatile_Full_Access`` for a composite -(record or array) type or object that has an ``Aliased`` subcomponent. - .. _Pragma-Volatile_Function: Pragma Volatile_Function diff --git a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst index 7bae014..c13a882 100644 --- a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst @@ -195,12 +195,12 @@ increasing it. For example, if we have: type My_Boolean is new Boolean; for My_Boolean'Size use 32; -then values of this type will always be 32 bits long. In the case of -discrete types, the size can be increased up to 64 bits, with the effect -that the entire specified field is used to hold the value, sign- or -zero-extended as appropriate. If more than 64 bits is specified, then -padding space is allocated after the value, and a warning is issued that -there are unused bits. +then values of this type will always be 32-bit long. In the case of discrete +types, the size can be increased up to 64 bits on 32-bit targets and 128 bits +on 64-bit targets, with the effect that the entire specified field is used to +hold the value, sign- or zero-extended as appropriate. If more than 64 bits +or 128 bits resp. is specified, then padding space is allocated after the +value, and a warning is issued that there are unused bits. Similarly the size of records and arrays may be increased, and the effect is to add padding bits after the value. This also causes a warning message @@ -678,8 +678,9 @@ of this subtype, and must be a multiple of the alignment value. In addition, component size clauses are allowed which cause the array to be packed, by specifying a smaller value. A first case is for -component size values in the range 1 through 63. The value specified -must not be smaller than the Size of the subtype. GNAT will accurately +component size values in the range 1 through 63 on 32-bit targets, +and 1 through 127 on 64-bit targets. The value specified may not +be smaller than the Size of the subtype. GNAT will accurately honor all packing requests in this range. For example, if we have: @@ -1094,7 +1095,8 @@ be one of the following cases: * Any small simple record type with a static size. For all these cases, if the component subtype size is in the range -1 through 64, then the effect of the pragma ``Pack`` is exactly as though a +1 through 63 on 32-bit targets, and 1 through 127 on 64-bit targets, +then the effect of the pragma ``Pack`` is exactly as though a component size were specified giving the component subtype size. All other types are non-packable, they occupy an integral number of storage @@ -1124,11 +1126,13 @@ using an explicit ``Component_Size`` setting instead, which never generates a warning, since the intention of the programmer is clear in this case. GNAT treats packed arrays in one of two ways. If the size of the array is -known at compile time and is less than 64 bits, then internally the array -is represented as a single modular type, of exactly the appropriate number -of bits. If the length is greater than 63 bits, or is not known at compile -time, then the packed array is represented as an array of bytes, and the -length is always a multiple of 8 bits. +known at compile time and is at most 64 bits on 32-bit targets, and at most +128 bits on 64-bit targets, then internally the array is represented as a +single modular type, of exactly the appropriate number of bits. If the +length is greater than 64 bits on 32-bit targets, and greater than 128 +bits on 64-bit targets, or is not known at compile time, then the packed +array is represented as an array of bytes, and its length is always a +multiple of 8 bits. Note that to represent a packed array as a modular type, the alignment must be suitable for the modular type involved. For example, on typical machines @@ -1200,17 +1204,17 @@ taken by components. We distinguish between *packable* components and Components of the following types are considered packable: * Components of an elementary type are packable unless they are aliased, - independent, or of an atomic type. + independent or atomic. * Small packed arrays, where the size is statically known, are represented internally as modular integers, and so they are also packable. * Small simple records, where the size is statically known, are also packable. -For all these cases, if the ``'Size`` value is in the range 1 through 64, the -components occupy the exact number of bits corresponding to this value -and are packed with no padding bits, i.e. they can start on an arbitrary -bit boundary. +For all these cases, if the ``'Size`` value is in the range 1 through 64 on +32-bit targets, and 1 through 128 on 64-bit targets, the components occupy +the exact number of bits corresponding to this value and are packed with no +padding bits, i.e. they can start on an arbitrary bit boundary. All other types are non-packable, they occupy an integral number of storage units and the only effect of pragma ``Pack`` is to remove alignment gaps. @@ -1237,7 +1241,7 @@ For example, consider the record end record; pragma Pack (X2); -The representation for the record ``X2`` is as follows: +The representation for the record ``X2`` is as follows on 32-bit targets: .. code-block:: ada @@ -1252,17 +1256,16 @@ The representation for the record ``X2`` is as follows: end record; Studying this example, we see that the packable fields ``L1`` -and ``L2`` are -of length equal to their sizes, and placed at specific bit boundaries (and -not byte boundaries) to -eliminate padding. But ``L3`` is of a non-packable float type (because +and ``L2`` are of length equal to their sizes, and placed at +specific bit boundaries (and not byte boundaries) to eliminate +padding. But ``L3`` is of a non-packable float type (because it is aliased), so it is on the next appropriate alignment boundary. The next two fields are fully packable, so ``L4`` and ``L5`` are minimally packed with no gaps. However, type ``Rb2`` is a packed -array that is longer than 64 bits, so it is itself non-packable. Thus -the ``L6`` field is aligned to the next byte boundary, and takes an -integral number of bytes, i.e., 72 bits. +array that is longer than 64 bits, so it is itself non-packable on +32-bit targets. Thus the ``L6`` field is aligned to the next byte +boundary, and takes an integral number of bytes, i.e., 72 bits. .. _Record_Representation_Clauses: @@ -1283,7 +1286,8 @@ clauses is that the size must be at least the ``'Size`` value of the type (actually the Value_Size). There are no restrictions due to alignment, and such components may freely cross storage boundaries. -Packed arrays with a size up to and including 64 bits are represented +Packed arrays with a size up to and including 64 bits on 32-bit targets, +and up to and including 128 bits on 64-bit targets, are represented internally using a modular type with the appropriate number of bits, and thus the same lack of restriction applies. For example, if you declare: @@ -1296,30 +1300,30 @@ thus the same lack of restriction applies. For example, if you declare: then a component clause for a component of type ``R`` may start on any specified bit boundary, and may specify a value of 49 bits or greater. -For packed bit arrays that are longer than 64 bits, there are two -cases. If the component size is a power of 2 (1,2,4,8,16,32 bits), -including the important case of single bits or boolean values, then -there are no limitations on placement of such components, and they -may start and end at arbitrary bit boundaries. +For packed bit arrays that are longer than 64 bits on 32-bit targets, +and longer than 128 bits on 64-bit targets, there are two cases. If the +component size is a power of 2 (1,2,4,8,16,32,64 bits), including the +important case of single bits or boolean values, then there are no +limitations on placement of such components, and they may start and +end at arbitrary bit boundaries. -If the component size is not a power of 2 (e.g., 3 or 5), then -an array of this type longer than 64 bits must always be placed on -on a storage unit (byte) boundary and occupy an integral number -of storage units (bytes). Any component clause that does not -meet this requirement will be rejected. +If the component size is not a power of 2 (e.g., 3 or 5), then an array +of this type must always be placed on on a storage unit (byte) boundary +and occupy an integral number of storage units (bytes). Any component +clause that does not meet this requirement will be rejected. -Any aliased component, or component of an aliased type, must -have its normal alignment and size. A component clause that -does not meet this requirement will be rejected. +Any aliased component, or component of an aliased type, must have its +normal alignment and size. A component clause that does not meet this +requirement will be rejected. The tag field of a tagged type always occupies an address sized field at the start of the record. No component clause may attempt to overlay this tag. When a tagged type appears as a component, the tag field must have proper alignment -In the case of a record extension ``T1``, of a type ``T``, no component clause applied -to the type ``T1`` can specify a storage location that would overlap the first -``T'Size`` bytes of the record. +In the case of a record extension ``T1``, of a type ``T``, no component +clause applied to the type ``T1`` can specify a storage location that +would overlap the first ``T'Object_Size`` bits of the record. For all other component types, including non-bit-packed arrays, the component can be placed at an arbitrary bit boundary, @@ -1350,8 +1354,7 @@ Handling of Records with Holes .. index:: Handling of Records with Holes As a result of alignment considerations, records may contain "holes" -or gaps -which do not correspond to the data bits of any of the components. +or gaps which do not correspond to the data bits of any of the components. Record representation clauses can also result in holes in records. GNAT does not attempt to clear these holes, so in record objects, diff --git a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst index b0f59cf..3e7dc051 100644 --- a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst +++ b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst @@ -496,7 +496,7 @@ No_Local_Timing_Events ---------------------- .. index:: No_Local_Timing_Events -[RM D.7] All objects of type Ada.Timing_Events.Timing_Event are +[RM D.7] All objects of type Ada.Real_Time.Timing_Events.Timing_Event are declared at the library level. No_Long_Long_Integers diff --git a/gcc/ada/doc/gnat_rm/the_gnat_library.rst b/gcc/ada/doc/gnat_rm/the_gnat_library.rst index 6b9a410..d70e71c 100644 --- a/gcc/ada/doc/gnat_rm/the_gnat_library.rst +++ b/gcc/ada/doc/gnat_rm/the_gnat_library.rst @@ -505,6 +505,18 @@ This package provides subprograms for Text_IO for unbounded wide wide strings, avoiding the necessity for an intermediate operation with ordinary wide wide strings. +.. _`Ada.Task_Initialization_(a-tasini.ads)`: + +``Ada.Task_Initialization`` (:file:`a-tasini.ads`) +================================================== + +.. index:: Ada.Task_Initialization (a-tasini.ads) + +This package provides a way to set a global initialization handler that +is automatically invoked whenever a task is activated. Handlers are +parameterless procedures. Note that such a handler is only invoked for +those tasks activated after the handler is set. + .. _`Ada.Text_IO.C_Streams_(a-tiocst.ads)`: ``Ada.Text_IO.C_Streams`` (:file:`a-tiocst.ads`) diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index 1d44d70..1dec487 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -2058,15 +2058,6 @@ Alphabetical List of All Switches Cancel effect of previous :switch:`-gnatp` switch. -.. index:: -gnatP (gcc) - -:switch:`-gnatP` - Enable polling. This is required on some systems (notably Windows NT) to - obtain asynchronous abort and asynchronous transfer of control capability. - See ``Pragma_Polling`` in the :title:`GNAT_Reference_Manual` for full - details. - - .. index:: -gnatq (gcc) :switch:`-gnatq` @@ -3874,8 +3865,14 @@ of the pragma in the :title:`GNAT_Reference_manual`). This switch activates warnings for access to variables which may not be properly initialized. The default is that - such warnings are generated. + such warnings are generated. This switch will also be emitted when + initializing an array or record object via the following aggregate: + + .. code-block:: ada + Array_Or_Record : XXX := (others => <>); + + unless the relevant type fully initializes all components. .. index:: -gnatwV (gcc) @@ -3884,17 +3881,6 @@ of the pragma in the :title:`GNAT_Reference_manual`). This switch suppresses warnings for access to variables which may not be properly initialized. - For variables of a composite type, the warning can also be suppressed in - Ada 2005 by using a default initialization with a box. For example, if - Table is an array of records whose components are only partially uninitialized, - then the following code: - - .. code-block:: ada - - Tab : Table := (others => <>); - - will suppress warnings on subsequent statements that access components - of variable Tab. .. index:: -gnatw.v (gcc) @@ -6508,8 +6494,8 @@ be presented in subsequent sections. limitations: * Starting the program's execution in the debugger will cause it to - stop at the start of the ``main`` function instead of the main subprogram. - This can be worked around by manually inserting a breakpoint on that + stop at the start of the ``main`` function instead of the main subprogram. + This can be worked around by manually inserting a breakpoint on that subprogram and resuming the program's execution until reaching that breakpoint. * Programs using GNAT.Compiler_Version will not link. diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst index 883f012..5c51222 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst @@ -1920,12 +1920,13 @@ building specialized scripts. :switch:`--comments-fill` - Fill comment blocks. + Fill comment blocks. This is the default. + Use :switch:`--no-comments-fill` to turn off filling. :switch:`--comments-special` Keep unchanged special form comments. - This is the default. + The default is :switch:`--no-comments-special`. .. index:: --comments-only (gnatpp) @@ -2153,18 +2154,18 @@ building specialized scripts. A_Very_Very_Very_Very_Very_Very_Very_Very_Long_One); - .. index:: --call_threshold (gnatpp) + .. index:: --call-threshold (gnatpp) - :switch:`--call_threshold={nnn}` + :switch:`--call-threshold={nnn}` If the number of parameter associations is greater than ``nnn`` and if at least one association uses named notation, start each association from a new line. If ``nnn`` is 0, no check for the number of associations is made; this is the default. - .. index:: --par_threshold (gnatpp) + .. index:: --par-threshold (gnatpp) - :switch:`--par_threshold={nnn}` + :switch:`--par-threshold={nnn}` If the number of parameter specifications is greater than ``nnn`` (or equal to ``nnn`` in case of a function), start each specification from a new line. If ``nnn`` is 0, and :switch:`--no-separate-is` was not specified, then diff --git a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst index b8729d0..2f0e10c 100644 --- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst +++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst @@ -1445,7 +1445,6 @@ recognized by GNAT:: Overriding_Renamings Partition_Elaboration_Policy Persistent_BSS - Polling Prefix_Exception_Messages Priority_Specific_Dispatching Profile diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index bf839a5..f39b3bc 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -13,25 +13,16 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -pragma Style_Checks (All_Checks); --- Turn off subprogram ordering, not used for this unit - with Atree; use Atree; with Elists; use Elists; with Namet; use Namet; @@ -1526,7 +1517,7 @@ package body Einfo is function Has_Constrained_Partial_View (Id : E) return B is begin pragma Assert (Is_Type (Id)); - return Flag187 (Id); + return Flag187 (Base_Type (Id)); end Has_Constrained_Partial_View; function Has_Controlled_Component (Id : E) return B is @@ -2867,7 +2858,7 @@ package body Einfo is function Minimum_Accessibility (Id : E) return E is begin - pragma Assert (Ekind (Id) in Formal_Kind); + pragma Assert (Is_Formal (Id)); return Node24 (Id); end Minimum_Accessibility; @@ -3311,6 +3302,13 @@ package body Einfo is function Scope_Depth_Value (Id : E) return U is begin + pragma Assert + (Ekind (Id) in + Concurrent_Kind | Entry_Kind | Generic_Unit_Kind | + E_Package | E_Package_Body | Subprogram_Kind | + E_Block | E_Subprogram_Body | + E_Private_Type .. E_Limited_Private_Subtype | + E_Void | E_Loop | E_Return_Statement); return Uint22 (Id); end Scope_Depth_Value; @@ -6067,7 +6065,8 @@ package body Einfo is procedure Set_Limited_View (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Package); + pragma Assert (Ekind (Id) = E_Package + and then not Is_Generic_Instance (Id)); Set_Node23 (Id, V); end Set_Limited_View; @@ -6126,7 +6125,7 @@ package body Einfo is procedure Set_Minimum_Accessibility (Id : E; V : E) is begin - pragma Assert (Ekind (Id) in Formal_Kind); + pragma Assert (Is_Formal (Id)); Set_Node24 (Id, V); end Set_Minimum_Accessibility; @@ -6582,7 +6581,13 @@ package body Einfo is procedure Set_Scope_Depth_Value (Id : E; V : U) is begin - pragma Assert (not Is_Record_Type (Id)); + pragma Assert + (Ekind (Id) in + Concurrent_Kind | Entry_Kind | Generic_Unit_Kind | + E_Package | E_Package_Body | Subprogram_Kind | + E_Block | E_Subprogram_Body | + E_Private_Type .. E_Limited_Private_Subtype | + E_Void | E_Loop | E_Return_Statement); Set_Uint22 (Id, V); end Set_Scope_Depth_Value; @@ -7647,10 +7652,11 @@ package body Einfo is Id = Pragma_Refined_State or else Id = Pragma_Volatile_Function; - -- Contract / test case pragmas + -- Contract / subprogram variant / test case pragmas Is_CTC : constant Boolean := Id = Pragma_Contract_Cases or else + Id = Pragma_Subprogram_Variant or else Id = Pragma_Test_Case; -- Pre / postcondition pragmas @@ -7836,6 +7842,17 @@ package body Einfo is end Has_Invariants; -------------------------- + -- Has_Limited_View -- + -------------------------- + + function Has_Limited_View (Id : E) return B is + begin + return Ekind (Id) = E_Package + and then not Is_Generic_Instance (Id) + and then Present (Limited_View (Id)); + end Has_Limited_View; + + -------------------------- -- Has_Non_Limited_View -- -------------------------- @@ -8029,15 +8046,6 @@ package body Einfo is return Empty; end Invariant_Procedure; - ---------------------- - -- Is_Atomic_Or_VFA -- - ---------------------- - - function Is_Atomic_Or_VFA (Id : E) return B is - begin - return Is_Atomic (Id) or else Is_Volatile_Full_Access (Id); - end Is_Atomic_Or_VFA; - ------------------ -- Is_Base_Type -- ------------------ @@ -8196,6 +8204,15 @@ package body Einfo is return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; end Is_Finalizer; + ---------------------- + -- Is_Full_Access -- + ---------------------- + + function Is_Full_Access (Id : E) return B is + begin + return Is_Atomic (Id) or else Is_Volatile_Full_Access (Id); + end Is_Full_Access; + ------------------- -- Is_Null_State -- ------------------- @@ -10873,21 +10890,18 @@ package body Einfo is when Formal_Kind => Write_Str ("Protected_Formal"); - when E_Block - | E_Entry - | E_Entry_Family - | E_Function - | E_Generic_Function - | E_Generic_Package - | E_Generic_Procedure - | E_Loop + when Concurrent_Kind + | Entry_Kind + | Generic_Unit_Kind | E_Package | E_Package_Body - | E_Procedure - | E_Protected_Type - | E_Return_Statement + | Subprogram_Kind + | E_Block | E_Subprogram_Body - | E_Task_Type + | E_Private_Type .. E_Limited_Private_Subtype + | E_Void + | E_Loop + | E_Return_Statement => Write_Str ("Scope_Depth_Value"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7932c92..be195ab 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -1576,7 +1570,7 @@ package Einfo is -- Defined for the given type. Note that this flag can be False even -- if Component_Size is non-zero (happens in the case of derived types). --- Has_Constrained_Partial_View (Flag187) +-- Has_Constrained_Partial_View (Flag187) [base type only] -- Defined in private type and their completions, when the private -- type has no discriminants and the full view has discriminants with -- defaults. In Ada 2005 heap-allocated objects of such types are not @@ -1785,6 +1779,10 @@ package Einfo is -- invariant of its own or inherits at least one class-wide invariant -- from a parent type or an interface. +-- Has_Limited_View (synth) +-- Defined in all entities. True for non-generic package entities that +-- are non-instances and their Limited_View attribute is present. + -- Has_Loop_Entry_Attributes (Flag260) -- Defined in E_Loop entities. Set when the loop is subject to at least -- one attribute 'Loop_Entry. The flag also implies that the loop has @@ -1861,8 +1859,8 @@ package Einfo is -- Has_Own_DIC (Flag3) [base type only] -- Defined in all type entities. Set for a private type and its full view --- (and its underlying full view, if the full view is itsef private) when --- the type is subject to pragma Default_Initial_Condition. +-- (and its underlying full view, if the full view is itself private) +-- when the type is subject to pragma Default_Initial_Condition. -- Has_Own_Invariants (Flag232) [base type only] -- Defined in all type entities. Set on any type that defines at least @@ -2376,12 +2374,11 @@ package Einfo is -- In the case of private and incomplete types, this flag is set in -- both the partial view and the full view. --- Is_Atomic_Or_VFA (synth) +-- Is_Full_Access (synth) -- Defined in all type entities, and also in constants, components and --- variables. Set if a pragma Atomic or Shared or Volatile_Full_Access --- applies to the entity. For many purposes VFA objects should be treated --- the same as Atomic objects, and this predicate is intended for that --- usage. In the case of private and incomplete types, the predicate +-- variables. Set if an aspect/pragma Atomic/Shared, or an aspect/pragma +-- Volatile_Full_Access or an Ada 2020 aspect Full_Access_Only applies +-- to the entity. In the case of private and incomplete types, the flag -- applies to both the partial view and the full view. -- Is_Base_Type (synthesized) @@ -2657,10 +2654,6 @@ package Einfo is -- Used to generate constraint checks on calls to these subprograms, even -- within an instance of a predefined run-time unit, in which checks -- are otherwise suppressed. --- --- The flag is also set on the entity of the expression function created --- within an instance, for a function that has external axiomatization, --- for use in GNATprove mode. -- Is_Generic_Actual_Type (Flag94) -- Defined in all type and subtype entities. Set in the subtype @@ -3424,9 +3417,10 @@ package Einfo is -- Is_Volatile_Full_Access (Flag285) -- Defined in all type entities, and also in constants, components, and --- variables. Set if a pragma Volatile_Full_Access applies to the entity. --- In the case of private and incomplete types, this flag is set in --- both the partial view and the full view. +-- variables. Set if an aspect/pragma Volatile_Full_Access or an Ada 2020 +-- aspect Full_Access_Only applies to the entity. In the case of private +-- and incomplete types, this flag is set in both the partial view and +-- the full view. -- Is_Wrapper_Package (synthesized) -- Defined in package entities. Indicates that the package has been @@ -4280,14 +4274,16 @@ package Einfo is -- the Scope will be Standard. -- Scope_Depth (synthesized) --- Applies to program units, blocks, concurrent types and entries, and --- also to record types, i.e. to any entity that can appear on the scope --- stack. Yields the scope depth value, which for those entities other --- than records is simply the scope depth value, for record entities, it --- is the Scope_Depth of the record scope. +-- Applies to program units, blocks, loops, return statements, +-- concurrent types, private types and entries, and also to record types, +-- i.e. to any entity that can appear on the scope stack. Yields the +-- scope depth value, which for those entities other than records is +-- simply the scope depth value, for record entities, it is the +-- Scope_Depth of the record scope. -- Scope_Depth_Value (Uint22) --- Defined in program units, blocks, concurrent types, and entries. +-- Defined in program units, blocks, loops, return statements, +-- concurrent types, private types and entries. -- Indicates the number of scopes that statically enclose the declaration -- of the unit or type. Library units have a depth of zero. Note that -- record types can act as scopes but do NOT have this field set (see @@ -5819,7 +5815,7 @@ package Einfo is -- Implementation_Base_Type (synth) -- Invariant_Procedure (synth) -- Is_Access_Protected_Subprogram_Type (synth) - -- Is_Atomic_Or_VFA (synth) + -- Is_Full_Access (synth) -- Is_Controlled (synth) -- Object_Size_Clause (synth) -- Partial_Invariant_Procedure (synth) @@ -5986,7 +5982,7 @@ package Einfo is -- Is_Volatile (Flag16) -- Is_Volatile_Full_Access (Flag285) -- Treat_As_Volatile (Flag41) - -- Is_Atomic_Or_VFA (synth) + -- Is_Full_Access (synth) -- Next_Component (synth) -- Next_Component_Or_Discriminant (synth) @@ -6040,8 +6036,8 @@ package Einfo is -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) - -- Is_Atomic_Or_VFA (synth) -- Is_Elaboration_Target (synth) + -- Is_Full_Access (synth) -- Size_Clause (synth) -- E_Decimal_Fixed_Point_Type @@ -6482,6 +6478,7 @@ package Einfo is -- Has_Null_Abstract_State (synth) -- Is_Elaboration_Target (synth) -- Is_Wrapper_Package (synth) (non-generic case only) + -- Has_Limited_View (synth) (non-generic case only) -- Scope_Depth (synth) -- E_Package_Body @@ -6859,8 +6856,8 @@ package Einfo is -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) - -- Is_Atomic_Or_VFA (synth) -- Is_Elaboration_Target (synth) + -- Is_Full_Access (synth) -- Size_Clause (synth) -- E_Void @@ -7673,13 +7670,13 @@ package Einfo is function Has_Foreign_Convention (Id : E) return B; function Has_Interrupt_Handler (Id : E) return B; function Has_Invariants (Id : E) return B; + function Has_Limited_View (Id : E) return B; function Has_Non_Limited_View (Id : E) return B; function Has_Non_Null_Abstract_State (Id : E) return B; function Has_Non_Null_Visible_Refinement (Id : E) return B; function Has_Null_Abstract_State (Id : E) return B; function Has_Null_Visible_Refinement (Id : E) return B; function Implementation_Base_Type (Id : E) return E; - function Is_Atomic_Or_VFA (Id : E) return B; function Is_Base_Type (Id : E) return B; function Is_Boolean_Type (Id : E) return B; function Is_Constant_Object (Id : E) return B; @@ -7689,6 +7686,7 @@ package Einfo is function Is_Elaboration_Target (Id : E) return B; function Is_External_State (Id : E) return B; function Is_Finalizer (Id : E) return B; + function Is_Full_Access (Id : E) return B; function Is_Null_State (Id : E) return B; function Is_Package_Or_Generic_Package (Id : E) return B; function Is_Packed_Array (Id : E) return B; @@ -8519,6 +8517,7 @@ package Einfo is -- Refined_Global -- Refined_Post -- Refined_State + -- Subprogram_Variant -- Test_Case -- Volatile_Function @@ -8890,7 +8889,6 @@ package Einfo is pragma Inline (Is_Assignable); pragma Inline (Is_Asynchronous); pragma Inline (Is_Atomic); - pragma Inline (Is_Atomic_Or_VFA); pragma Inline (Is_Bit_Packed_Array); pragma Inline (Is_Called); pragma Inline (Is_Character_Type); @@ -8941,6 +8939,7 @@ package Einfo is pragma Inline (Is_Formal_Object); pragma Inline (Is_Formal_Subprogram); pragma Inline (Is_Frozen); + pragma Inline (Is_Full_Access); pragma Inline (Is_Generic_Actual_Subprogram); pragma Inline (Is_Generic_Actual_Type); pragma Inline (Is_Generic_Instance); @@ -9204,6 +9203,7 @@ package Einfo is pragma Inline (Base_Type); pragma Inline (Float_Rep); pragma Inline (Has_Foreign_Convention); + pragma Inline (Has_Limited_View); pragma Inline (Has_Non_Limited_View); pragma Inline (Is_Base_Type); pragma Inline (Is_Boolean_Type); diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index 90bcd2e..16e802d 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -373,6 +367,64 @@ package body Elists is return Elists.Last; end New_Elmt_List; + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List (Elmt1 : Node_Or_Entity_Id) + return Elist_Id + is + L : constant Elist_Id := New_Elmt_List; + begin + Append_Elmt (Elmt1, L); + return L; + end New_Elmt_List; + + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id) return Elist_Id + is + L : constant Elist_Id := New_Elmt_List (Elmt1); + begin + Append_Elmt (Elmt2, L); + return L; + end New_Elmt_List; + + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id; + Elmt3 : Node_Or_Entity_Id) return Elist_Id + is + L : constant Elist_Id := New_Elmt_List (Elmt1, Elmt2); + begin + Append_Elmt (Elmt3, L); + return L; + end New_Elmt_List; + + ------------------- + -- New_Elmt_List -- + ------------------- + + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id; + Elmt3 : Node_Or_Entity_Id; + Elmt4 : Node_Or_Entity_Id) return Elist_Id + is + L : constant Elist_Id := New_Elmt_List (Elmt1, Elmt2, Elmt3); + begin + Append_Elmt (Elmt4, L); + return L; + end New_Elmt_List; + --------------- -- Next_Elmt -- --------------- diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads index 12672a6..92b74fc 100644 --- a/gcc/ada/elists.ads +++ b/gcc/ada/elists.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -90,6 +84,21 @@ package Elists is -- a field in some other node which points to an element list where the -- list is then subsequently filled in using Append calls. + function New_Elmt_List (Elmt1 : Node_Or_Entity_Id) return Elist_Id; + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id) return Elist_Id; + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id; + Elmt3 : Node_Or_Entity_Id) return Elist_Id; + function New_Elmt_List + (Elmt1 : Node_Or_Entity_Id; + Elmt2 : Node_Or_Entity_Id; + Elmt3 : Node_Or_Entity_Id; + Elmt4 : Node_Or_Entity_Id) return Elist_Id; + -- Create a new element list containing the given arguments. + function First_Elmt (List : Elist_Id) return Elmt_Id; pragma Inline (First_Elmt); -- Obtains the first element of the given element list or, if the list has diff --git a/gcc/ada/env.c b/gcc/ada/env.c index 5df0539..0ee09f4 100644 --- a/gcc/ada/env.c +++ b/gcc/ada/env.c @@ -68,18 +68,9 @@ envLib.h on VxWorks MILS and VxWorks 653. */ #include <vThreadsData.h> #include <envLib.h> - #elif (_WRS_VXWORKS_MAJOR <= 6) + #else + /* Kernel mode */ #include <envLib.h> - /* In that mode the following symbol is not defined in any VxWorks - include files, prior to vxWorks 7, so we declare it as extern. */ - extern char** ppGlobalEnviron; - #elif (_WRS_VXWORKS_MAJOR >= 7) - /* This should work for kernel mode on VxWorks 7.x. In 7.2 the tcb - is made private, so accessor functions must be used, in 7.0 it - is optional but there is no way to distinguish between 7.2 - and 7.0 since the version.h header file was never updated. */ - #include <envLib.h> - #include <taskLibCommon.h> #endif #endif @@ -108,7 +99,8 @@ __gnat_getenv (char *name, int *len, char **value) void __gnat_setenv (char *name, char *value) { -#if (defined (__vxworks) && defined (__RTP__)) || defined (__APPLE__) +#if (defined (__vxworks) && (defined (__RTP__) || _WRS_VXWORKS_MAJOR >= 7)) \ + || defined (__APPLE__) setenv (name, value, 1); #else @@ -119,9 +111,9 @@ __gnat_setenv (char *name, char *value) sprintf (expression, "%s=%s", name, value); putenv (expression); -#if defined (__MINGW32__) || (defined (__vxworks) && ! defined (__RTP__)) - /* On some systems like MacOS X and Windows, putenv is making a copy of the - expression string so we can free it after the call to putenv */ +#if defined (__MINGW32__) || defined (__vxworks) + /* putenv for Windows and VxWorks 6 kernel modules makes a copy of the + expression string, so we need to free it after the call to putenv. */ free (expression); #endif #endif @@ -144,17 +136,16 @@ __gnat_environ (void) extern char **environ; return environ; #else - #if defined (__RTP__) || defined (VTHREADS) || (_WRS_VXWORKS_MAJOR <= 6) + #if defined (__RTP__) || defined (VTHREADS) return environ; - #elif (_WRS_VXWORKS_MAJOR >= 7) - char **task_environ; - - task_environ = envGet (taskIdSelf ()); - - if (task_environ == NULL) - return ppGlobalEnviron; - else - return task_environ; + #else + /* For VxWorks kernel modules use envGet to get the task's environment + (either the task's private environment if it has one or the global + environment otherwise). taskId parameter of 0 refers to the current + task (the VxWorks documentation says to use NULL but the compiler + complains that taskId is an int rather than a pointer. Internally, + VxWorks uses 0 as well). */ + return envGet (0); #endif #endif } @@ -162,7 +153,8 @@ __gnat_environ (void) void __gnat_unsetenv (char *name) { #if defined (__hpux__) || defined (__sun__) \ - || (defined (__vxworks) && ! defined (__RTP__)) \ + || (defined (__vxworks) && ! defined (__RTP__) \ + && _WRS_VXWORKS_MAJOR <= 6) \ || defined (_AIX) || defined (__Lynx__) /* On Solaris and HP-UX there is no function to clear an environment @@ -185,7 +177,7 @@ void __gnat_unsetenv (char *name) if (strlen (env[index]) > size) { if (strstr (env[index], name) == env[index] && env[index][size] == '=') { -#if defined (__vxworks) && ! defined (__RTP__) +#if defined (__vxworks) /* on Vxworks we are sure that the string has been allocated using malloc */ free (env[index]); @@ -218,9 +210,10 @@ void __gnat_unsetenv (char *name) void __gnat_clearenv (void) { #if defined (__sun__) \ - || (defined (__vxworks) && ! defined (__RTP__)) || defined (__Lynx__) \ + || (defined (__vxworks) && !defined (__RTP__) && _WRS_VXWORKS_MAJOR <= 6) \ + || defined (__Lynx__) \ || defined (__PikeOS__) - /* On Solaris, VxWorks (not RTPs), and Lynx there is no system + /* On Solaris, VxWorks kernel pre 7, and Lynx there is no system call to unset a variable or to clear the environment so set all the entries in the environ table to NULL (see comment in __gnat_unsetenv for more explanation). */ @@ -232,7 +225,8 @@ void __gnat_clearenv (void) index++; } #elif defined (__MINGW32__) || defined (__FreeBSD__) || defined (__APPLE__) \ - || (defined (__vxworks) && defined (__RTP__)) || defined (__CYGWIN__) \ + || (defined (__vxworks) && defined (__RTP__) || _WRS_VXWORKS_MAJOR >= 7) \ + || defined (__CYGWIN__) \ || defined (__NetBSD__) || defined (__OpenBSD__) || defined (__rtems__) \ || defined (__DragonFly__) || defined (__DJGPP__) /* On Windows, FreeBSD and MacOS there is no function to clean all the diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 1063d7d..049db89 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -1119,6 +1119,8 @@ package body Errout is Prev => No_Error_Msg, Sptr => Sptr, Optr => Optr, + Insertion_Sloc => (if Has_Insertion_Line then Error_Msg_Sloc + else No_Location), Sfile => Get_Source_File_Index (Sptr), Line => Get_Physical_Line_Number (Sptr), Col => Get_Column_Number (Sptr), @@ -1823,8 +1825,8 @@ package body Errout is --------------------- procedure Output_Messages is - E : Error_Msg_Id; - Err_Flag : Boolean; + + -- Local subprograms procedure Write_Error_Summary; -- Write error summary @@ -1835,6 +1837,14 @@ package body Errout is procedure Write_Max_Errors; -- Write message if max errors reached + procedure Write_Source_Code_Line (Loc : Source_Ptr); + -- Write the source code line corresponding to Loc, as follows: + -- + -- line | actual code line here with Loc somewhere + -- | ^ here + -- + -- where the carret on the last line points to location Loc. + ------------------------- -- Write_Error_Summary -- ------------------------- @@ -2025,6 +2035,83 @@ package body Errout is end if; end Write_Max_Errors; + ---------------------------- + -- Write_Source_Code_Line -- + ---------------------------- + + procedure Write_Source_Code_Line (Loc : Source_Ptr) is + + function Image (X : Positive; Width : Positive) return String; + -- Output number X over Width characters, with whitespace padding. + -- Only output the low-order Width digits of X, if X is larger than + -- Width digits. + + ----------- + -- Image -- + ----------- + + function Image (X : Positive; Width : Positive) return String is + Str : String (1 .. Width); + Curr : Natural := X; + begin + for J in reverse 1 .. Width loop + if Curr > 0 then + Str (J) := Character'Val (Character'Pos ('0') + Curr mod 10); + Curr := Curr / 10; + else + Str (J) := ' '; + end if; + end loop; + + return Str; + end Image; + + -- Local variables + + Line : constant Pos := Pos (Get_Physical_Line_Number (Loc)); + Col : constant Natural := Natural (Get_Column_Number (Loc)); + Width : constant := 5; + + Buf : Source_Buffer_Ptr; + Cur_Loc : Source_Ptr := Loc; + + -- Start of processing for Write_Source_Code_Line + + begin + if Loc >= First_Source_Ptr then + Buf := Source_Text (Get_Source_File_Index (Loc)); + + -- First line with the actual source code line + + Write_Str (Image (Positive (Line), Width => Width)); + Write_Str (" |"); + Write_Str (String (Buf (Loc - Source_Ptr (Col) + 1 .. Loc - 1))); + + while Cur_Loc <= Buf'Last + and then Buf (Cur_Loc) /= ASCII.LF + loop + Write_Char (Buf (Cur_Loc)); + Cur_Loc := Cur_Loc + 1; + end loop; + + Write_Eol; + + -- Second line with carret sign pointing to location Loc + + Write_Str (String'(1 .. Width => ' ')); + Write_Str (" |"); + Write_Str (String'(1 .. Col - 1 => ' ')); + Write_Str ("^ here"); + Write_Eol; + end if; + end Write_Source_Code_Line; + + -- Local variables + + E : Error_Msg_Id; + Err_Flag : Boolean; + Use_Prefix : Boolean; + -- Start of processing for Output_Messages begin @@ -2051,27 +2138,72 @@ package body Errout is E := First_Error_Msg; while E /= No_Error_Msg loop + + -- If -gnatdF is used, separate main messages from previous + -- messages with a newline (unless it is an info message) and + -- make continuation messages follow the main message with only + -- an indentation of two space characters, without repeating + -- file:line:col: prefix. + + Use_Prefix := + not (Debug_Flag_FF and then Errors.Table (E).Msg_Cont); + if not Errors.Table (E).Deleted and then not Debug_Flag_KK then - if Full_Path_Name_For_Brief_Errors then - Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); - else - Write_Name (Reference_Name (Errors.Table (E).Sfile)); + + if Debug_Flag_FF then + if Errors.Table (E).Msg_Cont then + Write_Str (" "); + elsif not Errors.Table (E).Info then + Write_Eol; + end if; end if; - Write_Char (':'); - Write_Int (Int (Physical_To_Logical - (Errors.Table (E).Line, - Errors.Table (E).Sfile))); - Write_Char (':'); + if Use_Prefix then + if Full_Path_Name_For_Brief_Errors then + Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); + else + Write_Name (Reference_Name (Errors.Table (E).Sfile)); + end if; + + Write_Char (':'); + Write_Int (Int (Physical_To_Logical + (Errors.Table (E).Line, + Errors.Table (E).Sfile))); + Write_Char (':'); + + if Errors.Table (E).Col < 10 then + Write_Char ('0'); + end if; - if Errors.Table (E).Col < 10 then - Write_Char ('0'); + Write_Int (Int (Errors.Table (E).Col)); + Write_Str (": "); end if; - Write_Int (Int (Errors.Table (E).Col)); - Write_Str (": "); Output_Msg_Text (E); Write_Eol; + + -- If -gnatdF is used, write the source code line corresponding + -- to the location of the main message (unless it is an info + -- message). Also write the source code line corresponding to + -- an insertion location inside continuation messages. + + if Debug_Flag_FF + and then not Errors.Table (E).Info + then + if Errors.Table (E).Msg_Cont then + declare + Loc : constant Source_Ptr := + Errors.Table (E).Insertion_Sloc; + begin + if Loc /= No_Location then + Write_Source_Code_Line (Loc); + end if; + end; + + else + Write_Source_Code_Line (Errors.Table (E).Sptr); + end if; + end if; end if; E := Errors.Table (E).Next; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 83a23cc..e46433f 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -112,8 +112,8 @@ package Errout is -- already placed an error (not warning) message at that location, -- then we assume this is cascaded junk and delete the message. - -- This normal suppression action may be overridden in cases 2-5 (but not - -- in case 1 or 7 by setting All_Errors mode, or by setting the special + -- This normal suppression action may be overridden in cases 2-5 (but + -- not in case 1 or 7) by setting All_Errors mode, or by setting the -- unconditional message insertion character (!) as described below. --------------------------------------------------------- @@ -453,6 +453,15 @@ package Errout is -- Note that is mandatory that the caller ensure that global variables -- are set before the Error_Msg call, otherwise the result is undefined. + -- Also note that calls to Error_Msg and its variants destroy the value of + -- these global variables, as a way to support the inclusion of multiple + -- insertion characters of the same type. For example, support for + -- multiple characters % for a name in the message (up to 3) is + -- implemented by unconditionally shifting the value for Error_Msg_Nam_2 + -- to Error_Msg_Nam_1 and from Error_Msg_Nam_3 to Error_Msg_Nam_2 after + -- dealing with insertion character %. The caller should ensure that all + -- global variables are restored if needed prior to calling Error_Msg. + Error_Msg_Col : Column_Number renames Err_Vars.Error_Msg_Col; -- Column for @ insertion character in message diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 0c5d98c..d0cc6ff 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -689,9 +689,16 @@ package body Erroutc is Txt := Text; end if; + -- If -gnatdF is used, continuation messages follow the main message + -- with only an indentation of two space characters, without repeating + -- any prefix. + + if Debug_Flag_FF and then E_Msg.Msg_Cont then + null; + -- For info messages, prefix message with "info: " - if E_Msg.Info then + elsif E_Msg.Info then Txt := new String'("info: " & Txt.all); -- Warning treated as error @@ -807,37 +814,49 @@ package body Erroutc is J : Natural; begin - -- Nothing to do for continuation line + -- Nothing to do for continuation line, unless -gnatdF is set - if Msg (Msg'First) = '\' then + if not Debug_Flag_FF and then Msg (Msg'First) = '\' then return; - end if; - -- Set initial values of globals (may be changed during scan) + -- Some global variables are not set for continuation messages, as they + -- only make sense for the initial mesage. + + elsif Msg (Msg'First) /= '\' then - Is_Serious_Error := True; - Is_Unconditional_Msg := False; - Is_Warning_Msg := False; - Has_Double_Exclam := False; + -- Set initial values of globals (may be changed during scan) - -- Check style message + Is_Serious_Error := True; + Is_Unconditional_Msg := False; + Is_Warning_Msg := False; - Is_Style_Msg := - Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)"; + -- Check style message - -- Check info message + Is_Style_Msg := + Msg'Length > 7 + and then Msg (Msg'First .. Msg'First + 6) = "(style)"; - Is_Info_Msg := - Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "info: "; + -- Check info message - -- Check check message + Is_Info_Msg := + Msg'Length > 6 + and then Msg (Msg'First .. Msg'First + 5) = "info: "; - Is_Check_Msg := - (Msg'Length > 8 and then Msg (Msg'First .. Msg'First + 7) = "medium: ") - or else - (Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "high: ") - or else - (Msg'Length > 5 and then Msg (Msg'First .. Msg'First + 4) = "low: "); + -- Check check message + + Is_Check_Msg := + (Msg'Length > 8 + and then Msg (Msg'First .. Msg'First + 7) = "medium: ") + or else + (Msg'Length > 6 + and then Msg (Msg'First .. Msg'First + 5) = "high: ") + or else + (Msg'Length > 5 + and then Msg (Msg'First .. Msg'First + 4) = "low: "); + end if; + + Has_Double_Exclam := False; + Has_Insertion_Line := False; -- Loop through message looking for relevant insertion sequences @@ -896,6 +915,12 @@ package body Erroutc is J := J + 1; end if; + -- Insertion line (# insertion) + + elsif Msg (J) = '#' then + Has_Insertion_Line := True; + J := J + 1; + -- Non-serious error (| insertion) elsif Msg (J) = '|' then diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 8472ee5..4c0e68a 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -51,6 +51,10 @@ package Erroutc is -- Set true to indicate that the current message contains the insertion -- sequence !! (force warnings even in non-main unit source files). + Has_Insertion_Line : Boolean := False; + -- Set True to indicate that the current message contains the insertion + -- character # (insert line number reference). + Is_Compile_Time_Msg : Boolean := False; -- Set true to indicate that the current message originates from a -- Compile_Time_Warning or Compile_Time_Error pragma. @@ -209,6 +213,9 @@ package Erroutc is -- instantiation copy corresponding to the instantiation referenced by -- Sptr). + Insertion_Sloc : Source_Ptr; + -- Location in message for insertion character # when used + Line : Physical_Line_Number; -- Line number for error message @@ -470,11 +477,15 @@ package Erroutc is -- Has_Double_Exclam is set True if the message contains the sequence !! -- and is otherwise set False. -- + -- Has_Insertion_Line is set True if the message contains the character # + -- and is otherwise set False. + -- -- We need to know right away these aspects of a message, since we will -- test these values before doing the full error scan. -- -- Note that the call has no effect for continuation messages (those whose - -- first character is '\'), and all variables are left unchanged. + -- first character is '\'), and all variables are left unchanged, unless + -- -gnatdF is set. procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr); -- All error messages whose location is in the range From .. To (not diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 75d29a9..d4821fc 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -209,6 +209,7 @@ package body Errutil is Sfile => Get_Source_File_Index (Sptr), Sptr => Sptr, Optr => Optr, + Insertion_Sloc => No_Location, Line => Get_Physical_Line_Number (Sptr), Col => Get_Column_Number (Sptr), Compile_Time_Pragma => Is_Compile_Time_Msg, diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 168a592..469777f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -53,6 +53,7 @@ with Sem; use Sem; with Sem_Aggr; use Sem_Aggr; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; @@ -425,6 +426,8 @@ package body Exp_Aggr is return Nkind (First (Assoc)) /= N_Iterated_Component_Association; end Is_OK_Aggregate; + -- Start of processing for Aggr_Assignment_OK_For_Backend + begin -- Back end doesn't know about <> @@ -473,7 +476,7 @@ package body Exp_Aggr is Csiz := Component_Size (Ctyp); Ctyp := Component_Type (Ctyp); - if Is_Atomic_Or_VFA (Ctyp) then + if Is_Full_Access (Ctyp) then return False; end if; end loop; @@ -1954,7 +1957,30 @@ package body Exp_Aggr is Expander_Mode_Save_And_Set (False); Tcopy := New_Copy_Tree (Expr); Set_Parent (Tcopy, N); - Analyze_And_Resolve (Tcopy, Component_Type (Etype (N))); + + -- For iterated_component_association analyze and resolve + -- the expression with name of the index parameter visible. + -- To manipulate scopes, we use entity of the implicit loop. + + if Is_Iterated_Component then + declare + Index_Parameter : constant Entity_Id := + Defining_Identifier (Parent (Expr)); + begin + Push_Scope (Scope (Index_Parameter)); + Enter_Name (Index_Parameter); + Analyze_And_Resolve + (Tcopy, Component_Type (Etype (N))); + End_Scope; + end; + + -- For ordinary component association, just analyze and + -- resolve the expression. + + else + Analyze_And_Resolve (Tcopy, Component_Type (Etype (N))); + end if; + Expander_Mode_Restore; end if; end if; @@ -2334,7 +2360,7 @@ package body Exp_Aggr is Sort_Case_Table (Table); end if; - -- STEP 1 (b): take care of the whole set of discrete choices + -- STEP 1 (b): take care of the whole set of discrete choices for J in 1 .. Nb_Choices loop Low := Table (J).Choice_Lo; @@ -6376,7 +6402,7 @@ package body Exp_Aggr is Convert_To_Positional (N); - -- if the result is no longer an aggregate (e.g. it may be a string + -- If the result is no longer an aggregate (e.g. it may be a string -- literal, or a temporary which has the needed value), then we are -- done, since there is no longer a nested aggregate. @@ -6755,13 +6781,16 @@ package body Exp_Aggr is ------------------------ procedure Expand_N_Aggregate (N : Node_Id) is + T : constant Entity_Id := Etype (N); begin -- Record aggregate case - if Is_Record_Type (Etype (N)) then + if Is_Record_Type (T) + and then not Is_Private_Type (T) + then Expand_Record_Aggregate (N); - elsif Has_Aspect (Etype (N), Aspect_Aggregate) then + elsif Has_Aspect (T, Aspect_Aggregate) then Expand_Container_Aggregate (N); -- Array aggregate case @@ -6809,11 +6838,10 @@ package body Exp_Aggr is and then No (Expressions (N)) then declare - T : constant Entity_Id := Etype (N); - X : constant Node_Id := First_Index (T); - EC : constant Node_Id := Expression (CA); - CV : constant Uint := Char_Literal_Value (EC); - CC : constant Int := UI_To_Int (CV); + X : constant Node_Id := First_Index (T); + EC : constant Node_Id := Expression (CA); + CV : constant Uint := Char_Literal_Value (EC); + CC : constant Int := UI_To_Int (CV); begin if Nkind (X) = N_Range @@ -6883,7 +6911,15 @@ package body Exp_Aggr is Comp : Node_Id; Decl : Node_Id; + Default : Node_Id; Init_Stat : Node_Id; + Siz : Int; + + function Aggregate_Size return Int; + -- Compute number of entries in aggregate, including choices + -- that cover a range, as well as iterated constructs. + -- Return -1 if the size is not known statically, in which case + -- we allocate a default size for the aggregate. procedure Expand_Iterated_Component (Comp : Node_Id); -- Handle iterated_component_association and iterated_Element @@ -6891,41 +6927,182 @@ package body Exp_Aggr is -- given either by a loop parameter specification or an iterator -- specification. + -------------------- + -- Aggregate_Size -- + -------------------- + + function Aggregate_Size return Int is + Comp : Node_Id; + Choice : Node_Id; + Lo, Hi : Node_Id; + Siz : Int := 0; + + procedure Add_Range_Size; + -- Compute size of component association given by + -- range or subtype name. + + procedure Add_Range_Size is + begin + if Nkind (Lo) = N_Integer_Literal then + Siz := Siz + UI_To_Int (Intval (Hi)) + - UI_To_Int (Intval (Lo)) + 1; + end if; + end Add_Range_Size; + + begin + if Present (Expressions (N)) then + Siz := List_Length (Expressions (N)); + end if; + + if Present (Component_Associations (N)) then + Comp := First (Component_Associations (N)); + + -- If the component is an Iterated_Element_Association + -- it includes an iterator or a loop parameter, possibly + -- with a filter, so we do not attempt to compute its + -- size. Room for future optimization ??? + + if Nkind (Comp) = N_Iterated_Element_Association then + return -1; + end if; + + while Present (Comp) loop + Choice := First (Choice_List (Comp)); + + while Present (Choice) loop + Analyze (Choice); + + if Nkind (Choice) = N_Range then + Lo := Low_Bound (Choice); + Hi := High_Bound (Choice); + if Nkind (Lo) /= N_Integer_Literal + or else Nkind (Hi) /= N_Integer_Literal + then + return -1; + else + Add_Range_Size; + end if; + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + Lo := Type_Low_Bound (Entity (Choice)); + Hi := Type_High_Bound (Entity (Choice)); + if Nkind (Lo) /= N_Integer_Literal + or else Nkind (Hi) /= N_Integer_Literal + then + return -1; + else + Add_Range_Size; + end if; + + Rewrite (Choice, + Make_Range (Loc, + New_Copy_Tree (Lo), + New_Copy_Tree (Hi))); + + else + -- Single choice (syntax excludes a subtype + -- indication). + + Siz := Siz + 1; + end if; + + Next (Choice); + end loop; + Next (Comp); + end loop; + end if; + + return Siz; + end Aggregate_Size; + ------------------------------- -- Expand_Iterated_Component -- ------------------------------- procedure Expand_Iterated_Component (Comp : Node_Id) is Expr : constant Node_Id := Expression (Comp); - Loop_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (Comp))); + Key_Expr : Node_Id := Empty; + Loop_Id : Entity_Id; L_Range : Node_Id; L_Iteration_Scheme : Node_Id; Loop_Stat : Node_Id; + Params : List_Id; Stats : List_Id; begin - if Present (Iterator_Specification (Comp)) then - L_Iteration_Scheme := - Make_Iteration_Scheme (Loc, - Iterator_Specification => Iterator_Specification (Comp)); + if Nkind (Comp) = N_Iterated_Element_Association then + Key_Expr := Key_Expression (Comp); + + -- We create a new entity as loop identifier in all cases, + -- as is done for generated loops elsewhere, as the loop + -- structure has been previously analyzed. + + if Present (Iterator_Specification (Comp)) then + + -- Either an Iterator_Specification of a Loop_Parameter_ + -- Specification is present. + + L_Iteration_Scheme := + Make_Iteration_Scheme (Loc, + Iterator_Specification => Iterator_Specification (Comp)); + Loop_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier + (Iterator_Specification (Comp)))); + Set_Defining_Identifier + (Iterator_Specification (L_Iteration_Scheme), Loop_Id); + else + L_Iteration_Scheme := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Loop_Parameter_Specification (Comp)); + Loop_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier + (Loop_Parameter_Specification (Comp)))); + Set_Defining_Identifier + (Loop_Parameter_Specification + (L_Iteration_Scheme), Loop_Id); + end if; else - L_Range := Relocate_Node (First (Discrete_Choices (Comp))); - L_Iteration_Scheme := - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => Loop_Id, - Discrete_Subtype_Definition => L_Range)); + + -- Iterated_Component_Association. + + Loop_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Comp))); + + if Present (Iterator_Specification (Comp)) then + L_Iteration_Scheme := + Make_Iteration_Scheme (Loc, + Iterator_Specification => Iterator_Specification (Comp)); + + else + -- Loop_Parameter_Specifcation is parsed with a choice list. + -- where the range is the first (and only) choice. + + L_Range := Relocate_Node (First (Discrete_Choices (Comp))); + + L_Iteration_Scheme := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Loop_Id, + Discrete_Subtype_Definition => L_Range)); + end if; end if; -- Build insertion statement. For a positional aggregate, only the -- expression is needed. For a named aggregate, the loop variable, -- whose type is that of the key, is an additional parameter for -- the insertion operation. + -- If a Key_Expression is present, it serves as the additional + -- parameter. Otherwise the key is given by the loop parameter + -- itself. if Present (Add_Unnamed_Subp) then Stats := New_List @@ -6935,13 +7112,23 @@ package body Exp_Aggr is New_List (New_Occurrence_Of (Temp, Loc), New_Copy_Tree (Expr)))); else + -- Named or indexed aggregate, for which a key is present, + -- possibly with a specified key_expression. + + if Present (Key_Expr) then + Params := New_List (New_Occurrence_Of (Temp, Loc), + New_Copy_Tree (Key_Expr), + New_Copy_Tree (Expr)); + else + Params := New_List (New_Occurrence_Of (Temp, Loc), + New_Occurrence_Of (Loop_Id, Loc), + New_Copy_Tree (Expr)); + end if; + Stats := New_List (Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Entity (Add_Named_Subp), Loc), - Parameter_Associations => - New_List (New_Occurrence_Of (Temp, Loc), - New_Occurrence_Of (Loop_Id, Loc), - New_Copy_Tree (Expr)))); + Parameter_Associations => Params)); end if; Loop_Stat := Make_Implicit_Loop_Statement @@ -6953,35 +7140,78 @@ package body Exp_Aggr is end Expand_Iterated_Component; + -- Start of processing for Expand_Container_Aggregate + begin Parse_Aspect_Aggregate (Asp, Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, New_Indexed_Subp, Assign_Indexed_Subp); - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => New_Occurrence_Of (Typ, Loc)); - - Insert_Action (N, Decl); - if Ekind (Entity (Empty_Subp)) = E_Function then - Init_Stat := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp, Loc), - Expression => Make_Function_Call (Loc, - Name => New_Occurrence_Of (Entity (Empty_Subp), Loc))); - else - Init_Stat := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp, Loc), - Expression => New_Occurrence_Of (Entity (Empty_Subp), Loc)); + + -- The constructor for bounded containers is a function with + -- a parameter that sets the size of the container. If the + -- size cannot be determined statically we use a default value. + + Siz := Aggregate_Size; + if Siz < 0 then + Siz := 10; end if; - Append (Init_Stat, Aggr_Code); + if Ekind (Entity (Empty_Subp)) = E_Function + and then Present (First_Formal (Entity (Empty_Subp))) + then + Default := Default_Value (First_Formal (Entity (Empty_Subp))); + -- If aggregate size is not static, use default value of + -- formal parameter for allocation. We assume that this + -- (implementation-dependent) value is static, even though + -- the AI does not require it ???. + + if Siz < 0 then + Siz := UI_To_Int (Intval (Default)); + end if; + + Init_Stat := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Make_Function_Call (Loc, + Name => New_Occurrence_Of (Entity (Empty_Subp), Loc), + Parameter_Associations => + New_List (Make_Integer_Literal (Loc, Siz)))); + + Append (Init_Stat, Aggr_Code); + + -- Use default value when aggregate size is not static. + + else + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Insert_Action (N, Decl); + if Ekind (Entity (Empty_Subp)) = E_Function then + Init_Stat := Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp, Loc), + Expression => Make_Function_Call (Loc, + Name => New_Occurrence_Of (Entity (Empty_Subp), Loc))); + else + Init_Stat := Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp, Loc), + Expression => New_Occurrence_Of (Entity (Empty_Subp), Loc)); + end if; + + Append (Init_Stat, Aggr_Code); + end if; --------------------------- -- Positional aggregate -- --------------------------- + -- If the aggregate is positional the aspect must include + -- an Add_Unnamed subprogram. + if Present (Add_Unnamed_Subp) - and then No (Assign_Indexed_Subp) + and then No (Component_Associations (N)) then if Present (Expressions (N)) then declare @@ -7027,7 +7257,9 @@ package body Exp_Aggr is -- generate an insertion statement for each. while Present (Comp) loop - if Nkind (Comp) = N_Iterated_Component_Association then + if Nkind (Comp) in N_Iterated_Component_Association + | N_Iterated_Element_Association + then Expand_Iterated_Component (Comp); else Key := First (Choices (Comp)); @@ -7048,21 +7280,25 @@ package body Exp_Aggr is Next (Comp); end loop; end; + end if; ----------------------- -- Indexed_Aggregate -- ----------------------- - elsif Present (Assign_Indexed_Subp) then + -- For an indexed aggregate there must be an Assigned_Indexeed + -- subprogram. Note that unlike array aggregates, a container + -- aggregate must be fully positional or fully indexed. In the + -- first case the expansion has already taken place. + + if Present (Assign_Indexed_Subp) + and then Present (Component_Associations (N)) + then declare Insert : constant Entity_Id := Entity (Assign_Indexed_Subp); Index_Type : constant Entity_Id := Etype (Next_Formal (First_Formal (Insert))); - function Aggregate_Size return Int; - -- Compute number of entries in aggregate, including choices - -- that cover a range, as well as iterated constructs. - function Expand_Range_Component (Rng : Node_Id; Expr : Node_Id) return Node_Id; @@ -7076,7 +7312,6 @@ package body Exp_Aggr is Pos : Int := 0; Stat : Node_Id; Key : Node_Id; - Size : Int := 0; ----------------------------- -- Expand_Raange_Component -- @@ -7116,74 +7351,8 @@ package body Exp_Aggr is Statements => Stats); end Expand_Range_Component; - -------------------- - -- Aggregate_Size -- - -------------------- - - function Aggregate_Size return Int is - Comp : Node_Id; - Choice : Node_Id; - Lo, Hi : Node_Id; - Siz : Int := 0; - - procedure Add_Range_Size; - -- Compute size of component association given by - -- range or subtype name. - - procedure Add_Range_Size is - begin - if Nkind (Lo) = N_Integer_Literal then - Siz := Siz + UI_To_Int (Intval (Hi)) - - UI_To_Int (Intval (Lo)) + 1; - end if; - end Add_Range_Size; - - begin - if Present (Expressions (N)) then - Siz := List_Length (Expressions (N)); - end if; - - if Present (Component_Associations (N)) then - Comp := First (Component_Associations (N)); - while Present (Comp) loop - Choice := First (Choices (Comp)); - - while Present (Choice) loop - Analyze (Choice); - - if Nkind (Choice) = N_Range then - Lo := Low_Bound (Choice); - Hi := High_Bound (Choice); - Add_Range_Size; - - elsif Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice)) - then - Lo := Type_Low_Bound (Entity (Choice)); - Hi := Type_High_Bound (Entity (Choice)); - Add_Range_Size; - Rewrite (Choice, - Make_Range (Loc, - New_Copy_Tree (Lo), - New_Copy_Tree (Hi))); - - else - Resolve (Choice, Index_Type); - Siz := Siz + 1; - end if; - - Next (Choice); - end loop; - Next (Comp); - end loop; - end if; - - return Siz; - end Aggregate_Size; - begin - Size := Aggregate_Size; - if Size > 0 then + if Siz > 0 then -- Modify the call to the constructor to allocate the -- required size for the aggregwte : call the provided @@ -7191,7 +7360,7 @@ package body Exp_Aggr is Index := Make_Op_Add (Loc, Left_Opnd => New_Copy_Tree (Type_Low_Bound (Index_Type)), - Right_Opnd => Make_Integer_Literal (Loc, Size - 1)); + Right_Opnd => Make_Integer_Literal (Loc, Siz - 1)); Set_Expression (Init_Stat, Make_Function_Call (Loc, @@ -7270,9 +7439,16 @@ package body Exp_Aggr is <<Next_Key>> Next (Key); end loop; + else - Error_Msg_N ("iterated associations peding", N); + -- Iterated component association. Discard + -- positional insertion procedure. + + Add_Named_Subp := Assign_Indexed_Subp; + Add_Unnamed_Subp := Empty; + Expand_Iterated_Component (Comp); end if; + Next (Comp); end loop; end if; @@ -8115,13 +8291,13 @@ package body Exp_Aggr is -- Start of processing for Expand_Record_Aggregate begin - -- If the aggregate is to be assigned to an atomic/VFA variable, we have + -- If the aggregate is to be assigned to a full access variable, we have -- to prevent a piecemeal assignment even if the aggregate is to be -- expanded. We create a temporary for the aggregate, and assign the -- temporary instead, so that the back end can generate an atomic move -- for it. - if Is_Atomic_VFA_Aggregate (N) then + if Is_Full_Access_Aggregate (N) then return; -- No special management required for aggregates used to initialize @@ -8163,7 +8339,7 @@ package body Exp_Aggr is Convert_To_Assignments (N, Typ); -- In all other cases, build a proper aggregate to be handled by - -- the back-end + -- the back-end. else Build_Back_End_Aggregate; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 855aa29..d3468d5 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -29,7 +29,6 @@ with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; with Exp_Atag; use Exp_Atag; -with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch9; use Exp_Ch9; @@ -137,6 +136,12 @@ package body Exp_Attr is -- special-case code that shuffles partial and full views in the middle -- of semantic analysis and expansion. + function Default_Streaming_Unavailable (Typ : Entity_Id) return Boolean; + -- + -- In most cases, references to unavailable streaming attributes + -- are rejected at compile time. In some obscure cases involving + -- generics and formal derived types, the problem is dealt with at runtime. + procedure Expand_Access_To_Protected_Op (N : Node_Id; Pref : Node_Id; @@ -928,6 +933,24 @@ package body Exp_Attr is end Compile_Stream_Body_In_Scope; ----------------------------------- + -- Default_Streaming_Unavailable -- + ----------------------------------- + + function Default_Streaming_Unavailable (Typ : Entity_Id) return Boolean is + Btyp : constant Entity_Id := Implementation_Base_Type (Typ); + begin + if Is_Immutably_Limited_Type (Btyp) + and then not Is_Tagged_Type (Btyp) + and then not (Ekind (Btyp) = E_Record_Type + and then Present (Corresponding_Concurrent_Type (Btyp))) + then + pragma Assert (In_Instance_Body); + return True; + end if; + return False; + end Default_Streaming_Unavailable; + + ----------------------------------- -- Expand_Access_To_Protected_Op -- ----------------------------------- @@ -1806,9 +1829,9 @@ package body Exp_Attr is ---------------------------------- procedure Expand_N_Attribute_Reference (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Pref : constant Node_Id := Prefix (N); - Exprs : constant List_Id := Expressions (N); + Loc : constant Source_Ptr := Sloc (N); + Pref : constant Node_Id := Prefix (N); + Exprs : constant List_Id := Expressions (N); function Get_Integer_Type (Typ : Entity_Id) return Entity_Id; -- Return a small integer type appropriate for the enumeration type @@ -1824,27 +1847,13 @@ package body Exp_Attr is function Get_Integer_Type (Typ : Entity_Id) return Entity_Id is Siz : constant Uint := Esize (Base_Type (Typ)); - Int_Typ : Entity_Id; begin -- We need to accommodate invalid values of the base type since we -- accept them for Enum_Rep and Pos, so we reason on the Esize. And -- we use an unsigned type since the enumeration type is unsigned. - if Siz <= Esize (Standard_Short_Short_Unsigned) then - Int_Typ := Standard_Short_Short_Unsigned; - - elsif Siz <= Esize (Standard_Short_Unsigned) then - Int_Typ := Standard_Short_Unsigned; - - elsif Siz <= Esize (Standard_Unsigned) then - Int_Typ := Standard_Unsigned; - - else - Int_Typ := Standard_Long_Long_Unsigned; - end if; - - return Int_Typ; + return Small_Integer_Type_For (Siz, Uns => True); end Get_Integer_Type; --------------------------------- @@ -1964,10 +1973,10 @@ package body Exp_Attr is Analyze (N); end Rewrite_Attribute_Proc_Call; - Typ : constant Entity_Id := Etype (N); - Btyp : constant Entity_Id := Base_Type (Typ); - Ptyp : constant Entity_Id := Etype (Pref); - Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); + Typ : constant Entity_Id := Etype (N); + Btyp : constant Entity_Id := Base_Type (Typ); + Ptyp : constant Entity_Id := Etype (Pref); + Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); -- Start of processing for Expand_N_Attribute_Reference @@ -2348,7 +2357,7 @@ package body Exp_Attr is and then Is_Entity_Name (Prefix (Enc_Object)) and then (Ekind (Btyp) = E_General_Access_Type or else Is_Local_Anonymous_Access (Btyp)) - and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind + and then Is_Formal (Entity (Prefix (Enc_Object))) and then Ekind (Etype (Entity (Prefix (Enc_Object)))) = E_Anonymous_Access_Type and then Present (Extra_Accessibility @@ -3470,8 +3479,12 @@ package body Exp_Attr is -- replace this attribute with a direct reference to the attribute of -- the appropriate index subtype (since otherwise the back end will -- try to give us the value of 'First for this implementation type). + -- Do not do this if Ptyp depends on a discriminant as its bounds + -- are only available through N. - if Is_Constrained_Packed_Array (Ptyp) then + if Is_Constrained_Packed_Array (Ptyp) + and then not Size_Depends_On_Discriminant (Ptyp) + then Rewrite (N, Make_Attribute_Reference (Loc, Attribute_Name => Attribute_Name (N), @@ -3826,6 +3839,14 @@ package body Exp_Attr is -- the latter. when Attribute_Initialized => + + -- Do not expand 'Initialized in CodePeer mode, it will be handled + -- by the back-end directly. + + if CodePeer_Mode then + return; + end if; + Rewrite (N, Make_Attribute_Reference @@ -3957,6 +3978,18 @@ package body Exp_Attr is Analyze_And_Resolve (N, B_Type); return; + -- Limited types + + elsif Default_Streaming_Unavailable (U_Type) then + -- Do the same thing here as is done above in the + -- case where a No_Streams restriction is active. + + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Stream_Operation_Not_Allowed)); + Set_Etype (N, B_Type); + return; + -- Elementary types elsif Is_Elementary_Type (U_Type) then @@ -4588,7 +4621,7 @@ package body Exp_Attr is -- b) The integer value is negative. In this case, we know that the -- result is modulus + value, where the value might be as small as -- -modulus. The trouble is what type do we use to do the subtract. - -- No type will do, since modulus can be as big as 2**64, and no + -- No type will do, since modulus can be as big as 2**128, and no -- integer type accommodates this value. Let's do bit of algebra -- modulus + value @@ -4667,6 +4700,8 @@ package body Exp_Attr is Subp : Node_Id; Temp : Entity_Id; + use Old_Attr_Util.Conditional_Evaluation; + use Old_Attr_Util.Indirect_Temps; begin -- Generating C code we don't need to expand this attribute when -- we are analyzing the internally built nested postconditions @@ -4750,10 +4785,60 @@ package body Exp_Attr is Ins_Nod := First (Declarations (Ins_Nod)); end if; + if Eligible_For_Conditional_Evaluation (N) then + declare + Eval_Stmts : constant List_Id := New_List; + + procedure Append_For_Indirect_Temp + (N : Node_Id; Is_Eval_Stmt : Boolean); + -- Append either a declaration (which is to be elaborated + -- unconditionally) or an evaluation statement (which is + -- to be executed conditionally). + + ------------------------------- + -- Append_For_Indirect_Temp -- + ------------------------------- + + procedure Append_For_Indirect_Temp + (N : Node_Id; Is_Eval_Stmt : Boolean) + is + begin + if Is_Eval_Stmt then + Append_To (Eval_Stmts, N); + else + Insert_Before_And_Analyze (Ins_Nod, N); + end if; + end Append_For_Indirect_Temp; + + procedure Declare_Indirect_Temporary is new + Declare_Indirect_Temp + (Append_Item => Append_For_Indirect_Temp); + begin + Declare_Indirect_Temporary + (Attr_Prefix => Pref, Indirect_Temp => Temp); + + Insert_Before_And_Analyze ( + Ins_Nod, + Make_If_Statement + (Sloc => Loc, + Condition => Conditional_Evaluation_Condition (N), + Then_Statements => Eval_Stmts)); + + Rewrite (N, Indirect_Temp_Value + (Temp => Temp, + Typ => Etype (Pref), + Loc => Loc)); + + if Present (Subp) then + Pop_Scope; + end if; + return; + end; + -- Preserve the tag of the prefix by offering a specific view of the -- class-wide version of the prefix. - if Is_Tagged_Type (Typ) then + elsif Is_Tagged_Type (Typ) then -- Generate: -- CW_Temp : constant Typ'Class := Typ'Class (Pref); @@ -5025,6 +5110,18 @@ package body Exp_Attr is Analyze (N); return; + -- Limited types + + elsif Default_Streaming_Unavailable (U_Type) then + -- Do the same thing here as is done above in the + -- case where a No_Streams restriction is active. + + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Stream_Operation_Not_Allowed)); + Set_Etype (N, Standard_Void_Type); + return; + -- For elementary types, we call the W_xxx routine directly. Note -- that the effect of Write and Output is identical for the case -- of an elementary type (there are no discriminants or bounds). @@ -5266,7 +5363,6 @@ package body Exp_Attr is when Attribute_Pred => Pred : declare Etyp : constant Entity_Id := Base_Type (Ptyp); - Ityp : Entity_Id; begin -- For enumeration types with non-standard representations, we @@ -5286,26 +5382,14 @@ package body Exp_Attr is Expand_Pred_Succ_Attribute (N); end if; - if Is_Unsigned_Type (Etyp) then - if Esize (Typ) <= Standard_Integer_Size then - Ityp := RTE (RE_Unsigned); - else - Ityp := RTE (RE_Long_Long_Unsigned); - end if; - - else - if Esize (Etyp) <= Standard_Integer_Size then - Ityp := Standard_Integer; - else - Ityp := Standard_Long_Long_Integer; - end if; - end if; - Rewrite (N, Unchecked_Convert_To (Etyp, Make_Op_Subtract (Loc, Left_Opnd => - Unchecked_Convert_To (Ityp, First (Exprs)), + Unchecked_Convert_To ( + Integer_Type_For + (Esize (Etyp), Is_Unsigned_Type (Etyp)), + First (Exprs)), Right_Opnd => Make_Integer_Literal (Loc, 1)))); @@ -5638,40 +5722,101 @@ package body Exp_Attr is E2 : constant Node_Id := Next (E1); Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); Typ : constant Entity_Id := Etype (N); + New_Loop : Node_Id; + Stat : Node_Id; + + function Build_Stat (Comp : Node_Id) return Node_Id; + -- The reducer can be a function, a procedure whose first + -- parameter is in-out, or an attribute that is a function, + -- which (for now) can only be Min/Max. This subprogram + -- builds the corresponding computation for the generated loop. + + ---------------- + -- Build_Stat -- + ---------------- + + function Build_Stat (Comp : Node_Id) return Node_Id is + begin + if Nkind (E1) = N_Attribute_Reference then + Stat := Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Bnn, Loc), + Expression => Make_Attribute_Reference (Loc, + Attribute_Name => Attribute_Name (E1), + Prefix => New_Copy (Prefix (E1)), + Expressions => New_List ( + New_Occurrence_Of (Bnn, Loc), + Comp))); + + elsif Ekind (Entity (E1)) = E_Procedure then + Stat := Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Entity (E1), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Bnn, Loc), + Comp)); + else + Stat := Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Bnn, Loc), + Expression => Make_Function_Call (Loc, + Name => New_Occurrence_Of (Entity (E1), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Bnn, Loc), + Comp))); + end if; + + return Stat; + end Build_Stat; -- If the prefix is an aggregate, its unique component is an -- Iterated_Element, and we create a loop out of its iterator. + -- The iterated_component_Association is parsed as a loop + -- parameter specification with "in" or as a container + -- iterator with "of". begin if Nkind (Prefix (N)) = N_Aggregate then declare Stream : constant Node_Id := First (Component_Associations (Prefix (N))); - Id : constant Node_Id := Defining_Identifier (Stream); Expr : constant Node_Id := Expression (Stream); - Ch : constant Node_Id := - First (Discrete_Choices (Stream)); + Id : constant Node_Id := Defining_Identifier (Stream); + It_Spec : constant Node_Id := + Iterator_Specification (Stream); + Ch : Node_Id; + Iter : Node_Id; + begin - New_Loop := Make_Loop_Statement (Loc, - Iteration_Scheme => + -- Iteration may be given by an element iterator: + + if Nkind (Stream) = N_Iterated_Component_Association + and then Present (It_Spec) + and then Of_Present (It_Spec) + then + Iter := + Make_Iteration_Scheme (Loc, + Iterator_Specification => + Relocate_Node (It_Spec), + Loop_Parameter_Specification => Empty); + + else + Ch := First (Discrete_Choices (Stream)); + Iter := Make_Iteration_Scheme (Loc, Iterator_Specification => Empty, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => New_Copy (Id), Discrete_Subtype_Definition => - Relocate_Node (Ch))), + Relocate_Node (Ch))); + end if; + + New_Loop := Make_Loop_Statement (Loc, + Iteration_Scheme => Iter, End_Label => Empty, - Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Bnn, Loc), - Expression => Make_Function_Call (Loc, - Name => New_Occurrence_Of (Entity (E1), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Bnn, Loc), - Relocate_Node (Expr)))))); + Statements => + New_List (Build_Stat (Relocate_Node (Expr)))); end; + else -- If the prefix is a name, we construct an element iterator -- over it. Its expansion will verify that it is an array or @@ -5696,13 +5841,7 @@ package body Exp_Attr is Loop_Parameter_Specification => Empty), End_Label => Empty, Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Bnn, Loc), - Expression => Make_Function_Call (Loc, - Name => New_Occurrence_Of (Entity (E1), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Bnn, Loc), - New_Occurrence_Of (Elem, Loc)))))); + Build_Stat (New_Occurrence_Of (Elem, Loc)))); end; end if; @@ -5816,6 +5955,18 @@ package body Exp_Attr is Analyze (N); return; + -- Limited types + + elsif Default_Streaming_Unavailable (U_Type) then + -- Do the same thing here as is done above in the + -- case where a No_Streams restriction is active. + + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Stream_Operation_Not_Allowed)); + Set_Etype (N, B_Type); + return; + -- For elementary types, we call the I_xxx routine using the first -- parameter and then assign the result into the second parameter. -- We set Assignment_OK to deal with the conversion case. @@ -5997,11 +6148,11 @@ package body Exp_Attr is when Attribute_Scaling => Expand_Fpt_Attribute_RI (N); - ------------------------- - -- Simple_Storage_Pool -- - ------------------------- + ---------------------------------------- + -- Simple_Storage_Pool & Storage_Pool -- + ---------------------------------------- - when Attribute_Simple_Storage_Pool => + when Attribute_Simple_Storage_Pool | Attribute_Storage_Pool => Rewrite (N, Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), @@ -6138,17 +6289,6 @@ package body Exp_Attr is end Size; ------------------ - -- Storage_Pool -- - ------------------ - - when Attribute_Storage_Pool => - Rewrite (N, - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), - Expression => New_Occurrence_Of (Entity (N), Loc))); - Analyze_And_Resolve (N, Typ); - - ------------------ -- Storage_Size -- ------------------ @@ -6344,7 +6484,6 @@ package body Exp_Attr is when Attribute_Succ => Succ : declare Etyp : constant Entity_Id := Base_Type (Ptyp); - Ityp : Entity_Id; begin -- For enumeration types with non-standard representations, we @@ -6364,26 +6503,14 @@ package body Exp_Attr is Expand_Pred_Succ_Attribute (N); end if; - if Is_Unsigned_Type (Etyp) then - if Esize (Typ) <= Standard_Integer_Size then - Ityp := RTE (RE_Unsigned); - else - Ityp := RTE (RE_Long_Long_Unsigned); - end if; - - else - if Esize (Etyp) <= Standard_Integer_Size then - Ityp := Standard_Integer; - else - Ityp := Standard_Long_Long_Integer; - end if; - end if; - Rewrite (N, Unchecked_Convert_To (Etyp, Make_Op_Add (Loc, Left_Opnd => - Unchecked_Convert_To (Ityp, First (Exprs)), + Unchecked_Convert_To ( + Integer_Type_For + (Esize (Etyp), Is_Unsigned_Type (Etyp)), + First (Exprs)), Right_Opnd => Make_Integer_Literal (Loc, 1)))); @@ -6667,7 +6794,6 @@ package body Exp_Attr is when Attribute_Val => Val : declare Etyp : constant Entity_Id := Base_Type (Ptyp); Expr : constant Node_Id := First (Exprs); - Ityp : Entity_Id; Rtyp : Entity_Id; begin @@ -6719,21 +6845,6 @@ package body Exp_Attr is -- Contiguous non-standard enumeration type if Present (Enum_Pos_To_Rep (Etyp)) then - if Is_Unsigned_Type (Etyp) then - if Esize (Typ) <= Standard_Integer_Size then - Ityp := RTE (RE_Unsigned); - else - Ityp := RTE (RE_Long_Long_Unsigned); - end if; - - else - if Esize (Etyp) <= Standard_Integer_Size then - Ityp := Standard_Integer; - else - Ityp := Standard_Long_Long_Integer; - end if; - end if; - Rewrite (N, Unchecked_Convert_To (Etyp, Make_Op_Add (Loc, @@ -6741,7 +6852,10 @@ package body Exp_Attr is Make_Integer_Literal (Loc, Enumeration_Rep (First_Literal (Etyp))), Right_Opnd => - Convert_To (Ityp, Expr)))); + Unchecked_Convert_To ( + Integer_Type_For + (Esize (Etyp), Is_Unsigned_Type (Etyp)), + Expr)))); -- Standard enumeration type @@ -7121,27 +7235,16 @@ package body Exp_Attr is -- correct, even though a value greater than 127 looks signed to a -- signed comparison. - elsif Is_Unsigned_Type (Ptyp) - or else (Is_Private_Type (Ptyp) and then Is_Unsigned_Type (Btyp)) - then - if Esize (Ptyp) <= 32 then - PBtyp := RTE (RE_Unsigned_32); - else - PBtyp := RTE (RE_Unsigned_64); - end if; - - Rewrite (N, Make_Range_Test); - - -- Signed types - else - if Esize (Ptyp) <= Esize (Standard_Integer) then - PBtyp := Standard_Integer; - else - PBtyp := Standard_Long_Long_Integer; - end if; - - Rewrite (N, Make_Range_Test); + declare + Uns : constant Boolean + := Is_Unsigned_Type (Ptyp) + or else (Is_Private_Type (Ptyp) + and then Is_Unsigned_Type (Btyp)); + begin + PBtyp := Integer_Type_For (Esize (Ptyp), Uns); + Rewrite (N, Make_Range_Test); + end; end if; -- If a predicate is present, then we do the predicate test, even if @@ -7473,6 +7576,18 @@ package body Exp_Attr is Analyze (N); return; + -- Limited types + + elsif Default_Streaming_Unavailable (U_Type) then + -- Do the same thing here as is done above in the + -- case where a No_Streams restriction is active. + + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Stream_Operation_Not_Allowed)); + Set_Etype (N, U_Type); + return; + -- For elementary types, we call the W_xxx routine directly elsif Is_Elementary_Type (U_Type) then @@ -7591,6 +7706,7 @@ package body Exp_Attr is | Attribute_Machine_Radix | Attribute_Machine_Rounds | Attribute_Max_Alignment_For_Allocation + | Attribute_Max_Integer_Size | Attribute_Maximum_Alignment | Attribute_Model_Emin | Attribute_Model_Epsilon diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index ff1029c..5c3435b 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -717,98 +717,4 @@ package body Exp_Ch2 is Analyze_And_Resolve (N, T); end Expand_Renaming; - ------------------ - -- Param_Entity -- - ------------------ - - -- This would be trivial, simply a test for an identifier that was a - -- reference to a formal, if it were not for the fact that a previous call - -- to Expand_Entry_Parameter will have modified the reference to the - -- identifier. A formal of a protected entity is rewritten as - - -- typ!(recobj).rec.all'Constrained - - -- where rec is a selector whose Entry_Formal link points to the formal - - -- If the type of the entry parameter has a representation clause, then an - -- extra temp is involved (see below). - - -- For a formal of a task entity, the formal is rewritten as a local - -- renaming. - - -- In addition, a formal that is marked volatile because it is aliased - -- through an address clause is rewritten as dereference as well. - - function Param_Entity (N : Node_Id) return Entity_Id is - Renamed_Obj : Node_Id; - - begin - -- Simple reference case - - if Nkind (N) in N_Identifier | N_Expanded_Name then - if Is_Formal (Entity (N)) then - return Entity (N); - - -- Handle renamings of formal parameters and formals of tasks that - -- are rewritten as renamings. - - elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then - Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); - - if Is_Entity_Name (Renamed_Obj) - and then Is_Formal (Entity (Renamed_Obj)) - then - return Entity (Renamed_Obj); - - elsif - Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement - then - return Entity (N); - end if; - end if; - - else - if Nkind (N) = N_Explicit_Dereference then - declare - P : Node_Id := Prefix (N); - S : Node_Id; - E : Entity_Id; - Decl : Node_Id; - - begin - -- If the type of an entry parameter has a representation - -- clause, then the prefix is not a selected component, but - -- instead a reference to a temp pointing at the selected - -- component. In this case, set P to be the initial value of - -- that temp. - - if Nkind (P) = N_Identifier then - E := Entity (P); - - if Ekind (E) = E_Constant then - Decl := Parent (E); - - if Nkind (Decl) = N_Object_Declaration then - P := Expression (Decl); - end if; - end if; - end if; - - if Nkind (P) = N_Selected_Component then - S := Selector_Name (P); - - if Present (Entry_Formal (Entity (S))) then - return Entry_Formal (Entity (S)); - end if; - - elsif Nkind (Original_Node (N)) = N_Identifier then - return Param_Entity (Original_Node (N)); - end if; - end; - end if; - end if; - - return (Empty); - end Param_Entity; - end Exp_Ch2; diff --git a/gcc/ada/exp_ch2.ads b/gcc/ada/exp_ch2.ads index 04487d4..8d11dd4 100644 --- a/gcc/ada/exp_ch2.ads +++ b/gcc/ada/exp_ch2.ads @@ -32,14 +32,4 @@ package Exp_Ch2 is procedure Expand_N_Identifier (N : Node_Id); procedure Expand_N_Real_Literal (N : Node_Id); - function Param_Entity (N : Node_Id) return Entity_Id; - -- Given an expression N, determines if the expression is a reference - -- to a formal (of a subprogram or entry), and if so returns the Id - -- of the corresponding formal entity, otherwise returns Empty. The - -- reason that this is in Exp_Ch2 is that it has to deal with the case - -- where the reference is to an entry formal, and has been expanded - -- already. Since Exp_Ch2 is in charge of the expansion, it is best - -- suited to knowing how to detect this case. Also handles the case - -- of references to renamings of formals. - end Exp_Ch2; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 0b601c5..f8b6ee6 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1335,6 +1335,31 @@ package body Exp_Ch3 is return Agg; end Build_Equivalent_Record_Aggregate; + ---------------------------- + -- Init_Proc_Level_Formal -- + ---------------------------- + + function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id is + Form : Entity_Id; + begin + -- Move through the formals of the initialization procedure Proc to find + -- the extra accessibility level parameter associated with the object + -- being initialized. + + Form := First_Formal (Proc); + while Present (Form) loop + if Chars (Form) = Name_uInit_Level then + return Form; + end if; + + Next_Formal (Form); + end loop; + + -- No formal was found, return Empty + + return Empty; + end Init_Proc_Level_Formal; + ------------------------------- -- Build_Initialization_Call -- ------------------------------- @@ -1772,6 +1797,24 @@ package body Exp_Ch3 is New_Copy_List (Parameter_Associations (Constructor_Ref))); end if; + -- Pass the extra accessibility level parameter associated with the + -- level of the object being initialized when required. + + -- When no entity is present for Id_Ref it may not have been fully + -- analyzed, so allow the default value of standard standard to be + -- passed ??? + + if Is_Entity_Name (Id_Ref) + and then Present (Init_Proc_Level_Formal (Proc)) + then + Append_To (Args, + Make_Parameter_Association (Loc, + Selector_Name => + Make_Identifier (Loc, Name_uInit_Level), + Explicit_Actual_Parameter => + Accessibility_Level (Id_Ref, Dynamic_Level))); + end if; + Append_To (Res, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Proc, Loc), @@ -2513,6 +2556,21 @@ package body Exp_Ch3 is New_Occurrence_Of (Standard_True, Loc))); end if; + -- Create an extra accessibility parameter to capture the level of + -- the object being initialized when its type is a limited record. + + if Is_Limited_Record (Rec_Type) then + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier + (Loc, Name_uInit_Level), + Parameter_Type => + New_Occurrence_Of (Standard_Natural, Loc), + Expression => + Make_Integer_Literal + (Loc, Scope_Depth (Standard_Standard)))); + end if; + Set_Parameter_Specifications (Proc_Spec_Node, Parameters); Set_Specification (Body_Node, Proc_Spec_Node); Set_Declarations (Body_Node, Decls); @@ -4758,7 +4816,7 @@ package body Exp_Ch3 is begin pragma Assert (Nkind (Obj_Decl) = N_Object_Declaration); - if Has_Task (Typ) or else Might_Have_Tasks (Typ) then + if Might_Have_Tasks (Typ) then Build_Activation_Chain_Entity (Obj_Decl); if Has_Task (Typ) then @@ -5095,32 +5153,15 @@ package body Exp_Ch3 is -- Is this right??? What about No_Exception_Propagation??? - -- Representations are signed + -- The underlying type is signed. Reset the Is_Unsigned_Type explicitly + -- because it might have been inherited from the parent type. if Enumeration_Rep (First_Literal (Typ)) < 0 then - - -- The underlying type is signed. Reset the Is_Unsigned_Type - -- explicitly, because it might have been inherited from - -- parent type. - Set_Is_Unsigned_Type (Typ, False); - - if Esize (Typ) <= Standard_Integer_Size then - Ityp := Standard_Integer; - else - Ityp := Standard_Long_Long_Integer; - end if; - - -- Representations are unsigned - - else - if Esize (Typ) <= Standard_Integer_Size then - Ityp := RTE (RE_Unsigned); - else - Ityp := RTE (RE_Long_Long_Unsigned); - end if; end if; + Ityp := Integer_Type_For (Esize (Typ), Is_Unsigned_Type (Typ)); + -- The body of the function is a case statement. First collect case -- alternatives, or optimize the contiguous case. @@ -5898,10 +5939,8 @@ package body Exp_Ch3 is Typ := Etype (Comp); if Ekind (Typ) = E_Anonymous_Access_Type - and then - (Has_Task (Available_View (Designated_Type (Typ))) - or else - Might_Have_Tasks (Available_View (Designated_Type (Typ)))) + and then Might_Have_Tasks + (Available_View (Designated_Type (Typ))) and then No (Master_Id (Typ)) then -- Ensure that the record or array type have a _master @@ -6785,7 +6824,7 @@ package body Exp_Ch3 is -- of the stacks in this scenario, the stacks of the first array are -- not counted. - if (Has_Task (Typ) or else Might_Have_Tasks (Typ)) + if Might_Have_Tasks (Typ) and then not Restriction_Active (No_Secondary_Stack) and then (Restriction_Active (No_Implicit_Heap_Allocations) or else Restriction_Active (No_Implicit_Task_Allocations)) @@ -7468,7 +7507,8 @@ package body Exp_Ch3 is if No (Expr) then Level_Expr := - Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard)); + Make_Integer_Literal + (Loc, Scope_Depth (Standard_Standard)); -- When the expression of the object is a function which returns -- an anonymous access type the master of the call is the object @@ -7477,13 +7517,13 @@ package body Exp_Ch3 is elsif Nkind (Expr) = N_Function_Call and then Ekind (Etype (Name (Expr))) = E_Anonymous_Access_Type then - Level_Expr := Make_Integer_Literal (Loc, - Object_Access_Level (Def_Id)); + Level_Expr := Accessibility_Level + (Def_Id, Object_Decl_Level); -- General case else - Level_Expr := Dynamic_Accessibility_Level (Expr); + Level_Expr := Accessibility_Level (Expr, Dynamic_Level); end if; Level_Decl := @@ -8162,7 +8202,8 @@ package body Exp_Ch3 is -- It is known that the accessibility level of the access -- type is deeper than that of the pool. - if Type_Access_Level (Def_Id) > Object_Access_Level (Pool) + if Type_Access_Level (Def_Id) + > Static_Accessibility_Level (Pool, Object_Decl_Level) and then Is_Class_Wide_Type (Etype (Pool)) and then not Accessibility_Checks_Suppressed (Def_Id) and then not Accessibility_Checks_Suppressed (Pool) @@ -8197,8 +8238,9 @@ package body Exp_Ch3 is -- Taft-amendment types, which potentially have controlled -- components), expand the list controller object that will store -- the dynamically allocated objects. Don't do this transformation - -- for expander-generated access types, but do it for types that - -- are the full view of types derived from other private types. + -- for expander-generated access types, except do it for types + -- that are the full view of types derived from other private + -- types and for access types used to implement indirect temps. -- Also suppress the list controller in the case of a designated -- type with convention Java, since this is used when binding to -- Java API specs, where there's no equivalent of a finalization @@ -8207,6 +8249,8 @@ package body Exp_Ch3 is if not Comes_From_Source (Def_Id) and then not Has_Private_Declaration (Def_Id) + and then not Old_Attr_Util.Indirect_Temps + .Is_Access_Type_For_Indirect_Temp (Def_Id) then null; @@ -8581,8 +8625,10 @@ package body Exp_Ch3 is Scal_Typ := Name_Unsigned_16; elsif Size_To_Use <= 32 then Scal_Typ := Name_Unsigned_32; - else + elsif Size_To_Use <= 64 then Scal_Typ := Name_Unsigned_64; + else + Scal_Typ := Name_Unsigned_128; end if; -- Signed types @@ -8594,8 +8640,10 @@ package body Exp_Ch3 is Scal_Typ := Name_Signed_16; elsif Size_To_Use <= 32 then Scal_Typ := Name_Signed_32; - else + elsif Size_To_Use <= 64 then Scal_Typ := Name_Signed_64; + else + Scal_Typ := Name_Signed_128; end if; end if; @@ -8649,10 +8697,10 @@ package body Exp_Ch3 is then Expr := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1); - -- Resolve as Unsigned_64, because the largest number we can - -- generate is out of range of universal integer. + -- Resolve as Long_Long_Long_Unsigned, because the largest number + -- we can generate is out of range of universal integer. - Analyze_And_Resolve (Expr, RTE (RE_Unsigned_64)); + Analyze_And_Resolve (Expr, Standard_Long_Long_Long_Unsigned); -- Case of signed types @@ -8739,11 +8787,14 @@ package body Exp_Ch3 is Size_To_Use := Size; end if; - -- The maximum size to use is 64 bits. This will create values of - -- type Unsigned_64 and the range must fit this type. + -- The maximum size to use is System_Max_Integer_Size bits. This + -- will create values of type Long_Long_Long_Unsigned and the range + -- must fit this type. - if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then - Size_To_Use := Uint_64; + if Size_To_Use /= No_Uint + and then Size_To_Use > System_Max_Integer_Size + then + Size_To_Use := UI_From_Int (System_Max_Integer_Size); end if; if Normalize_Scalars and then not IV_Attribute then @@ -9484,6 +9535,31 @@ package body Exp_Ch3 is (Is_Null_Extension (Etype (Subp)) and then Etype (Alias (Subp)) /= Etype (Subp)) then + -- If there is a non-overloadable homonym in the current + -- scope, the implicit declaration remains invisible. + -- We check the current entity with the same name, or its + -- homonym in case the derivation takes place after the + -- hiding object declaration. + + if Present (Current_Entity (Subp)) then + declare + Curr : constant Entity_Id := Current_Entity (Subp); + Prev : constant Entity_Id := Homonym (Curr); + begin + if (Comes_From_Source (Curr) + and then Scope (Curr) = Current_Scope + and then not Is_Overloadable (Curr)) + or else + (Present (Prev) + and then Comes_From_Source (Prev) + and then Scope (Prev) = Current_Scope + and then not Is_Overloadable (Prev)) + then + goto Next_Prim; + end if; + end; + end if; + Formal_List := No_List; Formal := First_Formal (Subp); diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 954b5a2..a4b7f1f 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -135,6 +135,11 @@ package Exp_Ch3 is -- type is valid only when Normalize_Scalars or Initialize_Scalars is -- active, or if N is the node for a 'Invalid_Value attribute node. + function Init_Proc_Level_Formal (Proc : Entity_Id) return Entity_Id; + -- Fetch the extra formal from an initalization procedure "proc" + -- corresponding to the level of the object being initialized. When none + -- is present Empty is returned. + procedure Init_Secondary_Tags (Typ : Entity_Id; Target : Node_Id; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 30824c6..076e0de 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -31,7 +31,6 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Atag; use Exp_Atag; -with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -824,6 +823,37 @@ package body Exp_Ch4 is Apply_Predicate_Check (Exp, T); + -- Check that any anonymous access discriminants are suitable + -- for use in an allocator. + + -- Note: This check is performed here instead of during analysis so that + -- we can check against the fully resolved etype of Exp. + + if Is_Entity_Name (Exp) + and then Has_Anonymous_Access_Discriminant (Etype (Exp)) + and then Static_Accessibility_Level (Exp, Object_Decl_Level) + > Static_Accessibility_Level (N, Object_Decl_Level) + then + -- A dynamic check and a warning are generated when we are within + -- an instance. + + if In_Instance then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Accessibility_Check_Failed)); + + Error_Msg_N ("anonymous access discriminant is too deep for use" + & " in allocator<<", N); + Error_Msg_N ("\Program_Error [<<", N); + + -- Otherwise, make the error static + + else + Error_Msg_N ("anonymous access discriminant is too deep for use" + & " in allocator", N); + end if; + end if; + if Do_Range_Check (Exp) then Generate_Range_Check (Exp, T, CE_Range_Check_Failed); end if; @@ -851,35 +881,6 @@ package body Exp_Ch4 is return; end if; - -- In the case of an Ada 2012 allocator whose initial value comes from a - -- function call, pass "the accessibility level determined by the point - -- of call" (AI05-0234) to the function. Conceptually, this belongs in - -- Expand_Call but it couldn't be done there (because the Etype of the - -- allocator wasn't set then) so we generate the parameter here. See - -- the Boolean variable Defer in (a block within) Expand_Call. - - if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then - declare - Subp : Entity_Id; - - begin - if Nkind (Name (Exp)) = N_Explicit_Dereference then - Subp := Designated_Type (Etype (Prefix (Name (Exp)))); - else - Subp := Entity (Name (Exp)); - end if; - - Subp := Ultimate_Alias (Subp); - - if Present (Extra_Accessibility_Of_Result (Subp)) then - Add_Extra_Actual_To_Call - (Subprogram_Call => Exp, - Extra_Formal => Extra_Accessibility_Of_Result (Subp), - Extra_Actual => Dynamic_Accessibility_Level (PtrT)); - end if; - end; - end if; - Aggr_In_Place := Is_Delayed_Aggregate (Exp); -- Case of tagged type or type requiring finalization @@ -1385,7 +1386,7 @@ package body Exp_Ch4 is -- (left'address, right'address, left'length, right'length) <op> 0 -- x = U for unsigned, S for signed - -- n = 8,16,32,64 for component size + -- n = 8,16,32,64,128 for component size -- Add _Unaligned if length < 4 and component size is 8. -- <op> is the standard comparison operator @@ -1422,12 +1423,19 @@ package body Exp_Ch4 is Comp := RE_Compare_Array_S32; end if; - else pragma Assert (Component_Size (Typ1) = 64); + elsif Component_Size (Typ1) = 64 then if Is_Unsigned_Type (Ctyp) then Comp := RE_Compare_Array_U64; else Comp := RE_Compare_Array_S64; end if; + + else pragma Assert (Component_Size (Typ1) = 128); + if Is_Unsigned_Type (Ctyp) then + Comp := RE_Compare_Array_U128; + else + Comp := RE_Compare_Array_S128; + end if; end if; if RTE_Available (Comp) then @@ -2963,12 +2971,13 @@ package body Exp_Ch4 is -- Local Declarations - Opnd_Typ : Entity_Id; - Ent : Entity_Id; - Len : Uint; - J : Nat; - Clen : Node_Id; - Set : Boolean; + Opnd_Typ : Entity_Id; + Subtyp_Ind : Entity_Id; + Ent : Entity_Id; + Len : Uint; + J : Nat; + Clen : Node_Id; + Set : Boolean; -- Start of processing for Expand_Concatenate @@ -3441,28 +3450,96 @@ package body Exp_Ch4 is -- Initialize_Scalars is enabled. Also since this is the actual result -- entity, we make sure we have debug information for the result. + Subtyp_Ind := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Atyp, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Low_Bound, + High_Bound => High_Bound)))); + Ent := Make_Temporary (Loc, 'S'); Set_Is_Internal (Ent); Set_Debug_Info_Needed (Ent); - -- If the bound is statically known to be out of range, we do not want - -- to abort, we want a warning and a runtime constraint error. Note that - -- we have arranged that the result will not be treated as a static - -- constant, so we won't get an illegality during this insertion. + -- If we are concatenating strings and the current scope already uses + -- the secondary stack, allocate the resulting string also on the + -- secondary stack to avoid putting too much pressure on the primary + -- stack. + -- Don't do this if -gnatd.h is set, as this will break the wrapping of + -- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat. - Insert_Action (Cnode, - Make_Object_Declaration (Loc, - Defining_Identifier => Ent, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Atyp, Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Range (Loc, - Low_Bound => Low_Bound, - High_Bound => High_Bound))))), - Suppress => All_Checks); + if Atyp = Standard_String + and then Uses_Sec_Stack (Current_Scope) + and then RTE_Available (RE_SS_Pool) + and then not Debug_Flag_Dot_H + then + -- Generate: + -- subtype Axx is ...; + -- type Ayy is access Axx; + -- Rxx : Ayy := new <subtype> [storage_pool = ss_pool]; + -- Sxx : <subtype> renames Rxx.all; + + declare + Alloc : Node_Id; + ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); + Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); + Temp : Entity_Id; + + begin + Insert_Action (Cnode, + Make_Subtype_Declaration (Loc, + Defining_Identifier => ConstrT, + Subtype_Indication => Subtyp_Ind), + Suppress => All_Checks); + Freeze_Itype (ConstrT, Cnode); + + Insert_Action (Cnode, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => New_Occurrence_Of (ConstrT, Loc))), + Suppress => All_Checks); + Alloc := + Make_Allocator (Loc, + Expression => New_Occurrence_Of (ConstrT, Loc)); + Set_Storage_Pool (Alloc, RTE (RE_SS_Pool)); + Set_Procedure_To_Call (Alloc, RTE (RE_SS_Allocate)); + + Temp := Make_Temporary (Loc, 'R', Alloc); + Insert_Action (Cnode, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), + Expression => Alloc), + Suppress => All_Checks); + + Insert_Action (Cnode, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Ent, + Subtype_Mark => New_Occurrence_Of (ConstrT, Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc))), + Suppress => All_Checks); + end; + else + -- If the bound is statically known to be out of range, we do not + -- want to abort, we want a warning and a runtime constraint error. + -- Note that we have arranged that the result will not be treated as + -- a static constant, so we won't get an illegality during this + -- insertion. + -- We also enable checks (in particular range checks) in case the + -- bounds of Subtyp_Ind are out of range. + + Insert_Action (Cnode, + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => Subtyp_Ind)); + end if; -- If the result of the concatenation appears as the initializing -- expression of an object declaration, we can just rename the @@ -6791,37 +6868,28 @@ package body Exp_Ch4 is -- Apply an accessibility check if the access object has an -- associated access level and when the level of the type is -- less deep than the level of the access parameter. This - -- only occur for access parameters and stand-alone objects - -- of an anonymous access type. + -- can only occur for access parameters and stand-alone + -- objects of an anonymous access type. else - if Present (Expr_Entity) - and then - Present - (Effective_Extra_Accessibility (Expr_Entity)) - and then UI_Gt (Object_Access_Level (Lop), - Type_Access_Level (Rtyp)) - then - Param_Level := - New_Occurrence_Of - (Effective_Extra_Accessibility (Expr_Entity), Loc); + Param_Level := Accessibility_Level + (Expr_Entity, Dynamic_Level); - Type_Level := - Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); + Type_Level := + Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); - -- Return True only if the accessibility level of the - -- expression entity is not deeper than the level of - -- the tested access type. + -- Return True only if the accessibility level of the + -- expression entity is not deeper than the level of + -- the tested access type. - Rewrite (N, - Make_And_Then (Loc, - Left_Opnd => Relocate_Node (N), - Right_Opnd => Make_Op_Le (Loc, - Left_Opnd => Param_Level, - Right_Opnd => Type_Level))); + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => Make_Op_Le (Loc, + Left_Opnd => Param_Level, + Right_Opnd => Type_Level))); - Analyze_And_Resolve (N); - end if; + Analyze_And_Resolve (N); -- If the designated type is tagged, do tagged membership -- operation. @@ -8269,12 +8337,12 @@ package body Exp_Ch4 is -- Where the component type is elementary we can use a block bit -- comparison (if supported on the target) exception in the case -- of floating-point (negative zero issues require element by - -- element comparison), and atomic/VFA types (where we must be sure + -- element comparison), and full access types (where we must be sure -- to load elements independently) and possibly unaligned arrays. elsif Is_Elementary_Type (Component_Type (Typl)) and then not Is_Floating_Point_Type (Component_Type (Typl)) - and then not Is_Atomic_Or_VFA (Component_Type (Typl)) + and then not Is_Full_Access (Component_Type (Typl)) and then not Is_Possibly_Unaligned_Object (Lhs) and then not Is_Possibly_Unaligned_Slice (Lhs) and then not Is_Possibly_Unaligned_Object (Rhs) @@ -8923,15 +8991,18 @@ package body Exp_Ch4 is Make_Integer_Literal (Loc, Modulus (Rtyp)), Exp)))); - -- Binary modular case, in this case, we call one of two routines, + -- Binary modular case, in this case, we call one of three routines, -- either the unsigned integer case, or the unsigned long long - -- integer case, with a final "and" operation to do the required mod. + -- integer case, or the unsigned long long long integer case, with a + -- final "and" operation to do the required mod. else - if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then + if Esize (Rtyp) <= Standard_Integer_Size then Ent := RTE (RE_Exp_Unsigned); - else + elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then Ent := RTE (RE_Exp_Long_Long_Unsigned); + else + Ent := RTE (RE_Exp_Long_Long_Long_Unsigned); end if; Rewrite (N, @@ -8953,36 +9024,43 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Typ); return; - -- Signed integer cases, done using either Integer or Long_Long_Integer. - -- It is not worth having routines for Short_[Short_]Integer, since for - -- most machines it would not help, and it would generate more code that - -- might need certification when a certified run time is required. + -- Signed integer cases, using either Integer, Long_Long_Integer or + -- Long_Long_Long_Integer. It is not worth also having routines for + -- Short_[Short_]Integer, since for most machines it would not help, + -- and it would generate more code that might need certification when + -- a certified run time is required. -- In the integer cases, we have two routines, one for when overflow -- checks are required, and one when they are not required, since there -- is a real gain in omitting checks on many machines. - elsif Rtyp = Base_Type (Standard_Long_Long_Integer) - or else (Rtyp = Base_Type (Standard_Long_Integer) - and then - Esize (Standard_Long_Integer) > Esize (Standard_Integer)) - or else Rtyp = Universal_Integer - then - Etyp := Standard_Long_Long_Integer; + elsif Is_Signed_Integer_Type (Rtyp) then + if Esize (Rtyp) <= Standard_Integer_Size then + Etyp := Standard_Integer; - if Ovflo then - Rent := RE_Exp_Long_Long_Integer; - else - Rent := RE_Exn_Long_Long_Integer; - end if; + if Ovflo then + Rent := RE_Exp_Integer; + else + Rent := RE_Exn_Integer; + end if; - elsif Is_Signed_Integer_Type (Rtyp) then - Etyp := Standard_Integer; + elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then + Etyp := Standard_Long_Long_Integer; + + if Ovflo then + Rent := RE_Exp_Long_Long_Integer; + else + Rent := RE_Exn_Long_Long_Integer; + end if; - if Ovflo then - Rent := RE_Exp_Integer; else - Rent := RE_Exn_Integer; + Etyp := Standard_Long_Long_Long_Integer; + + if Ovflo then + Rent := RE_Exp_Long_Long_Long_Integer; + else + Rent := RE_Exn_Long_Long_Long_Integer; + end if; end if; -- Floating-point cases. We do not need separate routines for the @@ -10265,15 +10343,17 @@ package body Exp_Ch4 is -- where Bits is the shift count mod Esize (the mod operation here -- deals with ludicrous large shift counts, which are apparently OK). - -- What about nonbinary modulus ??? + if Modify_Tree_For_C then + declare + Loc : constant Source_Ptr := Sloc (N); + Rtp : constant Entity_Id := Etype (Right_Opnd (N)); + Typ : constant Entity_Id := Etype (N); - declare - Loc : constant Source_Ptr := Sloc (N); - Rtp : constant Entity_Id := Etype (Right_Opnd (N)); - Typ : constant Entity_Id := Etype (N); + begin + -- Sem_Intr should prevent getting there with a non binary modulus + + pragma Assert (not Non_Binary_Modulus (Typ)); - begin - if Modify_Tree_For_C then Rewrite (Right_Opnd (N), Make_Op_Rem (Loc, Left_Opnd => Relocate_Node (Right_Opnd (N)), @@ -10298,8 +10378,8 @@ package body Exp_Ch4 is Duplicate_Subexpr_No_Checks (Right_Opnd (N)))))); Analyze_And_Resolve (N, Typ); - end if; - end; + end; + end if; end Expand_N_Op_Rotate_Left; ------------------------------ @@ -10318,22 +10398,24 @@ package body Exp_Ch4 is -- where Bits is the shift count mod Esize (the mod operation here -- deals with ludicrous large shift counts, which are apparently OK). - -- What about nonbinary modulus ??? + if Modify_Tree_For_C then + declare + Loc : constant Source_Ptr := Sloc (N); + Rtp : constant Entity_Id := Etype (Right_Opnd (N)); + Typ : constant Entity_Id := Etype (N); - declare - Loc : constant Source_Ptr := Sloc (N); - Rtp : constant Entity_Id := Etype (Right_Opnd (N)); - Typ : constant Entity_Id := Etype (N); + begin + -- Sem_Intr should prevent getting there with a non binary modulus - begin - Rewrite (Right_Opnd (N), - Make_Op_Rem (Loc, - Left_Opnd => Relocate_Node (Right_Opnd (N)), - Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ)))); + pragma Assert (not Non_Binary_Modulus (Typ)); - Analyze_And_Resolve (Right_Opnd (N), Rtp); + Rewrite (Right_Opnd (N), + Make_Op_Rem (Loc, + Left_Opnd => Relocate_Node (Right_Opnd (N)), + Right_Opnd => Make_Integer_Literal (Loc, Esize (Typ)))); + + Analyze_And_Resolve (Right_Opnd (N), Rtp); - if Modify_Tree_For_C then Rewrite (N, Make_Op_Or (Loc, Left_Opnd => @@ -10351,8 +10433,8 @@ package body Exp_Ch4 is Duplicate_Subexpr_No_Checks (Right_Opnd (N)))))); Analyze_And_Resolve (N, Typ); - end if; - end; + end; + end if; end Expand_N_Op_Rotate_Right; ---------------------------- @@ -10382,6 +10464,10 @@ package body Exp_Ch4 is Hi : Uint; begin + -- Sem_Intr should prevent getting there with a non binary modulus + + pragma Assert (not Non_Binary_Modulus (Typ)); + if Compile_Time_Known_Value (Right) then if Expr_Value (Right) >= Siz then Rewrite (N, Make_Integer_Literal (Loc, 0)); @@ -10439,7 +10525,14 @@ package body Exp_Ch4 is Binary_Op_Validity_Checks (N); -- If we are in Modify_Tree_For_C mode, there is no shift right - -- arithmetic in C, so we rewrite in terms of logical shifts. + -- arithmetic in C, so we rewrite in terms of logical shifts for + -- modular integers, and keep the Shift_Right intrinsic for signed + -- integers: even though doing a shift on a signed integer is not + -- fully guaranteed by the C standard, this is what C compilers + -- implement in practice. + -- Consider also taking advantage of this for modular integers by first + -- performing an unchecked conversion of the modular integer to a signed + -- integer of the same sign, and then convert back. -- Shift_Right (Num, Bits) or -- (if Num >= Sign @@ -10448,26 +10541,24 @@ package body Exp_Ch4 is -- Here Mask is all 1 bits (2**size - 1), and Sign is 2**(size - 1) - -- Note: in almost all C compilers it would work to just shift a - -- signed integer right, but it's undefined and we cannot rely on it. - -- Note: the above works fine for shift counts greater than or equal -- to the word size, since in this case (not (Shift_Right (Mask, bits))) -- generates all 1'bits. - -- What about nonbinary modulus ??? + if Modify_Tree_For_C and then Is_Modular_Integer_Type (Etype (N)) then + declare + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Sign : constant Uint := 2 ** (Esize (Typ) - 1); + Mask : constant Uint := (2 ** Esize (Typ)) - 1; + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Maskx : Node_Id; - declare - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (N); - Sign : constant Uint := 2 ** (Esize (Typ) - 1); - Mask : constant Uint := (2 ** Esize (Typ)) - 1; - Left : constant Node_Id := Left_Opnd (N); - Right : constant Node_Id := Right_Opnd (N); - Maskx : Node_Id; + begin + -- Sem_Intr should prevent getting there with a non binary modulus - begin - if Modify_Tree_For_C then + pragma Assert (not Non_Binary_Modulus (Typ)); -- Here if not (Shift_Right (Mask, bits)) can be computed at -- compile time as a single constant. @@ -10513,8 +10604,8 @@ package body Exp_Ch4 is Maskx, Make_Integer_Literal (Loc, 0))))); Analyze_And_Resolve (N, Typ); - end if; - end; + end; + end if; end Expand_N_Op_Shift_Right_Arithmetic; -------------------------- @@ -11366,7 +11457,12 @@ package body Exp_Ch4 is -- Start of processing for Discrete_Range_Check begin - -- Nothing to do if conversion was rewritten + -- Clear the Do_Range_Check flag on N if needed: this can occur when + -- e.g. a trivial type conversion is rewritten by its expression. + + Set_Do_Range_Check (N, False); + + -- Nothing more to do if conversion was rewritten if Nkind (N) /= N_Type_Conversion then return; @@ -11374,6 +11470,16 @@ package body Exp_Ch4 is Expr := Expression (N); + -- Nothing to do if no range check flag set + + if not Do_Range_Check (Expr) then + return; + end if; + + -- Clear the Do_Range_Check flag on Expr + + Set_Do_Range_Check (Expr, False); + -- Nothing to do if range checks suppressed if Range_Checks_Suppressed (Target_Type) then @@ -11392,23 +11498,20 @@ package body Exp_Ch4 is -- Before we do a range check, we have to deal with treating -- a fixed-point operand as an integer. The way we do this -- is simply to do an unchecked conversion to an appropriate - -- integer type large enough to hold the result. + -- integer type with the smallest size, so that we can suppress + -- trivial checks. if Is_Fixed_Point_Type (Etype (Expr)) then - if Esize (Base_Type (Etype (Expr))) > Standard_Integer_Size then - Ityp := Standard_Long_Long_Integer; - else - Ityp := Standard_Integer; - end if; + Ityp := Small_Integer_Type_For + (Esize (Base_Type (Etype (Expr))), False); - -- Generate a temporary with the large type to facilitate in the C - -- backend the code generation for the unchecked conversion. + -- Generate a temporary with the integer type to facilitate in the + -- C backend the code generation for the unchecked conversion. if Modify_Tree_For_C then Generate_Temporary; end if; - Set_Do_Range_Check (Expr, False); Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); end if; @@ -11645,7 +11748,12 @@ package body Exp_Ch4 is Tnn : Entity_Id; begin - -- Nothing to do if conversion was rewritten + -- Clear the Do_Range_Check flag on N if needed: this can occur when + -- e.g. a trivial type conversion is rewritten by its expression. + + Set_Do_Range_Check (N, False); + + -- Nothing more to do if conversion was rewritten if Nkind (N) /= N_Type_Conversion then return; @@ -11653,7 +11761,7 @@ package body Exp_Ch4 is Expr := Expression (N); - -- Clear the flag once for all + -- Clear the Do_Range_Check flag on Expr Set_Do_Range_Check (Expr, False); @@ -11928,7 +12036,8 @@ package body Exp_Ch4 is -- Nothing at all to do if conversion is to the identical type so remove -- the conversion completely, it is useless, except that it may carry - -- an Assignment_OK attribute, which must be propagated to the operand. + -- an Assignment_OK attribute, which must be propagated to the operand + -- and the Do_Range_Check flag on Operand should be taken into account. if Operand_Type = Target_Type then if Assignment_OK (N) then @@ -11936,6 +12045,13 @@ package body Exp_Ch4 is end if; Rewrite (N, Relocate_Node (Operand)); + + if Do_Range_Check (Operand) then + pragma Assert (Is_Discrete_Type (Operand_Type)); + + Discrete_Range_Check; + end if; + goto Done; end if; @@ -12044,7 +12160,7 @@ package body Exp_Ch4 is -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in -- the processing here. Also we still need the Checks circuit, since we -- have to be sure not to generate junk overflow checks in the first - -- place, since it would be trick to remove them here. + -- place, since it would be tricky to remove them here. if Integer_Promotion_Possible (N) then @@ -12172,8 +12288,8 @@ package body Exp_Ch4 is and then Ekind (Operand_Type) = E_Anonymous_Access_Type and then Nkind (Operand) = N_Selected_Component and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant - and then Object_Access_Level (Operand) > - Type_Access_Level (Target_Type) + and then Static_Accessibility_Level (Operand, Zero_On_Dynamic_Level) + > Type_Access_Level (Target_Type) then Raise_Accessibility_Error; goto Done; @@ -12328,7 +12444,9 @@ package body Exp_Ch4 is -- These conversions require special expansion and processing, found in -- the Exp_Fixd package. We ignore cases where Conversion_OK is set, -- since from a semantic point of view, these are simple integer - -- conversions, which do not need further processing. + -- conversions, which do not need further processing except for the + -- generation of range checks, which is performed at the end of this + -- procedure. elsif Is_Fixed_Point_Type (Operand_Type) and then not Conversion_OK (N) @@ -12536,11 +12654,15 @@ package body Exp_Ch4 is then Real_Range_Check; end if; + + pragma Assert (not Do_Range_Check (Expression (N))); end if; -- Here at end of processing <<Done>> + pragma Assert (not Do_Range_Check (N)); + -- Apply predicate check if required. Note that we can't just call -- Apply_Predicate_Check here, because the type looks right after -- the conversion and it would omit the check. The Comes_From_Source @@ -13988,6 +14110,11 @@ package body Exp_Ch4 is elsif Is_OK_For_Range (Uint_64) then return Uint_64; + -- If the size of Typ is 128 then check 127 + + elsif Tsiz = Uint_128 and then Is_OK_For_Range (Uint_127) then + return Uint_127; + else return Uint_128; end if; @@ -14107,12 +14234,8 @@ package body Exp_Ch4 is -- type instead of the first subtype because operations are done in -- the base type, so this avoids the need for useless conversions. - if Nsiz <= Standard_Integer_Size then - Ntyp := Etype (Standard_Integer); - - elsif Nsiz <= Standard_Long_Long_Integer_Size then - Ntyp := Etype (Standard_Long_Long_Integer); - + if Nsiz <= System_Max_Integer_Size then + Ntyp := Etype (Integer_Type_For (Nsiz, Uns => False)); else return; end if; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 309297b..93351cf 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -523,11 +523,11 @@ package body Exp_Ch5 is elsif Has_Controlled_Component (L_Type) then Loop_Required := True; - -- If object is atomic/VFA, we cannot tolerate a loop + -- If object is full access, we cannot tolerate a loop - elsif Is_Atomic_Or_VFA_Object (Act_Lhs) + elsif Is_Full_Access_Object (Act_Lhs) or else - Is_Atomic_Or_VFA_Object (Act_Rhs) + Is_Full_Access_Object (Act_Rhs) then return; @@ -536,8 +536,8 @@ package body Exp_Ch5 is elsif Has_Atomic_Components (L_Type) or else Has_Atomic_Components (R_Type) - or else Is_Atomic_Or_VFA (Component_Type (L_Type)) - or else Is_Atomic_Or_VFA (Component_Type (R_Type)) + or else Is_Full_Access (Component_Type (L_Type)) + or else Is_Full_Access (Component_Type (R_Type)) then Loop_Required := True; @@ -2518,7 +2518,7 @@ package body Exp_Ch5 is Condition => Make_Op_Gt (Loc, Left_Opnd => - Dynamic_Accessibility_Level (Rhs), + Accessibility_Level (Rhs, Dynamic_Level), Right_Opnd => Make_Integer_Literal (Loc, Intval => @@ -2534,7 +2534,8 @@ package body Exp_Ch5 is (Effective_Extra_Accessibility (Entity (Lhs)), Loc), Expression => - Dynamic_Accessibility_Level (Rhs)); + Accessibility_Level + (Rhs, Dynamic_Level)); begin if not Accessibility_Checks_Suppressed (Entity (Lhs)) then @@ -3115,7 +3116,35 @@ package body Exp_Ch5 is if Validity_Check_Default and then not Predicates_Ignored (Etype (Expr)) then - Ensure_Valid (Expr); + -- Recognize the simple case where Expr is an object reference + -- and the case statement is directly preceded by an + -- "if Obj'Valid then": in this case, do not emit another validity + -- check. + + declare + Check_Validity : Boolean := True; + Attr : Node_Id; + begin + if Nkind (Expr) = N_Identifier + and then Nkind (Parent (N)) = N_If_Statement + and then Nkind (Original_Node (Condition (Parent (N)))) + = N_Attribute_Reference + and then No (Prev (N)) + then + Attr := Original_Node (Condition (Parent (N))); + + if Attribute_Name (Attr) = Name_Valid + and then Nkind (Prefix (Attr)) = N_Identifier + and then Entity (Prefix (Attr)) = Entity (Expr) + then + Check_Validity := False; + end if; + end if; + + if Check_Validity then + Ensure_Valid (Expr); + end if; + end; end if; -- If there is only a single alternative, just replace it with the @@ -3510,17 +3539,6 @@ package body Exp_Ch5 is Analyze (N); end Expand_Formal_Container_Element_Loop; - ----------------------------- - -- Expand_N_Goto_Statement -- - ----------------------------- - - -- Add poll before goto if polling active - - procedure Expand_N_Goto_Statement (N : Node_Id) is - begin - Generate_Poll_Call (N); - end Expand_N_Goto_Statement; - --------------------------- -- Expand_N_If_Statement -- --------------------------- @@ -4608,7 +4626,6 @@ package body Exp_Ch5 is -- 4. Deal with while loops where Condition_Actions is set -- 5. Deal with loops over predicated subtypes -- 6. Deal with loops with iterators over arrays and containers - -- 7. Insert polling call if required procedure Expand_N_Loop_Statement (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -4629,12 +4646,6 @@ package body Exp_Ch5 is Adjust_Condition (Condition (Scheme)); end if; - -- Generate polling call - - if Is_Non_Empty_List (Statements (N)) then - Generate_Poll_Call (First (Statements (N))); - end if; - -- Nothing more to do for plain loop with no iteration scheme if No (Scheme) then diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads index f4cb868..4f5e995 100644 --- a/gcc/ada/exp_ch5.ads +++ b/gcc/ada/exp_ch5.ads @@ -32,7 +32,6 @@ package Exp_Ch5 is procedure Expand_N_Block_Statement (N : Node_Id); procedure Expand_N_Case_Statement (N : Node_Id); procedure Expand_N_Exit_Statement (N : Node_Id); - procedure Expand_N_Goto_Statement (N : Node_Id); procedure Expand_N_If_Statement (N : Node_Id); procedure Expand_N_Loop_Statement (N : Node_Id); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 57d3884..b762026 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -34,7 +34,6 @@ with Elists; use Elists; with Expander; use Expander; with Exp_Aggr; use Exp_Aggr; with Exp_Atag; use Exp_Atag; -with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; @@ -1458,12 +1457,12 @@ package body Exp_Ch6 is Subp : Entity_Id; Post_Call : out List_Id) is - Loc : constant Source_Ptr := Sloc (N); - Actual : Node_Id; - Formal : Entity_Id; - N_Node : Node_Id; - E_Actual : Entity_Id; - E_Formal : Entity_Id; + Loc : constant Source_Ptr := Sloc (N); + Actual : Node_Id; + Formal : Entity_Id; + N_Node : Node_Id; + E_Actual : Entity_Id; + E_Formal : Entity_Id; procedure Add_Call_By_Copy_Code; -- For cases where the parameter must be passed by copy, this routine @@ -1807,13 +1806,7 @@ package body Exp_Ch6 is pragma Assert (Ada_Version >= Ada_2012); - if Type_Access_Level (E_Formal) > - Object_Access_Level (Lhs) - then - Append_To (Post_Call, - Make_Raise_Program_Error (Loc, - Reason => PE_Accessibility_Check_Failed)); - end if; + Apply_Accessibility_Check (Lhs, E_Formal, N); Append_To (Post_Call, Make_Assignment_Statement (Loc, @@ -2366,9 +2359,7 @@ package body Exp_Ch6 is elsif Nkind (Actual) = N_Type_Conversion and then - (Is_Numeric_Type (E_Formal) - or else Is_Access_Type (E_Formal) - or else Is_Enumeration_Type (E_Formal) + (Is_Elementary_Type (E_Formal) or else Is_Bit_Packed_Array (Etype (Formal)) or else Is_Bit_Packed_Array (Etype (Expression (Actual))) @@ -2682,22 +2673,22 @@ package body Exp_Ch6 is | N_Function_Call | N_Procedure_Call_Statement); - -- Check that this is not the call in the body of the wrapper. + -- Check that this is not the call in the body of the wrapper if Must_Rewrite_Indirect_Call and then (not Is_Overloadable (Current_Scope) or else not Is_Access_Subprogram_Wrapper (Current_Scope)) then declare - Loc : constant Source_Ptr := Sloc (N); - Wrapper : constant Entity_Id := + Loc : constant Source_Ptr := Sloc (N); + Wrapper : constant Entity_Id := Access_Subprogram_Wrapper (Etype (Name (N))); Ptr : constant Node_Id := Prefix (Name (N)); Ptr_Type : constant Entity_Id := Etype (Ptr); Typ : constant Entity_Id := Etype (N); New_N : Node_Id; - Parms : List_Id := Parameter_Associations (N); + Parms : List_Id := Parameter_Associations (N); Ptr_Act : Node_Id; begin @@ -2735,7 +2726,7 @@ package body Exp_Ch6 is if Nkind (N) = N_Procedure_Call_Statement then New_N := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Wrapper, Loc), + Name => New_Occurrence_Of (Wrapper, Loc), Parameter_Associations => Parms); else New_N := Make_Function_Call (Loc, @@ -2784,6 +2775,15 @@ package body Exp_Ch6 is -- default parameters and for extra actuals (for Extra_Formals). The -- argument is an N_Parameter_Association node. + procedure Add_Cond_Expression_Extra_Actual (Formal : Entity_Id); + -- Adds extra accessibility actuals in the case of a conditional + -- expression corresponding to Formal. + + -- Note: Conditional expressions used as actuals for anonymous access + -- formals complicate the process of propagating extra accessibility + -- actuals and must be handled in a recursive fashion since they can + -- be embedded within each other. + procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); -- Adds an extra actual to the list of extra actuals. Expr is the -- expression for the value of the actual, EF is the entity for the @@ -2802,6 +2802,10 @@ package body Exp_Ch6 is -- though useless predicate checks will be generally removed by -- back-end optimizations. + procedure Check_Subprogram_Variant; + -- Emit a call to the internally generated procedure with checks for + -- aspect Subprogrgram_Variant, if present and enabled. + function Inherited_From_Formal (S : Entity_Id) return Entity_Id; -- Within an instance, a type derived from an untagged formal derived -- type inherits from the original parent, not from the actual. The @@ -2867,6 +2871,219 @@ package body Exp_Ch6 is Prev := Actual_Expr; end Add_Actual_Parameter; + -------------------------------------- + -- Add_Cond_Expression_Extra_Actual -- + -------------------------------------- + + procedure Add_Cond_Expression_Extra_Actual + (Formal : Entity_Id) + is + Decl : Node_Id; + + -- Suppress warning for the final removal loop + pragma Warnings (Off, Decl); + + Lvl : Entity_Id; + Res : Entity_Id; + Temp : Node_Id; + Typ : Node_Id; + + procedure Insert_Level_Assign (Branch : Node_Id); + -- Recursivly add assignment of the level temporary on each branch + -- while moving through nested conditional expressions. + + ------------------------- + -- Insert_Level_Assign -- + ------------------------- + + procedure Insert_Level_Assign (Branch : Node_Id) is + + procedure Expand_Branch (Res_Assn : Node_Id); + -- Perform expansion or iterate further within nested + -- conditionals given the object declaration or assignment to + -- result object created during expansion which represents a + -- branch of the conditional expression. + + ------------------- + -- Expand_Branch -- + ------------------- + + procedure Expand_Branch (Res_Assn : Node_Id) is + begin + pragma Assert (Nkind (Res_Assn) in + N_Assignment_Statement | + N_Object_Declaration); + + -- There are more nested conditional expressions so we must go + -- deeper. + + if Nkind (Expression (Res_Assn)) = + N_Expression_With_Actions + and then + Nkind + (Original_Node (Expression (Res_Assn))) + in N_Case_Expression | N_If_Expression + then + Insert_Level_Assign + (Expression (Res_Assn)); + + -- Add the level assignment + + else + Insert_Before_And_Analyze (Res_Assn, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of + (Lvl, Loc), + Expression => + Accessibility_Level + (Expression (Res_Assn), Dynamic_Level))); + end if; + end Expand_Branch; + + Cond : Node_Id; + Alt : Node_Id; + + -- Start of processing for Insert_Level_Assign + + begin + -- Examine further nested condtionals + + pragma Assert (Nkind (Branch) = + N_Expression_With_Actions); + + -- Find the relevant statement in the actions + + Cond := First (Actions (Branch)); + while Present (Cond) loop + exit when Nkind (Cond) in + N_Case_Statement | N_If_Statement; + + Next (Cond); + end loop; + + -- The conditional expression may have been optimized away, so + -- examine the actions in the branch. + + if No (Cond) then + Expand_Branch (Last (Actions (Branch))); + + -- Iterate through if expression branches + + elsif Nkind (Cond) = N_If_Statement then + Expand_Branch (Last (Then_Statements (Cond))); + Expand_Branch (Last (Else_Statements (Cond))); + + -- Iterate through case alternatives + + elsif Nkind (Cond) = N_Case_Statement then + + Alt := First (Alternatives (Cond)); + while Present (Alt) loop + Expand_Branch (Last (Statements (Alt))); + + Next (Alt); + end loop; + end if; + end Insert_Level_Assign; + + -- Start of processing for cond expression case + + begin + -- Create declaration of a temporary to store the accessibility + -- level of each branch of the conditional expression. + + Lvl := Make_Temporary (Loc, 'L'); + Decl := Make_Object_Declaration (Loc, + Defining_Identifier => Lvl, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc)); + + -- Install the declaration and perform necessary expansion if we + -- are dealing with a function call. + + if Nkind (Call_Node) = N_Procedure_Call_Statement then + -- Generate: + -- Lvl : Natural; + -- Call ( + -- {do + -- If_Exp_Res : Typ; + -- if Cond then + -- Lvl := 0; -- Access level + -- If_Exp_Res := Exp; + -- ... + -- in If_Exp_Res end;}, + -- Lvl, + -- ... + -- ) + + Insert_Before_And_Analyze (Call_Node, Decl); + + -- A function call must be transformed into an expression with + -- actions. + + else + -- Generate: + -- do + -- Lvl : Natural; + -- in Call (do{ + -- If_Exp_Res : Typ + -- if Cond then + -- Lvl := 0; -- Access level + -- If_Exp_Res := Exp; + -- in If_Exp_Res end;}, + -- Lvl, + -- ... + -- ) + -- end; + + Res := Make_Temporary (Loc, 'R'); + Typ := Etype (Call_Node); + Temp := Relocate_Node (Call_Node); + + -- Perform the rewrite with the dummy + + Rewrite (Call_Node, + + Make_Expression_With_Actions (Loc, + Expression => New_Occurrence_Of (Res, Loc), + Actions => New_List ( + Decl, + + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Object_Definition => + New_Occurrence_Of (Typ, Loc))))); + + -- Analyze the expression with the dummy + + Analyze_And_Resolve (Call_Node, Typ); + + -- Properly set the expression and move our view of the call node + + Set_Expression (Call_Node, Relocate_Node (Temp)); + Call_Node := Expression (Call_Node); + + -- Remove the declaration of the dummy and the subsequent actions + -- its analysis has created. + + while Present (Remove_Next (Decl)) loop + null; + end loop; + end if; + + -- Decorate the conditional expression with assignments to our level + -- temporary. + + Insert_Level_Assign (Prev); + + -- Make our level temporary the passed actual + + Add_Extra_Actual + (Expr => New_Occurrence_Of (Lvl, Loc), + EF => Extra_Accessibility (Formal)); + end Add_Cond_Expression_Extra_Actual; + ---------------------- -- Add_Extra_Actual -- ---------------------- @@ -2927,7 +3144,7 @@ package body Exp_Ch6 is if Has_Invariants (Curr_Typ) and then Present (Invariant_Procedure (Curr_Typ)) then - -- Verify the invariate of the current type. Generate: + -- Verify the invariant of the current type. Generate: -- <Curr_Typ>Invariant (Curr_Typ (Arg)); @@ -2945,7 +3162,12 @@ package body Exp_Ch6 is Par_Typ := Base_Type (Etype (Curr_Typ)); end loop; - if not Is_Empty_List (Inv_Checks) then + -- If the node is a function call the generated tests have been + -- already handled in Insert_Post_Call_Actions. + + if not Is_Empty_List (Inv_Checks) + and then Nkind (Call_Node) = N_Procedure_Call_Statement + then Insert_Actions_After (Call_Node, Inv_Checks); end if; end Add_View_Conversion_Invariants; @@ -2971,9 +3193,7 @@ package body Exp_Ch6 is function May_Fold (N : Node_Id) return Traverse_Result is begin case Nkind (N) is - when N_Binary_Op - | N_Unary_Op - => + when N_Op => return OK; when N_Expanded_Name @@ -3057,6 +3277,37 @@ package body Exp_Ch6 is end if; end Can_Fold_Predicate_Call; + ------------------------------ + -- Check_Subprogram_Variant -- + ------------------------------ + + procedure Check_Subprogram_Variant is + Variant_Prag : constant Node_Id := + Get_Pragma (Current_Scope, Pragma_Subprogram_Variant); + + Variant_Proc : Entity_Id; + + begin + if Present (Variant_Prag) and then Is_Checked (Variant_Prag) then + + -- Analysis of the pragma rewrites its argument with a reference + -- to the internally generated procedure. + + Variant_Proc := + Entity + (Expression + (First + (Pragma_Argument_Associations (Variant_Prag)))); + + Insert_Action (Call_Node, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Variant_Proc, Loc), + Parameter_Associations => + New_Copy_List (Parameter_Associations (Call_Node)))); + end if; + end Check_Subprogram_Variant; + --------------------------- -- Inherited_From_Formal -- --------------------------- @@ -3217,7 +3468,7 @@ package body Exp_Ch6 is then declare Actual : Node_Id; - Formal : Node_Id; + Formal : Entity_Id; begin Actual := First (Parameter_Associations (Call_Node)); @@ -3261,10 +3512,9 @@ package body Exp_Ch6 is Actual : Node_Id; Formal : Entity_Id; Orig_Subp : Entity_Id := Empty; - Param_Count : Natural := 0; + Param_Count : Positive; Parent_Formal : Entity_Id; Parent_Subp : Entity_Id; - Prev_Ult : Node_Id; Scop : Entity_Id; Subp : Entity_Id; @@ -3405,8 +3655,7 @@ package body Exp_Ch6 is end; end if; - -- if this is a call to a predicate function, try to constant - -- fold it. + -- If this is a call to a predicate function, try to constant fold it if Nkind (Call_Node) = N_Function_Call and then Is_Entity_Name (Name (Call_Node)) @@ -3623,7 +3872,7 @@ package body Exp_Ch6 is -- Create possible extra actual for accessibility level - if Present (Get_Accessibility (Formal)) then + if Present (Extra_Accessibility (Formal)) then -- Ada 2005 (AI-252): If the actual was rewritten as an Access -- attribute, then the original actual may be an aliased object @@ -3712,413 +3961,25 @@ package body Exp_Ch6 is Add_Extra_Actual (Expr => - New_Occurrence_Of (Get_Accessibility (Parm_Ent), Loc), - EF => Get_Accessibility (Formal)); + New_Occurrence_Of + (Get_Dynamic_Accessibility (Parm_Ent), Loc), + EF => Extra_Accessibility (Formal)); end; - elsif Is_Entity_Name (Prev_Orig) then - - -- When passing an access parameter, or a renaming of an access - -- parameter, as the actual to another access parameter we need - -- to pass along the actual's own access level parameter. This - -- is done if we are within the scope of the formal access - -- parameter (if this is an inlined body the extra formal is - -- irrelevant). - - if (Is_Formal (Entity (Prev_Orig)) - or else - (Present (Renamed_Object (Entity (Prev_Orig))) - and then - Is_Entity_Name (Renamed_Object (Entity (Prev_Orig))) - and then - Is_Formal - (Entity (Renamed_Object (Entity (Prev_Orig)))))) - and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type - and then In_Open_Scopes (Scope (Entity (Prev_Orig))) - then - declare - Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); - - begin - pragma Assert (Present (Parm_Ent)); - - if Present (Get_Accessibility (Parm_Ent)) then - Add_Extra_Actual - (Expr => - New_Occurrence_Of - (Get_Accessibility (Parm_Ent), Loc), - EF => Get_Accessibility (Formal)); - - -- If the actual access parameter does not have an - -- associated extra formal providing its scope level, - -- then treat the actual as having library-level - -- accessibility. + -- Conditional expressions - else - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => Scope_Depth (Standard_Standard)), - EF => Get_Accessibility (Formal)); - end if; - end; - - -- The actual is a normal access value, so just pass the level - -- of the actual's access type. - - else - Add_Extra_Actual - (Expr => Dynamic_Accessibility_Level (Prev_Orig), - EF => Get_Accessibility (Formal)); - end if; - - -- If the actual is an access discriminant, then pass the level - -- of the enclosing object (RM05-3.10.2(12.4/2)). - - elsif Nkind (Prev_Orig) = N_Selected_Component - and then Ekind (Entity (Selector_Name (Prev_Orig))) = - E_Discriminant - and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) = - E_Anonymous_Access_Type + elsif Nkind (Prev) = N_Expression_With_Actions + and then Nkind (Original_Node (Prev)) in + N_If_Expression | N_Case_Expression then - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => Object_Access_Level (Prefix (Prev_Orig))), - EF => Get_Accessibility (Formal)); + Add_Cond_Expression_Extra_Actual (Formal); - -- All other cases + -- Normal case else - case Nkind (Prev_Orig) is - when N_Attribute_Reference => - case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is - -- Ignore 'Result, 'Loop_Entry, and 'Old as they can - -- be used to identify access objects and do not have - -- an effect on accessibility level. - - when Attribute_Loop_Entry - | Attribute_Old - | Attribute_Result - => - null; - - -- For X'Access, pass on the level of the prefix X - - when Attribute_Access => - - -- Accessibility level of S'Access is that of A - - Prev_Orig := Prefix (Prev_Orig); - - -- If the expression is a view conversion, the - -- accessibility level is that of the expression. - - if Nkind (Original_Node (Prev_Orig)) = - N_Type_Conversion - and then - Nkind (Expression (Original_Node (Prev_Orig))) = - N_Explicit_Dereference - then - Prev_Orig := - Expression (Original_Node (Prev_Orig)); - end if; - - -- Obtain the ultimate prefix so we can check for - -- the case where we are taking 'Access of a - -- component of an anonymous access formal - which - -- would mean we need to pass said formal's - -- corresponding extra accessibility formal. - - Prev_Ult := Ultimate_Prefix (Prev_Orig); - - if Is_Entity_Name (Prev_Ult) - and then not Is_Type (Entity (Prev_Ult)) - and then Present - (Get_Accessibility - (Entity (Prev_Ult))) - then - Add_Extra_Actual - (Expr => - New_Occurrence_Of - (Get_Accessibility - (Entity (Prev_Ult)), Loc), - EF => Get_Accessibility (Formal)); - - -- Normal case, call Object_Access_Level. Note: - -- should be Dynamic_Accessibility_Level ??? - - else - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => - Object_Access_Level (Prev_Orig)), - EF => Get_Accessibility (Formal)); - end if; - - -- Treat the unchecked attributes as library-level - - when Attribute_Unchecked_Access - | Attribute_Unrestricted_Access - => - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => Scope_Depth (Standard_Standard)), - EF => Get_Accessibility (Formal)); - - -- No other cases of attributes returning access - -- values that can be passed to access parameters. - - when others => - raise Program_Error; - - end case; - - -- For allocators we pass the level of the execution of the - -- called subprogram, which is one greater than the current - -- scope level. However, according to RM 3.10.2(14/3) this - -- is wrong since for an anonymous allocator defining the - -- value of an access parameter, the accessibility level is - -- that of the innermost master of the call??? - - when N_Allocator => - Add_Extra_Actual - (Expr => - Make_Integer_Literal (Loc, - Intval => Scope_Depth (Current_Scope) + 1), - EF => Get_Accessibility (Formal)); - - -- For most other cases we simply pass the level of the - -- actual's access type. The type is retrieved from - -- Prev rather than Prev_Orig, because in some cases - -- Prev_Orig denotes an original expression that has - -- not been analyzed. - - -- However, when the actual is wrapped in a conditional - -- expression we must add a local temporary to store the - -- level at each branch, and, possibly, expand the call - -- into an expression with actions. - - when others => - if Nkind (Prev) = N_Expression_With_Actions - and then Nkind (Original_Node (Prev)) in - N_If_Expression | N_Case_Expression - then - declare - Decl : Node_Id; - pragma Warnings (Off, Decl); - -- Suppress warning for the final removal loop - Lvl : Entity_Id; - Res : Entity_Id; - Temp : Node_Id; - Typ : Node_Id; - - procedure Insert_Level_Assign (Branch : Node_Id); - -- Recursivly add assignment of the level temporary - -- on each branch while moving through nested - -- conditional expressions. - - ------------------------- - -- Insert_Level_Assign -- - ------------------------- - - procedure Insert_Level_Assign (Branch : Node_Id) is - - procedure Expand_Branch (Assn : Node_Id); - -- Perform expansion or iterate further within - -- nested conditionals. - - ------------------- - -- Expand_Branch -- - ------------------- - - procedure Expand_Branch (Assn : Node_Id) is - begin - pragma Assert (Nkind (Assn) = - N_Assignment_Statement); - - -- There are more nested conditional - -- expressions so we must go deeper. - - if Nkind (Expression (Assn)) = - N_Expression_With_Actions - and then - Nkind - (Original_Node (Expression (Assn))) in - N_Case_Expression | N_If_Expression - then - Insert_Level_Assign (Expression (Assn)); - - -- Add the level assignment - - else - Insert_Before_And_Analyze (Assn, - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Lvl, Loc), - Expression => - Dynamic_Accessibility_Level - (Expression (Assn)))); - end if; - end Expand_Branch; - - Cond : Node_Id; - Alt : Node_Id; - - -- Start of processing for Insert_Level_Assign - - begin - -- Examine further nested condtionals - - pragma Assert (Nkind (Branch) = - N_Expression_With_Actions); - - -- Find the relevant statement in the actions - - Cond := First (Actions (Branch)); - loop - exit when Nkind (Cond) in - N_Case_Statement | N_If_Statement; - - Next (Cond); - - if No (Cond) then - raise Program_Error; - end if; - end loop; - - -- Iterate through if expression branches - - if Nkind (Cond) = N_If_Statement then - Expand_Branch (Last (Then_Statements (Cond))); - Expand_Branch (Last (Else_Statements (Cond))); - - -- Iterate through case alternatives - - elsif Nkind (Cond) = N_Case_Statement then - - Alt := First (Alternatives (Cond)); - while Present (Alt) loop - Expand_Branch (Last (Statements (Alt))); - - Next (Alt); - end loop; - end if; - end Insert_Level_Assign; - - -- Start of processing for cond expression case - - begin - -- Create declaration of a temporary to store the - -- accessibility level of each branch of the - -- conditional expression. - - Lvl := Make_Temporary (Loc, 'L'); - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Lvl, - Object_Definition => - New_Occurrence_Of (Standard_Natural, Loc)); - - -- Install the declaration and perform necessary - -- expansion if we are dealing with a function - -- call. - - if Nkind (Call_Node) = N_Procedure_Call_Statement - then - -- Generate: - -- Lvl : Natural; - -- Call ( - -- {do - -- If_Exp_Res : Typ; - -- if Cond then - -- Lvl := 0; -- Access level - -- If_Exp_Res := Exp; - -- ... - -- in If_Exp_Res end;}, - -- Lvl, - -- ... - -- ) - - Insert_Before_And_Analyze (Call_Node, Decl); - - -- A function call must be transformed into an - -- expression with actions. - - else - -- Generate: - -- do - -- Lvl : Natural; - -- in Call (do{ - -- If_Exp_Res : Typ - -- if Cond then - -- Lvl := 0; -- Access level - -- If_Exp_Res := Exp; - -- in If_Exp_Res end;}, - -- Lvl, - -- ... - -- ) - -- end; - - Res := Make_Temporary (Loc, 'R'); - Typ := Etype (Call_Node); - Temp := Relocate_Node (Call_Node); - - -- Perform the rewrite with the dummy - - Rewrite (Call_Node, - - Make_Expression_With_Actions (Loc, - Expression => New_Occurrence_Of (Res, Loc), - Actions => New_List ( - Decl, - - Make_Object_Declaration (Loc, - Defining_Identifier => Res, - Object_Definition => - New_Occurrence_Of (Typ, Loc))))); - - -- Analyze the expression with the dummy - - Analyze_And_Resolve (Call_Node, Typ); - - -- Properly set the expression and move our view - -- of the call node - - Set_Expression (Call_Node, Relocate_Node (Temp)); - Call_Node := Expression (Call_Node); - - -- Remove the declaration of the dummy and the - -- subsequent actions its analysis has created. - - while Present (Remove_Next (Decl)) loop - null; - end loop; - end if; - - -- Decorate the conditional expression with - -- assignments to our level temporary. - - Insert_Level_Assign (Prev); - - -- Make our level temporary the passed actual - - Add_Extra_Actual - (Expr => New_Occurrence_Of (Lvl, Loc), - EF => Get_Accessibility (Formal)); - end; - - -- General case uncomplicated by conditional expressions - - else - Add_Extra_Actual - (Expr => Dynamic_Accessibility_Level (Prev), - EF => Get_Accessibility (Formal)); - end if; - end case; + Add_Extra_Actual + (Expr => Accessibility_Level (Prev, Dynamic_Level), + EF => Extra_Accessibility (Formal)); end if; end if; @@ -4342,110 +4203,44 @@ package body Exp_Ch6 is Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))) then declare - Ancestor : Node_Id := Parent (Call_Node); - Level : Node_Id := Empty; - Defer : Boolean := False; + Extra_Form : Node_Id := Empty; + Level : Node_Id := Empty; begin - -- Unimplemented: if Subp returns an anonymous access type, then - - -- a) if the call is the operand of an explict conversion, then - -- the target type of the conversion (a named access type) - -- determines the accessibility level pass in; - - -- b) if the call defines an access discriminant of an object - -- (e.g., the discriminant of an object being created by an - -- allocator, or the discriminant of a function result), - -- then the accessibility level to pass in is that of the - -- discriminated object being initialized). - - -- ??? - - while Nkind (Ancestor) = N_Qualified_Expression - loop - Ancestor := Parent (Ancestor); - end loop; - - case Nkind (Ancestor) is - when N_Allocator => - - -- At this point, we'd like to assign - - -- Level := Dynamic_Accessibility_Level (Ancestor); - - -- but Etype of Ancestor may not have been set yet, - -- so that doesn't work. - - -- Handle this later in Expand_Allocator_Expression. - - Defer := True; - - when N_Object_Declaration - | N_Object_Renaming_Declaration - => - declare - Def_Id : constant Entity_Id := - Defining_Identifier (Ancestor); - - begin - if Is_Return_Object (Def_Id) then - if Present (Extra_Accessibility_Of_Result - (Return_Applies_To (Scope (Def_Id)))) - then - -- Pass along value that was passed in if the - -- routine we are returning from also has an - -- Accessibility_Of_Result formal. - - Level := - New_Occurrence_Of - (Extra_Accessibility_Of_Result - (Return_Applies_To (Scope (Def_Id))), Loc); - end if; - else - Level := - Make_Integer_Literal (Loc, - Intval => Object_Access_Level (Def_Id)); - end if; - end; - - when N_Simple_Return_Statement => - if Present (Extra_Accessibility_Of_Result - (Return_Applies_To - (Return_Statement_Entity (Ancestor)))) - then - -- Pass along value that was passed in if the returned - -- routine also has an Accessibility_Of_Result formal. - - Level := - New_Occurrence_Of - (Extra_Accessibility_Of_Result - (Return_Applies_To - (Return_Statement_Entity (Ancestor))), Loc); - end if; + -- Detect cases where the function call has been internally + -- generated by examining the original node and return library + -- level - taking care to avoid ignoring function calls expanded + -- in prefix notation. + + if Nkind (Original_Node (Call_Node)) not in N_Function_Call + | N_Selected_Component + | N_Indexed_Component + then + Level := Make_Integer_Literal + (Loc, Scope_Depth (Standard_Standard)); - when others => - null; - end case; + -- Otherwise get the level normally based on the call node - if not Defer then - if not Present (Level) then + else + Level := Accessibility_Level (Call_Node, Dynamic_Level); - -- The "innermost master that evaluates the function call". + end if; - -- ??? - Should we use Integer'Last here instead in order - -- to deal with (some of) the problems associated with - -- calls to subps whose enclosing scope is unknown (e.g., - -- Anon_Access_To_Subp_Param.all)? + -- It may be possible that we are re-expanding an already + -- expanded call when are are dealing with dispatching ??? - Level := - Make_Integer_Literal (Loc, - Intval => Scope_Depth (Current_Scope) + 1); - end if; + if not Present (Parameter_Associations (Call_Node)) + or else Nkind (Last (Parameter_Associations (Call_Node))) + /= N_Parameter_Association + or else not Is_Accessibility_Actual + (Last (Parameter_Associations (Call_Node))) + then + Extra_Form := Extra_Accessibility_Of_Result + (Ultimate_Alias (Subp)); Add_Extra_Actual (Expr => Level, - EF => - Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))); + EF => Extra_Form); end if; end; end if; @@ -4516,7 +4311,7 @@ package body Exp_Ch6 is end if; -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand - -- it to point to the correct secondary virtual table + -- it to point to the correct secondary virtual table. if Nkind (Call_Node) in N_Subprogram_Call and then CW_Interface_Formals_Present @@ -4650,6 +4445,18 @@ package body Exp_Ch6 is Expand_Actuals (Call_Node, Subp, Post_Call); + -- If it is a recursive call then call the internal procedure that + -- verifies Subprogram_Variant contract (if present and enabled). + -- Detecting calls to subprogram aliases is necessary for recursive + -- calls in instances of generic subprograms, where the renaming of + -- the current subprogram is called. + + if Is_Subprogram (Subp) + and then Same_Or_Aliased_Subprograms (Subp, Current_Scope) + then + Check_Subprogram_Variant; + end if; + -- Verify that the actuals do not share storage. This check must be done -- on the caller side rather that inside the subprogram to avoid issues -- of parameter passing. @@ -4932,7 +4739,7 @@ package body Exp_Ch6 is -- A call to a null procedure is replaced by a null statement, but we -- are not allowed to ignore possible side effects of the call, so we -- make sure that actuals are evaluated. - -- We also suppress this optimization for GNATCoverage. + -- We also suppress this optimization for GNATcoverage. elsif Is_Null_Procedure (Subp) and then not Opt.Suppress_Control_Flow_Optimizations @@ -6389,9 +6196,6 @@ package body Exp_Ch6 is -- Expand_N_Subprogram_Body -- ------------------------------ - -- Add poll call if ATC polling is enabled, unless the body will be inlined - -- by the back-end. - -- Add dummy push/pop label nodes at start and end to clear any local -- exception indications if local-exception-to-goto optimization is active. @@ -6601,25 +6405,6 @@ package body Exp_Ch6 is end; end if; - -- Need poll on entry to subprogram if polling enabled. We only do this - -- for non-empty subprograms, since it does not seem necessary to poll - -- for a dummy null subprogram. - - if Is_Non_Empty_List (L) then - - -- Do not add a polling call if the subprogram is to be inlined by - -- the back-end, to avoid repeated calls with multiple inlinings. - - if Is_Inlined (Spec_Id) - and then Front_End_Inlining - and then Optimization_Level > 1 - then - null; - else - Generate_Poll_Call (First (L)); - end if; - end if; - -- Initialize any scalar OUT args if Initialize/Normalize_Scalars if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then @@ -7318,6 +7103,13 @@ package body Exp_Ch6 is Exp : Node_Id := Expression (N); pragma Assert (Present (Exp)); + Exp_Is_Function_Call : constant Boolean := + Nkind (Exp) = N_Function_Call + or else (Nkind (Exp) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Exp)) + and then Ekind (Entity (Prefix (Exp))) = E_Constant + and then Is_Related_To_Func_Return (Entity (Prefix (Exp)))); + Exp_Typ : constant Entity_Id := Etype (Exp); -- The type of the expression (not necessarily the same as R_Type) @@ -7329,27 +7121,6 @@ package body Exp_Ch6 is -- of the return object to the specific type on assignments to the -- individual components. - procedure Check_Against_Result_Level (Level : Node_Id); - -- Check the given accessibility level against the level - -- determined by the point of call. (AI05-0234). - - -------------------------------- - -- Check_Against_Result_Level -- - -------------------------------- - - procedure Check_Against_Result_Level (Level : Node_Id) is - begin - Insert_Action (N, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Level, - Right_Opnd => - New_Occurrence_Of - (Extra_Accessibility_Of_Result (Scope_Id), Loc)), - Reason => PE_Accessibility_Check_Failed)); - end Check_Against_Result_Level; - -- Start of processing for Expand_Simple_Function_Return begin @@ -7477,10 +7248,9 @@ package body Exp_Ch6 is -- Check the result expression of a scalar function against the subtype -- of the function by inserting a conversion. This conversion must -- eventually be performed for other classes of types, but for now it's - -- only done for scalars. - -- ??? + -- only done for scalars ??? - if Is_Scalar_Type (Exp_Typ) then + if Is_Scalar_Type (Exp_Typ) and then Exp_Typ /= R_Type then Rewrite (Exp, Convert_To (R_Type, Exp)); -- The expression is resolved to ensure that the conversion gets @@ -7533,7 +7303,7 @@ package body Exp_Ch6 is Decl : Node_Id; Ent : Entity_Id; begin - if Nkind (Exp) /= N_Function_Call + if not Exp_Is_Function_Call and then Has_Discriminants (Ubt) and then not Is_Constrained (Ubt) and then not Has_Unchecked_Union (Ubt) @@ -7556,22 +7326,14 @@ package body Exp_Ch6 is Set_Enclosing_Sec_Stack_Return (N); -- Optimize the case where the result is a function call. In this - -- case either the result is already on the secondary stack, or is - -- already being returned with the stack pointer depressed and no - -- further processing is required except to set the By_Ref flag - -- to ensure that gigi does not attempt an extra unnecessary copy. - -- (actually not just unnecessary but harmfully wrong in the case - -- of a controlled type, where gigi does not know how to do a copy). - -- To make up for a gcc 2.8.1 deficiency (???), we perform the copy - -- for array types if the constrained status of the target type is - -- different from that of the expression. + -- case the result is already on the secondary stack and no further + -- processing is required except to set the By_Ref flag to ensure + -- that gigi does not attempt an extra unnecessary copy. (Actually + -- not just unnecessary but wrong in the case of a controlled type, + -- where gigi does not know how to do a copy.) if Requires_Transient_Scope (Exp_Typ) - and then - (not Is_Array_Type (Exp_Typ) - or else Is_Constrained (Exp_Typ) = Is_Constrained (R_Type) - or else CW_Or_Has_Controlled_Part (Utyp)) - and then Nkind (Exp) = N_Function_Call + and then Exp_Is_Function_Call then Set_By_Ref (N); @@ -7800,199 +7562,6 @@ package body Exp_Ch6 is Suppress => All_Checks); end if; - -- Determine if the special rules within RM 3.10.2 for explicitly - -- aliased formals apply to Exp - in which case we require a dynamic - -- check to be generated. - - if Is_Special_Aliased_Formal_Access (Exp, Scope_Id) then - Check_Against_Result_Level - (Make_Integer_Literal (Loc, - Object_Access_Level (Entity (Ultimate_Prefix (Prefix (Exp)))))); - end if; - - -- AI05-0234: Check unconstrained access discriminants to ensure - -- that the result does not outlive an object designated by one - -- of its discriminants (RM 6.5(21/3)). - - if Present (Extra_Accessibility_Of_Result (Scope_Id)) - and then Has_Unconstrained_Access_Discriminants (R_Type) - then - declare - Discrim_Source : Node_Id; - begin - Discrim_Source := Exp; - while Nkind (Discrim_Source) = N_Qualified_Expression loop - Discrim_Source := Expression (Discrim_Source); - end loop; - - if Nkind (Discrim_Source) = N_Identifier - and then Is_Return_Object (Entity (Discrim_Source)) - then - Discrim_Source := Entity (Discrim_Source); - - if Is_Constrained (Etype (Discrim_Source)) then - Discrim_Source := Etype (Discrim_Source); - else - Discrim_Source := Expression (Parent (Discrim_Source)); - end if; - - elsif Nkind (Discrim_Source) = N_Identifier - and then Nkind (Original_Node (Discrim_Source)) in - N_Aggregate | N_Extension_Aggregate - then - Discrim_Source := Original_Node (Discrim_Source); - - elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then - Nkind (Original_Node (Discrim_Source)) = N_Function_Call - then - Discrim_Source := Original_Node (Discrim_Source); - end if; - - Discrim_Source := Unqual_Conv (Discrim_Source); - - case Nkind (Discrim_Source) is - when N_Defining_Identifier => - pragma Assert (Is_Composite_Type (Discrim_Source) - and then Has_Discriminants (Discrim_Source) - and then Is_Constrained (Discrim_Source)); - - declare - Discrim : Entity_Id := - First_Discriminant (Base_Type (R_Type)); - Disc_Elmt : Elmt_Id := - First_Elmt (Discriminant_Constraint - (Discrim_Source)); - begin - loop - if Ekind (Etype (Discrim)) = - E_Anonymous_Access_Type - then - Check_Against_Result_Level - (Dynamic_Accessibility_Level (Node (Disc_Elmt))); - end if; - - Next_Elmt (Disc_Elmt); - Next_Discriminant (Discrim); - exit when not Present (Discrim); - end loop; - end; - - when N_Aggregate - | N_Extension_Aggregate - => - -- Unimplemented: extension aggregate case where discrims - -- come from ancestor part, not extension part. - - declare - Discrim : Entity_Id := - First_Discriminant (Base_Type (R_Type)); - - Disc_Exp : Node_Id := Empty; - - Positionals_Exhausted - : Boolean := not Present (Expressions - (Discrim_Source)); - - function Associated_Expr - (Comp_Id : Entity_Id; - Associations : List_Id) return Node_Id; - - -- Given a component and a component associations list, - -- locate the expression for that component; returns - -- Empty if no such expression is found. - - --------------------- - -- Associated_Expr -- - --------------------- - - function Associated_Expr - (Comp_Id : Entity_Id; - Associations : List_Id) return Node_Id - is - Assoc : Node_Id; - Choice : Node_Id; - - begin - -- Simple linear search seems ok here - - Assoc := First (Associations); - while Present (Assoc) loop - Choice := First (Choices (Assoc)); - while Present (Choice) loop - if (Nkind (Choice) = N_Identifier - and then Chars (Choice) = Chars (Comp_Id)) - or else (Nkind (Choice) = N_Others_Choice) - then - return Expression (Assoc); - end if; - - Next (Choice); - end loop; - - Next (Assoc); - end loop; - - return Empty; - end Associated_Expr; - - begin - if not Positionals_Exhausted then - Disc_Exp := First (Expressions (Discrim_Source)); - end if; - - loop - if Positionals_Exhausted then - Disc_Exp := - Associated_Expr - (Discrim, - Component_Associations (Discrim_Source)); - end if; - - if Ekind (Etype (Discrim)) = - E_Anonymous_Access_Type - then - Check_Against_Result_Level - (Dynamic_Accessibility_Level (Disc_Exp)); - end if; - - Next_Discriminant (Discrim); - exit when not Present (Discrim); - - if not Positionals_Exhausted then - Next (Disc_Exp); - Positionals_Exhausted := not Present (Disc_Exp); - end if; - end loop; - end; - - when N_Function_Call => - - -- No check needed (check performed by callee) - - null; - - when others => - declare - Level : constant Node_Id := - Make_Integer_Literal (Loc, - Object_Access_Level (Discrim_Source)); - - begin - -- Unimplemented: check for name prefix that includes - -- a dereference of an access value with a dynamic - -- accessibility level (e.g., an access param or a - -- saooaaat) and use dynamic level in that case. For - -- example: - -- return Access_Param.all(Some_Index).Some_Component; - -- ??? - - Set_Etype (Level, Standard_Natural); - Check_Against_Result_Level (Level); - end; - end case; - end; - end if; - -- If we are returning a nonscalar object that is possibly unaligned, -- then copy the value into a temporary first. This copy may need to -- expand to a loop of component operations. @@ -8329,9 +7898,12 @@ package body Exp_Ch6 is -- The write-back of (in)-out parameters is handled by the back-end, -- but the constraint checks generated when subtypes of formal and -- actual don't match must be inserted in the form of assignments. + -- Also do this in the case of explicit dereferences, which can occur + -- due to rewritings of function calls with controlled results. if Nkind (N) = N_Function_Call or else Nkind (Original_Node (N)) = N_Function_Call + or else Nkind (N) = N_Explicit_Dereference then pragma Assert (Ada_Version >= Ada_2012); -- Functions with '[in] out' parameters are only allowed in Ada @@ -8356,13 +7928,28 @@ package body Exp_Ch6 is -- the write back to be skipped completely. -- To deal with this, we replace the call by - + -- -- do -- Tnnn : constant function-result-type := function-call; -- Post_Call actions -- in -- Tnnn; -- end; + -- + -- However, that doesn't work if function-result-type requires + -- finalization (because function-call's result never gets + -- finalized). So in that case, we instead replace the call by + -- + -- do + -- type Ref is access all function-result-type; + -- Ptr : constant Ref := function-call'Reference; + -- Tnnn : constant function-result-type := Ptr.all; + -- Finalize (Ptr.all); + -- Post_Call actions + -- in + -- Tnnn; + -- end; + -- declare Loc : constant Source_Ptr := Sloc (N); @@ -8371,12 +7958,63 @@ package body Exp_Ch6 is Name : constant Node_Id := Relocate_Node (N); begin - Prepend_To (Post_Call, - Make_Object_Declaration (Loc, - Defining_Identifier => Tnnn, - Object_Definition => New_Occurrence_Of (FRTyp, Loc), - Constant_Present => True, - Expression => Name)); + if Needs_Finalization (FRTyp) then + declare + Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Ptr_Typ_Decl : constant Node_Id := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (FRTyp, Loc))); + + Ptr_Obj : constant Entity_Id := + Make_Temporary (Loc, 'P'); + + Ptr_Obj_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Ptr_Obj, + Object_Definition => + New_Occurrence_Of (Ptr_Typ, Loc), + Constant_Present => True, + Expression => + Make_Attribute_Reference (Loc, + Prefix => Name, + Attribute_Name => Name_Unrestricted_Access)); + + function Ptr_Dereference return Node_Id is + (Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Ptr_Obj, Loc))); + + Tnn_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Tnnn, + Object_Definition => New_Occurrence_Of (FRTyp, Loc), + Constant_Present => True, + Expression => Ptr_Dereference); + + Finalize_Call : constant Node_Id := + Make_Final_Call + (Obj_Ref => Ptr_Dereference, Typ => FRTyp); + begin + -- Prepend in reverse order + + Prepend_To (Post_Call, Finalize_Call); + Prepend_To (Post_Call, Tnn_Decl); + Prepend_To (Post_Call, Ptr_Obj_Decl); + Prepend_To (Post_Call, Ptr_Typ_Decl); + end; + else + Prepend_To (Post_Call, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnnn, + Object_Definition => New_Occurrence_Of (FRTyp, Loc), + Constant_Present => True, + Expression => Name)); + end if; Rewrite (N, Make_Expression_With_Actions (Loc, @@ -8417,6 +8055,7 @@ package body Exp_Ch6 is -- The only exception is when the function call acts as an actual in a -- procedure call. In this case the function call is in a list, but the -- post-call actions must be inserted after the procedure call. + -- What if the function call is an aggregate component ??? elsif Nkind (Context) = N_Procedure_Call_Statement then Insert_Actions_After (Context, Post_Call); @@ -8906,7 +8545,7 @@ package body Exp_Ch6 is -- rather than some outer chain. begin - if Has_Task (Result_Subt) or else Might_Have_Tasks (Result_Subt) then + if Might_Have_Tasks (Result_Subt) then Actions := New_List; Build_Task_Allocate_Block_With_Init_Stmts (Actions, Allocator, Init_Stmts => New_List (Assign)); @@ -9561,9 +9200,15 @@ package body Exp_Ch6 is -- Finally, create an access object initialized to a reference to the -- function call. We know this access value cannot be null, so mark the - -- entity accordingly to suppress the access check. + -- entity accordingly to suppress the access check. We need to suppress + -- warnings, because this can be part of the expansion of "for ... of" + -- and similar constructs that generate finalization actions. Such + -- finalization actions are safe, because they check a count that + -- indicates which objects should be finalized, but the back end + -- nonetheless warns about uninitialized objects. Def_Id := Make_Temporary (Loc, 'R', Func_Call); + Set_Warnings_Off (Def_Id); Set_Etype (Def_Id, Ptr_Typ); Set_Is_Known_Non_Null (Def_Id); @@ -9609,7 +9254,7 @@ package body Exp_Ch6 is -- which prompted the generation of the transient block. To resolve -- this scenario, store the build-in-place call. - if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then + if Scope_Is_Transient then Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl); end if; @@ -9948,8 +9593,9 @@ package body Exp_Ch6 is begin return not Global_No_Tasking and then not No_Run_Time_Mode - and then Is_Class_Wide_Type (Typ) - and then Is_Limited_Record (Typ); + and then (Has_Task (Typ) + or else (Is_Class_Wide_Type (Typ) + and then Is_Limited_Record (Typ))); end Might_Have_Tasks; ---------------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 69b1909..272f893 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -241,8 +241,8 @@ package Exp_Ch6 is -- object. Function_Call must denote a call to a CPP_Constructor function. function Might_Have_Tasks (Typ : Entity_Id) return Boolean; - -- Return True if Typ is a limited class-wide type (or subtype), since it - -- might have task components. + -- Return True when type Typ has tasks or when it is a limited class-wide + -- type (or subtype), since it might have task components. function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean; -- Ada 2005 (AI-318-02): Return True if the function needs an implicit diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 07640bf..b58a3c1 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -398,6 +398,31 @@ package body Exp_Ch7 is -- actions or secondary-stack management, in which case the nested -- subprogram is a finalizer. + procedure Unnest_If_Statement (If_Stmt : Node_Id); + -- The separate statement lists associated with an if-statement (then part, + -- elsif parts, else part) may require unnesting if they directly contain + -- a subprogram body that references up-level objects. Each statement list + -- is traversed to locate such subprogram bodies, and if a part's statement + -- list contains a body, then the list is replaced with a new procedure + -- containing the part's statements followed by a call to the procedure. + -- Furthermore, any nested blocks, loops, or if statements will also be + -- traversed to determine the need for further unnesting transformations. + + procedure Unnest_Statement_List (Stmts : in out List_Id); + -- A list of statements that directly contains a subprogram at its outer + -- level, that may reference objects declared in that same statement list, + -- is rewritten as a procedure containing the statement list Stmts (which + -- includes any such objects as well as the nested subprogram), followed by + -- a call to the new procedure, and Stmts becomes the list containing the + -- procedure and the call. This ensures that Unnest_Subprogram will later + -- properly handle up-level references from the nested subprogram to + -- objects declared earlier in statement list, by creating an activation + -- record and passing it to the nested subprogram. This procedure also + -- resets the Scope of objects declared in the statement list, as well as + -- the Scope of the nested subprogram, to refer to the new procedure. + -- Also, the new procedure is marked Has_Nested_Subprogram, so this should + -- only be called when known that the statement list contains a subprogram. + procedure Unnest_Loop (Loop_Stmt : Node_Id); -- Top-level Loops that contain nested subprograms with up-level references -- need to have activation records. We do this by rewriting the loop as a @@ -3132,6 +3157,14 @@ package body Exp_Ch7 is Append_To (Finalizer_Stmts, Label); + -- Disable warnings on Obj_Id. This works around an issue where GCC + -- is not able to detect that Obj_Id is protected by a counter and + -- emits spurious warnings. + + if not Comes_From_Source (Obj_Id) then + Set_Warnings_Off (Obj_Id); + end if; + -- Processing for simple protected objects. Such objects require -- manual finalization of their lock managers. @@ -4233,6 +4266,17 @@ package body Exp_Ch7 is then Unnest_Block (Decl_Or_Stmt); + -- If-statements may contain subprogram bodies at the outer level + -- of their statement lists, and the subprograms may make up-level + -- references (such as to objects declared in the same statement + -- list). Unlike block and loop cases, however, we don't have an + -- entity on which to test the Contains_Subprogram flag, so + -- Unnest_If_Statement must traverse the statement lists to + -- determine whether there are nested subprograms present. + + elsif Nkind (Decl_Or_Stmt) = N_If_Statement then + Unnest_If_Statement (Decl_Or_Stmt); + elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then declare Id : constant Entity_Id := @@ -4883,7 +4927,6 @@ package body Exp_Ch7 is Fin_Id : Entity_Id; Mark : Entity_Id := Empty; New_Decls : List_Id; - Old_Poll : Boolean; begin -- If we are generating expanded code for debugging purposes, use the @@ -4900,12 +4943,6 @@ package body Exp_Ch7 is Loc := No_Location; end if; - -- Set polling off. The finalization and cleanup code is executed - -- with aborts deferred. - - Old_Poll := Polling_Required; - Polling_Required := False; - -- A task activation call has already been built for a task -- allocation block. @@ -5014,10 +5051,6 @@ package body Exp_Ch7 is if Present (Fin_Id) then Build_Finalizer_Call (N, Fin_Id); end if; - - -- Restore saved polling mode - - Polling_Required := Old_Poll; end; end Expand_Cleanup_Actions; @@ -5643,10 +5676,18 @@ package body Exp_Ch7 is -- <or> -- Hook := Obj_Id'Unrestricted_Access; - if Ekind (Obj_Id) in E_Constant | E_Variable - and then Present (Last_Aggregate_Assignment (Obj_Id)) - then - Hook_Insert := Last_Aggregate_Assignment (Obj_Id); + -- Similarly if we have a build in place call: we must + -- initialize Hook only after the call has happened, otherwise + -- Obj_Id will not be initialized yet. + + if Ekind (Obj_Id) in E_Constant | E_Variable then + if Present (Last_Aggregate_Assignment (Obj_Id)) then + Hook_Insert := Last_Aggregate_Assignment (Obj_Id); + elsif Present (BIP_Initialization_Call (Obj_Id)) then + Hook_Insert := BIP_Initialization_Call (Obj_Id); + else + Hook_Insert := Obj_Decl; + end if; -- Otherwise the hook seizes the related object immediately @@ -9261,6 +9302,11 @@ package body Exp_Ch7 is Handled_Statement_Sequence => Handled_Statement_Sequence (Decl)); + -- Handlers in the block may contain nested subprograms that require + -- unnesting. + + Check_Unnesting_In_Handlers (Local_Body); + Rewrite (Decl, Local_Body); Analyze (Decl); Set_Has_Nested_Subprogram (Local_Proc); @@ -9288,6 +9334,94 @@ package body Exp_Ch7 is end loop; end Unnest_Block; + ------------------------- + -- Unnest_If_Statement -- + ------------------------- + + procedure Unnest_If_Statement (If_Stmt : Node_Id) is + + procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id); + -- A list of statements (that may be a list associated with a then, + -- elsif, or else part of an if-statement) is traversed at the top + -- level to determine whether it contains a subprogram body, and if so, + -- the statements will be replaced with a new procedure body containing + -- the statements followed by a call to the procedure. The individual + -- statements may also be blocks, loops, or other if statements that + -- themselves may require contain nested subprograms needing unnesting. + + procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id) is + Subp_Found : Boolean := False; + + begin + if Is_Empty_List (Stmts) then + return; + end if; + + declare + Stmt : Node_Id := First (Stmts); + begin + while Present (Stmt) loop + if Nkind (Stmt) = N_Subprogram_Body then + Subp_Found := True; + exit; + end if; + + Next (Stmt); + end loop; + end; + + -- The statements themselves may be blocks, loops, etc. that in turn + -- contain nested subprograms requiring an unnesting transformation. + -- We perform this traversal after looking for subprogram bodies, to + -- avoid considering procedures created for one of those statements + -- (such as a block rewritten as a procedure) as a nested subprogram + -- of the statement list (which could result in an unneeded wrapper + -- procedure). + + Check_Unnesting_In_Decls_Or_Stmts (Stmts); + + -- If there was a top-level subprogram body in the statement list, + -- then perform an unnesting transformation on the list by replacing + -- the statements with a wrapper procedure body containing the + -- original statements followed by a call to that procedure. + + if Subp_Found then + Unnest_Statement_List (Stmts); + end if; + end Check_Stmts_For_Subp_Unnesting; + + -- Local variables + + Then_Stmts : List_Id := Then_Statements (If_Stmt); + Else_Stmts : List_Id := Else_Statements (If_Stmt); + + -- Start of processing for Unnest_If_Statement + + begin + Check_Stmts_For_Subp_Unnesting (Then_Stmts); + Set_Then_Statements (If_Stmt, Then_Stmts); + + if not Is_Empty_List (Elsif_Parts (If_Stmt)) then + declare + Elsif_Part : Node_Id := + First (Elsif_Parts (If_Stmt)); + Elsif_Stmts : List_Id; + begin + while Present (Elsif_Part) loop + Elsif_Stmts := Then_Statements (Elsif_Part); + + Check_Stmts_For_Subp_Unnesting (Elsif_Stmts); + Set_Then_Statements (Elsif_Part, Elsif_Stmts); + + Next (Elsif_Part); + end loop; + end; + end if; + + Check_Stmts_For_Subp_Unnesting (Else_Stmts); + Set_Else_Statements (If_Stmt, Else_Stmts); + end Unnest_If_Statement; + ----------------- -- Unnest_Loop -- ----------------- @@ -9349,6 +9483,75 @@ package body Exp_Ch7 is -- same loop entity that now belongs to the copied loop statement. end Unnest_Loop; + --------------------------- + -- Unnest_Statement_List -- + --------------------------- + + procedure Unnest_Statement_List (Stmts : in out List_Id) is + Loc : constant Source_Ptr := Sloc (First (Stmts)); + Local_Body : Node_Id; + Local_Call : Node_Id; + Local_Proc : Entity_Id; + New_Stmts : constant List_Id := Empty_List; + + begin + Local_Proc := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); + + Local_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Local_Proc), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + + Append_To (New_Stmts, Local_Body); + + Analyze (Local_Body); + + Set_Has_Nested_Subprogram (Local_Proc); + + Local_Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Local_Proc, Loc)); + + Append_To (New_Stmts, Local_Call); + Analyze (Local_Call); + + -- Traverse the statements, and for any that are declarations or + -- subprogram bodies that have entities, set the Scope of those + -- entities to the new procedure's Entity_Id. + + declare + Stmt : Node_Id := First (Stmts); + + begin + while Present (Stmt) loop + case Nkind (Stmt) is + when N_Declaration + | N_Renaming_Declaration + => + Set_Scope (Defining_Identifier (Stmt), Local_Proc); + + when N_Subprogram_Body => + Set_Scope + (Defining_Unit_Name (Specification (Stmt)), Local_Proc); + + when others => + null; + end case; + + Next (Stmt); + end loop; + end; + + Stmts := New_Stmts; + end Unnest_Statement_List; + -------------------------------- -- Wrap_Transient_Declaration -- -------------------------------- diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 630d62f..9f4c65c 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -129,7 +129,7 @@ package body Exp_Ch8 is if Is_Packed (Etype (Prefix (Nam))) then return True; - elsif Is_Atomic_Or_VFA_Object (Prefix (Nam)) then + elsif Is_Full_Access_Object (Prefix (Nam)) then return True; else @@ -152,7 +152,7 @@ package body Exp_Ch8 is then return True; - elsif Is_Atomic_Or_VFA_Object (Prefix (Nam)) then + elsif Is_Full_Access_Object (Prefix (Nam)) then return True; else diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 9cf90d1..7207723 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Aspects; use Aspects; with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; @@ -4089,8 +4090,17 @@ package body Exp_Ch9 is Parameter_Associations => Uactuals)); end if; - Lock_Kind := RE_Lock_Read_Only; - + if Has_Aspect (Pid, Aspect_Exclusive_Functions) + and then + (No (Find_Value_Of_Aspect (Pid, Aspect_Exclusive_Functions)) + or else + Is_True (Static_Boolean (Find_Value_Of_Aspect + (Pid, Aspect_Exclusive_Functions)))) + then + Lock_Kind := RE_Lock; + else + Lock_Kind := RE_Lock_Read_Only; + end if; else Unprot_Call := Make_Procedure_Call_Statement (Loc, @@ -4950,6 +4960,18 @@ package body Exp_Ch9 is if No (Chain) or else Is_Ignored_Ghost_Entity (Chain) then return; + + -- The availability of the activation chain entity does not ensure + -- that we have tasks to activate because it may have been declared + -- by the frontend to pass a required extra formal to a build-in-place + -- subprogram call. If we are within the scope of a protected type and + -- pragma Detect_Blocking is active we can assume that no tasks will be + -- activated; if tasks are created in a protected object and this pragma + -- is active then the frontend emits a warning and Program_Error is + -- raised at runtime. + + elsif Detect_Blocking and then Within_Protected_Type (Current_Scope) then + return; end if; -- The location of the activation call must be as close as possible to @@ -10051,6 +10073,7 @@ package body Exp_Ch9 is Conc_Typ : Entity_Id; Concval : Node_Id; Ename : Node_Id; + Enc_Subp : Entity_Id; Index : Node_Id; Old_Typ : Entity_Id; @@ -10567,6 +10590,26 @@ package body Exp_Ch9 is Old_Typ := Scope (Old_Typ); end loop; + -- Obtain the innermost enclosing callable construct for use in + -- generating a dynamic accessibility check. + + Enc_Subp := Current_Scope; + + if Ekind (Enc_Subp) not in Entry_Kind | Subprogram_Kind then + Enc_Subp := Enclosing_Subprogram (Enc_Subp); + end if; + + -- Generate a dynamic accessibility check on the target object + + Insert_Before_And_Analyze (N, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Accessibility_Level (Name (N), Dynamic_Level), + Right_Opnd => Make_Integer_Literal (Loc, + Scope_Depth (Enc_Subp))), + Reason => PE_Accessibility_Check_Failed)); + -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form -- Concval.Ename where the type of Concval is class-wide concurrent -- interface. diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index b973fb6..c2e7741 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -247,7 +247,7 @@ package body Exp_Dbug is -- Here we check if the static bounds match the natural size, which is -- the size passed through with the debugging information. This is the - -- Esize rounded up to 8, 16, 32 or 64 as appropriate. + -- Esize rounded up to 8, 16, 32, 64 or 128 as appropriate. else declare @@ -261,8 +261,10 @@ package body Exp_Dbug is Siz := Uint_16; elsif Esize (E) <= 32 then Siz := Uint_32; - else + elsif Esize (E) <= 64 then Siz := Uint_64; + else + Siz := Uint_128; end if; if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 1618fe6..760a412 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -5296,7 +5296,7 @@ package body Exp_Dist is function Hash (F : Name_Id) return Hash_Index is begin - return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); + return Hash_Index (Integer (F) mod Positive (Hash_Index'Last + 1)); end Hash; -------------------------- diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index d956278..42cf626 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -186,7 +186,7 @@ package body Exp_Fixd is -- Given an operand of fixed-point operation, return an expression that -- represents the corresponding Universal_Real value. The expression -- can be of integer type, floating-point type, or fixed-point type. - -- The expression returned is neither analyzed and resolved. The Etype + -- The expression returned is neither analyzed nor resolved. The Etype -- of the result is properly set (to Universal_Real). function Integer_Literal @@ -620,7 +620,7 @@ package body Exp_Fixd is Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Double_Divide), Loc), + Name => New_Occurrence_Of (RTE (RE_Double_Divide64), Loc), Parameter_Associations => New_List ( Build_Conversion (N, QR_Typ, X), Build_Conversion (N, QR_Typ, Y), @@ -977,7 +977,7 @@ package body Exp_Fixd is Object_Definition => New_Occurrence_Of (QR_Typ, Loc)), Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Scaled_Divide), Loc), + Name => New_Occurrence_Of (RTE (RE_Scaled_Divide64), Loc), Parameter_Associations => New_List ( Build_Conversion (N, QR_Typ, X), Build_Conversion (N, QR_Typ, Y), @@ -2351,19 +2351,8 @@ package body Exp_Fixd is --------------- function Fpt_Value (N : Node_Id) return Node_Id is - Typ : constant Entity_Id := Etype (N); - begin - if Is_Integer_Type (Typ) - or else Is_Floating_Point_Type (Typ) - then - return Build_Conversion (N, Universal_Real, N); - - -- Fixed-point case, must get integer value first - - else - return Build_Conversion (N, Universal_Real, N); - end if; + return Build_Conversion (N, Universal_Real, N); end Fpt_Value; --------------------- diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 41e4b1b..40cb514 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -479,13 +479,16 @@ package body Exp_Imgv is Ptyp := Entity (Pref); - -- Ada 2020 allows 'Image on private types, so we need to fetch the - -- underlying type. + -- Ada 2020 allows 'Image on private types, so fetch the underlying + -- type to obtain the structure of the type. We use the base type, + -- not the root type, to handle properly derived types, but we use + -- the root type for enumeration types, because the literal map is + -- attached to the root. Should be inherited ??? - if Ada_Version >= Ada_2020 then + if Is_Enumeration_Type (Ptyp) then Rtyp := Underlying_Type (Root_Type (Ptyp)); else - Rtyp := Root_Type (Ptyp); + Rtyp := Underlying_Type (Base_Type (Ptyp)); end if; -- Enable speed-optimized expansion of user-defined enumeration types @@ -567,21 +570,27 @@ package body Exp_Imgv is Tent := Rtyp; elsif Is_Signed_Integer_Type (Rtyp) then - if Esize (Rtyp) <= Esize (Standard_Integer) then + if Esize (Rtyp) <= Standard_Integer_Size then Imid := RE_Image_Integer; Tent := Standard_Integer; - else + elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then Imid := RE_Image_Long_Long_Integer; Tent := Standard_Long_Long_Integer; + else + Imid := RE_Image_Long_Long_Long_Integer; + Tent := Standard_Long_Long_Long_Integer; end if; elsif Is_Modular_Integer_Type (Rtyp) then if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then Imid := RE_Image_Unsigned; Tent := RTE (RE_Unsigned); - else + elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then Imid := RE_Image_Long_Long_Unsigned; Tent := RTE (RE_Long_Long_Unsigned); + else + Imid := RE_Image_Long_Long_Long_Unsigned; + Tent := RTE (RE_Long_Long_Long_Unsigned); end if; elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then @@ -610,15 +619,18 @@ package body Exp_Imgv is or else No (Lit_Strings (Rtyp)) then -- When pragma Discard_Names applies to the first subtype, build - -- (Pref'Pos (Expr))'Img. + -- (Long_Long_Integer (Pref'Pos (Expr)))'Img. The conversion is + -- there to avoid applying 'Img directly in Universal_Integer, + -- which can be a very large type. See also the handling of 'Val. Rewrite (N, Make_Attribute_Reference (Loc, Prefix => - Make_Attribute_Reference (Loc, - Prefix => Pref, - Attribute_Name => Name_Pos, - Expressions => New_List (Expr)), + Convert_To (Standard_Long_Long_Integer, + Make_Attribute_Reference (Loc, + Prefix => Pref, + Attribute_Name => Name_Pos, + Expressions => New_List (Expr))), Attribute_Name => Name_Img)); Analyze_And_Resolve (N, Standard_String); @@ -657,9 +669,10 @@ package body Exp_Imgv is T : Entity_Id; begin -- In Ada 2020 we need the underlying type here, because 'Image is - -- allowed on private types. + -- allowed on private types. We have already checked the version + -- when resolving the attribute. - if Ada_Version >= Ada_2020 then + if Is_Private_Type (Ptyp) then T := Rtyp; else T := Ptyp; @@ -683,9 +696,7 @@ package body Exp_Imgv is declare Conv : Node_Id; begin - if Ada_Version >= Ada_2020 - and then Is_Private_Type (Etype (Expr)) - then + if Is_Private_Type (Etype (Expr)) then if Is_Fixed_Point_Type (Rtyp) then Conv := Convert_To (Tent, OK_Convert_To (Rtyp, Expr)); else @@ -893,20 +904,22 @@ package body Exp_Imgv is Make_Integer_Literal (Loc, Intval => Int (Wide_Character_Encoding_Method))); - elsif Rtyp = Base_Type (Standard_Short_Short_Integer) - or else Rtyp = Base_Type (Standard_Short_Integer) - or else Rtyp = Base_Type (Standard_Integer) - then - Vid := RE_Value_Integer; - elsif Is_Signed_Integer_Type (Rtyp) then - Vid := RE_Value_Long_Long_Integer; + if Esize (Rtyp) <= Standard_Integer_Size then + Vid := RE_Value_Integer; + elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then + Vid := RE_Value_Long_Long_Integer; + else + Vid := RE_Value_Long_Long_Long_Integer; + end if; elsif Is_Modular_Integer_Type (Rtyp) then if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then Vid := RE_Value_Unsigned; - else + elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then Vid := RE_Value_Long_Long_Unsigned; + else + Vid := RE_Value_Long_Long_Long_Unsigned; end if; elsif Is_Decimal_Fixed_Point_Type (Rtyp) then @@ -1413,14 +1426,30 @@ package body Exp_Imgv is -- Signed integer types elsif Is_Signed_Integer_Type (Rtyp) then - XX := RE_Width_Long_Long_Integer; - YY := Standard_Long_Long_Integer; + if Esize (Rtyp) <= Standard_Integer_Size then + XX := RE_Width_Integer; + YY := Standard_Integer; + elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then + XX := RE_Width_Long_Long_Integer; + YY := Standard_Long_Long_Integer; + else + XX := RE_Width_Long_Long_Long_Integer; + YY := Standard_Long_Long_Long_Integer; + end if; -- Modular integer types elsif Is_Modular_Integer_Type (Rtyp) then - XX := RE_Width_Long_Long_Unsigned; - YY := RTE (RE_Long_Long_Unsigned); + if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then + XX := RE_Width_Unsigned; + YY := RTE (RE_Unsigned); + elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then + XX := RE_Width_Long_Long_Unsigned; + YY := RTE (RE_Long_Long_Unsigned); + else + XX := RE_Width_Long_Long_Long_Unsigned; + YY := RTE (RE_Long_Long_Long_Unsigned); + end if; -- Real types diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 04ad92b..78bde89 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -205,12 +205,16 @@ package body Exp_Intr is return; end if; - -- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64 + -- Use the appropriate type for the size - if Siz > 32 then - T3 := RTE (RE_Unsigned_64); - else + if Siz <= 32 then T3 := RTE (RE_Unsigned_32); + + elsif Siz <= 64 then + T3 := RTE (RE_Unsigned_64); + + else pragma Assert (Siz <= 128); + T3 := RTE (RE_Unsigned_128); end if; -- Copy operator node, and reset type and entity fields, for diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index b95bd32..07a05a5 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -233,8 +233,11 @@ package body Exp_Pakd is elsif T_Size <= 32 then Swap_RE := RE_Bswap_32; - else pragma Assert (T_Size <= 64); + elsif T_Size <= 64 then Swap_RE := RE_Bswap_64; + + else pragma Assert (T_Size <= 128); + Swap_RE := RE_Bswap_128; end if; Swap_F := RTE (Swap_RE); @@ -316,7 +319,7 @@ package body Exp_Pakd is -- Integer (subscript) - Integer (Styp'First) - if Esize (Styp) < Esize (Standard_Integer) then + if Esize (Styp) < Standard_Integer_Size then Newsub := Make_Op_Subtract (Loc, Left_Opnd => Convert_To (Standard_Integer, Newsub), @@ -917,22 +920,7 @@ package body Exp_Pakd is -- The bounds are statically known, and btyp is one of the -- unsigned types, depending on the length. - if Len_Bits <= Standard_Short_Short_Integer_Size then - Btyp := RTE (RE_Short_Short_Unsigned); - - elsif Len_Bits <= Standard_Short_Integer_Size then - Btyp := RTE (RE_Short_Unsigned); - - elsif Len_Bits <= Standard_Integer_Size then - Btyp := RTE (RE_Unsigned); - - elsif Len_Bits <= Standard_Long_Integer_Size then - Btyp := RTE (RE_Long_Unsigned); - - else - Btyp := RTE (RE_Long_Long_Unsigned); - end if; - + Btyp := Small_Integer_Type_For (Len_Bits, Uns => True); Lit := Make_Integer_Literal (Loc, 2 ** Len_Bits - 1); Set_Print_In_Hex (Lit); diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads index 33726ba..559f54a 100644 --- a/gcc/ada/exp_pakd.ads +++ b/gcc/ada/exp_pakd.ads @@ -217,12 +217,12 @@ package Exp_Pakd is -- Entity Tables for Packed Access Routines -- ---------------------------------------------- - -- For the cases of component size = 3,5-7,9-15,17-31,33-63 we call library - -- routines. These tables provide the entity for the proper routine. They - -- are exposed in the spec to allow checking for the presence of the needed - -- routine when an array is subject to pragma Pack. + -- For the cases of component size = 3,5-7,9-15,17-31,33-63,65-127 we call + -- library routines. These tables provide the entity for the right routine. + -- They are exposed in the spec to allow checking for the presence of the + -- needed routine when an array is subject to pragma Pack. - type E_Array is array (Int range 01 .. 63) of RE_Id; + type E_Array is array (Int range 1 .. 127) of RE_Id; -- Array of Bits_nn entities. Note that we do not use library routines -- for the 8-bit and 16-bit cases, but we still fill in the table, using @@ -292,7 +292,71 @@ package Exp_Pakd is 60 => RE_Bits_60, 61 => RE_Bits_61, 62 => RE_Bits_62, - 63 => RE_Bits_63); + 63 => RE_Bits_63, + 64 => RE_Unsigned_64, + 65 => RE_Bits_65, + 66 => RE_Bits_66, + 67 => RE_Bits_67, + 68 => RE_Bits_68, + 69 => RE_Bits_69, + 70 => RE_Bits_70, + 71 => RE_Bits_71, + 72 => RE_Bits_72, + 73 => RE_Bits_73, + 74 => RE_Bits_74, + 75 => RE_Bits_75, + 76 => RE_Bits_76, + 77 => RE_Bits_77, + 78 => RE_Bits_78, + 79 => RE_Bits_79, + 80 => RE_Bits_80, + 81 => RE_Bits_81, + 82 => RE_Bits_82, + 83 => RE_Bits_83, + 84 => RE_Bits_84, + 85 => RE_Bits_85, + 86 => RE_Bits_86, + 87 => RE_Bits_87, + 88 => RE_Bits_88, + 89 => RE_Bits_89, + 90 => RE_Bits_90, + 91 => RE_Bits_91, + 92 => RE_Bits_92, + 93 => RE_Bits_93, + 94 => RE_Bits_94, + 95 => RE_Bits_95, + 96 => RE_Bits_96, + 97 => RE_Bits_97, + 98 => RE_Bits_98, + 99 => RE_Bits_99, + 100 => RE_Bits_100, + 101 => RE_Bits_101, + 102 => RE_Bits_102, + 103 => RE_Bits_103, + 104 => RE_Bits_104, + 105 => RE_Bits_105, + 106 => RE_Bits_106, + 107 => RE_Bits_107, + 108 => RE_Bits_108, + 109 => RE_Bits_109, + 110 => RE_Bits_110, + 111 => RE_Bits_111, + 112 => RE_Bits_112, + 113 => RE_Bits_113, + 114 => RE_Bits_114, + 115 => RE_Bits_115, + 116 => RE_Bits_116, + 117 => RE_Bits_117, + 118 => RE_Bits_118, + 119 => RE_Bits_119, + 120 => RE_Bits_120, + 121 => RE_Bits_121, + 122 => RE_Bits_122, + 123 => RE_Bits_123, + 124 => RE_Bits_124, + 125 => RE_Bits_125, + 126 => RE_Bits_126, + 127 => RE_Bits_127); -- Array of Get routine entities. These are used to obtain an element from -- a packed array. The N'th entry is used to obtain elements from a packed @@ -362,7 +426,71 @@ package Exp_Pakd is 60 => RE_Get_60, 61 => RE_Get_61, 62 => RE_Get_62, - 63 => RE_Get_63); + 63 => RE_Get_63, + 64 => RE_Null, + 65 => RE_Get_65, + 66 => RE_Get_66, + 67 => RE_Get_67, + 68 => RE_Get_68, + 69 => RE_Get_69, + 70 => RE_Get_70, + 71 => RE_Get_71, + 72 => RE_Get_72, + 73 => RE_Get_73, + 74 => RE_Get_74, + 75 => RE_Get_75, + 76 => RE_Get_76, + 77 => RE_Get_77, + 78 => RE_Get_78, + 79 => RE_Get_79, + 80 => RE_Get_80, + 81 => RE_Get_81, + 82 => RE_Get_82, + 83 => RE_Get_83, + 84 => RE_Get_84, + 85 => RE_Get_85, + 86 => RE_Get_86, + 87 => RE_Get_87, + 88 => RE_Get_88, + 89 => RE_Get_89, + 90 => RE_Get_90, + 91 => RE_Get_91, + 92 => RE_Get_92, + 93 => RE_Get_93, + 94 => RE_Get_94, + 95 => RE_Get_95, + 96 => RE_Get_96, + 97 => RE_Get_97, + 98 => RE_Get_98, + 99 => RE_Get_99, + 100 => RE_Get_100, + 101 => RE_Get_101, + 102 => RE_Get_102, + 103 => RE_Get_103, + 104 => RE_Get_104, + 105 => RE_Get_105, + 106 => RE_Get_106, + 107 => RE_Get_107, + 108 => RE_Get_108, + 109 => RE_Get_109, + 110 => RE_Get_110, + 111 => RE_Get_111, + 112 => RE_Get_112, + 113 => RE_Get_113, + 114 => RE_Get_114, + 115 => RE_Get_115, + 116 => RE_Get_116, + 117 => RE_Get_117, + 118 => RE_Get_118, + 119 => RE_Get_119, + 120 => RE_Get_120, + 121 => RE_Get_121, + 122 => RE_Get_122, + 123 => RE_Get_123, + 124 => RE_Get_124, + 125 => RE_Get_125, + 126 => RE_Get_126, + 127 => RE_Get_127); -- Array of Get routine entities to be used in the case where the packed -- array is itself a component of a packed structure, and therefore may not @@ -432,7 +560,71 @@ package Exp_Pakd is 60 => RE_GetU_60, 61 => RE_Get_61, 62 => RE_GetU_62, - 63 => RE_Get_63); + 63 => RE_Get_63, + 64 => RE_Null, + 65 => RE_Get_65, + 66 => RE_GetU_66, + 67 => RE_Get_67, + 68 => RE_GetU_68, + 69 => RE_Get_69, + 70 => RE_GetU_70, + 71 => RE_Get_71, + 72 => RE_GetU_72, + 73 => RE_Get_73, + 74 => RE_GetU_74, + 75 => RE_Get_75, + 76 => RE_GetU_76, + 77 => RE_Get_77, + 78 => RE_GetU_78, + 79 => RE_Get_79, + 80 => RE_GetU_80, + 81 => RE_Get_81, + 82 => RE_GetU_82, + 83 => RE_Get_83, + 84 => RE_GetU_84, + 85 => RE_Get_85, + 86 => RE_GetU_86, + 87 => RE_Get_87, + 88 => RE_GetU_88, + 89 => RE_Get_89, + 90 => RE_GetU_90, + 91 => RE_Get_91, + 92 => RE_GetU_92, + 93 => RE_Get_93, + 94 => RE_GetU_94, + 95 => RE_Get_95, + 96 => RE_GetU_96, + 97 => RE_Get_97, + 98 => RE_GetU_98, + 99 => RE_Get_99, + 100 => RE_GetU_100, + 101 => RE_Get_101, + 102 => RE_GetU_102, + 103 => RE_Get_103, + 104 => RE_GetU_104, + 105 => RE_Get_105, + 106 => RE_GetU_106, + 107 => RE_Get_107, + 108 => RE_GetU_108, + 109 => RE_Get_109, + 110 => RE_GetU_110, + 111 => RE_Get_111, + 112 => RE_GetU_112, + 113 => RE_Get_113, + 114 => RE_GetU_114, + 115 => RE_Get_115, + 116 => RE_GetU_116, + 117 => RE_Get_117, + 118 => RE_GetU_118, + 119 => RE_Get_119, + 120 => RE_GetU_120, + 121 => RE_Get_121, + 122 => RE_GetU_122, + 123 => RE_Get_123, + 124 => RE_GetU_124, + 125 => RE_Get_125, + 126 => RE_GetU_126, + 127 => RE_Get_127); -- Array of Set routine entities. These are used to assign an element of a -- packed array. The N'th entry is used to assign elements for a packed @@ -502,7 +694,71 @@ package Exp_Pakd is 60 => RE_Set_60, 61 => RE_Set_61, 62 => RE_Set_62, - 63 => RE_Set_63); + 63 => RE_Set_63, + 64 => RE_Null, + 65 => RE_Set_65, + 66 => RE_Set_66, + 67 => RE_Set_67, + 68 => RE_Set_68, + 69 => RE_Set_69, + 70 => RE_Set_70, + 71 => RE_Set_71, + 72 => RE_Set_72, + 73 => RE_Set_73, + 74 => RE_Set_74, + 75 => RE_Set_75, + 76 => RE_Set_76, + 77 => RE_Set_77, + 78 => RE_Set_78, + 79 => RE_Set_79, + 80 => RE_Set_80, + 81 => RE_Set_81, + 82 => RE_Set_82, + 83 => RE_Set_83, + 84 => RE_Set_84, + 85 => RE_Set_85, + 86 => RE_Set_86, + 87 => RE_Set_87, + 88 => RE_Set_88, + 89 => RE_Set_89, + 90 => RE_Set_90, + 91 => RE_Set_91, + 92 => RE_Set_92, + 93 => RE_Set_93, + 94 => RE_Set_94, + 95 => RE_Set_95, + 96 => RE_Set_96, + 97 => RE_Set_97, + 98 => RE_Set_98, + 99 => RE_Set_99, + 100 => RE_Set_100, + 101 => RE_Set_101, + 102 => RE_Set_102, + 103 => RE_Set_103, + 104 => RE_Set_104, + 105 => RE_Set_105, + 106 => RE_Set_106, + 107 => RE_Set_107, + 108 => RE_Set_108, + 109 => RE_Set_109, + 110 => RE_Set_110, + 111 => RE_Set_111, + 112 => RE_Set_112, + 113 => RE_Set_113, + 114 => RE_Set_114, + 115 => RE_Set_115, + 116 => RE_Set_116, + 117 => RE_Set_117, + 118 => RE_Set_118, + 119 => RE_Set_119, + 120 => RE_Set_120, + 121 => RE_Set_121, + 122 => RE_Set_122, + 123 => RE_Set_123, + 124 => RE_Set_124, + 125 => RE_Set_125, + 126 => RE_Set_126, + 127 => RE_Set_127); -- Array of Set routine entities to be used in the case where the packed -- array is itself a component of a packed structure, and therefore may not @@ -572,7 +828,71 @@ package Exp_Pakd is 60 => RE_SetU_60, 61 => RE_Set_61, 62 => RE_SetU_62, - 63 => RE_Set_63); + 63 => RE_Set_63, + 64 => RE_Null, + 65 => RE_Set_65, + 66 => RE_SetU_66, + 67 => RE_Set_67, + 68 => RE_SetU_68, + 69 => RE_Set_69, + 70 => RE_SetU_70, + 71 => RE_Set_71, + 72 => RE_SetU_72, + 73 => RE_Set_73, + 74 => RE_SetU_74, + 75 => RE_Set_75, + 76 => RE_SetU_76, + 77 => RE_Set_77, + 78 => RE_SetU_78, + 79 => RE_Set_79, + 80 => RE_SetU_80, + 81 => RE_Set_81, + 82 => RE_SetU_82, + 83 => RE_Set_83, + 84 => RE_SetU_84, + 85 => RE_Set_85, + 86 => RE_SetU_86, + 87 => RE_Set_87, + 88 => RE_SetU_88, + 89 => RE_Set_89, + 90 => RE_SetU_90, + 91 => RE_Set_91, + 92 => RE_SetU_92, + 93 => RE_Set_93, + 94 => RE_SetU_94, + 95 => RE_Set_95, + 96 => RE_SetU_96, + 97 => RE_Set_97, + 98 => RE_SetU_98, + 99 => RE_Set_99, + 100 => RE_SetU_100, + 101 => RE_Set_101, + 102 => RE_SetU_102, + 103 => RE_Set_103, + 104 => RE_SetU_104, + 105 => RE_Set_105, + 106 => RE_SetU_106, + 107 => RE_Set_107, + 108 => RE_SetU_108, + 109 => RE_Set_109, + 110 => RE_SetU_110, + 111 => RE_Set_111, + 112 => RE_SetU_112, + 113 => RE_Set_113, + 114 => RE_SetU_114, + 115 => RE_Set_115, + 116 => RE_SetU_116, + 117 => RE_Set_117, + 118 => RE_SetU_118, + 119 => RE_Set_119, + 120 => RE_SetU_120, + 121 => RE_Set_121, + 122 => RE_SetU_122, + 123 => RE_Set_123, + 124 => RE_SetU_124, + 125 => RE_Set_125, + 126 => RE_SetU_126, + 127 => RE_Set_127); ----------------- -- Subprograms -- diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index e978595..14ccac9 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -28,6 +28,7 @@ with Casing; use Casing; with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; @@ -67,6 +68,7 @@ package body Exp_Prag is procedure Expand_Pragma_Abort_Defer (N : Node_Id); procedure Expand_Pragma_Check (N : Node_Id); procedure Expand_Pragma_Common_Object (N : Node_Id); + procedure Expand_Pragma_CUDA_Execute (N : Node_Id); procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); @@ -156,6 +158,9 @@ package body Exp_Prag is when Pragma_Common_Object => Expand_Pragma_Common_Object (N); + when Pragma_CUDA_Execute => + Expand_Pragma_CUDA_Execute (N); + when Pragma_Import => Expand_Pragma_Import_Or_Interface (N); @@ -614,6 +619,572 @@ package body Exp_Prag is Expression => New_Copy_Tree (Psect))))); end Expand_Pragma_Common_Object; + -------------------------------- + -- Expand_Pragma_CUDA_Execute -- + -------------------------------- + + -- Pragma CUDA_Execute is expanded in the following manner: + + -- Original Code + + -- pragma CUDA_Execute (My_Proc (X, Y), Blocks, Grids, Mem, Stream) + + -- Expanded Code + + -- declare + -- Blocks_Id : CUDA.Vector_Types.Dim3 := Blocks; + -- Grids_Id : CUDA.Vector_Types.Dim3 := Grids; + -- Mem_Id : Integer := <Mem or 0>; + -- Stream_Id : CUDA.Driver_Types.Stream_T := <Stream or null>; + -- X_Id : <Type of X> := X; + -- Y_Id : <Type of Y> := Y; + -- Arg_Id : Array (1..2) of System.Address := + -- (X'Address,_Id Y'Address);_Id + -- begin + -- CUDA.Internal.Push_Call_Configuration ( + -- Grids_Id, + -- Blocks_Id, + -- Mem_Id, + -- Stream_Id); + -- CUDA.Internal.Pop_Call_Configuration ( + -- Grids_Id'address, + -- Blocks_Id'address, + -- Mem_Id'address, + -- Stream_Id'address), + -- CUDA.Runtime_Api.Launch_Kernel ( + -- My_Proc'Address, + -- Blocks_Id, + -- Grids_Id, + -- Arg_Id'Address, + -- Mem_Id, + -- Stream_Id); + -- end; + + procedure Expand_Pragma_CUDA_Execute (N : Node_Id) is + + Loc : constant Source_Ptr := Sloc (N); + + procedure Append_Copies + (Params : List_Id; + Decls : List_Id; + Copies : Elist_Id); + -- For each parameter in list Params, create an object declaration of + -- the followinng form: + -- + -- Copy_Id : Param_Typ := Param_Val; + -- + -- Param_Typ is the type of the parameter. Param_Val is the initial + -- value of the parameter. The declarations are stored in Decls, the + -- entities of the new objects are collected in list Copies. + + function Build_Dim3_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id; + -- Build an object declaration of the form + -- + -- Decl_Id : CUDA.Internal.Dim3 := Val; + -- + -- Val depends on the nature of Init_Val, as follows: + -- + -- * If Init_Val is of type CUDA.Vector_Types.Dim3, then Val has the + -- following form: + -- + -- (Interfaces.C.Unsigned (Val.X), + -- Interfaces.C.Unsigned (Val.Y), + -- Interfaces.C.Unsigned (Val.Z)) + -- + -- * If Init_Val is a single Integer, Val has the following form: + -- + -- (Interfaces.C.Unsigned (Init_Val), + -- Interfaces.C.Unsigned (1), + -- Interfaces.C.Unsigned (1)) + -- + -- * If Init_Val is an aggregate of three values, Val has the + -- following form: + -- + -- (Interfaces.C.Unsigned (Val_1), + -- Interfaces.C.Unsigned (Val_2), + -- Interfaces.C.Unsigned (Val_3)) + + function Build_Kernel_Args_Declaration + (Kernel_Arg : Entity_Id; + Var_Ids : Elist_Id) return Node_Id; + -- Given a list of variables, return an object declaration of the + -- following form: + -- + -- Kernel_Arg : ... := (Var_1'Address, ..., Var_N'Address); + + function Build_Launch_Kernel_Call + (Proc : Entity_Id; + Grid_Dims : Entity_Id; + Block_Dims : Entity_Id; + Kernel_Arg : Entity_Id; + Memory : Entity_Id; + Stream : Entity_Id) return Node_Id; + -- Builds and returns a call to CUDA.Launch_Kernel using the given + -- arguments. Proc is the entity of the procedure passed to the + -- CUDA_Execute pragma. Grid_Dims and Block_Dims are entities of the + -- generated declarations that hold the kernel's dimensions. Args is the + -- entity of the temporary array that holds the arguments of the kernel. + -- Memory and Stream are the entities of the temporaries that hold the + -- fourth and fith arguments of CUDA_Execute or their default values. + + function Build_Shared_Memory_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id; + -- Builds a declaration the Defining_Identifier of which is Decl_Id, the + -- type of which is inferred from CUDA.Internal.Launch_Kernel and the + -- value of which is Init_Val if present or null if not. + + function Build_Simple_Declaration_With_Default + (Decl_Id : Entity_Id; + Init_Val : Entity_Id; + Typ : Entity_Id; + Default_Val : Entity_Id) return Node_Id; + -- Build a declaration the Defining_Identifier of which is Decl_Id, the + -- Object_Definition of which is Typ, the value of which is Init_Val if + -- present or Default otherwise. + + function Build_Stream_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id; + -- Build a declaration the Defining_Identifier of which is Decl_Id, the + -- type of which is Integer, the value of which is Init_Val if present + -- and 0 otherwise. + + function Etype_Or_Dim3 (N : Node_Id) return Node_Id; + -- If N is an aggregate whose type is unknown, return a new occurrence + -- of the public Dim3 type. Otherwise, return a new occurrence of N's + -- type. + + function Get_Nth_Arg_Type + (Subprogram : Entity_Id; + N : Positive) return Entity_Id; + -- Returns the type of the Nth argument of Subprogram. + + function To_Addresses (Elmts : Elist_Id) return List_Id; + -- Returns a new list containing each element of Elmts wrapped in an + -- 'address attribute reference. When passed No_Elist, returns an empty + -- list. + + ------------------- + -- Append_Copies -- + ------------------- + + procedure Append_Copies + (Params : List_Id; + Decls : List_Id; + Copies : Elist_Id) + is + Copy : Entity_Id; + Param : Node_Id; + begin + Param := First (Params); + while Present (Param) loop + Copy := Make_Temporary (Loc, 'C'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Copy, + Object_Definition => New_Occurrence_Of (Etype (Param), Loc), + Expression => New_Copy_Tree (Param))); + + Append_Elmt (Copy, Copies); + Next (Param); + end loop; + end Append_Copies; + + ---------------------------- + -- Build_Dim3_Declaration -- + ---------------------------- + + function Build_Dim3_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id + is + -- Expressions for each component of the returned Dim3 + Dim_X : Node_Id; + Dim_Y : Node_Id; + Dim_Z : Node_Id; + + -- Type of CUDA.Internal.Dim3 - inferred from + -- RE_Push_Call_Configuration to avoid needing changes in GNAT when + -- the CUDA bindings change (this happens frequently). + Internal_Dim3 : constant Entity_Id := + Get_Nth_Arg_Type (RTE (RE_Push_Call_Configuration), 1); + + -- Entities for each component of external and internal Dim3 + First_Component : Entity_Id := First_Entity (RTE (RE_Dim3)); + Second_Component : Entity_Id := Next_Entity (First_Component); + Third_Component : Entity_Id := Next_Entity (Second_Component); + begin + + -- Sem_prag.adb ensured that Init_Val is either a Dim3, an + -- aggregate of three Any_Integers or Any_Integer. + + -- If Init_Val is a Dim3, use each of its components. + + if Etype (Init_Val) = RTE (RE_Dim3) then + Dim_X := Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Entity (Init_Val), Loc), + Selector_Name => New_Occurrence_Of (First_Component, Loc)); + + Dim_Y := Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Entity (Init_Val), Loc), + Selector_Name => New_Occurrence_Of (Second_Component, Loc)); + + Dim_Z := Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Entity (Init_Val), Loc), + Selector_Name => New_Occurrence_Of (Third_Component, Loc)); + else + -- If Init_Val is an aggregate, use each of its arguments + + if Nkind (Init_Val) = N_Aggregate then + Dim_X := First (Expressions (Init_Val)); + Dim_Y := Next (Dim_X); + Dim_Z := Next (Dim_Y); + + -- Otherwise, we know it is an integer and the rest defaults to 1. + + else + Dim_X := Init_Val; + Dim_Y := Make_Integer_Literal (Loc, 1); + Dim_Z := Make_Integer_Literal (Loc, 1); + end if; + end if; + + First_Component := First_Entity (Internal_Dim3); + Second_Component := Next_Entity (First_Component); + Third_Component := Next_Entity (Second_Component); + + -- Finally return the CUDA.Internal.Dim3 declaration with an + -- aggregate initialization expression. + + return Make_Object_Declaration (Loc, + Defining_Identifier => Decl_Id, + Object_Definition => New_Occurrence_Of (Internal_Dim3, Loc), + Expression => Make_Aggregate (Loc, + Expressions => New_List ( + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (First_Component), Loc), + Expression => New_Copy_Tree (Dim_X)), + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Second_Component), Loc), + Expression => New_Copy_Tree (Dim_Y)), + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Third_Component), Loc), + Expression => New_Copy_Tree (Dim_Z))))); + end Build_Dim3_Declaration; + + ----------------------------------- + -- Build_Kernel_Args_Declaration -- + ----------------------------------- + + function Build_Kernel_Args_Declaration + (Kernel_Arg : Entity_Id; + Var_Ids : Elist_Id) return Node_Id + is + Vals : constant List_Id := To_Addresses (Var_Ids); + begin + return + Make_Object_Declaration (Loc, + Defining_Identifier => Kernel_Arg, + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Integer_Literal (Loc, List_Length (Vals)))), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Etype (RTE (RE_Address)), Loc))), + Expression => Make_Aggregate (Loc, Vals)); + end Build_Kernel_Args_Declaration; + + ------------------------------- + -- Build_Launch_Kernel_Call -- + ------------------------------- + + function Build_Launch_Kernel_Call + (Proc : Entity_Id; + Grid_Dims : Entity_Id; + Block_Dims : Entity_Id; + Kernel_Arg : Entity_Id; + Memory : Entity_Id; + Stream : Entity_Id) return Node_Id is + begin + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Launch_Kernel), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Proc, Loc), + Attribute_Name => Name_Address), + New_Occurrence_Of (Grid_Dims, Loc), + New_Occurrence_Of (Block_Dims, Loc), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Kernel_Arg, Loc), + Attribute_Name => Name_Address), + New_Occurrence_Of (Memory, Loc), + New_Occurrence_Of (Stream, Loc))); + end Build_Launch_Kernel_Call; + + ------------------------------------- + -- Build_Shared_Memory_Declaration -- + ------------------------------------- + + function Build_Shared_Memory_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id + is + begin + return Build_Simple_Declaration_With_Default + (Decl_Id => Decl_Id, + Init_Val => Init_Val, + Typ => + New_Occurrence_Of + (Get_Nth_Arg_Type (RTE (RE_Launch_Kernel), 5), Loc), + Default_Val => Make_Integer_Literal (Loc, 0)); + end Build_Shared_Memory_Declaration; + + ------------------------------------------- + -- Build_Simple_Declaration_With_Default -- + ------------------------------------------- + + function Build_Simple_Declaration_With_Default + (Decl_Id : Entity_Id; + Init_Val : Node_Id; + Typ : Entity_Id; + Default_Val : Node_Id) return Node_Id + is + Value : Node_Id := Init_Val; + begin + if No (Value) then + Value := Default_Val; + end if; + + return Make_Object_Declaration (Loc, + Defining_Identifier => Decl_Id, + Object_Definition => Typ, + Expression => Value); + end Build_Simple_Declaration_With_Default; + + ------------------------------ + -- Build_Stream_Declaration -- + ------------------------------ + + function Build_Stream_Declaration + (Decl_Id : Entity_Id; + Init_Val : Node_Id) return Node_Id + is + begin + return Build_Simple_Declaration_With_Default + (Decl_Id => Decl_Id, + Init_Val => Init_Val, + Typ => + New_Occurrence_Of + (Get_Nth_Arg_Type (RTE (RE_Launch_Kernel), 6), Loc), + Default_Val => Make_Null (Loc)); + end Build_Stream_Declaration; + + ------------------------ + -- Etype_Or_Dim3 -- + ------------------------ + + function Etype_Or_Dim3 (N : Node_Id) return Node_Id is + begin + if Nkind (N) = N_Aggregate and then Is_Composite_Type (Etype (N)) + then + return New_Occurrence_Of (RTE (RE_Dim3), Sloc (N)); + end if; + + return New_Occurrence_Of (Etype (N), Loc); + end Etype_Or_Dim3; + + ---------------------- + -- Get_Nth_Arg_Type -- + ---------------------- + + function Get_Nth_Arg_Type + (Subprogram : Entity_Id; + N : Positive) return Entity_Id + is + Argument : Entity_Id := First_Entity (Subprogram); + begin + for J in 2 .. N loop + Argument := Next_Entity (Argument); + end loop; + + return Etype (Argument); + end Get_Nth_Arg_Type; + + ------------------ + -- To_Addresses -- + ------------------ + + function To_Addresses (Elmts : Elist_Id) return List_Id is + Result : constant List_Id := New_List; + Elmt : Elmt_Id; + begin + if Elmts = No_Elist then + return Result; + end if; + + Elmt := First_Elmt (Elmts); + while Present (Elmt) loop + Append_To (Result, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Node (Elmt), Loc), + Attribute_Name => Name_Address)); + Next_Elmt (Elmt); + end loop; + + return Result; + end To_Addresses; + + -- Local variables + + -- Pragma arguments + + Procedure_Call : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 1)); + Grid_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 2)); + Block_Dimensions : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 3)); + Shared_Memory : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 4)); + CUDA_Stream : constant Node_Id := Get_Pragma_Arg (Arg_N (N, 5)); + + -- Entities of objects that will be overwritten by calls to cuda runtime + Grids_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); + Blocks_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); + Memory_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); + Stream_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); + + -- Entities of objects that capture the value of pragma arguments + Temp_Grid : constant Entity_Id := Make_Temporary (Loc, 'C'); + Temp_Block : constant Entity_Id := Make_Temporary (Loc, 'C'); + + -- Declarations for temporary block and grids. These needs to be stored + -- in temporary declarations as the expressions will need to be + -- referenced multiple times but could have side effects. + Temp_Grid_Decl : constant Node_Id := Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Grid, + Object_Definition => Etype_Or_Dim3 (Grid_Dimensions), + Expression => Grid_Dimensions); + Temp_Block_Decl : constant Node_Id := Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Block, + Object_Definition => Etype_Or_Dim3 (Block_Dimensions), + Expression => Block_Dimensions); + + -- List holding the entities of the copies of Procedure_Call's + -- arguments. + + Kernel_Arg_Copies : constant Elist_Id := New_Elmt_List; + + -- Entity of the array that contains the address of each of the kernel's + -- arguments. + + Kernel_Args_Id : constant Entity_Id := Make_Temporary (Loc, 'C'); + + -- Calls to the CUDA runtime API. + + Launch_Kernel_Call : Node_Id; + Pop_Call : Node_Id; + Push_Call : Node_Id; + + -- Declaration of all temporaries required for CUDA API Calls. + + Blk_Decls : constant List_Id := New_List; + + -- Start of processing for CUDA_Execute + + begin + -- Append temporary declarations + + Append_To (Blk_Decls, Temp_Grid_Decl); + Analyze (Temp_Grid_Decl); + + Append_To (Blk_Decls, Temp_Block_Decl); + Analyze (Temp_Block_Decl); + + -- Build parameter declarations for CUDA API calls + + Append_To + (Blk_Decls, + Build_Dim3_Declaration + (Grids_Id, New_Occurrence_Of (Temp_Grid, Loc))); + + Append_To + (Blk_Decls, + Build_Dim3_Declaration + (Blocks_Id, New_Occurrence_Of (Temp_Block, Loc))); + + Append_To + (Blk_Decls, + Build_Shared_Memory_Declaration (Memory_Id, Shared_Memory)); + + Append_To + (Blk_Decls, Build_Stream_Declaration (Stream_Id, CUDA_Stream)); + + Append_Copies + (Parameter_Associations (Procedure_Call), + Blk_Decls, + Kernel_Arg_Copies); + + Append_To + (Blk_Decls, + Build_Kernel_Args_Declaration + (Kernel_Args_Id, Kernel_Arg_Copies)); + + -- Build calls to the CUDA API + + Push_Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Push_Call_Configuration), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Grids_Id, Loc), + New_Occurrence_Of (Blocks_Id, Loc), + New_Occurrence_Of (Memory_Id, Loc), + New_Occurrence_Of (Stream_Id, Loc))); + + Pop_Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Pop_Call_Configuration), Loc), + Parameter_Associations => To_Addresses + (New_Elmt_List + (Grids_Id, + Blocks_Id, + Memory_Id, + Stream_Id))); + + Launch_Kernel_Call := Build_Launch_Kernel_Call + (Proc => Entity (Name (Procedure_Call)), + Grid_Dims => Grids_Id, + Block_Dims => Blocks_Id, + Kernel_Arg => Kernel_Args_Id, + Memory => Memory_Id, + Stream => Stream_Id); + + -- Finally make the block that holds declarations and calls + + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => Blk_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Push_Call, + Pop_Call, + Launch_Kernel_Call)))); + Analyze (N); + end Expand_Pragma_CUDA_Execute; + ---------------------------------- -- Expand_Pragma_Contract_Cases -- ---------------------------------- @@ -892,9 +1463,43 @@ package body Exp_Prag is ----------------------- function Expand_Attributes (N : Node_Id) return Traverse_Result is - Decl : Node_Id; - Pref : Node_Id; - Temp : Entity_Id; + Decl : Node_Id; + Pref : Node_Id; + Temp : Entity_Id; + Indirect : Boolean := False; + + use Sem_Util.Old_Attr_Util.Indirect_Temps; + + procedure Append_For_Indirect_Temp + (N : Node_Id; Is_Eval_Stmt : Boolean); + + -- Append either a declaration (which is to be elaborated + -- unconditionally) or an evaluation statement (which is + -- to be executed conditionally). + + ------------------------------- + -- Append_For_Indirect_Temp -- + ------------------------------- + + procedure Append_For_Indirect_Temp + (N : Node_Id; Is_Eval_Stmt : Boolean) + is + begin + if Is_Eval_Stmt then + Append_To (Eval_Stmts, N); + else + Prepend_To (Decls, N); + -- This use of Prepend (as opposed to Append) is why + -- we have the Append_Decls_In_Reverse_Order parameter. + end if; + end Append_For_Indirect_Temp; + + procedure Declare_Indirect_Temporary is new + Declare_Indirect_Temp ( + Append_Item => Append_For_Indirect_Temp, + Append_Decls_In_Reverse_Order => True); + + -- Start of processing for Expand_Attributes begin -- Attribute 'Old @@ -903,37 +1508,49 @@ package body Exp_Prag is and then Attribute_Name (N) = Name_Old then Pref := Prefix (N); - Temp := Make_Temporary (Loc, 'T', Pref); - Set_Etype (Temp, Etype (Pref)); - -- Generate a temporary to capture the value of the prefix: - -- Temp : <Pref type>; + Indirect := Indirect_Temp_Needed (Etype (Pref)); + + if Indirect then + if No (Eval_Stmts) then + Eval_Stmts := New_List; + end if; + + Declare_Indirect_Temporary + (Attr_Prefix => Pref, + Indirect_Temp => Temp); - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Etype (Pref), Loc)); + -- Declare a temporary of the prefix type with no explicit + -- initial value. If the appropriate contract case is selected + -- at run time, then the temporary will be initialized via an + -- assignment statement. - -- Place that temporary at the beginning of declarations, to - -- prevent anomalies in the GNATprove flow-analysis pass in - -- the precondition procedure that follows. + else + Temp := Make_Temporary (Loc, 'T', Pref); + Set_Etype (Temp, Etype (Pref)); - Prepend_To (Decls, Decl); + -- Generate a temporary to capture the value of the prefix: + -- Temp : <Pref type>; - -- If the type is unconstrained, the prefix provides its - -- value and constraint, so add it to declaration. + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (Etype (Pref), Loc)); - if not Is_Constrained (Etype (Pref)) - and then Is_Entity_Name (Pref) - then - Set_Expression (Decl, Pref); - Analyze (Decl); + -- Place that temporary at the beginning of declarations, to + -- prevent anomalies in the GNATprove flow-analysis pass in + -- the precondition procedure that follows. - -- Otherwise add an assignment statement to temporary using - -- prefix as RHS. + Prepend_To (Decls, Decl); - else + -- Initially Temp is uninitialized (which is required for + -- correctness if default initialization might have side + -- effects). Assign prefix value to temp on Eval_Statement + -- list, so assignment will be executed conditionally. + + Set_Ekind (Temp, E_Variable); + Set_Suppress_Initialization (Temp); Analyze (Decl); if No (Eval_Stmts) then @@ -944,7 +1561,6 @@ package body Exp_Prag is Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Temp, Loc), Expression => Pref)); - end if; -- Ensure that the prefix is valid @@ -956,7 +1572,13 @@ package body Exp_Prag is -- Replace the original attribute 'Old by a reference to the -- generated temporary. - Rewrite (N, New_Occurrence_Of (Temp, Loc)); + if Indirect then + Rewrite (N, + Indirect_Temp_Value + (Temp => Temp, Typ => Etype (Pref), Loc => Loc)); + else + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + end if; -- Attribute 'Result @@ -1307,11 +1929,7 @@ package body Exp_Prag is -- Raise Assertion_Error when the corresponding consequence of a case -- guard that evaluated to True fails. - if No (Stmts) then - Stmts := New_List; - end if; - - Append_To (Stmts, Conseq_Checks); + Append_New_To (Stmts, Conseq_Checks); In_Assertion_Expr := In_Assertion_Expr - 1; end Expand_Pragma_Contract_Cases; @@ -1848,32 +2466,6 @@ package body Exp_Prag is --------------------- procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean) is - function Make_Op - (Loc : Source_Ptr; - Curr_Val : Node_Id; - Old_Val : Node_Id) return Node_Id; - -- Generate a comparison between Curr_Val and Old_Val depending on - -- the change mode (Increases / Decreases) of the variant. - - ------------- - -- Make_Op -- - ------------- - - function Make_Op - (Loc : Source_Ptr; - Curr_Val : Node_Id; - Old_Val : Node_Id) return Node_Id - is - begin - if Chars (Variant) = Name_Increases then - return Make_Op_Gt (Loc, Curr_Val, Old_Val); - else pragma Assert (Chars (Variant) = Name_Decreases); - return Make_Op_Lt (Loc, Curr_Val, Old_Val); - end if; - end Make_Op; - - -- Local variables - Expr : constant Node_Id := Expression (Variant); Expr_Typ : constant Entity_Id := Etype (Expr); Loc : constant Source_Ptr := Sloc (Expr); @@ -1882,8 +2474,6 @@ package body Exp_Prag is Old_Id : Entity_Id; Prag : Node_Id; - -- Start of processing for Process_Variant - begin -- All temporaries generated in this routine must be inserted before -- the related loop statement. Ensure that the proper scope is on the @@ -1955,28 +2545,20 @@ package body Exp_Prag is -- Step 3: Store value of the expression from the previous iteration - if No (Old_Assign) then - Old_Assign := New_List; - end if; - -- Generate: -- Old := Curr; - Append_To (Old_Assign, + Append_New_To (Old_Assign, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Old_Id, Loc), Expression => New_Occurrence_Of (Curr_Id, Loc))); -- Step 4: Store the current value of the expression - if No (Curr_Assign) then - Curr_Assign := New_List; - end if; - -- Generate: -- Curr := <Expr>; - Append_To (Curr_Assign, + Append_New_To (Curr_Assign, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Curr_Id, Loc), Expression => Relocate_Node (Expr))); @@ -1994,7 +2576,8 @@ package body Exp_Prag is Expression => Make_Identifier (Loc, Name_Loop_Variant)), Make_Pragma_Argument_Association (Loc, Expression => - Make_Op (Loc, + Make_Variant_Comparison (Loc, + Mode => Chars (Variant), Curr_Val => New_Occurrence_Of (Curr_Id, Loc), Old_Val => New_Occurrence_Of (Old_Id, Loc))))); @@ -2177,6 +2760,338 @@ package body Exp_Prag is end if; end Expand_Pragma_Relative_Deadline; + -------------------------------------- + -- Expand_Pragma_Subprogram_Variant -- + -------------------------------------- + + -- Aspect Subprogram_Variant is expanded in the following manner: + + -- Original code + + -- procedure Proc (Param : T) with + -- with Variant (Increases => Incr_Expr, + -- Decreases => Decr_Expr) + -- <declarations> + -- is + -- <source statements> + -- Proc (New_Param_Value); + -- end Proc; + + -- Expanded code + + -- procedure Proc (Param : T) is + -- Old_Incr : constant <type of Incr_Expr> := <Incr_Expr>; + -- Old_Decr : constant <type of Decr_Expr> := <Decr_Expr> ; + -- + -- procedure Variants (Param : T); + -- + -- procedure Variants (Param : T) is + -- Curr_Incr : constant <type of Incr_Expr> := <Incr_Expr>; + -- Curr_Decr : constant <type of Decr_Expr> := <Decr_Expr>; + -- begin + -- if Curr_Incr /= Old_Incr then + -- pragma Check (Variant, Curr_Incr > Old_Incr); + -- else + -- pragma Check (Variant, Curr_Decr < Old_Decr); + -- end if; + -- end Variants; + -- + -- <declarations> + -- begin + -- <source statements> + -- Variants (New_Param_Value); + -- Proc (New_Param_Value); + -- end Proc; + + procedure Expand_Pragma_Subprogram_Variant + (Prag : Node_Id; + Subp_Id : Node_Id; + Body_Decls : List_Id) + is + Curr_Decls : List_Id; + If_Stmt : Node_Id := Empty; + + function Formal_Param_Map + (Old_Subp : Entity_Id; + New_Subp : Entity_Id) return Elist_Id; + -- Given two subprogram entities Old_Subp and New_Subp with the same + -- number of formal parameters return a list of the form: + -- + -- old formal 1 + -- new formal 1 + -- old formal 2 + -- new formal 2 + -- ... + -- + -- as required by New_Copy_Tree to replace references to formal + -- parameters of Old_Subp with references to formal parameters of + -- New_Subp. + + procedure Process_Variant + (Variant : Node_Id; + Formal_Map : Elist_Id; + Prev_Decl : in out Node_Id; + Is_Last : Boolean); + -- Process a single increasing / decreasing termination variant given by + -- a component association Variant. Formal_Map is a list of formal + -- parameters of the annotated subprogram and of the internal procedure + -- that verifies the variant in the format required by New_Copy_Tree. + -- The Old_... object created by this routine will be appended after + -- Prev_Decl and is stored in this parameter for a next call to this + -- routine. Is_Last is True when there are no more variants to process. + + ---------------------- + -- Formal_Param_Map -- + ---------------------- + + function Formal_Param_Map + (Old_Subp : Entity_Id; + New_Subp : Entity_Id) return Elist_Id + is + Old_Formal : Entity_Id := First_Formal (Old_Subp); + New_Formal : Entity_Id := First_Formal (New_Subp); + + Param_Map : Elist_Id; + begin + if Present (Old_Formal) then + Param_Map := New_Elmt_List; + while Present (Old_Formal) and then Present (New_Formal) loop + Append_Elmt (Old_Formal, Param_Map); + Append_Elmt (New_Formal, Param_Map); + + Next_Formal (Old_Formal); + Next_Formal (New_Formal); + end loop; + + return Param_Map; + else + return No_Elist; + end if; + end Formal_Param_Map; + + --------------------- + -- Process_Variant -- + --------------------- + + procedure Process_Variant + (Variant : Node_Id; + Formal_Map : Elist_Id; + Prev_Decl : in out Node_Id; + Is_Last : Boolean) + is + Expr : constant Node_Id := Expression (Variant); + Expr_Typ : constant Entity_Id := Etype (Expr); + Loc : constant Source_Ptr := Sloc (Expr); + + Old_Id : Entity_Id; + Old_Decl : Node_Id; + Curr_Id : Entity_Id; + Curr_Decl : Node_Id; + Prag : Node_Id; + + begin + -- Create temporaries that store the old values of the associated + -- expression. + + -- Generate: + -- Old : constant <type of Expr> := <Expr>; + + Old_Id := Make_Temporary (Loc, 'P'); + + Old_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Old_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Expr_Typ, Loc), + Expression => New_Copy_Tree (Expr)); + + Insert_After_And_Analyze (Prev_Decl, Old_Decl); + + Prev_Decl := Old_Decl; + + -- Generate: + -- Curr : constant <type of Expr> := <Expr>; + + Curr_Id := Make_Temporary (Loc, 'C'); + + Curr_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Curr_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Expr_Typ, Loc), + Expression => + New_Copy_Tree (Expr, Map => Formal_Map)); + + Append (Curr_Decl, Curr_Decls); + + -- Generate: + -- pragma Check (Variant, Curr <|> Old); + + Prag := + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, + Name_Subprogram_Variant)), + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Variant_Comparison (Loc, + Mode => Chars (First (Choices (Variant))), + Curr_Val => New_Occurrence_Of (Curr_Id, Loc), + Old_Val => New_Occurrence_Of (Old_Id, Loc))))); + + -- Generate: + -- if Curr /= Old then + -- <Prag>; + + if No (If_Stmt) then + + -- When there is just one termination variant, do not compare + -- the old and current value for equality, just check the + -- pragma. + + if Is_Last then + If_Stmt := Prag; + else + If_Stmt := + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Curr_Id, Loc), + Right_Opnd => New_Occurrence_Of (Old_Id, Loc)), + Then_Statements => New_List (Prag)); + end if; + + -- Generate: + -- else + -- <Prag>; + -- end if; + + elsif Is_Last then + Set_Else_Statements (If_Stmt, New_List (Prag)); + + -- Generate: + -- elsif Curr /= Old then + -- <Prag>; + + else + if Elsif_Parts (If_Stmt) = No_List then + Set_Elsif_Parts (If_Stmt, New_List); + end if; + + Append_To (Elsif_Parts (If_Stmt), + Make_Elsif_Part (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Curr_Id, Loc), + Right_Opnd => New_Occurrence_Of (Old_Id, Loc)), + Then_Statements => New_List (Prag))); + end if; + end Process_Variant; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (Prag); + + Aggr : Node_Id; + Formal_Map : Elist_Id; + Last : Node_Id; + Last_Variant : Node_Id; + Proc_Bod : Node_Id; + Proc_Decl : Node_Id; + Proc_Id : Entity_Id; + Proc_Spec : Node_Id; + Variant : Node_Id; + + begin + -- Do nothing if pragma is not present or is disabled + + if Is_Ignored (Prag) then + return; + end if; + + Aggr := Expression (First (Pragma_Argument_Associations (Prag))); + + -- The expansion of Subprogram Variant is quite distributed as it + -- produces various statements to capture and compare the arguments. + -- To preserve the original context, set the Is_Assertion_Expr flag. + -- This aids the Ghost legality checks when verifying the placement + -- of a reference to a Ghost entity. + + In_Assertion_Expr := In_Assertion_Expr + 1; + + -- Create declaration of the procedure that compares values of the + -- variant expressions captured at the start of subprogram with their + -- values at the recursive call of the subprogram. + + Proc_Id := Make_Defining_Identifier (Loc, Name_uVariants); + + Proc_Spec := + Make_Procedure_Specification + (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => Copy_Parameter_List (Subp_Id)); + + Proc_Decl := + Make_Subprogram_Declaration (Loc, Proc_Spec); + + Insert_Before_First_Source_Declaration (Proc_Decl, Body_Decls); + Analyze (Proc_Decl); + + -- Create a mapping between formals of the annotated subprogram (which + -- are used to compute values of the variant expression at the start of + -- subprogram) and formals of the internal procedure (which are used to + -- compute values of of the variant expression at the recursive call). + + Formal_Map := + Formal_Param_Map (Old_Subp => Subp_Id, New_Subp => Proc_Id); + + -- Process invidual increasing / decreasing variants + + Last := Proc_Decl; + Curr_Decls := New_List; + Last_Variant := Nlists.Last (Component_Associations (Aggr)); + + Variant := First (Component_Associations (Aggr)); + while Present (Variant) loop + Process_Variant + (Variant => Variant, + Formal_Map => Formal_Map, + Prev_Decl => Last, + Is_Last => Variant = Last_Variant); + Next (Variant); + end loop; + + -- Create a subprogram body with declarations of objects that capture + -- the current values of variant expressions at a recursive call and an + -- if-then-else statement that compares current with old values. + + Proc_Bod := + Make_Subprogram_Body (Loc, + Specification => + Copy_Subprogram_Spec (Proc_Spec), + Declarations => Curr_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (If_Stmt), + End_Label => Make_Identifier (Loc, Chars (Proc_Id)))); + + Insert_After_And_Analyze (Last, Proc_Bod); + + -- Restore assertion context + + In_Assertion_Expr := In_Assertion_Expr - 1; + + -- Rewrite the aspect expression, which is no longer needed, with + -- a reference to the procedure that has just been created. We will + -- generate a call to this procedure at each recursive call of the + -- subprogram that has been annotated with Subprogram_Variant. + + Rewrite (Aggr, New_Occurrence_Of (Proc_Id, Loc)); + end Expand_Pragma_Subprogram_Variant; + ------------------------------------------- -- Expand_Pragma_Suppress_Initialization -- ------------------------------------------- diff --git a/gcc/ada/exp_prag.ads b/gcc/ada/exp_prag.ads index 9957b21..59f0d6a 100644 --- a/gcc/ada/exp_prag.ads +++ b/gcc/ada/exp_prag.ads @@ -49,4 +49,15 @@ package Exp_Prag is -- applies to package Pack_Id. N denotes the related package spec or -- body. + procedure Expand_Pragma_Subprogram_Variant + (Prag : Node_Id; + Subp_Id : Entity_Id; + Body_Decls : List_Id); + -- Given pragma Subprogram_Variant Prag, create the circuitry needed + -- to evaluate variant expressions at the subprogram entry and at the + -- recursive call. Subp_Id is the related subprogram for which the pragma + -- applies and Body_Decls are its body declarations. On exit, the argument + -- of Prag is replaced with a reference to procedure with checks for the + -- variant expressions. + end Exp_Prag; diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index 80b49a7..3fae317 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -300,23 +300,27 @@ package body Exp_Put_Image is if Is_Signed_Integer_Type (U_Type) then if P_Size <= Standard_Integer_Size then Lib_RE := RE_Put_Image_Integer; - else - pragma Assert (P_Size <= Standard_Long_Long_Integer_Size); + elsif P_Size <= Standard_Long_Long_Integer_Size then Lib_RE := RE_Put_Image_Long_Long_Integer; + else + pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size); + Lib_RE := RE_Put_Image_Long_Long_Long_Integer; end if; elsif Is_Modular_Integer_Type (U_Type) then if P_Size <= Standard_Integer_Size then -- Yes, Integer Lib_RE := RE_Put_Image_Unsigned; - else - pragma Assert (P_Size <= Standard_Long_Long_Integer_Size); + elsif P_Size <= Standard_Long_Long_Integer_Size then Lib_RE := RE_Put_Image_Long_Long_Unsigned; + else + pragma Assert (P_Size <= Standard_Long_Long_Long_Integer_Size); + Lib_RE := RE_Put_Image_Long_Long_Long_Unsigned; end if; elsif Is_Access_Type (U_Type) then - if Is_Access_Protected_Subprogram_Type (U_Type) then + if Is_Access_Protected_Subprogram_Type (Base_Type (U_Type)) then Lib_RE := RE_Put_Image_Access_Prot_Subp; - elsif Is_Access_Subprogram_Type (U_Type) then + elsif Is_Access_Subprogram_Type (Base_Type (U_Type)) then Lib_RE := RE_Put_Image_Access_Subp; elsif P_Size = System_Address_Size then Lib_RE := RE_Put_Image_Thin_Pointer; diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index b400268..f6ef865 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -36,6 +36,7 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Ch8; use Sem_Ch8; with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -51,6 +52,9 @@ package body Exp_SPARK is -- Local Subprograms -- ----------------------- + procedure Expand_SPARK_N_Aggregate (N : Node_Id); + -- Perform aggregate-specific expansion + procedure Expand_SPARK_N_Attribute_Reference (N : Node_Id); -- Perform attribute-reference-specific expansion @@ -101,6 +105,9 @@ package body Exp_SPARK is => Qualify_Entity_Names (N); + when N_Aggregate => + Expand_SPARK_N_Aggregate (N); + -- Replace occurrences of System'To_Address by calls to -- System.Storage_Elements.To_Address. @@ -215,25 +222,48 @@ package body Exp_SPARK is Expr := Expression (Assoc); Comp_Type := Component_Type (Typ); + -- Analyze expression of the iterated_component_association + -- with its index parameter in scope. + + if Nkind (Assoc) = N_Iterated_Component_Association then + Push_Scope (Scope (Defining_Identifier (Assoc))); + Analyze_And_Resolve (Expression (Assoc), Comp_Type); + end if; + if Is_Scalar_Type (Comp_Type) then Apply_Scalar_Range_Check (Expr, Comp_Type); end if; - Index := First (Choices (Assoc)); - Index_Typ := First_Index (Typ); - - while Present (Index) loop - -- The index denotes a range of elements + -- Restore scope of the iterated_component_association - if Nkind (Index) = N_Range then - Apply_Scalar_Range_Check - (Low_Bound (Index), Base_Type (Etype (Index_Typ))); - Apply_Scalar_Range_Check - (High_Bound (Index), Base_Type (Etype (Index_Typ))); + if Nkind (Assoc) = N_Iterated_Component_Association then + End_Scope; + end if; - -- Otherwise the index denotes a single element + Index := + First + (if Nkind (Assoc) = N_Iterated_Component_Association + then Discrete_Choices (Assoc) + else Choices (Assoc)); + Index_Typ := First_Index (Typ); - else + while Present (Index) loop + -- If the index denotes a range of elements or a constrained + -- subtype indication, then their low and high bounds + -- already have range checks applied. + + if Nkind (Index) in N_Range | N_Subtype_Indication then + null; + + -- Otherwise the index denotes a single expression where + -- range checks need to be applied or a subtype name + -- (without range constraints) where applying checks is + -- harmless. + -- + -- In delta_aggregate and Update attribute on array the + -- others_choice is not allowed. + + else pragma Assert (Nkind (Index) in N_Subexpr); Apply_Scalar_Range_Check (Index, Etype (Index_Typ)); end if; @@ -340,6 +370,74 @@ package body Exp_SPARK is end if; end Expand_SPARK_N_Freeze_Type; + ------------------------------ + -- Expand_SPARK_N_Aggregate -- + ------------------------------ + + procedure Expand_SPARK_N_Aggregate (N : Node_Id) is + Assoc : Node_Id := First (Component_Associations (N)); + begin + -- For compilation, frontend analyses a copy of the + -- iterated_component_association's expression for legality checking; + -- (then the expression is copied again when expanding association into + -- assignments for the individual choices). For SPARK we analyze the + -- original expression and apply range checks, if required. + + while Present (Assoc) loop + if Nkind (Assoc) = N_Iterated_Component_Association then + declare + Typ : constant Entity_Id := Etype (N); + + Comp_Type : constant Entity_Id := Component_Type (Typ); + Expr : constant Node_Id := Expression (Assoc); + Index_Typ : constant Entity_Id := First_Index (Typ); + + Index : Node_Id; + + begin + -- Analyze expression with index parameter in scope + + Push_Scope (Scope (Defining_Identifier (Assoc))); + Enter_Name (Defining_Identifier (Assoc)); + Analyze_And_Resolve (Expression (Assoc), Comp_Type); + + if Is_Scalar_Type (Comp_Type) then + Apply_Scalar_Range_Check (Expr, Comp_Type); + end if; + + End_Scope; + + -- Analyze discrete choices + + Index := First (Discrete_Choices (Assoc)); + + while Present (Index) loop + + -- The index denotes a range of elements where range checks + -- have been already applied. + + if Nkind (Index) in N_Others_Choice + | N_Range + | N_Subtype_Indication + then + null; + + -- Otherwise the index denotes a single element (or a + -- subtype name which doesn't require range checks). + + else pragma Assert (Nkind (Index) in N_Subexpr); + Apply_Scalar_Range_Check (Index, Etype (Index_Typ)); + end if; + + Next (Index); + end loop; + end; + end if; + + Next (Assoc); + end loop; + end Expand_SPARK_N_Aggregate; + ---------------------------------------- -- Expand_SPARK_N_Attribute_Reference -- ---------------------------------------- diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index b640843..40943fb 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -164,7 +164,13 @@ package body Exp_Tss is -- If Typ is a derived type, it may inherit attributes from an ancestor if No (Proc) and then Is_Derived_Type (Btyp) then - Proc := Find_Inherited_TSS (Etype (Btyp), Nam); + if not Derivation_Too_Early_To_Inherit (Btyp, Nam) then + Proc := Find_Inherited_TSS (Etype (Btyp), Nam); + elsif Is_Derived_Type (Etype (Btyp)) then + -- Skip one link in the derivation chain + Proc := Find_Inherited_TSS + (Etype (Base_Type (Etype (Btyp))), Nam); + end if; end if; -- If nothing else, use the TSS of the root type diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 0f8505f..6b474d8 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -32,7 +32,6 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; -with Exp_Ch2; use Exp_Ch2; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; @@ -325,7 +324,6 @@ package body Exp_Util is declare Loc : constant Source_Ptr := Sloc (N); T : constant Entity_Id := Etype (N); - Ti : Entity_Id; begin -- Defend against a call where the argument has no type, or has a @@ -357,15 +355,11 @@ package body Exp_Util is -- value of type T. if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then - if Esize (T) <= Esize (Standard_Integer) then - Ti := Standard_Integer; - else - Ti := Standard_Long_Long_Integer; - end if; - Rewrite (N, Make_Op_Ne (Loc, - Left_Opnd => Unchecked_Convert_To (Ti, N), + Left_Opnd => + Unchecked_Convert_To + (Integer_Type_For (Esize (T), Uns => False), N), Right_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Enum_Rep, @@ -739,12 +733,13 @@ package body Exp_Util is -- Local variables - Desig_Typ : Entity_Id; - Expr : Node_Id; - Needs_Fin : Boolean; - Pool_Id : Entity_Id; - Proc_To_Call : Node_Id := Empty; - Ptr_Typ : Entity_Id; + Desig_Typ : Entity_Id; + Expr : Node_Id; + Needs_Fin : Boolean; + Pool_Id : Entity_Id; + Proc_To_Call : Node_Id := Empty; + Ptr_Typ : Entity_Id; + Use_Secondary_Stack_Pool : Boolean; -- Start of processing for Build_Allocate_Deallocate_Proc @@ -809,17 +804,22 @@ package body Exp_Util is Desig_Typ := Corresponding_Record_Type (Desig_Typ); end if; + Use_Secondary_Stack_Pool := + Is_RTE (Pool_Id, RE_SS_Pool) + or else (Nkind (Expr) = N_Allocator + and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool)); + -- Do not process allocations / deallocations without a pool if No (Pool_Id) then return; -- Do not process allocations on / deallocations from the secondary - -- stack. + -- stack, except for access types used to implement indirect temps. - elsif Is_RTE (Pool_Id, RE_SS_Pool) - or else (Nkind (Expr) = N_Allocator - and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool)) + elsif Use_Secondary_Stack_Pool + and then not Old_Attr_Util.Indirect_Temps + .Is_Access_Type_For_Indirect_Temp (Ptr_Typ) then return; @@ -956,7 +956,9 @@ package body Exp_Util is Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc)); Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc)); - if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then + if (Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ)) + and then not Use_Secondary_Stack_Pool + then Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc)); -- For deallocation of class-wide types we obtain the value of @@ -972,6 +974,9 @@ package body Exp_Util is -- into the code that reads the value of alignment from the TSD -- (see Expand_N_Attribute_Reference) + -- In the Use_Secondary_Stack_Pool case, Alig_Id is not + -- passed in and therefore must not be referenced. + Append_To (Actuals, Unchecked_Convert_To (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, @@ -1121,55 +1126,67 @@ package body Exp_Util is -- Create a custom Allocate / Deallocate routine which has identical -- profile to that of System.Storage_Pools. - Insert_Action (N, - Make_Subprogram_Body (Loc, - Specification => - - -- procedure Pnn - - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Proc_Id, - Parameter_Specifications => New_List ( - - -- P : Root_Storage_Pool - - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Temporary (Loc, 'P'), - Parameter_Type => - New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)), - - -- A : [out] Address - - Make_Parameter_Specification (Loc, - Defining_Identifier => Addr_Id, - Out_Present => Is_Allocate, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Address), Loc)), - - -- S : Storage_Count - - Make_Parameter_Specification (Loc, - Defining_Identifier => Size_Id, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Storage_Count), Loc)), - - -- L : Storage_Count - - Make_Parameter_Specification (Loc, - Defining_Identifier => Alig_Id, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))), - - Declarations => No_List, + declare + -- P : Root_Storage_Pool + function Pool_Param return Node_Id is ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Temporary (Loc, 'P'), + Parameter_Type => + New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc))); + + -- A : [out] Address + function Address_Param return Node_Id is ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Addr_Id, + Out_Present => Is_Allocate, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Address), Loc))); + + -- S : Storage_Count + function Size_Param return Node_Id is ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Size_Id, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Storage_Count), Loc))); + + -- L : Storage_Count + function Alignment_Param return Node_Id is ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Alig_Id, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Storage_Count), Loc))); + + Formal_Params : List_Id; + begin + if Use_Secondary_Stack_Pool then + -- Gigi expects a different profile in the Secondary_Stack_Pool + -- case. There must be no uses of the two missing formals + -- (i.e., Pool_Param and Alignment_Param) in this case. + Formal_Params := New_List (Address_Param, Size_Param); + else + Formal_Params := New_List ( + Pool_Param, Address_Param, Size_Param, Alignment_Param); + end if; - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Proc_To_Call, Loc), - Parameter_Associations => Actuals)))), - Suppress => All_Checks); + Insert_Action (N, + Make_Subprogram_Body (Loc, + Specification => + -- procedure Pnn + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => Formal_Params), + + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Proc_To_Call, Loc), + Parameter_Associations => Actuals)))), + Suppress => All_Checks); + end; -- The newly generated Allocate / Deallocate becomes the default -- procedure to call when the back end processes the allocation / @@ -4574,11 +4591,11 @@ package body Exp_Util is if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then return False; - -- If we know that we have a small (64 bits or less) record or small - -- bit-packed array, then everything is fine, since the back end can - -- handle these cases correctly. + -- If we know that we have a small (at most the maximum integer size) + -- record or bit-packed array, then everything is fine, since the back + -- end can handle these cases correctly. - elsif Esize (Comp) <= 64 + elsif Esize (Comp) <= System_Max_Integer_Size and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT)) then return False; @@ -4598,60 +4615,6 @@ package body Exp_Util is end if; end Component_May_Be_Bit_Aligned; - ---------------------------------------- - -- Containing_Package_With_Ext_Axioms -- - ---------------------------------------- - - function Containing_Package_With_Ext_Axioms - (E : Entity_Id) return Entity_Id - is - begin - -- E is the package or generic package which is externally axiomatized - - if Is_Package_Or_Generic_Package (E) - and then Has_Annotate_Pragma_For_External_Axiomatization (E) - then - return E; - end if; - - -- If E's scope is axiomatized, E is axiomatized - - if Present (Scope (E)) then - declare - First_Ax_Parent_Scope : constant Entity_Id := - Containing_Package_With_Ext_Axioms (Scope (E)); - begin - if Present (First_Ax_Parent_Scope) then - return First_Ax_Parent_Scope; - end if; - end; - end if; - - -- Otherwise, if E is a package instance, it is axiomatized if the - -- corresponding generic package is axiomatized. - - if Ekind (E) = E_Package then - declare - Par : constant Node_Id := Parent (E); - Decl : Node_Id; - - begin - if Nkind (Par) = N_Defining_Program_Unit_Name then - Decl := Parent (Par); - else - Decl := Par; - end if; - - if Present (Generic_Parent (Decl)) then - return - Containing_Package_With_Ext_Axioms (Generic_Parent (Decl)); - end if; - end; - end if; - - return Empty; - end Containing_Package_With_Ext_Axioms; - ------------------------------- -- Convert_To_Actual_Subtype -- ------------------------------- @@ -6203,26 +6166,6 @@ package body Exp_Util is return End_String; end Fully_Qualified_Name_String; - ------------------------ - -- Generate_Poll_Call -- - ------------------------ - - procedure Generate_Poll_Call (N : Node_Id) is - begin - -- No poll call if polling not active - - if not Polling_Required then - return; - - -- Otherwise generate require poll call - - else - Insert_Before_And_Analyze (N, - Make_Procedure_Call_Statement (Sloc (N), - Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N)))); - end if; - end Generate_Poll_Call; - --------------------------------- -- Get_Current_Value_Condition -- --------------------------------- @@ -6656,122 +6599,6 @@ package body Exp_Util is end if; end Has_Access_Constraint; - ----------------------------------------------------- - -- Has_Annotate_Pragma_For_External_Axiomatization -- - ----------------------------------------------------- - - function Has_Annotate_Pragma_For_External_Axiomatization - (E : Entity_Id) return Boolean - is - function Is_Annotate_Pragma_For_External_Axiomatization - (N : Node_Id) return Boolean; - -- Returns whether N is - -- pragma Annotate (GNATprove, External_Axiomatization); - - ---------------------------------------------------- - -- Is_Annotate_Pragma_For_External_Axiomatization -- - ---------------------------------------------------- - - -- The general form of pragma Annotate is - - -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); - -- ARG ::= NAME | EXPRESSION - - -- The first two arguments are by convention intended to refer to an - -- external tool and a tool-specific function. These arguments are - -- not analyzed. - - -- The following is used to annotate a package specification which - -- GNATprove should treat specially, because the axiomatization of - -- this unit is given by the user instead of being automatically - -- generated. - - -- pragma Annotate (GNATprove, External_Axiomatization); - - function Is_Annotate_Pragma_For_External_Axiomatization - (N : Node_Id) return Boolean - is - Name_GNATprove : constant String := - "gnatprove"; - Name_External_Axiomatization : constant String := - "external_axiomatization"; - -- Special names - - begin - if Nkind (N) = N_Pragma - and then Get_Pragma_Id (N) = Pragma_Annotate - and then List_Length (Pragma_Argument_Associations (N)) = 2 - then - declare - Arg1 : constant Node_Id := - First (Pragma_Argument_Associations (N)); - Arg2 : constant Node_Id := Next (Arg1); - Nam1 : Name_Id; - Nam2 : Name_Id; - - begin - -- Fill in Name_Buffer with Name_GNATprove first, and then with - -- Name_External_Axiomatization so that Name_Find returns the - -- corresponding name. This takes care of all possible casings. - - Name_Len := 0; - Add_Str_To_Name_Buffer (Name_GNATprove); - Nam1 := Name_Find; - - Name_Len := 0; - Add_Str_To_Name_Buffer (Name_External_Axiomatization); - Nam2 := Name_Find; - - return Chars (Get_Pragma_Arg (Arg1)) = Nam1 - and then - Chars (Get_Pragma_Arg (Arg2)) = Nam2; - end; - - else - return False; - end if; - end Is_Annotate_Pragma_For_External_Axiomatization; - - -- Local variables - - Decl : Node_Id; - Vis_Decls : List_Id; - N : Node_Id; - - -- Start of processing for Has_Annotate_Pragma_For_External_Axiomatization - - begin - if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then - Decl := Parent (Parent (E)); - else - Decl := Parent (E); - end if; - - Vis_Decls := Visible_Declarations (Decl); - - N := First (Vis_Decls); - while Present (N) loop - - -- Skip declarations generated by the frontend. Skip all pragmas - -- that are not the desired Annotate pragma. Stop the search on - -- the first non-pragma source declaration. - - if Comes_From_Source (N) then - if Nkind (N) = N_Pragma then - if Is_Annotate_Pragma_For_External_Axiomatization (N) then - return True; - end if; - else - return False; - end if; - end if; - - Next (N); - end loop; - - return False; - end Has_Annotate_Pragma_For_External_Axiomatization; - -------------------- -- Homonym_Number -- -------------------- @@ -7727,6 +7554,46 @@ package body Exp_Util is return Proc /= Empty; end Inside_Init_Proc; + ---------------------- + -- Integer_Type_For -- + ---------------------- + + function Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id is + begin + pragma Assert (S <= System_Max_Integer_Size); + + -- This is the canonical 32-bit type + + if S <= Standard_Integer_Size then + if Uns then + return Standard_Unsigned; + else + return Standard_Integer; + end if; + + -- This is the canonical 64-bit type + + elsif S <= Standard_Long_Long_Integer_Size then + if Uns then + return Standard_Long_Long_Unsigned; + else + return Standard_Long_Long_Integer; + end if; + + -- This is the canonical 128-bit type + + elsif S <= Standard_Long_Long_Long_Integer_Size then + if Uns then + return Standard_Long_Long_Long_Unsigned; + else + return Standard_Long_Long_Long_Integer; + end if; + + else + raise Program_Error; + end if; + end Integer_Type_For; + ---------------------------- -- Is_All_Null_Statements -- ---------------------------- @@ -8734,9 +8601,14 @@ package body Exp_Util is function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is Expr : constant Node_Id := Related_Expression (Id); begin + -- In the case of a function with a class-wide result that returns + -- a call to a function with a specific result, we introduce a + -- type conversion for the return expression. We do not want that + -- type conversion to influence the result of this function. + return Present (Expr) - and then Nkind (Expr) = N_Explicit_Dereference + and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference and then Nkind (Parent (Expr)) = N_Simple_Return_Statement; end Is_Related_To_Func_Return; @@ -9919,6 +9791,24 @@ package body Exp_Util is Constraints => List_Constr)); end Make_Subtype_From_Expr; + ----------------------------- + -- Make_Variant_Comparison -- + ----------------------------- + + function Make_Variant_Comparison + (Loc : Source_Ptr; + Mode : Name_Id; + Curr_Val : Node_Id; + Old_Val : Node_Id) return Node_Id + is + begin + if Mode = Name_Increases then + return Make_Op_Gt (Loc, Curr_Val, Old_Val); + else pragma Assert (Mode = Name_Decreases); + return Make_Op_Lt (Loc, Curr_Val, Old_Val); + end if; + end Make_Variant_Comparison; + --------------- -- Map_Types -- --------------- @@ -10554,37 +10444,8 @@ package body Exp_Util is -- Unsigned integer cases (includes normal enumeration types) - elsif Is_Unsigned_Type (Typ) then - if Siz <= Esize (Standard_Short_Short_Unsigned) then - return Standard_Short_Short_Unsigned; - elsif Siz <= Esize (Standard_Short_Unsigned) then - return Standard_Short_Unsigned; - elsif Siz <= Esize (Standard_Unsigned) then - return Standard_Unsigned; - elsif Siz <= Esize (Standard_Long_Unsigned) then - return Standard_Long_Unsigned; - elsif Siz <= Esize (Standard_Long_Long_Unsigned) then - return Standard_Long_Long_Unsigned; - else - raise Program_Error; - end if; - - -- Signed integer cases - else - if Siz <= Esize (Standard_Short_Short_Integer) then - return Standard_Short_Short_Integer; - elsif Siz <= Esize (Standard_Short_Integer) then - return Standard_Short_Integer; - elsif Siz <= Esize (Standard_Integer) then - return Standard_Integer; - elsif Siz <= Esize (Standard_Long_Integer) then - return Standard_Long_Integer; - elsif Siz <= Esize (Standard_Long_Long_Integer) then - return Standard_Long_Long_Integer; - else - raise Program_Error; - end if; + return Small_Integer_Type_For (Siz, Is_Unsigned_Type (Typ)); end if; end Matching_Standard_Type; @@ -10645,9 +10506,9 @@ package body Exp_Util is -- initialization, or the object is imported. -- The same holds for all initialized scalar types and all access types. - -- Packed bit arrays of size up to 64 are represented using a modular - -- type with an initialization (to zero) and can be processed like other - -- initialized scalar types. + -- Packed bit array types of size up to the maximum integer size are + -- represented using a modular type with an initialization (to zero) and + -- can be processed like other initialized scalar types. -- If the type is controlled, code to attach the object to a -- finalization chain is generated at the point of declaration, and @@ -10841,12 +10702,12 @@ package body Exp_Util is Ptyp : constant Entity_Id := Etype (P); begin - -- If we know the component size and it is not larger than 64, - -- then we are definitely OK. The back end does the assignment - -- of misaligned small objects correctly. + -- If we know the component size and it is not larger than the + -- maximum integer size, then we are OK. The back end does the + -- assignment of small misaligned objects correctly. if Known_Static_Component_Size (Ptyp) - and then Component_Size (Ptyp) <= 64 + and then Component_Size (Ptyp) <= System_Max_Integer_Size then return False; @@ -11324,6 +11185,14 @@ package body Exp_Util is and then Is_Class_Wide_Type (Etype (Exp)) then return; + + -- An expression which is in SPARK mode is considered side effect free + -- if the resulting value is captured by a variable or a constant. + + elsif GNATprove_Mode + and then Nkind (Parent (Exp)) = N_Object_Declaration + then + return; end if; -- The remaining processing is done with all checks suppressed @@ -11361,7 +11230,7 @@ package body Exp_Util is elsif (Is_Elementary_Type (Exp_Type) or else (Is_Record_Type (Exp_Type) and then Known_Static_RM_Size (Exp_Type) - and then RM_Size (Exp_Type) <= 64 + and then RM_Size (Exp_Type) <= System_Max_Integer_Size and then not Has_Discriminants (Exp_Type) and then not Is_By_Reference_Type (Exp_Type))) and then (Variable_Ref @@ -11522,7 +11391,26 @@ package body Exp_Util is Insert_Action (Exp, E); end if; - -- For expressions that denote names, we can use a renaming scheme. + -- If this is a packed array component or a selected component with a + -- nonstandard representation, we cannot generate a reference because + -- the component may be unaligned, so we must use a renaming and this + -- renaming must be handled by the front end, as the back end may balk + -- at the nonstandard representation (see Exp_Ch2.Expand_Renaming). + + elsif Nkind (Exp) in N_Indexed_Component | N_Selected_Component + and then Has_Non_Standard_Rep (Etype (Prefix (Exp))) + then + Def_Id := Build_Temporary (Loc, 'R', Exp); + Res := New_Occurrence_Of (Def_Id, Loc); + + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), + Name => Relocate_Node (Exp))); + + -- For an expression that denotes a name, we can use a renaming scheme + -- that is handled by the back end, instead of the front end as above. -- This is needed for correctness in the case of a volatile object of -- a nonvolatile type because the Make_Reference call of the "default" -- approach would generate an illegal access value (an access value @@ -11545,21 +11433,7 @@ package body Exp_Util is Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), Name => Relocate_Node (Exp))); - -- If this is a packed reference, or a selected component with - -- a nonstandard representation, a reference to the temporary - -- will be replaced by a copy of the original expression (see - -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be - -- elaborated by gigi, and is of course not to be replaced in-line - -- by the expression it renames, which would defeat the purpose of - -- removing the side effect. - - if Nkind (Exp) in N_Selected_Component | N_Indexed_Component - and then Has_Non_Standard_Rep (Etype (Prefix (Exp))) - then - null; - else - Set_Is_Renaming_Of_Object (Def_Id, False); - end if; + Set_Is_Renaming_Of_Object (Def_Id, False); -- Avoid generating a variable-sized temporary, by generating the -- reference just for the function call. The transformation could be @@ -11576,15 +11450,6 @@ package body Exp_Util is -- Otherwise we generate a reference to the expression else - -- An expression which is in SPARK mode is considered side effect - -- free if the resulting value is captured by a variable or a - -- constant. - - if GNATprove_Mode - and then Nkind (Parent (Exp)) = N_Object_Declaration - then - goto Leave; - -- When generating C code we cannot consider side effect free object -- declarations that have discriminants and are initialized by means -- of a function call since on this target there is no secondary @@ -11598,7 +11463,7 @@ package body Exp_Util is -- be identified here to avoid entering into a never-ending loop -- generating internal object declarations. - elsif Modify_Tree_For_C + if Modify_Tree_For_C and then Nkind (Parent (Exp)) = N_Object_Declaration and then (Nkind (Exp) /= N_Function_Call @@ -13522,6 +13387,62 @@ package body Exp_Util is Reason => CE_Range_Check_Failed)); end Silly_Boolean_Array_Xor_Test; + ---------------------------- + -- Small_Integer_Type_For -- + ---------------------------- + + function Small_Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id + is + begin + pragma Assert (S <= System_Max_Integer_Size); + + if S <= Standard_Short_Short_Integer_Size then + if Uns then + return Standard_Short_Short_Unsigned; + else + return Standard_Short_Short_Integer; + end if; + + elsif S <= Standard_Short_Integer_Size then + if Uns then + return Standard_Short_Unsigned; + else + return Standard_Short_Integer; + end if; + + elsif S <= Standard_Integer_Size then + if Uns then + return Standard_Unsigned; + else + return Standard_Integer; + end if; + + elsif S <= Standard_Long_Integer_Size then + if Uns then + return Standard_Long_Unsigned; + else + return Standard_Long_Integer; + end if; + + elsif S <= Standard_Long_Long_Integer_Size then + if Uns then + return Standard_Long_Long_Unsigned; + else + return Standard_Long_Long_Integer; + end if; + + elsif S <= Standard_Long_Long_Long_Integer_Size then + if Uns then + return Standard_Long_Long_Long_Unsigned; + else + return Standard_Long_Long_Long_Integer; + end if; + + else + raise Program_Error; + end if; + end Small_Integer_Type_For; + -------------------------- -- Target_Has_Fixed_Ops -- -------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 3f882a6..37eb86f 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -427,11 +427,6 @@ package Exp_Util is -- for trouble using this function and, if so, the assignment is expanded -- component-wise, which the back end is required to handle correctly. - function Containing_Package_With_Ext_Axioms - (E : Entity_Id) return Entity_Id; - -- Returns the package entity with an external axiomatization containing E, - -- if any, or Empty if none. - procedure Convert_To_Actual_Subtype (Exp : Node_Id); -- The Etype of an expression is the nominal type of the expression, -- not the actual subtype. Often these are the same, but not always. @@ -687,10 +682,6 @@ package Exp_Util is -- of entity E, in all upper case, with an ASCII.NUL appended at the end -- of the name if Append_NUL is True. - procedure Generate_Poll_Call (N : Node_Id); - -- If polling is active, then a call to the Poll routine is built, - -- and then inserted before the given node N and analyzed. - procedure Get_Current_Value_Condition (Var : Node_Id; Op : out Node_Kind; @@ -734,12 +725,6 @@ package Exp_Util is function Has_Access_Constraint (E : Entity_Id) return Boolean; -- Given object or type E, determine if a discriminant is of an access type - function Has_Annotate_Pragma_For_External_Axiomatization - (E : Entity_Id) return Boolean; - -- Returns whether E is a package entity, for which the initial list of - -- pragmas at the start of the package declaration contains - -- pragma Annotate (GNATprove, External_Axiomatization); - function Homonym_Number (Subp : Entity_Id) return Pos; -- Here subp is the entity for a subprogram. This routine returns the -- homonym number used to disambiguate overloaded subprograms in the same @@ -761,6 +746,10 @@ package Exp_Util is -- unconditionally executed, i.e. it is not within a loop or a conditional -- or a case statement etc. + function Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id; + -- Return a suitable standard integer type containing at least S bits and + -- of the signedness given by Uns. + function Is_All_Null_Statements (L : List_Id) return Boolean; -- Return True if all the items of the list are N_Null_Statement nodes. -- False otherwise. True for an empty list. It is an error to call this @@ -910,6 +899,15 @@ package Exp_Util is -- wide type. Set Related_Id to request an external name for the subtype -- rather than an internal temporary. + function Make_Variant_Comparison + (Loc : Source_Ptr; + Mode : Name_Id; + Curr_Val : Node_Id; + Old_Val : Node_Id) return Node_Id; + -- Subsidiary to the expansion of pragmas Loop_Variant and + -- Subprogram_Variant. Generate a comparison between Curr_Val and Old_Val + -- depending on the variant mode (Increases / Decreases). + procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id); -- Establish the following mapping between the attributes of tagged parent -- type Parent_Type and tagged derived type Derived_Type. @@ -982,6 +980,11 @@ package Exp_Util is -- If so, returns the value K, otherwise returns zero. The caller checks -- that N is of an integer type. + function Predicate_Check_In_Scope (N : Node_Id) return Boolean; + -- Return True if predicate checks should be generated in the current + -- scope on the given node. Will return False for example when the current + -- scope is a predefined primitive operation. + procedure Process_Statements_For_Controlled_Objects (N : Node_Id); -- N is a node which contains a non-handled statement list. Inspect the -- statements looking for declarations of controlled objects. If at least @@ -1165,6 +1168,10 @@ package Exp_Util is -- True..True, where a raise of a Constraint_Error exception is required -- (RM 4.5.6(6)) and ACATS-tested. + function Small_Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id; + -- Return the smallest standard integer type containing at least S bits and + -- of the signedness given by Uns. + function Target_Has_Fixed_Ops (Left_Typ : Entity_Id; Right_Typ : Entity_Id; @@ -1195,11 +1202,6 @@ package Exp_Util is function Within_Case_Or_If_Expression (N : Node_Id) return Boolean; -- Determine whether arbitrary node N is within a case or an if expression - function Predicate_Check_In_Scope (N : Node_Id) return Boolean; - -- Return True if predicate checks should be generated in the current - -- scope on the given node. Will return False for example when the current - -- scope is a predefined primitive operation. - private pragma Inline (Duplicate_Subexpr); pragma Inline (Force_Evaluation); diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index b8e86b8..d6219f4 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -273,9 +273,6 @@ package body Expander is when N_Generic_Instantiation => Expand_N_Generic_Instantiation (N); - when N_Goto_Statement => - Expand_N_Goto_Statement (N); - when N_Handled_Sequence_Of_Statements => Expand_N_Handled_Sequence_Of_Statements (N); diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index a5ae66e..40aeef1 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -162,12 +162,12 @@ package body Fmap is function Hash (F : File_Name_Type) return Header_Num is begin - return Header_Num (Int (F) rem Header_Num'Range_Length); + return Header_Num (Int (F) mod Header_Num'Range_Length); end Hash; function Hash (F : Unit_Name_Type) return Header_Num is begin - return Header_Num (Int (F) rem Header_Num'Range_Length); + return Header_Num (Int (F) mod Header_Num'Range_Length); end Hash; ---------------- diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index 97d3b7b..48e2bc2 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -598,7 +598,7 @@ package body Fname.UF is function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is begin - return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length); + return SFN_Header_Num (Int (F) mod SFN_Header_Num'Range_Length); end SFN_Hash; begin diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb index ad316eb..67d05e2 100644 --- a/gcc/ada/fname.adb +++ b/gcc/ada/fname.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -140,11 +134,13 @@ package body Fname is Renamings_Included : Boolean := True) return Boolean is begin - -- Definitely false if longer than 12 characters (8.3) - -- except for the Interfaces packages + -- Definitely false if longer than 12 characters (8.3), except for the + -- Interfaces packages and also the implementation units of the 128-bit + -- types under System. if Fname'Length > 12 and then Fname (Fname'First .. Fname'First + 1) /= "i-" + and then Fname (Fname'First .. Fname'First + 1) /= "s-" then return False; end if; diff --git a/gcc/ada/fname.ads b/gcc/ada/fname.ads index 06a77f1..7790fbf 100644 --- a/gcc/ada/fname.ads +++ b/gcc/ada/fname.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 1c177b1..f3abba1 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -80,8 +80,8 @@ package body Freeze is -- Typ is a type that is being frozen. If no size clause is given, -- but a default Esize has been computed, then this default Esize is -- adjusted up if necessary to be consistent with a given alignment, - -- but never to a value greater than Long_Long_Integer'Size. This - -- is used for all discrete types and for fixed-point types. + -- but never to a value greater than System_Max_Integer_Size. This is + -- used for all discrete types and for fixed-point types. procedure Build_And_Analyze_Renamed_Body (Decl : Node_Id; @@ -182,6 +182,12 @@ package body Freeze is -- the designated type. Otherwise freezing the access type does not freeze -- the designated type. + function Is_Uninitialized_Aggregate (N : Node_Id) return Boolean; + -- Determine whether an array aggregate used in an object declaration + -- is uninitialized, when the aggregate is declared with a box and + -- the component type has no default value. Such an aggregate can be + -- optimized away and prevent the copying of uninitialized data. + procedure Process_Default_Expressions (E : Entity_Id; After : in out Node_Id); @@ -231,9 +237,7 @@ package body Freeze is if Known_Esize (Typ) and then Known_Alignment (Typ) then Align := Alignment_In_Bits (Typ); - if Align > Esize (Typ) - and then Align <= Standard_Long_Long_Integer_Size - then + if Align > Esize (Typ) and then Align <= System_Max_Integer_Size then Set_Esize (Typ, Align); end if; end if; @@ -636,7 +640,7 @@ package body Freeze is -- If Rep_Clauses are to be ignored, remove address clause from -- list attached to entity, because it may be illegal for gigi, - -- for example by breaking order of elaboration.. + -- for example by breaking order of elaboration. if Ignore_Rep_Clauses then declare @@ -720,7 +724,14 @@ package body Freeze is -- expansion elsewhere. This exception is necessary to avoid copying -- limited objects. - if Present (Init) and then not Is_Limited_View (Typ) then + if Present (Init) + and then not Is_Limited_View (Typ) + then + if Is_Uninitialized_Aggregate (Init) then + Init := Empty; + Set_No_Initialization (Decl); + return; + end if; -- Capture initialization value at point of declaration, and make -- explicit assignment legal, because object may be a constant. @@ -758,9 +769,8 @@ package body Freeze is procedure Check_Compile_Time_Size (T : Entity_Id) is procedure Set_Small_Size (T : Entity_Id; S : Uint); - -- Sets the compile time known size (64 bits or less) in the RM_Size - -- field of T, checking for a size clause that was given which attempts - -- to give a smaller size. + -- Sets the compile time known size in the RM_Size field of T, checking + -- for a size clause that was given which attempts to give a small size. function Size_Known (T : Entity_Id) return Boolean; -- Recursive function that does all the work @@ -778,7 +788,7 @@ package body Freeze is procedure Set_Small_Size (T : Entity_Id; S : Uint) is begin - if S > 64 then + if S > System_Max_Integer_Size then return; -- Check for bad size clause given @@ -848,7 +858,8 @@ package body Freeze is end if; -- Check for all indexes static, and also compute possible size - -- (in case it is not greater than 64 and may be packable). + -- (in case it is not greater than System_Max_Integer_Size and + -- thus may be packable). declare Size : Uint := Component_Size (T); @@ -1077,8 +1088,7 @@ package body Freeze is -- We can deal with elementary types, small packed arrays -- if the representation is a modular type and also small - -- record types (if the size is not greater than 64, but - -- the condition is checked by Set_Small_Size). + -- record types as checked by Set_Small_Size. if Is_Elementary_Type (Ctyp) or else (Is_Array_Type (Ctyp) @@ -1610,7 +1620,10 @@ package body Freeze is Comp : Entity_Id; begin - if Is_By_Reference_Type (E) then + -- Bit-packed array types do not require strict alignment, even if they + -- are by-reference types, because they are accessed in a special way. + + if Is_By_Reference_Type (E) and then not Is_Bit_Packed_Array (E) then Set_Strict_Alignment (E); elsif Is_Array_Type (E) then @@ -1724,11 +1737,11 @@ package body Freeze is end loop; end Check_Unsigned_Type; - ----------------------------- - -- Is_Atomic_VFA_Aggregate -- - ----------------------------- + ------------------------------ + -- Is_Full_Access_Aggregate -- + ------------------------------ - function Is_Atomic_VFA_Aggregate (N : Node_Id) return Boolean is + function Is_Full_Access_Aggregate (N : Node_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); New_N : Node_Id; Par : Node_Id; @@ -1752,9 +1765,9 @@ package body Freeze is when N_Assignment_Statement => Typ := Etype (Name (Par)); - if not Is_Atomic_Or_VFA (Typ) + if not Is_Full_Access (Typ) and then not (Is_Entity_Name (Name (Par)) - and then Is_Atomic_Or_VFA (Entity (Name (Par)))) + and then Is_Full_Access (Entity (Name (Par)))) then return False; end if; @@ -1762,8 +1775,8 @@ package body Freeze is when N_Object_Declaration => Typ := Etype (Defining_Identifier (Par)); - if not Is_Atomic_Or_VFA (Typ) - and then not Is_Atomic_Or_VFA (Defining_Identifier (Par)) + if not Is_Full_Access (Typ) + and then not Is_Full_Access (Defining_Identifier (Par)) then return False; end if; @@ -1784,7 +1797,7 @@ package body Freeze is Set_Expression (Par, New_Occurrence_Of (Temp, Loc)); return True; - end Is_Atomic_VFA_Aggregate; + end Is_Full_Access_Aggregate; ----------------------------------------------- -- Explode_Initialization_Compound_Statement -- @@ -2202,7 +2215,7 @@ package body Freeze is -- generated a message on the template. procedure Check_Suspicious_Modulus (Utype : Entity_Id); - -- Give warning for modulus of 8, 16, 32, or 64 given as an explicit + -- Give warning for modulus of 8, 16, 32, 64 or 128 given as an explicit -- integer literal without an explicit corresponding size clause. The -- caller has checked that Utype is a modular integer type. @@ -2626,12 +2639,12 @@ package body Freeze is end; end if; - -- Check for Aliased or Atomic_Components/Atomic/VFA with + -- Check for Aliased or Atomic_Components or Full Access with -- unsuitable packing or explicit component size clause given. if (Has_Aliased_Components (Arr) or else Has_Atomic_Components (Arr) - or else Is_Atomic_Or_VFA (Ctyp)) + or else Is_Full_Access (Ctyp)) and then (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr)) then @@ -2639,8 +2652,8 @@ package body Freeze is procedure Complain_CS (T : String); -- Outputs error messages for incorrect CS clause or pragma - -- Pack for aliased or atomic/VFA components (T is "aliased" - -- or "atomic/vfa"); + -- Pack for aliased or full access components (T is either + -- "aliased" or "atomic" or "volatile full access"); ----------------- -- Complain_CS -- @@ -2831,7 +2844,7 @@ package body Freeze is -- Case of component size that may result in bit packing - if 1 <= Csiz and then Csiz <= 64 then + if 1 <= Csiz and then Csiz <= System_Max_Integer_Size then declare Ent : constant Entity_Id := First_Subtype (Arr); @@ -2894,7 +2907,7 @@ package body Freeze is end if; end if; - -- Bit packing is never needed for 8, 16, 32, 64 + -- Bit packing is never needed for 8, 16, 32, 64 or 128 if Addressable (Csiz) then @@ -3177,9 +3190,9 @@ package body Freeze is procedure Check_Large_Modular_Array (Typ : Entity_Id); -- Check that the size of array type Typ can be computed without -- overflow, and generates a Storage_Error otherwise. This is only - -- relevant for array types whose index is a (mod 2**64) type, where - -- wrap-around arithmetic might yield a meaningless value for the - -- length of the array, or its corresponding attribute. + -- relevant for array types whose index has System_Max_Integer_Size + -- bits, where wrap-around arithmetic might yield a meaningless value + -- for the length of the array, or its corresponding attribute. procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id); -- Ensure that the initialization state of variable Var_Id subject @@ -5505,11 +5518,11 @@ package body Freeze is -- than component-wise (the assignment to the temp may be done -- component-wise, but that is harmless). - elsif Is_Atomic_Or_VFA (E) + elsif Is_Full_Access (E) and then Nkind (Parent (E)) = N_Object_Declaration and then Present (Expression (Parent (E))) and then Nkind (Expression (Parent (E))) = N_Aggregate - and then Is_Atomic_VFA_Aggregate (Expression (Parent (E))) + and then Is_Full_Access_Aggregate (Expression (Parent (E))) then null; end if; @@ -5810,7 +5823,7 @@ package body Freeze is and then not Has_Pragma_Pack (E) and then not Has_Component_Size_Clause (E) and then Known_Static_RM_Size (Ctyp) - and then Rsiz <= 64 + and then Rsiz <= System_Max_Integer_Size and then not (Addressable (Rsiz) and then Known_Static_Esize (Ctyp) and then Esize (Ctyp) = Rsiz) @@ -6387,7 +6400,7 @@ package body Freeze is end if; -- The pool applies to named and anonymous access types, but not - -- to subprogram and to internal types generated for 'Access + -- to subprogram and to internal types generated for 'Access -- references. elsif Is_Access_Type (E) @@ -6412,6 +6425,11 @@ package body Freeze is if Nkind (Default_Pool) = N_Null then Set_No_Pool_Assigned (E); + -- Case of pragma Default_Storage_Pool (Standard) + + elsif Entity (Default_Pool) = Standard_Standard then + Set_Associated_Storage_Pool (E, RTE (RE_Global_Pool_Object)); + -- Case of pragma Default_Storage_Pool (storage_pool_NAME) else @@ -6826,7 +6844,7 @@ package body Freeze is end if; -- If the type has a Defaut_Value/Default_Component_Value aspect, - -- this is where we analye the expression (after the type is frozen, + -- this is where we analyze the expression (after the type is frozen, -- since in the case of Default_Value, we are analyzing with the -- type itself, and we treat Default_Component_Value similarly for -- the sake of uniformity). @@ -7990,19 +8008,19 @@ package body Freeze is if Nkind (Node) in N_Has_Etype and then Present (Etype (Node)) and then Is_Access_Type (Etype (Node)) - and then Nkind (Parent (Node)) = N_Function_Call - and then Node = Controlling_Argument (Parent (Node)) then - Check_And_Freeze_Type (Designated_Type (Etype (Node))); + if Nkind (Parent (Node)) = N_Function_Call + and then Node = Controlling_Argument (Parent (Node)) + then + Check_And_Freeze_Type (Designated_Type (Etype (Node))); - -- An explicit dereference freezes the designated type as well, - -- even though that type is not attached to an entity in the - -- expression. + -- An explicit dereference freezes the designated type as well, + -- even though that type is not attached to an entity in the + -- expression. - elsif Nkind (Node) in N_Has_Etype - and then Nkind (Parent (Node)) = N_Explicit_Dereference - then - Check_And_Freeze_Type (Designated_Type (Etype (Node))); + elsif Nkind (Parent (Node)) = N_Explicit_Dereference then + Check_And_Freeze_Type (Designated_Type (Etype (Node))); + end if; -- An iterator specification freezes the iterator type, even though -- that type is not attached to an entity in the construct. @@ -8494,21 +8512,21 @@ package body Freeze is Set_Analyzed (Lo, False); Analyze (Lo); - -- Resolve with universal fixed if the base type, and the base type if - -- it is a subtype. Note we can't resolve the base type with itself, - -- that would be a reference before definition. + -- Resolve with universal fixed if the base type, and with the base + -- type if we are freezing a subtype. Note we can't resolve the base + -- type with itself, that would be a reference before definition. + -- The resolution of the bounds of a subtype, if they are given by real + -- literals, includes the setting of the Corresponding_Integer_Value, + -- as for other literals of a fixed-point type. if Typ = Btyp then Resolve (Lo, Universal_Fixed); + Set_Corresponding_Integer_Value + (Lo, UR_To_Uint (Realval (Lo) / Small)); else Resolve (Lo, Btyp); end if; - -- Set corresponding integer value for bound - - Set_Corresponding_Integer_Value - (Lo, UR_To_Uint (Realval (Lo) / Small)); - -- Similar processing for high bound Set_Etype (Hi, Empty); @@ -8517,13 +8535,12 @@ package body Freeze is if Typ = Btyp then Resolve (Hi, Universal_Fixed); + Set_Corresponding_Integer_Value + (Hi, UR_To_Uint (Realval (Hi) / Small)); else Resolve (Hi, Btyp); end if; - Set_Corresponding_Integer_Value - (Hi, UR_To_Uint (Realval (Hi) / Small)); - -- Set type of range to correspond to bounds Set_Etype (Rng, Etype (Lo)); @@ -9127,6 +9144,40 @@ package body Freeze is end if; end Freeze_Subprogram; + -------------------------------- + -- Is_Uninitialized_Aggregate -- + -------------------------------- + + function Is_Uninitialized_Aggregate (N : Node_Id) return Boolean is + Aggr : constant Node_Id := Original_Node (N); + Typ : constant Entity_Id := Etype (Aggr); + + Comp : Node_Id; + Comp_Type : Entity_Id; + begin + if Nkind (Aggr) /= N_Aggregate + or else No (Typ) + or else Ekind (Typ) /= E_Array_Type + or else Present (Expressions (Aggr)) + or else No (Component_Associations (Aggr)) + then + return False; + else + Comp_Type := Component_Type (Typ); + Comp := First (Component_Associations (Aggr)); + + if not Box_Present (Comp) + or else Present (Next (Comp)) + then + return False; + end if; + + return Is_Scalar_Type (Comp_Type) + and then No (Default_Aspect_Component_Value (Typ)) + and then No (Default_Aspect_Value (Comp_Type)); + end if; + end Is_Uninitialized_Aggregate; + ---------------------- -- Is_Fully_Defined -- ---------------------- diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index 56061a07..448d1ed 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -152,15 +152,15 @@ package Freeze is -- occur. -- -- Size is known at compile time, but the actual value of the size is not - -- known to the front end or is definitely greater than 64. In this case, - -- Size_Known_At_Compile_Time is set, but the RM_Size field is left set - -- to zero (to be set by Gigi). + -- known to the front end or is greater than System_Max_Integer_Size. In + -- this case, Size_Known_At_Compile_Time is set, but the RM_Size field is + -- left set to zero (to be set by Gigi). -- -- Size is known at compile time, and the actual value of the size is - -- known to the front end and is not greater than 64. In this case, the - -- flag Size_Known_At_Compile_Time is set, and in addition RM_Size is set - -- to the required size, allowing for possible front end packing of an - -- array using this type as a component type. + -- known to the front end and not greater than System_Max_Integer_Size. + -- In this case, Size_Known_At_Compile_Time is set, and in addition the + -- RM_Size field is set to the required size, allowing for possible front + -- end packing of an array using this type as a component type. -- -- Note: the flag Size_Known_At_Compile_Time is used to determine if the -- secondary stack must be used to return a value of the type, and also @@ -174,8 +174,8 @@ package Freeze is -- do not allow a size clause if the size would not otherwise be known at -- compile time in any case. - function Is_Atomic_VFA_Aggregate (N : Node_Id) return Boolean; - -- If an atomic/VFA object is initialized with an aggregate or is assigned + function Is_Full_Access_Aggregate (N : Node_Id) return Boolean; + -- If a full access object is initialized with an aggregate or is assigned -- an aggregate, we have to prevent a piecemeal access or assignment to the -- object, even if the aggregate is to be expanded. We create a temporary -- for the aggregate, and assign the temporary instead, so that the back diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 7d2ea52..78fe602 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -68,7 +68,7 @@ ALL_ADAFLAGS = \ $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) $(CHECKING_ADAFLAGS) $(WARN_ADAFLAGS) FORCE_DEBUG_ADAFLAGS = -g ADA_CFLAGS = -ADA_INCLUDES = -nostdinc -I- -I. -Iada/generated -Iada -I$(srcdir)/ada -I$(srcdir)/ada/gcc-interface -Iada/libgnat -I$(srcdir)/ada/libgnat +ADA_INCLUDES = -nostdinc -I- -I. -Iada/generated -Iada -Iada/gcc-interface -I$(srcdir)/ada -I$(srcdir)/ada/gcc-interface -Iada/libgnat -I$(srcdir)/ada/libgnat GNATLIBFLAGS= -W -Wall -gnatpg -nostdinc GNATLIBCFLAGS= -g -O2 $(TCFLAGS) ADA_INCLUDE_DIR = $(libsubdir)/adainclude @@ -327,6 +327,7 @@ GNAT_ADA_OBJS = \ ada/libgnat/g-u3spch.o \ ada/get_targ.o \ ada/ghost.o \ + ada/gnat_cuda.o \ ada/libgnat/gnat.o \ ada/gnatvsn.o \ ada/hostparm.o \ @@ -469,7 +470,7 @@ GNAT_ADA_OBJS = \ ada/stylesw.o \ ada/switch-c.o \ ada/switch.o \ - ada/libgnat/system.o \ + ada/gcc-interface/system.o \ ada/table.o \ ada/targparm.o \ ada/tbuild.o \ @@ -627,7 +628,7 @@ GNATBIND_OBJS = \ ada/stylesw.o \ ada/switch-b.o \ ada/switch.o \ - ada/libgnat/system.o \ + ada/gcc-interface/system.o \ ada/table.o \ ada/targext.o \ ada/targparm.o \ @@ -1038,8 +1039,9 @@ ada/sdefault.o : ada/libgnat/ada.ads ada/libgnat/a-except.ads ada/libgnat/a-uncc ada/libgnat/s-exctab.ads ada/libgnat/s-memory.ads ada/libgnat/s-os_lib.ads ada/libgnat/s-parame.ads \ ada/libgnat/s-stalib.ads ada/libgnat/s-strops.ads ada/libgnat/s-sopco3.ads ada/libgnat/s-sopco4.ads \ ada/libgnat/s-sopco5.ads ada/libgnat/s-string.ads ada/libgnat/s-traent.ads ada/libgnat/s-unstyp.ads \ - ada/libgnat/s-wchcon.ads ada/libgnat/system.ads ada/table.adb ada/table.ads \ - ada/types.ads ada/libgnat/unchdeal.ads ada/libgnat/unchconv.ads + ada/libgnat/s-wchcon.ads ada/table.adb ada/table.ads \ + ada/types.ads ada/libgnat/unchdeal.ads ada/libgnat/unchconv.ads \ + ada/gcc-interface/system.ads # Special flags - see gcc-interface/Makefile.in for the template. diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index c9c2a95..4e6dc84 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -232,7 +232,7 @@ static tree build_position_list (tree, bool, tree, tree, unsigned int, tree); static vec<subst_pair> build_subst_list (Entity_Id, Entity_Id, bool); static vec<variant_desc> build_variant_list (tree, Node_Id, vec<subst_pair>, vec<variant_desc>); -static tree maybe_saturate_size (tree); +static tree maybe_saturate_size (tree, unsigned int align); static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool, const char *, const char *); static void set_rm_size (Uint, tree, Entity_Id); @@ -896,13 +896,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_size = bitsize_unit_node; /* If this is an object with no specified size and alignment, and - if either it is atomic or we are not optimizing alignment for + if either it is full access or we are not optimizing alignment for space and it is composite and not an exception, an Out parameter or a reference to another object, and the size of its type is a constant, set the alignment to the smallest one which is not smaller than the size, with an appropriate cap. */ if (!gnu_size && align == 0 - && (Is_Atomic_Or_VFA (gnat_entity) + && (Is_Full_Access (gnat_entity) || (!Optimize_Alignment_Space (gnat_entity) && kind != E_Exception && kind != E_Out_Parameter @@ -1014,7 +1014,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } /* Now check if the type of the object allows atomic access. */ - if (Is_Atomic_Or_VFA (gnat_entity)) + if (Is_Full_Access (gnat_entity)) check_ok_for_atomic_type (gnu_type, gnat_entity, false); /* If this is a renaming, avoid as much as possible to create a new @@ -2876,7 +2876,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) { const int quals = TYPE_QUAL_VOLATILE - | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0); + | (Is_Full_Access (gnat_entity) ? TYPE_QUAL_ATOMIC : 0); gnu_type = change_qualified_type (gnu_type, quals); } /* Make it artificial only if the base type was artificial too. @@ -4362,12 +4362,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnat_entity); } } - else if (Is_Atomic_Or_VFA (gnat_entity) && !gnu_size + else if (Is_Full_Access (gnat_entity) && !gnu_size && tree_fits_uhwi_p (TYPE_SIZE (gnu_type)) && integer_pow2p (TYPE_SIZE (gnu_type))) align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (TYPE_SIZE (gnu_type))); - else if (Is_Atomic_Or_VFA (gnat_entity) && gnu_size + else if (Is_Full_Access (gnat_entity) && gnu_size && tree_fits_uhwi_p (gnu_size) && integer_pow2p (gnu_size)) align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (gnu_size)); @@ -4425,7 +4425,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If the size is self-referential, annotate the maximum value after saturating it, if need be, to avoid a No_Uint value. */ if (CONTAINS_PLACEHOLDER_P (gnu_size)) - gnu_size = maybe_saturate_size (max_size (gnu_size, true)); + { + const unsigned int align + = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT; + gnu_size + = maybe_saturate_size (max_size (gnu_size, true), align); + } /* If we are just annotating types and the type is tagged, the tag and the parent components are not generated by the front-end so @@ -4461,7 +4466,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_size = size_binop (PLUS_EXPR, gnu_size, offset); } - gnu_size = maybe_saturate_size (round_up (gnu_size, align)); + gnu_size + = maybe_saturate_size (round_up (gnu_size, align), align); Set_Esize (gnat_entity, annotate_value (gnu_size)); /* Tagged types are Strict_Alignment so RM_Size = Esize. */ @@ -4597,7 +4603,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } /* Now check if the type allows atomic access. */ - if (Is_Atomic_Or_VFA (gnat_entity)) + if (Is_Full_Access (gnat_entity)) check_ok_for_atomic_type (gnu_type, gnat_entity, false); /* If this is not an unconstrained array type, set some flags. */ @@ -4715,7 +4721,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) { const int quals = TYPE_QUAL_VOLATILE - | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0); + | (Is_Full_Access (gnat_entity) ? TYPE_QUAL_ATOMIC : 0); gnu_type = change_qualified_type (gnu_type, quals); } @@ -5244,7 +5250,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, } /* Now check if the type of the component allows atomic access. */ - if (Has_Atomic_Components (gnat_array) || Is_Atomic_Or_VFA (gnat_type)) + if (Has_Atomic_Components (gnat_array) || Is_Full_Access (gnat_type)) check_ok_for_atomic_type (gnu_type, gnat_array, true); /* If the component type is a padded type made for a non-bit-packed array @@ -7099,9 +7105,9 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, const Entity_Id gnat_field_type = Etype (gnat_field); tree gnu_field_type = gnat_to_gnu_type (gnat_field_type); tree gnu_field_id = get_entity_name (gnat_field); - const bool is_atomic - = (Is_Atomic_Or_VFA (gnat_field) || Is_Atomic_Or_VFA (gnat_field_type)); const bool is_aliased = Is_Aliased (gnat_field); + const bool is_full_access + = (Is_Full_Access (gnat_field) || Is_Full_Access (gnat_field_type)); const bool is_independent = (Is_Independent (gnat_field) || Is_Independent (gnat_field_type)); const bool is_volatile @@ -7116,7 +7122,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, only constraint is the implementation advice whereby only the bits of the components should be accessed if they both start and end on byte boundaries, but that should be guaranteed by the GCC memory model. - Note that we have some redundancies (is_atomic => is_independent, + Note that we have some redundancies (is_full_access => is_independent, is_aliased => is_independent and is_by_ref => is_strict_alignment) so the following formula is sufficient. */ const bool needs_strict_alignment = (is_independent || is_strict_alignment); @@ -7125,10 +7131,16 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, bool is_bitfield; /* The qualifier to be used in messages. */ - if (is_atomic) - field_s = "atomic&"; - else if (is_aliased) + if (is_aliased) field_s = "aliased&"; + else if (is_full_access) + { + if (Is_Volatile_Full_Access (gnat_field) + || Is_Volatile_Full_Access (gnat_field_type)) + field_s = "volatile full access&"; + else + field_s = "atomic&"; + } else if (is_independent) field_s = "independent&"; else if (is_by_ref) @@ -7139,7 +7151,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, field_s = "&"; /* The message to be used for incompatible size. */ - if (is_atomic || is_aliased) + if (is_aliased || is_full_access) size_s = "size for %s must be ^"; else if (field_s) size_s = "size for %s too small{, minimum allowed is ^}"; @@ -7231,7 +7243,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, } /* Now check if the type of the field allows atomic access. */ - if (Is_Atomic_Or_VFA (gnat_field)) + if (Is_Full_Access (gnat_field)) { const unsigned int align = promote_object_alignment (gnu_field_type, gnat_field); @@ -7327,7 +7339,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, /* If the size is lower than that of the type, or greater for atomic and aliased, then error out and reset the size. */ else if ((cmp = tree_int_cst_compare (gnu_size, type_size)) < 0 - || (cmp > 0 && (is_atomic || is_aliased))) + || (cmp > 0 && (is_aliased || is_full_access))) { char s[128]; snprintf (s, sizeof (s), size_s, field_s); @@ -8946,15 +8958,21 @@ build_variant_list (tree gnu_qual_union_type, Node_Id gnat_variant_part, } /* If SIZE has overflowed, return the maximum valid size, which is the upper - bound of the signed sizetype in bits; otherwise return SIZE unmodified. */ + bound of the signed sizetype in bits, rounded down to ALIGN. Otherwise + return SIZE unmodified. */ static tree -maybe_saturate_size (tree size) +maybe_saturate_size (tree size, unsigned int align) { if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size)) - size = size_binop (MULT_EXPR, - fold_convert (bitsizetype, TYPE_MAX_VALUE (ssizetype)), - build_int_cst (bitsizetype, BITS_PER_UNIT)); + { + size + = size_binop (MULT_EXPR, + fold_convert (bitsizetype, TYPE_MAX_VALUE (ssizetype)), + build_int_cst (bitsizetype, BITS_PER_UNIT)); + size = round_down (size, align); + } + return size; } @@ -9266,8 +9284,8 @@ promote_object_alignment (tree gnu_type, Entity_Id gnat_entity) the NRV optimization for it. No point in jumping through all the hoops needed in order to support BIGGEST_ALIGNMENT if we don't really have to. So we cap to the smallest alignment that corresponds to a known efficient - memory access pattern, except for Atomic and Volatile_Full_Access. */ - if (Is_Atomic_Or_VFA (gnat_entity)) + memory access pattern, except for a full access entity. */ + if (Is_Full_Access (gnat_entity)) { size_cap = UINT_MAX; align_cap = BIGGEST_ALIGNMENT; diff --git a/gcc/ada/libgnat/system.ads b/gcc/ada/gcc-interface/system.ads index f54c43f..f54c43f 100644 --- a/gcc/ada/libgnat/system.ads +++ b/gcc/ada/gcc-interface/system.ads diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 3491451..059e1a4 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -50,6 +50,7 @@ #include "gomp-constants.h" #include "stringpool.h" #include "attribs.h" +#include "tree-nested.h" #include "ada.h" #include "adadecode.h" @@ -900,7 +901,7 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant, the actual assignment might end up being done component-wise. */ return (!constant ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node))) - && Is_Atomic_Or_VFA (Defining_Entity (gnat_parent))) + && Is_Full_Access (Defining_Entity (gnat_parent))) /* We don't use a constructor if this is a class-wide object because the effective type of the object is the equivalent type of the class-wide subtype and it smashes most of the @@ -915,7 +916,7 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant, || Name (gnat_parent) == gnat_node || (Is_Composite_Type (Underlying_Type (Etype (gnat_node))) && Is_Entity_Name (Name (gnat_parent)) - && Is_Atomic_Or_VFA (Entity (Name (gnat_parent))))); + && Is_Full_Access (Entity (Name (gnat_parent))))); case N_Unchecked_Type_Conversion: if (!constant) @@ -3696,7 +3697,8 @@ finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data) static void walk_nesting_tree (struct cgraph_node *node, walk_tree_fn func, void *data) { - for (node = node->nested; node; node = node->next_nested) + for (node = first_nested_function (node); + node; node = next_nested_function (node)) { walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), func, data); walk_nesting_tree (node, func, data); @@ -4017,6 +4019,11 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnat_poplevel (); gnu_result = end_stmt_group (); + /* Attempt setting the end_locus of our GCC body tree, typically a BIND_EXPR, + then the end_locus of our GCC subprogram declaration tree. */ + set_end_locus_from_node (gnu_result, gnat_node); + set_end_locus_from_node (gnu_subprog_decl, gnat_node); + /* If we populated the parameter attributes cache, we need to make sure that the cached expressions are evaluated on all the possible paths leading to their uses. So we force their evaluation on entry of the function. */ @@ -4111,12 +4118,6 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnu_return_label_stack->pop (); - /* Attempt setting the end_locus of our GCC body tree, typically a - BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram - declaration tree. */ - set_end_locus_from_node (gnu_result, gnat_node); - set_end_locus_from_node (gnu_subprog_decl, gnat_node); - /* On SEH targets, install an exception handler around the main entry point to catch unhandled exceptions. */ if (DECL_NAME (gnu_subprog_decl) == main_identifier_node diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 048a0cf..d50872f 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -92,6 +92,7 @@ static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *); static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *); static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *); static tree handle_stack_protect_attribute (tree *, tree, tree, int, bool *); +static tree handle_no_stack_protector_attribute (tree *, tree, tree, int, bool *); static tree handle_noinline_attribute (tree *, tree, tree, int, bool *); static tree handle_noclone_attribute (tree *, tree, tree, int, bool *); static tree handle_noicf_attribute (tree *, tree, tree, int, bool *); @@ -116,6 +117,13 @@ static const struct attribute_spec::exclusions attr_cold_hot_exclusions[] = { NULL , false, false, false } }; +static const struct attribute_spec::exclusions attr_stack_protect_exclusions[] = +{ + { "stack_protect", true, false, false }, + { "no_stack_protector", true, false, false }, + { NULL, false, false, false }, +}; + /* Fake handler for attributes we don't properly support, typically because they'd require dragging a lot of the common-c front-end circuitry. */ static tree fake_attribute_handler (tree *, tree, tree, int, bool *); @@ -141,7 +149,11 @@ const struct attribute_spec gnat_internal_attribute_table[] = { "noreturn", 0, 0, true, false, false, false, handle_noreturn_attribute, NULL }, { "stack_protect",0, 0, true, false, false, false, - handle_stack_protect_attribute, NULL }, + handle_stack_protect_attribute, + attr_stack_protect_exclusions }, + { "no_stack_protector",0, 0, true, false, false, false, + handle_no_stack_protector_attribute, + attr_stack_protect_exclusions }, { "noinline", 0, 0, true, false, false, false, handle_noinline_attribute, NULL }, { "noclone", 0, 0, true, false, false, false, @@ -6560,6 +6572,23 @@ handle_stack_protect_attribute (tree *node, tree name, tree, int, return NULL_TREE; } +/* Handle a "no_stack_protector" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_no_stack_protector_attribute (tree *node, tree name, tree, int, + bool *no_add_attrs) +{ + if (TREE_CODE (*node) != FUNCTION_DECL) + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + + /* Handle a "noinline" attribute; arguments as in struct attribute_spec.handler. */ diff --git a/gcc/ada/get_targ.adb b/gcc/ada/get_targ.adb index ef307f2..8b35b1c 100644 --- a/gcc/ada/get_targ.adb +++ b/gcc/ada/get_targ.adb @@ -126,6 +126,18 @@ package body Get_Targ is return C_Get_Long_Long_Size; end Get_Long_Long_Size; + ----------------------------- + -- Get_Long_Long_Long_Size -- + ----------------------------- + + function Get_Long_Long_Long_Size return Pos is + function C_Get_Long_Long_Long_Size return Pos; + pragma Import (C, C_Get_Long_Long_Long_Size, + "get_target_long_long_long_size"); + begin + return C_Get_Long_Long_Long_Size; + end Get_Long_Long_Long_Size; + ---------------------- -- Get_Pointer_Size -- ---------------------- @@ -309,10 +321,11 @@ package body Get_Targ is function Width_From_Size (Size : Pos) return Pos is begin case Size is - when 8 => return 4; - when 16 => return 6; - when 32 => return 11; - when 64 => return 21; + when 8 => return 4; + when 16 => return 6; + when 32 => return 11; + when 64 => return 21; + when 128 => return 40; when others => raise Program_Error; end case; end Width_From_Size; diff --git a/gcc/ada/get_targ.ads b/gcc/ada/get_targ.ads index 5a21418..676e117 100644 --- a/gcc/ada/get_targ.ads +++ b/gcc/ada/get_targ.ads @@ -68,6 +68,9 @@ package Get_Targ is function Get_Long_Long_Size return Pos; -- Size of Standard.Long_Long_Integer + function Get_Long_Long_Long_Size return Pos; + -- Size of Standard.Long_Long_Long_Integer + function Get_Pointer_Size return Pos; -- Size of System.Address diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 54d52ba..866f7f7 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -34,7 +34,6 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Sem; use Sem; with Sem_Aux; use Sem_Aux; -with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Prag; use Sem_Prag; @@ -65,6 +64,12 @@ package body Ghost is -- Local subprograms -- ----------------------- + function Whole_Object_Ref (Ref : Node_Id) return Node_Id; + -- For a name that denotes an object, returns a name that denotes the whole + -- object, declared by an object declaration, formal parameter declaration, + -- etc. For example, for P.X.Comp (J), if P is a package X is a record + -- object, this returns P.X. + function Ghost_Entity (Ref : Node_Id) return Entity_Id; pragma Inline (Ghost_Entity); -- Obtain the entity of a Ghost entity from reference Ref. Return Empty if @@ -1009,10 +1014,8 @@ package body Ghost is ---------------------------- function Ultimate_Original_Node (Nod : Node_Id) return Node_Id is - Res : Node_Id; - + Res : Node_Id := Nod; begin - Res := Nod; while Original_Node (Res) /= Res loop Res := Original_Node (Res); end loop; @@ -1176,61 +1179,73 @@ package body Ghost is ----------------------------------- procedure Mark_And_Set_Ghost_Assignment (N : Node_Id) is - Orig_Lhs : constant Node_Id := Name (N); - Orig_Ref : constant Node_Id := Ultimate_Prefix (Orig_Lhs); - - Id : Entity_Id; - Ref : Node_Id; + -- A ghost assignment is an assignment whose left-hand side denotes a + -- ghost object. Subcomponents are not marked "ghost", so we need to + -- find the containing "whole" object. So, for "P.X.Comp (J) := ...", + -- where P is a package, X is a record, and Comp is an array, we need + -- to check the ghost flags of X. + Orig_Lhs : constant Node_Id := Name (N); begin - -- A reference to a whole Ghost object (SPARK RM 6.9(1)) appears as an - -- identifier. If the reference has not been analyzed yet, preanalyze a - -- copy of the reference to discover the nature of its entity. - - if Nkind (Orig_Ref) = N_Identifier and then not Analyzed (Orig_Ref) then - Ref := New_Copy_Tree (Orig_Ref); - - -- Alter the assignment statement by setting its left-hand side to - -- the copy. - - Set_Name (N, Ref); - Set_Parent (Ref, N); - - -- Preanalysis is carried out by looking for a Ghost entity while - -- suppressing all possible side effects. - - Find_Direct_Name - (N => Ref, - Errors_OK => False, - Marker_OK => False, - Reference_OK => False); - - -- Restore the original state of the assignment statement - - Set_Name (N, Orig_Lhs); + -- Ghost assignments are irrelevant when the expander is inactive, and + -- processing them in that mode can lead to spurious errors. + + if Expander_Active then + if not Analyzed (Orig_Lhs) + and then Nkind (Orig_Lhs) = N_Indexed_Component + and then Nkind (Prefix (Orig_Lhs)) = N_Selected_Component + and then Nkind (Prefix (Prefix (Orig_Lhs))) = + N_Indexed_Component + then + Analyze (Orig_Lhs); + end if; - -- A potential reference to a Ghost entity is already properly resolved - -- when the left-hand side is analyzed. + -- Make sure Lhs is at least preanalyzed, so we can tell whether + -- it denotes a ghost variable. In some cases we need to do a full + -- analysis, or else the back end gets confused. Note that in the + -- preanalysis case, we are preanalyzing a copy of the left-hand + -- side name, temporarily attached to the tree. - else - Ref := Orig_Ref; - end if; + declare + Lhs : constant Node_Id := + (if Analyzed (Orig_Lhs) then Orig_Lhs + else New_Copy_Tree (Orig_Lhs)); + begin + if not Analyzed (Lhs) then + Set_Name (N, Lhs); + Set_Parent (Lhs, N); + Preanalyze_Without_Errors (Lhs); + Set_Name (N, Orig_Lhs); + end if; - -- An assignment statement becomes Ghost when its target denotes a Ghost - -- object. Install the Ghost mode of the target. + declare + Whole : constant Node_Id := Whole_Object_Ref (Lhs); + Id : Entity_Id; + begin + if Is_Entity_Name (Whole) then + Id := Entity (Whole); - Id := Ghost_Entity (Ref); + if Present (Id) then + -- Left-hand side denotes a Checked ghost entity, so + -- install the region. - if Present (Id) then - if Is_Checked_Ghost_Entity (Id) then - Install_Ghost_Region (Check, N); + if Is_Checked_Ghost_Entity (Id) then + Install_Ghost_Region (Check, N); - elsif Is_Ignored_Ghost_Entity (Id) then - Install_Ghost_Region (Ignore, N); + -- Left-hand side denotes an Ignored ghost entity, so + -- install the region, and mark the assignment statement + -- as an ignored ghost assignment, so it will be removed + -- later. - Set_Is_Ignored_Ghost_Node (N); - Record_Ignored_Ghost_Node (N); - end if; + elsif Is_Ignored_Ghost_Entity (Id) then + Install_Ghost_Region (Ignore, N); + Set_Is_Ignored_Ghost_Node (N); + Record_Ignored_Ghost_Node (N); + end if; + end if; + end if; + end; + end; end if; end Mark_And_Set_Ghost_Assignment; @@ -1855,4 +1870,24 @@ package body Ghost is end if; end Set_Is_Ghost_Entity; + ---------------------- + -- Whole_Object_Ref -- + ---------------------- + + function Whole_Object_Ref (Ref : Node_Id) return Node_Id is + begin + if Nkind (Ref) in N_Indexed_Component | N_Slice + or else (Nkind (Ref) = N_Selected_Component + and then Is_Object_Reference (Prefix (Ref))) + then + if Is_Access_Type (Etype (Prefix (Ref))) then + return Ref; + else + return Whole_Object_Ref (Prefix (Ref)); + end if; + else + return Ref; + end if; + end Whole_Object_Ref; + end Ghost; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index a9f48ce..180a140 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -342,10 +342,6 @@ procedure Gnat1drv is Xref_Active := True; - -- Polling mode forced off, since it generates confusing junk - - Polling_Required := False; - -- Set operating mode to Generate_Code to benefit from full front-end -- expansion (e.g. generics). @@ -531,10 +527,6 @@ procedure Gnat1drv is Xref_Active := True; - -- Polling mode forced off, since it generates confusing junk - - Polling_Required := False; - -- Set operating mode to Check_Semantics, but a light front-end -- expansion is still performed. @@ -807,6 +799,24 @@ procedure Gnat1drv is Set_Standard_Output; end if; + -- Enable or disable the support for 128-bit types. It is automatically + -- enabled if the back end supports them, unless -gnatd.H is specified. + + Enable_128bit_Types := Ttypes.Standard_Long_Long_Long_Integer_Size = 128; + + if Enable_128bit_Types and then Debug_Flag_Dot_HH then + Enable_128bit_Types := False; + + Ttypes.Standard_Long_Long_Long_Integer_Size := + Ttypes.Standard_Long_Long_Integer_Size; + Ttypes.Standard_Long_Long_Long_Integer_Width := + Ttypes.Standard_Long_Long_Integer_Width; + Ttypes.System_Max_Integer_Size := + Ttypes.Standard_Long_Long_Integer_Size; + Ttypes.System_Max_Binary_Modulus_Power := + Ttypes.Standard_Long_Long_Integer_Size; + end if; + -- Finally capture adjusted value of Suppress_Options as the initial -- value for Scope_Suppress, which will be modified as we move from -- scope to scope (by Suppress/Unsuppress/Overflow_Checks pragmas). @@ -1075,9 +1085,13 @@ begin -- Initialize all packages. For the most part, these initialization -- calls can be made in any order. Exceptions are as follows: - -- Lib.Initialize need to be called before Scan_Compiler_Arguments, + -- Lib.Initialize needs to be called before Scan_Compiler_Arguments, -- because it initializes a table filled by Scan_Compiler_Arguments. + -- Atree.Initialize needs to be called after Scan_Compiler_Arguments, + -- because the value specified by the -gnaten switch is used by + -- Atree.Initialize. + Osint.Initialize; Fmap.Reset_Tables; Lib.Initialize; @@ -1700,7 +1714,10 @@ begin end; <<End_Of_Program>> - null; + + if Debug_Flag_Dot_AA then + Atree.Print_Statistics; + end if; -- The outer exception handler handles an unrecoverable error diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb new file mode 100644 index 0000000..39a55e6 --- /dev/null +++ b/gcc/ada/gnat_cuda.adb @@ -0,0 +1,586 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C U D A -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2020, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines CUDA-specific datastructures and functions. + +with Atree; use Atree; +with Debug; use Debug; +with Elists; use Elists; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sinfo; use Sinfo; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Sem; use Sem; +with Sem_Util; use Sem_Util; +with Snames; use Snames; + +with GNAT.HTable; + +package body GNAT_CUDA is + + -------------------------------------- + -- Hash Table for CUDA_Global nodes -- + -------------------------------------- + + type Hash_Range is range 0 .. 510; + -- Size of hash table headers + + function Hash (F : Entity_Id) return Hash_Range; + -- Hash function for hash table + + package CUDA_Kernels_Table is new + GNAT.HTable.Simple_HTable + (Header_Num => Hash_Range, + Element => Elist_Id, + No_Element => No_Elist, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- The keys of this table are package entities whose bodies contain at + -- least one procedure marked with aspect CUDA_Global. The values are + -- Elists of the marked procedures. + + function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id; + -- Returns an Elist of all procedures marked with pragma CUDA_Global that + -- are declared within package body Pack_Body. Returns No_Elist if + -- Pack_Id does not contain such procedures. + + procedure Set_CUDA_Kernels + (Pack_Id : Entity_Id; + Kernels : Elist_Id); + -- Stores Kernels as the list of kernels belonging to the package entity + -- Pack_Id. Pack_Id must not have a list of kernels. + + --------------------- + -- Add_CUDA_Kernel -- + --------------------- + + procedure Add_CUDA_Kernel + (Pack_Id : Entity_Id; + Kernel : Entity_Id) + is + Kernels : Elist_Id := Get_CUDA_Kernels (Pack_Id); + begin + if Kernels = No_Elist then + Kernels := New_Elmt_List; + Set_CUDA_Kernels (Pack_Id, Kernels); + end if; + Append_Elmt (Kernel, Kernels); + end Add_CUDA_Kernel; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Entity_Id) return Hash_Range is + begin + return Hash_Range (F mod 511); + end Hash; + + ---------------------- + -- Get_CUDA_Kernels -- + ---------------------- + + function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id is + begin + return CUDA_Kernels_Table.Get (Pack_Id); + end Get_CUDA_Kernels; + + ------------------------------------------ + -- Build_And_Insert_CUDA_Initialization -- + ------------------------------------------ + + procedure Build_And_Insert_CUDA_Initialization (N : Node_Id) is + + -- For the following kernel declaration: + -- + -- package body <Package_Name> is + -- procedure <Proc_Name> (X : Integer) with CUDA_Global; + -- end package; + -- + -- Insert the following declarations: + -- + -- Fat_Binary : System.Address; + -- pragma Import + -- (Convention => C, + -- Entity => Fat_Binary, + -- External_Name => "_binary_<Package_Name>_fatbin_start"); + -- + -- Wrapper : Fatbin_Wrapper := + -- (16#466243b1#, 1, Fat_Binary'Address, System.Null_Address); + -- + -- Proc_Symbol_Name : Interfaces.C.Strings.Chars_Ptr := + -- Interfaces.C.Strings.New_Char_Array("<Proc_Name>"); + -- + -- Fat_Binary_Handle : System.Address := + -- CUDA.Internal.Register_Fat_Binary (Wrapper'Address); + -- + -- procedure Initialize_CUDA_Kernel is + -- begin + -- CUDA.Internal.Register_Function + -- (Fat_Binary_Handle, + -- <Proc_Name>'Address, + -- Proc_Symbol_Name, + -- Proc_Symbol_Name, + -- -1, + -- System.Null_Address, + -- System.Null_Address, + -- System.Null_Address, + -- System.Null_Address, + -- System.Null_Address); + -- CUDA.Internal.Register_Fat_Binary_End (Fat_Binary_Handle); + -- end Initialize_CUDA_Kernel; + -- + -- Proc_Symbol_Name is the name of the procedure marked with + -- CUDA_Global. The CUDA runtime uses this in order to be able to find + -- kernels in the fat binary, so it has to match the name of the + -- procedure symbol compiled by GNAT_LLVM. When looking at the code + -- generated by NVCC, it seems that the CUDA runtime also needs the name + -- of the procedure symbol of the host. Fortuantely, the procedures are + -- named the same way whether they are compiled for the host or the + -- device, so we use Vector_Add_Name to specify the name of the symbol + -- for both the host and the device. The meaning of the rest of the + -- arguments is unknown. + + function Build_CUDA_Init_Proc + (Init_Id : Entity_Id; + CUDA_Kernels : Elist_Id; + Handle_Id : Entity_Id; + Pack_Decls : List_Id) return Node_Id; + -- Create the declaration of Init_Id, the function that binds each + -- kernel present in CUDA_Kernels with the fat binary Handle_Id and then + -- tells the CUDA runtime that no new function will be bound to the fat + -- binary. + + function Build_Fat_Binary_Declaration + (Bin_Id : Entity_Id) return Node_Id; + -- Create a declaration for Bin_Id, the entity that represents the fat + -- binary, i.e.: + -- + -- Bin_Id : System.Address; + + function Build_Fat_Binary_Handle_Declaration + (Handle_Id : Entity_Id; + Wrapper_Id : Entity_Id) return Node_Id; + -- Create the declaration of Handle_Id, a System.Address that will + -- receive the results of passing the address of Wrapper_Id to + -- CUDA.Register_Fat_Binary, i.e.: + -- + -- Handle_Id : System.Address := + -- CUDA.Register_Fat_Binary (Wrapper_Id'Address) + + function Build_Fat_Binary_Wrapper_Declaration + (Wrapper_Id : Entity_Id; + Bin_Id : Entity_Id) return Node_Id; + -- Create the declaration of the fat binary wrapper Wrapper_Id, which + -- holds magic numbers and Bin_Id'Address, i.e.: + -- + -- Wrapper_Id : System.Address := + -- (16#466243b1#, 1, Bin_Id'Address, System.Null_Address); + + function Build_Import_Pragma + (Bin_Id : Entity_Id; + Pack_Body : Node_Id) return Node_Id; + -- Create a pragma that will bind the fat binary Bin_Id to its external + -- symbol. N is the package body Bin_Id belongs to, i.e.: + -- + -- pragma Import + -- (Convention => C, + -- Entity => Bin_Id, + -- External_Name => "_binary_<Pack_Body's name>_fatbin_start"); + + function Build_Kernel_Name_Declaration + (Kernel : Entity_Id) return Node_Id; + -- Create the declaration of a C string that contains the name of + -- Kernel's symbol, i.e.: + -- + -- Kernel : Interfaces.C.Strings.Chars_Ptr := + -- Interfaces.C.Strings.New_Char_Array("<Kernel's name>"); + + function Build_Register_Procedure_Call + (Loc : Source_Ptr; + Bin : Entity_Id; + Kernel : Entity_Id; + Kernel_Name : Entity_Id) return Node_Id; + -- Return a call to CUDA.Internal.Register_Function that binds Kernel + -- (the entity of a procedure) to the symbol described by the C string + -- Kernel_Name in the fat binary Bin, using Loc as location. + + -------------------------- + -- Build_CUDA_Init_Proc -- + -------------------------- + + function Build_CUDA_Init_Proc + (Init_Id : Entity_Id; + CUDA_Kernels : Elist_Id; + Handle_Id : Entity_Id; + Pack_Decls : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Init_Id); + + Stmts : constant List_Id := New_List; + -- List of statements that will be used by the cuda initialization + -- function. + + New_Stmt : Node_Id; + -- Temporary variable to hold the various newly-created nodes. + + Kernel_Elmt : Elmt_Id; + Kernel_Id : Entity_Id; + + begin + -- For each CUDA_Global function, declare a C string that holds + -- its symbol's name (i.e. packagename __ functionname). + + -- Also create a function call to CUDA.Internal.Register_Function + -- that takes the declared C string, a pointer to the function and + -- the fat binary handle. + + Kernel_Elmt := First_Elmt (CUDA_Kernels); + while Present (Kernel_Elmt) loop + Kernel_Id := Node (Kernel_Elmt); + + New_Stmt := + Build_Kernel_Name_Declaration (Kernel_Id); + Append (New_Stmt, Pack_Decls); + Analyze (New_Stmt); + + Append_To (Stmts, + Build_Register_Procedure_Call (Loc, + Bin => Handle_Id, + Kernel => Kernel_Id, + Kernel_Name => Defining_Entity (New_Stmt))); + + Next_Elmt (Kernel_Elmt); + end loop; + + -- Finish the CUDA initialization function: add a call to + -- register_fat_binary_end, to let the CUDA runtime know that we + -- won't be registering any other symbol with the current fat binary. + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Fat_Binary_End), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Handle_Id, Loc)))); + + -- Now that we have all the declarations and calls we need, we can + -- build and and return the initialization procedure. + + return + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, Init_Id), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + end Build_CUDA_Init_Proc; + + ---------------------------------- + -- Build_Fat_Binary_Declaration -- + ---------------------------------- + + function Build_Fat_Binary_Declaration + (Bin_Id : Entity_Id) return Node_Id + is + begin + return + Make_Object_Declaration (Sloc (Bin_Id), + Defining_Identifier => Bin_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Sloc (Bin_Id))); + end Build_Fat_Binary_Declaration; + + ----------------------------------------- + -- Build_Fat_Binary_Handle_Declaration -- + ----------------------------------------- + + function Build_Fat_Binary_Handle_Declaration + (Handle_Id : Entity_Id; + Wrapper_Id : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Handle_Id); + begin + -- Generate: + -- Handle_Id : System.Address := + -- CUDA.Register_Fat_Binary (Wrapper_Id'Address); + + return + Make_Object_Declaration (Loc, + Defining_Identifier => Handle_Id, + Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Fat_Binary), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Wrapper_Id, Loc), + Attribute_Name => Name_Address)))); + end Build_Fat_Binary_Handle_Declaration; + + ------------------------------------------ + -- Build_Fat_Binary_Wrapper_Declaration -- + ------------------------------------------ + + function Build_Fat_Binary_Wrapper_Declaration + (Wrapper_Id : Entity_Id; + Bin_Id : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Wrapper_Id); + begin + return + Make_Object_Declaration (Loc, + Defining_Identifier => Wrapper_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Fatbin_Wrapper), Loc), + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Integer_Literal (Loc, UI_From_Int (16#466243b1#)), + Make_Integer_Literal (Loc, UI_From_Int (1)), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Bin_Id, Loc), + Attribute_Name => Name_Address), + New_Occurrence_Of (RTE (RE_Null_Address), Loc)))); + end Build_Fat_Binary_Wrapper_Declaration; + + ------------------------- + -- Build_Import_Pragma -- + ------------------------- + + function Build_Import_Pragma + (Bin_Id : Entity_Id; + Pack_Body : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Bin_Id); + External_Symbol : String_Id; + begin + Start_String; + Store_String_Chars + ("_binary_" + & Get_Name_String (Chars (Defining_Unit_Name (Pack_Body))) + & "_fatbin_start"); + External_Symbol := End_String; + + return + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Loc, Name_Import), + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Chars => Name_Convention, + Expression => Make_Identifier (Loc, Name_C)), + Make_Pragma_Argument_Association (Loc, + Chars => Name_Entity, + Expression => New_Occurrence_Of (Bin_Id, Loc)), + Make_Pragma_Argument_Association (Loc, + Chars => Name_External_Name, + Expression => Make_String_Literal (Loc, External_Symbol)))); + end Build_Import_Pragma; + + ------------------------------------- + -- Build_Kernel_Name_Declaration -- + ------------------------------------- + + function Build_Kernel_Name_Declaration + (Kernel : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Kernel); + + Package_Name : constant String := + Get_Name_String (Chars (Scope (Kernel))); + + Symbol_Name : constant String := Get_Name_String (Chars (Kernel)); + + Kernel_Name : String_Id; + begin + Start_String; + Store_String_Chars (Package_Name & "__" & Symbol_Name); + Kernel_Name := End_String; + + return + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'C'), + Object_Definition => + New_Occurrence_Of (RTE (RE_Chars_Ptr), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_New_Char_Array), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Kernel_Name)))); + end Build_Kernel_Name_Declaration; + + ----------------------------------- + -- Build_Register_Procedure_Call -- + ----------------------------------- + + function Build_Register_Procedure_Call + (Loc : Source_Ptr; + Bin : Entity_Id; + Kernel : Entity_Id; + Kernel_Name : Entity_Id) return Node_Id + is + Args : constant List_Id := New_List; + begin + -- First argument: the handle of the fat binary. + + Append (New_Occurrence_Of (Bin, Loc), Args); + + -- Second argument: the host address of the function that is + -- marked with CUDA_Global. + + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Kernel, Loc), + Attribute_Name => Name_Address)); + + -- Third argument, the name of the function on the host. + + Append (New_Occurrence_Of (Kernel_Name, Loc), Args); + + -- Fourth argument, the name of the function on the device. + + Append (New_Occurrence_Of (Kernel_Name, Loc), Args); + + -- Fith argument: -1. Meaning unknown - this has been copied from + -- LLVM. + + Append (Make_Integer_Literal (Loc, UI_From_Int (-1)), Args); + + -- Args 6, 7, 8, 9, 10: Null pointers. Again, meaning unknown. + + for Arg_Count in 1 .. 5 loop + Append_To (Args, New_Occurrence_Of (RTE (RE_Null_Address), Loc)); + end loop; + + -- Build the call to CUDARegisterFunction, passing the argument + -- list we just built. + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Function), Loc), + Parameter_Associations => Args); + end Build_Register_Procedure_Call; + + -- Local declarations + + Loc : constant Source_Ptr := Sloc (N); + + Spec_Id : constant Node_Id := Corresponding_Spec (N); + -- The specification of the package we're adding a cuda init func to. + + Pack_Decls : constant List_Id := Declarations (N); + + CUDA_Node_List : constant Elist_Id := Get_CUDA_Kernels (Spec_Id); + -- CUDA nodes that belong to the package. + + CUDA_Init_Func : Entity_Id; + -- Entity of the cuda init func. + + Fat_Binary : Entity_Id; + -- Entity of the fat binary of N. Bound to said fat binary by a pragma. + + Fat_Binary_Handle : Entity_Id; + -- Entity of the result of passing the fat binary wrapper to. + -- CUDA.Register_Fat_Binary. + + Fat_Binary_Wrapper : Entity_Id; + -- Entity of a record that holds a bunch of magic numbers and a + -- reference to Fat_Binary. + + New_Stmt : Node_Id; + -- Node to store newly-created declarations + + -- Start of processing for Build_And_Insert_CUDA_Initialization + + begin + if CUDA_Node_List = No_Elist or not Debug_Flag_Underscore_C then + return; + end if; + + Fat_Binary := Make_Temporary (Loc, 'C'); + New_Stmt := Build_Fat_Binary_Declaration (Fat_Binary); + Append_To (Pack_Decls, New_Stmt); + Analyze (New_Stmt); + + New_Stmt := Build_Import_Pragma (Fat_Binary, N); + Append_To (Pack_Decls, New_Stmt); + Analyze (New_Stmt); + + Fat_Binary_Wrapper := Make_Temporary (Loc, 'C'); + New_Stmt := + Build_Fat_Binary_Wrapper_Declaration + (Wrapper_Id => Fat_Binary_Wrapper, + Bin_Id => Fat_Binary); + Append_To (Pack_Decls, New_Stmt); + Analyze (New_Stmt); + + Fat_Binary_Handle := Make_Temporary (Loc, 'C'); + New_Stmt := + Build_Fat_Binary_Handle_Declaration + (Fat_Binary_Handle, Fat_Binary_Wrapper); + Append_To (Pack_Decls, New_Stmt); + Analyze (New_Stmt); + + CUDA_Init_Func := Make_Temporary (Loc, 'C'); + New_Stmt := + Build_CUDA_Init_Proc + (Init_Id => CUDA_Init_Func, + CUDA_Kernels => CUDA_Node_List, + Handle_Id => Fat_Binary_Handle, + Pack_Decls => Pack_Decls); + Append_To (Pack_Decls, New_Stmt); + Analyze (New_Stmt); + + New_Stmt := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (CUDA_Init_Func, Loc)); + Append_To (Pack_Decls, New_Stmt); + Analyze (New_Stmt); + end Build_And_Insert_CUDA_Initialization; + + -------------------- + -- Set_CUDA_Nodes -- + -------------------- + + procedure Set_CUDA_Kernels + (Pack_Id : Entity_Id; + Kernels : Elist_Id) + is + begin + pragma Assert (Get_CUDA_Kernels (Pack_Id) = No_Elist); + CUDA_Kernels_Table.Set (Pack_Id, Kernels); + end Set_CUDA_Kernels; + +end GNAT_CUDA; diff --git a/gcc/ada/gnat_cuda.ads b/gcc/ada/gnat_cuda.ads new file mode 100644 index 0000000..e27be34 --- /dev/null +++ b/gcc/ada/gnat_cuda.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- C U D A -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010-2020, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines CUDA-specific datastructures and subprograms. +-- +-- Compiling for CUDA requires compiling for two targets. One is the CPU (more +-- frequently named "host"), the other is the GPU (the "device"). Compiling +-- for the host requires compiling the whole program. Compiling for the device +-- only requires compiling packages that contain CUDA kernels. +-- +-- When compiling for the device, GNAT-LLVM is used. It produces assembly +-- tailored to Nvidia's GPU (NVPTX). This NVPTX code is then assembled into +-- an object file by ptxas, an assembler provided by Nvidia. This object file +-- is then combined with its source code into a fat binary by a tool named +-- `fatbin`, also provided by Nvidia. The resulting fat binary is turned into +-- a regular object file by the host's linker and linked with the program that +-- executes on the host. +-- +-- A CUDA kernel is a procedure marked with the CUDA_Global pragma or aspect. +-- CUDA_Global does not have any effect when compiling for the device. When +-- compiling for the host, the frontend stores procedures marked with +-- CUDA_Global in a hash table the key of which is the Node_Id of the package +-- body that contains the CUDA_Global procedure. This is done in sem_prag.adb. +-- Once the declarations of a package body have been analyzed, variable, type +-- and procedure declarations necessary for the initialization of the CUDA +-- runtime are appended to the package that contains the CUDA_Global +-- procedure. +-- +-- These declarations are used to register the CUDA kernel with the CUDA +-- runtime when the program is launched. Registering a CUDA kernel with the +-- CUDA runtime requires multiple function calls: +-- - The first one registers the fat binary which corresponds to the package +-- with the CUDA runtime. +-- - Then, as many function calls as there are kernels in order to bind them +-- with the fat binary. +-- fat binary. +-- - The last call lets the CUDA runtime know that we are done initializing +-- CUDA. +-- Expansion of the CUDA_Global aspect is triggered in sem_ch7.adb, during +-- analysis of the package. All of this expansion is performed in the +-- Insert_CUDA_Initialization procedure defined in GNAT_CUDA. +-- +-- Once a CUDA package is initialized, its kernels are ready to be used. +-- Launching CUDA kernels is done by using the CUDA_Execute pragma. When +-- compiling for the host, the CUDA_Execute pragma is expanded into a declare +-- block which performs calls to the CUDA runtime functions. +-- - The first one pushes a "launch configuration" on the "configuration +-- stack" of the CUDA runtime. +-- - The second call pops this call configuration, making it effective. +-- - The third call actually launches the kernel. +-- Light validation of the CUDA_Execute pragma is performed in sem_prag.adb +-- and expansion is performed in exp_prag.adb. + +with Types; use Types; + +package GNAT_CUDA is + + procedure Add_CUDA_Kernel (Pack_Id : Entity_Id; Kernel : Entity_Id); + -- Add Kernel to the list of CUDA_Global nodes that belong to Pack_Id. + -- Kernel is a procedure entity marked with CUDA_Global, Pack_Id is the + -- entity of its parent package body. + + procedure Build_And_Insert_CUDA_Initialization (N : Node_Id); + -- Builds declarations necessary for CUDA initialization and inserts them + -- in N, the package body that contains CUDA_Global nodes. These + -- declarations are: + -- + -- * A symbol to hold the pointer to the CUDA fat binary + -- + -- * A type definition for a wrapper that contains the pointer to the + -- CUDA fat binary + -- + -- * An object of the aforementioned type to hold the aforementioned + -- pointer. + -- + -- * For each CUDA_Global procedure in the package, a declaration of a C + -- string containing the function's name. + -- + -- * A function that takes care of calling CUDA functions that register + -- CUDA_Global procedures with the runtime. + -- + -- * A boolean that holds the result of the call to the aforementioned + -- function. + +end GNAT_CUDA; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 882f9e2..e1a5568 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , Jul 01, 2020 +GNAT Reference Manual , Sep 29, 2020 AdaCore @@ -222,7 +222,6 @@ Implementation Defined Pragmas * Pragma Part_Of:: * Pragma Passive:: * Pragma Persistent_BSS:: -* Pragma Polling:: * Pragma Post:: * Pragma Postcondition:: * Pragma Post_Class:: @@ -407,6 +406,7 @@ Implementation Defined Attributes * Attribute Machine_Size:: * Attribute Mantissa:: * Attribute Maximum_Alignment:: +* Attribute Max_Integer_Size:: * Attribute Mechanism_Code:: * Attribute Null_Parameter:: * Attribute Object_Size:: @@ -713,6 +713,7 @@ The GNAT Library * Ada.Strings.Unbounded.Text_IO (a-suteio.ads): Ada Strings Unbounded Text_IO a-suteio ads. * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads): Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads. * Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads): Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads. +* Ada.Task_Initialization (a-tasini.ads): Ada Task_Initialization a-tasini ads. * Ada.Text_IO.C_Streams (a-tiocst.ads): Ada Text_IO C_Streams a-tiocst ads. * Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads): Ada Text_IO Reset_Standard_Files a-tirsfi ads. * Ada.Wide_Characters.Unicode (a-wichun.ads): Ada Wide_Characters Unicode a-wichun ads. @@ -1297,7 +1298,6 @@ consideration, the use of these pragmas should be minimized. * Pragma Part_Of:: * Pragma Passive:: * Pragma Persistent_BSS:: -* Pragma Polling:: * Pragma Post:: * Pragma Postcondition:: * Pragma Post_Class:: @@ -1394,7 +1394,21 @@ This pragma must appear at the start of the statement sequence of a handled sequence of statements (right after the @code{begin}). It has the effect of deferring aborts for the sequence of statements (but not for the declarations or handlers, if any, associated with this statement -sequence). +sequence). This can also be useful for adding a polling point in Ada code, +where asynchronous abort of tasks is checked when leaving the statement +sequence, and is lighter than, for example, using @code{delay 0.0;}, since with +zero-cost exception handling, propagating exceptions (implicitly used to +implement task abort) cannot be done reliably in an asynchronous way. + +An example of usage would be: + +@example +-- Add a polling point to check for task aborts + +begin + pragma Abort_Defer; +end; +@end example @node Pragma Abstract_State,Pragma Ada_83,Pragma Abort_Defer,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-abstract-state}@anchor{1c}@anchor{gnat_rm/implementation_defined_pragmas id2}@anchor{1d} @@ -5959,7 +5973,7 @@ optimized. GNAT does not attempt to optimize any tasks in this manner For more information on the subject of passive tasks, see the section 'Passive Task Optimization' in the GNAT Users Guide. -@node Pragma Persistent_BSS,Pragma Polling,Pragma Passive,Implementation Defined Pragmas +@node Pragma Persistent_BSS,Pragma Post,Pragma Passive,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas id29}@anchor{b6}@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{b7} @section Pragma Persistent_BSS @@ -5990,50 +6004,8 @@ type is potentially persistent. If this pragma is used on a target where this feature is not supported, then the pragma will be ignored. See also @code{pragma Linker_Section}. -@node Pragma Polling,Pragma Post,Pragma Persistent_BSS,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-polling}@anchor{b8} -@section Pragma Polling - - -Syntax: - -@example -pragma Polling (ON | OFF); -@end example - -This pragma controls the generation of polling code. This is normally off. -If @code{pragma Polling (ON)} is used then periodic calls are generated to -the routine @code{Ada.Exceptions.Poll}. This routine is a separate unit in the -runtime library, and can be found in file @code{a-excpol.adb}. - -Pragma @code{Polling} can appear as a configuration pragma (for example it -can be placed in the @code{gnat.adc} file) to enable polling globally, or it -can be used in the statement or declaration sequence to control polling -more locally. - -A call to the polling routine is generated at the start of every loop and -at the start of every subprogram call. This guarantees that the @code{Poll} -routine is called frequently, and places an upper bound (determined by -the complexity of the code) on the period between two @code{Poll} calls. - -The primary purpose of the polling interface is to enable asynchronous -aborts on targets that cannot otherwise support it (for example Windows -NT), but it may be used for any other purpose requiring periodic polling. -The standard version is null, and can be replaced by a user program. This -will require re-compilation of the @code{Ada.Exceptions} package that can -be found in files @code{a-except.ads} and @code{a-except.adb}. - -A standard alternative unit (in file @code{4wexcpol.adb} in the standard GNAT -distribution) is used to enable the asynchronous abort capability on -targets that do not normally support the capability. The version of -@code{Poll} in this file makes a call to the appropriate runtime routine -to test for an abort condition. - -Note that polling can also be enabled by use of the @emph{-gnatP} switch. -See the section on switches for gcc in the @cite{GNAT User's Guide}. - -@node Pragma Post,Pragma Postcondition,Pragma Polling,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{b9} +@node Pragma Post,Pragma Postcondition,Pragma Persistent_BSS,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{b8} @section Pragma Post @@ -6058,7 +6030,7 @@ appear at the start of the declarations in a subprogram body (preceded only by other pragmas). @node Pragma Postcondition,Pragma Post_Class,Pragma Post,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{ba} +@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{b9} @section Pragma Postcondition @@ -6223,7 +6195,7 @@ Ada 2012, and has been retained in its original form for compatibility purposes. @node Pragma Post_Class,Pragma Rename_Pragma,Pragma Postcondition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{bb} +@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{ba} @section Pragma Post_Class @@ -6258,7 +6230,7 @@ policy that controls this pragma is @code{Post'Class}, not @code{Post_Class}. @node Pragma Rename_Pragma,Pragma Pre,Pragma Post_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{bc} +@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{bb} @section Pragma Rename_Pragma @@ -6297,7 +6269,7 @@ Pragma Inline_Only will not necessarily mean the same thing as the other Ada compiler; it's up to you to make sure the semantics are close enough. @node Pragma Pre,Pragma Precondition,Pragma Rename_Pragma,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{bd} +@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{bc} @section Pragma Pre @@ -6322,7 +6294,7 @@ appear at the start of the declarations in a subprogram body (preceded only by other pragmas). @node Pragma Precondition,Pragma Predicate,Pragma Pre,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{be} +@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{bd} @section Pragma Precondition @@ -6381,7 +6353,7 @@ Ada 2012, and has been retained in its original form for compatibility purposes. @node Pragma Predicate,Pragma Predicate_Failure,Pragma Precondition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{bf}@anchor{gnat_rm/implementation_defined_pragmas id30}@anchor{c0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{be}@anchor{gnat_rm/implementation_defined_pragmas id30}@anchor{bf} @section Pragma Predicate @@ -6435,7 +6407,7 @@ defined for subtype B). When following this approach, the use of predicates should be avoided. @node Pragma Predicate_Failure,Pragma Preelaborable_Initialization,Pragma Predicate,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate-failure}@anchor{c1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate-failure}@anchor{c0} @section Pragma Predicate_Failure @@ -6452,7 +6424,7 @@ the language-defined @code{Predicate_Failure} aspect, and shares its restrictions and semantics. @node Pragma Preelaborable_Initialization,Pragma Prefix_Exception_Messages,Pragma Predicate_Failure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{c2} +@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{c1} @section Pragma Preelaborable_Initialization @@ -6467,7 +6439,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Prefix_Exception_Messages,Pragma Pre_Class,Pragma Preelaborable_Initialization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{c3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{c2} @section Pragma Prefix_Exception_Messages @@ -6498,7 +6470,7 @@ prefixing in this case, you can always call @code{GNAT.Source_Info.Enclosing_Entity} and prepend the string manually. @node Pragma Pre_Class,Pragma Priority_Specific_Dispatching,Pragma Prefix_Exception_Messages,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{c4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{c3} @section Pragma Pre_Class @@ -6533,7 +6505,7 @@ policy that controls this pragma is @code{Pre'Class}, not @code{Pre_Class}. @node Pragma Priority_Specific_Dispatching,Pragma Profile,Pragma Pre_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{c5} +@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{c4} @section Pragma Priority_Specific_Dispatching @@ -6557,7 +6529,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Profile,Pragma Profile_Warnings,Pragma Priority_Specific_Dispatching,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{c6} +@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{c5} @section Pragma Profile @@ -6831,7 +6803,7 @@ conforming Ada constructs. The profile enables the following three pragmas: @end itemize @node Pragma Profile_Warnings,Pragma Propagate_Exceptions,Pragma Profile,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{c7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{c6} @section Pragma Profile_Warnings @@ -6849,7 +6821,7 @@ violations of the profile generate warning messages instead of error messages. @node Pragma Propagate_Exceptions,Pragma Provide_Shift_Operators,Pragma Profile_Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{c8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{c7} @section Pragma Propagate_Exceptions @@ -6868,7 +6840,7 @@ purposes. It used to be used in connection with optimization of a now-obsolete mechanism for implementation of exceptions. @node Pragma Provide_Shift_Operators,Pragma Psect_Object,Pragma Propagate_Exceptions,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{c9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{c8} @section Pragma Provide_Shift_Operators @@ -6888,7 +6860,7 @@ including the function declarations for these five operators, together with the pragma Import (Intrinsic, ...) statements. @node Pragma Psect_Object,Pragma Pure_Function,Pragma Provide_Shift_Operators,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{ca} +@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{c9} @section Pragma Psect_Object @@ -6908,7 +6880,7 @@ EXTERNAL_SYMBOL ::= This pragma is identical in effect to pragma @code{Common_Object}. @node Pragma Pure_Function,Pragma Rational,Pragma Psect_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{cb}@anchor{gnat_rm/implementation_defined_pragmas id31}@anchor{cc} +@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{ca}@anchor{gnat_rm/implementation_defined_pragmas id31}@anchor{cb} @section Pragma Pure_Function @@ -6970,7 +6942,7 @@ unit is not a Pure unit in the categorization sense. So for example, a function thus marked is free to @code{with} non-pure units. @node Pragma Rational,Pragma Ravenscar,Pragma Pure_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{cd} +@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{cc} @section Pragma Rational @@ -6988,7 +6960,7 @@ pragma Profile (Rational); @end example @node Pragma Ravenscar,Pragma Refined_Depends,Pragma Rational,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{ce} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{cd} @section Pragma Ravenscar @@ -7008,7 +6980,7 @@ pragma Profile (Ravenscar); which is the preferred method of setting the @code{Ravenscar} profile. @node Pragma Refined_Depends,Pragma Refined_Global,Pragma Ravenscar,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{cf}@anchor{gnat_rm/implementation_defined_pragmas id32}@anchor{d0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{ce}@anchor{gnat_rm/implementation_defined_pragmas id32}@anchor{cf} @section Pragma Refined_Depends @@ -7041,7 +7013,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Depends the SPARK 2014 Reference Manual, section 6.1.5. @node Pragma Refined_Global,Pragma Refined_Post,Pragma Refined_Depends,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{d1}@anchor{gnat_rm/implementation_defined_pragmas id33}@anchor{d2} +@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{d0}@anchor{gnat_rm/implementation_defined_pragmas id33}@anchor{d1} @section Pragma Refined_Global @@ -7066,7 +7038,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Global} the SPARK 2014 Reference Manual, section 6.1.4. @node Pragma Refined_Post,Pragma Refined_State,Pragma Refined_Global,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{d3}@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{d2}@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d3} @section Pragma Refined_Post @@ -7080,7 +7052,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_Post} i the SPARK 2014 Reference Manual, section 7.2.7. @node Pragma Refined_State,Pragma Relative_Deadline,Pragma Refined_Post,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{d5}@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d6} +@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{d4}@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d5} @section Pragma Refined_State @@ -7106,7 +7078,7 @@ For the semantics of this pragma, see the entry for aspect @code{Refined_State} the SPARK 2014 Reference Manual, section 7.2.2. @node Pragma Relative_Deadline,Pragma Remote_Access_Type,Pragma Refined_State,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{d7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{d6} @section Pragma Relative_Deadline @@ -7121,7 +7093,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Remote_Access_Type,Pragma Restricted_Run_Time,Pragma Relative_Deadline,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d8}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{d9} +@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d7}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{d8} @section Pragma Remote_Access_Type @@ -7147,7 +7119,7 @@ pertaining to remote access to class-wide types. At instantiation, the actual type must be a remote access to class-wide type. @node Pragma Restricted_Run_Time,Pragma Restriction_Warnings,Pragma Remote_Access_Type,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{da} +@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{d9} @section Pragma Restricted_Run_Time @@ -7168,7 +7140,7 @@ which is the preferred method of setting the restricted run time profile. @node Pragma Restriction_Warnings,Pragma Reviewable,Pragma Restricted_Run_Time,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{db} +@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{da} @section Pragma Restriction_Warnings @@ -7206,7 +7178,7 @@ generating a warning, but any other use of implementation defined pragmas will cause a warning to be generated. @node Pragma Reviewable,Pragma Secondary_Stack_Size,Pragma Restriction_Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{dc} +@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{db} @section Pragma Reviewable @@ -7310,7 +7282,7 @@ comprehensive messages identifying possible problems based on this information. @node Pragma Secondary_Stack_Size,Pragma Share_Generic,Pragma Reviewable,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{dd}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{de} +@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{dc}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{dd} @section Pragma Secondary_Stack_Size @@ -7346,7 +7318,7 @@ Note the pragma cannot appear when the restriction @code{No_Secondary_Stack} is in effect. @node Pragma Share_Generic,Pragma Shared,Pragma Secondary_Stack_Size,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{df} +@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{de} @section Pragma Share_Generic @@ -7364,7 +7336,7 @@ than to check that the given names are all names of generic units or generic instances. @node Pragma Shared,Pragma Short_Circuit_And_Or,Pragma Share_Generic,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{e0}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{e1} +@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{df}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{e0} @section Pragma Shared @@ -7372,7 +7344,7 @@ This pragma is provided for compatibility with Ada 83. The syntax and semantics are identical to pragma Atomic. @node Pragma Short_Circuit_And_Or,Pragma Short_Descriptors,Pragma Shared,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{e2} +@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{e1} @section Pragma Short_Circuit_And_Or @@ -7391,7 +7363,7 @@ within the file being compiled, it applies only to the file being compiled. There is no requirement that all units in a partition use this option. @node Pragma Short_Descriptors,Pragma Simple_Storage_Pool_Type,Pragma Short_Circuit_And_Or,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{e3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{e2} @section Pragma Short_Descriptors @@ -7405,7 +7377,7 @@ This pragma is provided for compatibility with other Ada implementations. It is recognized but ignored by all current versions of GNAT. @node Pragma Simple_Storage_Pool_Type,Pragma Source_File_Name,Pragma Short_Descriptors,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{e4}@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{e5} +@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{e3}@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{e4} @section Pragma Simple_Storage_Pool_Type @@ -7459,7 +7431,7 @@ storage-management discipline). An object of a simple storage pool type can be associated with an access type by specifying the attribute -@ref{e6,,Simple_Storage_Pool}. For example: +@ref{e5,,Simple_Storage_Pool}. For example: @example My_Pool : My_Simple_Storage_Pool_Type; @@ -7469,11 +7441,11 @@ type Acc is access My_Data_Type; for Acc'Simple_Storage_Pool use My_Pool; @end example -See attribute @ref{e6,,Simple_Storage_Pool} +See attribute @ref{e5,,Simple_Storage_Pool} for further details. @node Pragma Source_File_Name,Pragma Source_File_Name_Project,Pragma Simple_Storage_Pool_Type,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{e7}@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{e6}@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e7} @section Pragma Source_File_Name @@ -7565,20 +7537,20 @@ aware of these pragmas, and so other tools that use the projet file would not be aware of the intended naming conventions. If you are using project files, file naming is controlled by Source_File_Name_Project pragmas, which are usually supplied automatically by the project manager. A pragma -Source_File_Name cannot appear after a @ref{e9,,Pragma Source_File_Name_Project}. +Source_File_Name cannot appear after a @ref{e8,,Pragma Source_File_Name_Project}. For more details on the use of the @code{Source_File_Name} pragma, see the sections on @cite{Using Other File Names} and @cite{Alternative File Naming Schemes} in the @cite{GNAT User's Guide}. @node Pragma Source_File_Name_Project,Pragma Source_Reference,Pragma Source_File_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{e9}@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{ea} +@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{e8}@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{e9} @section Pragma Source_File_Name_Project This pragma has the same syntax and semantics as pragma Source_File_Name. It is only allowed as a stand-alone configuration pragma. -It cannot appear after a @ref{e7,,Pragma Source_File_Name}, and +It cannot appear after a @ref{e6,,Pragma Source_File_Name}, and most importantly, once pragma Source_File_Name_Project appears, no further Source_File_Name pragmas are allowed. @@ -7590,7 +7562,7 @@ Source_File_Name or Source_File_Name_Project pragmas (which would not be known to the project manager). @node Pragma Source_Reference,Pragma SPARK_Mode,Pragma Source_File_Name_Project,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{eb} +@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{ea} @section Pragma Source_Reference @@ -7614,7 +7586,7 @@ string expression other than a string literal. This is because its value is needed for error messages issued by all phases of the compiler. @node Pragma SPARK_Mode,Pragma Static_Elaboration_Desired,Pragma Source_Reference,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{ec}@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{ed} +@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{eb}@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{ec} @section Pragma SPARK_Mode @@ -7696,7 +7668,7 @@ SPARK_Mode (@code{Off}), then that pragma will need to be repeated in the package body. @node Pragma Static_Elaboration_Desired,Pragma Stream_Convert,Pragma SPARK_Mode,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{ee} +@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{ed} @section Pragma Static_Elaboration_Desired @@ -7720,7 +7692,7 @@ construction of larger aggregates with static components that include an others choice.) @node Pragma Stream_Convert,Pragma Style_Checks,Pragma Static_Elaboration_Desired,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{ef} +@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{ee} @section Pragma Stream_Convert @@ -7797,7 +7769,7 @@ the pragma is silently ignored, and the default implementation of the stream attributes is used instead. @node Pragma Style_Checks,Pragma Subtitle,Pragma Stream_Convert,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{f0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{ef} @section Pragma Style_Checks @@ -7870,7 +7842,7 @@ Rf2 : Integer := ARG; -- OK, no error @end example @node Pragma Subtitle,Pragma Suppress,Pragma Style_Checks,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{f1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{f0} @section Pragma Subtitle @@ -7884,7 +7856,7 @@ This pragma is recognized for compatibility with other Ada compilers but is ignored by GNAT. @node Pragma Suppress,Pragma Suppress_All,Pragma Subtitle,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{f2} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{f1} @section Pragma Suppress @@ -7957,7 +7929,7 @@ Of course, run-time checks are omitted whenever the compiler can prove that they will not fail, whether or not checks are suppressed. @node Pragma Suppress_All,Pragma Suppress_Debug_Info,Pragma Suppress,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{f3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{f2} @section Pragma Suppress_All @@ -7976,7 +7948,7 @@ The use of the standard Ada pragma @code{Suppress (All_Checks)} as a normal configuration pragma is the preferred usage in GNAT. @node Pragma Suppress_Debug_Info,Pragma Suppress_Exception_Locations,Pragma Suppress_All,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{f4}@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{f5} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{f3}@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{f4} @section Pragma Suppress_Debug_Info @@ -7991,7 +7963,7 @@ for the specified entity. It is intended primarily for use in debugging the debugger, and navigating around debugger problems. @node Pragma Suppress_Exception_Locations,Pragma Suppress_Initialization,Pragma Suppress_Debug_Info,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{f6} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{f5} @section Pragma Suppress_Exception_Locations @@ -8014,7 +7986,7 @@ a partition, so it is fine to have some units within a partition compiled with this pragma and others compiled in normal mode without it. @node Pragma Suppress_Initialization,Pragma Task_Name,Pragma Suppress_Exception_Locations,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f7}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{f8} +@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f6}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{f7} @section Pragma Suppress_Initialization @@ -8059,7 +8031,7 @@ is suppressed, just as though its subtype had been given in a pragma Suppress_Initialization, as described above. @node Pragma Task_Name,Pragma Task_Storage,Pragma Suppress_Initialization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{f9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{f8} @section Pragma Task_Name @@ -8115,7 +8087,7 @@ end; @end example @node Pragma Task_Storage,Pragma Test_Case,Pragma Task_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{fa} +@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{f9} @section Pragma Task_Storage @@ -8135,7 +8107,7 @@ created, depending on the target. This pragma can appear anywhere a type. @node Pragma Test_Case,Pragma Thread_Local_Storage,Pragma Task_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{fb}@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{fc} +@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{fa}@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{fb} @section Pragma Test_Case @@ -8191,7 +8163,7 @@ postcondition. Mode @code{Robustness} indicates that the precondition and postcondition of the subprogram should be ignored for this test case. @node Pragma Thread_Local_Storage,Pragma Time_Slice,Pragma Test_Case,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{fd}@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{fe} +@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{fc}@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{fd} @section Pragma Thread_Local_Storage @@ -8229,7 +8201,7 @@ If this pragma is used on a system where @code{TLS} is not supported, then an error message will be generated and the program will be rejected. @node Pragma Time_Slice,Pragma Title,Pragma Thread_Local_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{ff} +@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{fe} @section Pragma Time_Slice @@ -8245,7 +8217,7 @@ It is ignored if it is used in a system that does not allow this control, or if it appears in other than the main program unit. @node Pragma Title,Pragma Type_Invariant,Pragma Time_Slice,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{100} +@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{ff} @section Pragma Title @@ -8270,7 +8242,7 @@ notation is used, and named and positional notation can be mixed following the normal rules for procedure calls in Ada. @node Pragma Type_Invariant,Pragma Type_Invariant_Class,Pragma Title,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{101} +@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{100} @section Pragma Type_Invariant @@ -8291,7 +8263,7 @@ controlled by the assertion identifier @code{Type_Invariant} rather than @code{Invariant}. @node Pragma Type_Invariant_Class,Pragma Unchecked_Union,Pragma Type_Invariant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{102}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{103} +@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{101}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{102} @section Pragma Type_Invariant_Class @@ -8318,7 +8290,7 @@ policy that controls this pragma is @code{Type_Invariant'Class}, not @code{Type_Invariant_Class}. @node Pragma Unchecked_Union,Pragma Unevaluated_Use_Of_Old,Pragma Type_Invariant_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{104} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{103} @section Pragma Unchecked_Union @@ -8338,7 +8310,7 @@ version in all language modes (Ada 83, Ada 95, and Ada 2005). For full details, consult the Ada 2012 Reference Manual, section B.3.3. @node Pragma Unevaluated_Use_Of_Old,Pragma Unimplemented_Unit,Pragma Unchecked_Union,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{105} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{104} @section Pragma Unevaluated_Use_Of_Old @@ -8393,7 +8365,7 @@ uses up to the end of the corresponding statement sequence or sequence of package declarations. @node Pragma Unimplemented_Unit,Pragma Universal_Aliasing,Pragma Unevaluated_Use_Of_Old,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{106} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{105} @section Pragma Unimplemented_Unit @@ -8413,7 +8385,7 @@ The abort only happens if code is being generated. Thus you can use specs of unimplemented packages in syntax or semantic checking mode. @node Pragma Universal_Aliasing,Pragma Universal_Data,Pragma Unimplemented_Unit,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{107}@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{108} +@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{106}@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{107} @section Pragma Universal_Aliasing @@ -8432,7 +8404,7 @@ situations in which it must be suppressed, see the section on @code{Optimization and Strict Aliasing} in the @cite{GNAT User's Guide}. @node Pragma Universal_Data,Pragma Unmodified,Pragma Universal_Aliasing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-data}@anchor{109}@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{10a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-data}@anchor{108}@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{109} @section Pragma Universal_Data @@ -8456,7 +8428,7 @@ of this pragma is also available by applying the -univ switch on the compilations of units where universal addressing of the data is desired. @node Pragma Unmodified,Pragma Unreferenced,Pragma Universal_Data,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{10b}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{10c} +@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{10a}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{10b} @section Pragma Unmodified @@ -8490,7 +8462,7 @@ Thus it is never necessary to use @code{pragma Unmodified} for such variables, though it is harmless to do so. @node Pragma Unreferenced,Pragma Unreferenced_Objects,Pragma Unmodified,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{10d}@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{10c}@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10d} @section Pragma Unreferenced @@ -8550,7 +8522,7 @@ Thus it is never necessary to use @code{pragma Unreferenced} for such variables, though it is harmless to do so. @node Pragma Unreferenced_Objects,Pragma Unreserve_All_Interrupts,Pragma Unreferenced,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{10f}@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{110} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{10e}@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{10f} @section Pragma Unreferenced_Objects @@ -8575,7 +8547,7 @@ compiler will automatically suppress unwanted warnings about these variables not being referenced. @node Pragma Unreserve_All_Interrupts,Pragma Unsuppress,Pragma Unreferenced_Objects,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{111} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{110} @section Pragma Unreserve_All_Interrupts @@ -8611,7 +8583,7 @@ handled, see pragma @code{Interrupt_State}, which subsumes the functionality of the @code{Unreserve_All_Interrupts} pragma. @node Pragma Unsuppress,Pragma Use_VADS_Size,Pragma Unreserve_All_Interrupts,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{112} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{111} @section Pragma Unsuppress @@ -8647,7 +8619,7 @@ number of implementation-defined check names. See the description of pragma @code{Suppress} for full details. @node Pragma Use_VADS_Size,Pragma Unused,Pragma Unsuppress,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{113} +@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{112} @section Pragma Use_VADS_Size @@ -8671,7 +8643,7 @@ as implemented in the VADS compiler. See description of the VADS_Size attribute for further details. @node Pragma Unused,Pragma Validity_Checks,Pragma Use_VADS_Size,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{114}@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{115} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{113}@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{114} @section Pragma Unused @@ -8705,7 +8677,7 @@ Thus it is never necessary to use @code{pragma Unmodified} for such variables, though it is harmless to do so. @node Pragma Validity_Checks,Pragma Volatile,Pragma Unused,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{116} +@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{115} @section Pragma Validity_Checks @@ -8761,7 +8733,7 @@ A := C; -- C will be validity checked @end example @node Pragma Volatile,Pragma Volatile_Full_Access,Pragma Validity_Checks,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{117}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{118} +@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{116}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{117} @section Pragma Volatile @@ -8779,7 +8751,7 @@ implementation of pragma Volatile is upwards compatible with the implementation in DEC Ada 83. @node Pragma Volatile_Full_Access,Pragma Volatile_Function,Pragma Volatile,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{119}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{11a} +@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{118}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{119} @section Pragma Volatile_Full_Access @@ -8804,14 +8776,8 @@ there is no guarantee that all the bits will be accessed if the reference is not to the whole object; the compiler is allowed (and generally will) access only part of the object in this case. -It is not permissible to specify @code{Atomic} and @code{Volatile_Full_Access} for -the same type or object. - -It is not permissible to specify @code{Volatile_Full_Access} for a composite -(record or array) type or object that has an @code{Aliased} subcomponent. - @node Pragma Volatile_Function,Pragma Warning_As_Error,Pragma Volatile_Full_Access,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11b}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{11c} +@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11a}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{11b} @section Pragma Volatile_Function @@ -8825,7 +8791,7 @@ For the semantics of this pragma, see the entry for aspect @code{Volatile_Functi in the SPARK 2014 Reference Manual, section 7.1.2. @node Pragma Warning_As_Error,Pragma Warnings,Pragma Volatile_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{11d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{11c} @section Pragma Warning_As_Error @@ -8865,7 +8831,7 @@ you can use multiple pragma Warning_As_Error. The above use of patterns to match the message applies only to warning messages generated by the front end. This pragma can also be applied to -warnings provided by the back end and mentioned in @ref{11e,,Pragma Warnings}. +warnings provided by the back end and mentioned in @ref{11d,,Pragma Warnings}. By using a single full @emph{-Wxxx} switch in the pragma, such warnings can also be treated as errors. @@ -8915,7 +8881,7 @@ the tag is changed from "warning:" to "error:" and the string "[warning-as-error]" is appended to the end of the message. @node Pragma Warnings,Pragma Weak_External,Pragma Warning_As_Error,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id57}@anchor{11f}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{11e} +@anchor{gnat_rm/implementation_defined_pragmas id57}@anchor{11e}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{11d} @section Pragma Warnings @@ -9071,7 +9037,7 @@ selectively for each tool, and as a consequence to detect useless pragma Warnings with switch @code{-gnatw.w}. @node Pragma Weak_External,Pragma Wide_Character_Encoding,Pragma Warnings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{120} +@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{11f} @section Pragma Weak_External @@ -9122,7 +9088,7 @@ end External_Module; @end example @node Pragma Wide_Character_Encoding,,Pragma Weak_External,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{121} +@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{120} @section Pragma Wide_Character_Encoding @@ -9153,7 +9119,7 @@ encoding within that file, and does not affect withed units, specs, or subunits. @node Implementation Defined Aspects,Implementation Defined Attributes,Implementation Defined Pragmas,Top -@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{122}@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{123}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{124} +@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{121}@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{122}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{123} @chapter Implementation Defined Aspects @@ -9273,7 +9239,7 @@ or attribute definition clause. @end menu @node Aspect Abstract_State,Aspect Annotate,,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{125} +@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{124} @section Aspect Abstract_State @@ -9282,7 +9248,7 @@ or attribute definition clause. This aspect is equivalent to @ref{1c,,pragma Abstract_State}. @node Aspect Annotate,Aspect Async_Readers,Aspect Abstract_State,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{126} +@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{125} @section Aspect Annotate @@ -9309,7 +9275,7 @@ Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);} @end table @node Aspect Async_Readers,Aspect Async_Writers,Aspect Annotate,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{127} +@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{126} @section Aspect Async_Readers @@ -9318,7 +9284,7 @@ Equivalent to @code{pragma Annotate (ID, ID @{, ARG@}, Entity => Name);} This boolean aspect is equivalent to @ref{2d,,pragma Async_Readers}. @node Aspect Async_Writers,Aspect Constant_After_Elaboration,Aspect Async_Readers,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{128} +@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{127} @section Aspect Async_Writers @@ -9327,7 +9293,7 @@ This boolean aspect is equivalent to @ref{2d,,pragma Async_Readers}. This boolean aspect is equivalent to @ref{30,,pragma Async_Writers}. @node Aspect Constant_After_Elaboration,Aspect Contract_Cases,Aspect Async_Writers,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{129} +@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{128} @section Aspect Constant_After_Elaboration @@ -9336,7 +9302,7 @@ This boolean aspect is equivalent to @ref{30,,pragma Async_Writers}. This aspect is equivalent to @ref{42,,pragma Constant_After_Elaboration}. @node Aspect Contract_Cases,Aspect Depends,Aspect Constant_After_Elaboration,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{12a} +@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{129} @section Aspect Contract_Cases @@ -9347,7 +9313,7 @@ of clauses being enclosed in parentheses so that syntactically it is an aggregate. @node Aspect Depends,Aspect Default_Initial_Condition,Aspect Contract_Cases,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{12b} +@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{12a} @section Aspect Depends @@ -9356,7 +9322,7 @@ aggregate. This aspect is equivalent to @ref{53,,pragma Depends}. @node Aspect Default_Initial_Condition,Aspect Dimension,Aspect Depends,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{12c} +@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{12b} @section Aspect Default_Initial_Condition @@ -9365,7 +9331,7 @@ This aspect is equivalent to @ref{53,,pragma Depends}. This aspect is equivalent to @ref{4e,,pragma Default_Initial_Condition}. @node Aspect Dimension,Aspect Dimension_System,Aspect Default_Initial_Condition,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{12d} +@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{12c} @section Aspect Dimension @@ -9401,7 +9367,7 @@ Note that when the dimensioned type is an integer type, then any dimension value must be an integer literal. @node Aspect Dimension_System,Aspect Disable_Controlled,Aspect Dimension,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{12e} +@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{12d} @section Aspect Dimension_System @@ -9461,7 +9427,7 @@ See section 'Performing Dimensionality Analysis in GNAT' in the GNAT Users Guide for detailed examples of use of the dimension system. @node Aspect Disable_Controlled,Aspect Effective_Reads,Aspect Dimension_System,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{12f} +@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{12e} @section Aspect Disable_Controlled @@ -9474,7 +9440,7 @@ where for example you might want a record to be controlled or not depending on whether some run-time check is enabled or suppressed. @node Aspect Effective_Reads,Aspect Effective_Writes,Aspect Disable_Controlled,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{130} +@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{12f} @section Aspect Effective_Reads @@ -9483,7 +9449,7 @@ whether some run-time check is enabled or suppressed. This aspect is equivalent to @ref{59,,pragma Effective_Reads}. @node Aspect Effective_Writes,Aspect Extensions_Visible,Aspect Effective_Reads,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{131} +@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{130} @section Aspect Effective_Writes @@ -9492,7 +9458,7 @@ This aspect is equivalent to @ref{59,,pragma Effective_Reads}. This aspect is equivalent to @ref{5b,,pragma Effective_Writes}. @node Aspect Extensions_Visible,Aspect Favor_Top_Level,Aspect Effective_Writes,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{132} +@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{131} @section Aspect Extensions_Visible @@ -9501,7 +9467,7 @@ This aspect is equivalent to @ref{5b,,pragma Effective_Writes}. This aspect is equivalent to @ref{67,,pragma Extensions_Visible}. @node Aspect Favor_Top_Level,Aspect Ghost,Aspect Extensions_Visible,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{133} +@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{132} @section Aspect Favor_Top_Level @@ -9510,7 +9476,7 @@ This aspect is equivalent to @ref{67,,pragma Extensions_Visible}. This boolean aspect is equivalent to @ref{6c,,pragma Favor_Top_Level}. @node Aspect Ghost,Aspect Global,Aspect Favor_Top_Level,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{134} +@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{133} @section Aspect Ghost @@ -9519,7 +9485,7 @@ This boolean aspect is equivalent to @ref{6c,,pragma Favor_Top_Level}. This aspect is equivalent to @ref{6f,,pragma Ghost}. @node Aspect Global,Aspect Initial_Condition,Aspect Ghost,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{135} +@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{134} @section Aspect Global @@ -9528,7 +9494,7 @@ This aspect is equivalent to @ref{6f,,pragma Ghost}. This aspect is equivalent to @ref{71,,pragma Global}. @node Aspect Initial_Condition,Aspect Initializes,Aspect Global,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{136} +@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{135} @section Aspect Initial_Condition @@ -9537,7 +9503,7 @@ This aspect is equivalent to @ref{71,,pragma Global}. This aspect is equivalent to @ref{7f,,pragma Initial_Condition}. @node Aspect Initializes,Aspect Inline_Always,Aspect Initial_Condition,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{137} +@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{136} @section Aspect Initializes @@ -9546,7 +9512,7 @@ This aspect is equivalent to @ref{7f,,pragma Initial_Condition}. This aspect is equivalent to @ref{81,,pragma Initializes}. @node Aspect Inline_Always,Aspect Invariant,Aspect Initializes,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{138} +@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{137} @section Aspect Inline_Always @@ -9555,7 +9521,7 @@ This aspect is equivalent to @ref{81,,pragma Initializes}. This boolean aspect is equivalent to @ref{84,,pragma Inline_Always}. @node Aspect Invariant,Aspect Invariant'Class,Aspect Inline_Always,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{139} +@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{138} @section Aspect Invariant @@ -9566,18 +9532,18 @@ synonym for the language defined aspect @code{Type_Invariant} except that it is separately controllable using pragma @code{Assertion_Policy}. @node Aspect Invariant'Class,Aspect Iterable,Aspect Invariant,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{13a} +@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{139} @section Aspect Invariant'Class @geindex Invariant'Class -This aspect is equivalent to @ref{103,,pragma Type_Invariant_Class}. It is a +This aspect is equivalent to @ref{102,,pragma Type_Invariant_Class}. It is a synonym for the language defined aspect @code{Type_Invariant'Class} except that it is separately controllable using pragma @code{Assertion_Policy}. @node Aspect Iterable,Aspect Linker_Section,Aspect Invariant'Class,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{13b} +@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{13a} @section Aspect Iterable @@ -9657,7 +9623,7 @@ function Get_Element (Cont : Container; Position : Cursor) return Element_Type; This aspect is used in the GNAT-defined formal container packages. @node Aspect Linker_Section,Aspect Lock_Free,Aspect Iterable,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{13c} +@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{13b} @section Aspect Linker_Section @@ -9666,7 +9632,7 @@ This aspect is used in the GNAT-defined formal container packages. This aspect is equivalent to @ref{93,,pragma Linker_Section}. @node Aspect Lock_Free,Aspect Max_Queue_Length,Aspect Linker_Section,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{13d} +@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{13c} @section Aspect Lock_Free @@ -9675,7 +9641,7 @@ This aspect is equivalent to @ref{93,,pragma Linker_Section}. This boolean aspect is equivalent to @ref{95,,pragma Lock_Free}. @node Aspect Max_Queue_Length,Aspect No_Caching,Aspect Lock_Free,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{13e} +@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{13d} @section Aspect Max_Queue_Length @@ -9684,7 +9650,7 @@ This boolean aspect is equivalent to @ref{95,,pragma Lock_Free}. This aspect is equivalent to @ref{9d,,pragma Max_Queue_Length}. @node Aspect No_Caching,Aspect No_Elaboration_Code_All,Aspect Max_Queue_Length,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{13f} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{13e} @section Aspect No_Caching @@ -9693,7 +9659,7 @@ This aspect is equivalent to @ref{9d,,pragma Max_Queue_Length}. This boolean aspect is equivalent to @ref{9f,,pragma No_Caching}. @node Aspect No_Elaboration_Code_All,Aspect No_Inline,Aspect No_Caching,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{140} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{13f} @section Aspect No_Elaboration_Code_All @@ -9703,7 +9669,7 @@ This aspect is equivalent to @ref{a3,,pragma No_Elaboration_Code_All} for a program unit. @node Aspect No_Inline,Aspect No_Tagged_Streams,Aspect No_Elaboration_Code_All,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{141} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{140} @section Aspect No_Inline @@ -9712,7 +9678,7 @@ for a program unit. This boolean aspect is equivalent to @ref{a6,,pragma No_Inline}. @node Aspect No_Tagged_Streams,Aspect Object_Size,Aspect No_Inline,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{142} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{141} @section Aspect No_Tagged_Streams @@ -9723,16 +9689,16 @@ argument specifying a root tagged type (thus this aspect can only be applied to such a type). @node Aspect Object_Size,Aspect Obsolescent,Aspect No_Tagged_Streams,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{143} +@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{142} @section Aspect Object_Size @geindex Object_Size -This aspect is equivalent to @ref{144,,attribute Object_Size}. +This aspect is equivalent to @ref{143,,attribute Object_Size}. @node Aspect Obsolescent,Aspect Part_Of,Aspect Object_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{145} +@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{144} @section Aspect Obsolescent @@ -9743,7 +9709,7 @@ evaluation of this aspect happens at the point of occurrence, it is not delayed until the freeze point. @node Aspect Part_Of,Aspect Persistent_BSS,Aspect Obsolescent,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{146} +@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{145} @section Aspect Part_Of @@ -9752,7 +9718,7 @@ delayed until the freeze point. This aspect is equivalent to @ref{b4,,pragma Part_Of}. @node Aspect Persistent_BSS,Aspect Predicate,Aspect Part_Of,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{147} +@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{146} @section Aspect Persistent_BSS @@ -9761,13 +9727,13 @@ This aspect is equivalent to @ref{b4,,pragma Part_Of}. This boolean aspect is equivalent to @ref{b7,,pragma Persistent_BSS}. @node Aspect Predicate,Aspect Pure_Function,Aspect Persistent_BSS,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{148} +@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{147} @section Aspect Predicate @geindex Predicate -This aspect is equivalent to @ref{bf,,pragma Predicate}. It is thus +This aspect is equivalent to @ref{be,,pragma Predicate}. It is thus similar to the language defined aspects @code{Dynamic_Predicate} and @code{Static_Predicate} except that whether the resulting predicate is static or dynamic is controlled by the form of the @@ -9775,52 +9741,52 @@ expression. It is also separately controllable using pragma @code{Assertion_Policy}. @node Aspect Pure_Function,Aspect Refined_Depends,Aspect Predicate,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{149} +@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{148} @section Aspect Pure_Function @geindex Pure_Function -This boolean aspect is equivalent to @ref{cb,,pragma Pure_Function}. +This boolean aspect is equivalent to @ref{ca,,pragma Pure_Function}. @node Aspect Refined_Depends,Aspect Refined_Global,Aspect Pure_Function,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{14a} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{149} @section Aspect Refined_Depends @geindex Refined_Depends -This aspect is equivalent to @ref{cf,,pragma Refined_Depends}. +This aspect is equivalent to @ref{ce,,pragma Refined_Depends}. @node Aspect Refined_Global,Aspect Refined_Post,Aspect Refined_Depends,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{14b} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{14a} @section Aspect Refined_Global @geindex Refined_Global -This aspect is equivalent to @ref{d1,,pragma Refined_Global}. +This aspect is equivalent to @ref{d0,,pragma Refined_Global}. @node Aspect Refined_Post,Aspect Refined_State,Aspect Refined_Global,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{14c} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{14b} @section Aspect Refined_Post @geindex Refined_Post -This aspect is equivalent to @ref{d3,,pragma Refined_Post}. +This aspect is equivalent to @ref{d2,,pragma Refined_Post}. @node Aspect Refined_State,Aspect Relaxed_Initialization,Aspect Refined_Post,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{14d} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{14c} @section Aspect Refined_State @geindex Refined_State -This aspect is equivalent to @ref{d5,,pragma Refined_State}. +This aspect is equivalent to @ref{d4,,pragma Refined_State}. @node Aspect Relaxed_Initialization,Aspect Remote_Access_Type,Aspect Refined_State,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{14e} +@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{14d} @section Aspect Relaxed_Initialization @@ -9830,194 +9796,196 @@ For the syntax and semantics of this aspect, see the SPARK 2014 Reference Manual, section 6.10. @node Aspect Remote_Access_Type,Aspect Secondary_Stack_Size,Aspect Relaxed_Initialization,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{14f} +@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{14e} @section Aspect Remote_Access_Type @geindex Remote_Access_Type -This aspect is equivalent to @ref{d9,,pragma Remote_Access_Type}. +This aspect is equivalent to @ref{d8,,pragma Remote_Access_Type}. @node Aspect Secondary_Stack_Size,Aspect Scalar_Storage_Order,Aspect Remote_Access_Type,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{150} +@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{14f} @section Aspect Secondary_Stack_Size @geindex Secondary_Stack_Size -This aspect is equivalent to @ref{de,,pragma Secondary_Stack_Size}. +This aspect is equivalent to @ref{dd,,pragma Secondary_Stack_Size}. @node Aspect Scalar_Storage_Order,Aspect Shared,Aspect Secondary_Stack_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{151} +@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{150} @section Aspect Scalar_Storage_Order @geindex Scalar_Storage_Order -This aspect is equivalent to a @ref{152,,attribute Scalar_Storage_Order}. +This aspect is equivalent to a @ref{151,,attribute Scalar_Storage_Order}. @node Aspect Shared,Aspect Simple_Storage_Pool,Aspect Scalar_Storage_Order,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{153} +@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{152} @section Aspect Shared @geindex Shared -This boolean aspect is equivalent to @ref{e1,,pragma Shared} +This boolean aspect is equivalent to @ref{e0,,pragma Shared} and is thus a synonym for aspect @code{Atomic}. @node Aspect Simple_Storage_Pool,Aspect Simple_Storage_Pool_Type,Aspect Shared,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{154} +@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{153} @section Aspect Simple_Storage_Pool @geindex Simple_Storage_Pool -This aspect is equivalent to @ref{e6,,attribute Simple_Storage_Pool}. +This aspect is equivalent to @ref{e5,,attribute Simple_Storage_Pool}. @node Aspect Simple_Storage_Pool_Type,Aspect SPARK_Mode,Aspect Simple_Storage_Pool,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{155} +@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{154} @section Aspect Simple_Storage_Pool_Type @geindex Simple_Storage_Pool_Type -This boolean aspect is equivalent to @ref{e4,,pragma Simple_Storage_Pool_Type}. +This boolean aspect is equivalent to @ref{e3,,pragma Simple_Storage_Pool_Type}. @node Aspect SPARK_Mode,Aspect Suppress_Debug_Info,Aspect Simple_Storage_Pool_Type,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{156} +@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{155} @section Aspect SPARK_Mode @geindex SPARK_Mode -This aspect is equivalent to @ref{ec,,pragma SPARK_Mode} and +This aspect is equivalent to @ref{eb,,pragma SPARK_Mode} and may be specified for either or both of the specification and body of a subprogram or package. @node Aspect Suppress_Debug_Info,Aspect Suppress_Initialization,Aspect SPARK_Mode,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{157} +@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{156} @section Aspect Suppress_Debug_Info @geindex Suppress_Debug_Info -This boolean aspect is equivalent to @ref{f4,,pragma Suppress_Debug_Info}. +This boolean aspect is equivalent to @ref{f3,,pragma Suppress_Debug_Info}. @node Aspect Suppress_Initialization,Aspect Test_Case,Aspect Suppress_Debug_Info,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{158} +@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{157} @section Aspect Suppress_Initialization @geindex Suppress_Initialization -This boolean aspect is equivalent to @ref{f8,,pragma Suppress_Initialization}. +This boolean aspect is equivalent to @ref{f7,,pragma Suppress_Initialization}. @node Aspect Test_Case,Aspect Thread_Local_Storage,Aspect Suppress_Initialization,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{159} +@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{158} @section Aspect Test_Case @geindex Test_Case -This aspect is equivalent to @ref{fb,,pragma Test_Case}. +This aspect is equivalent to @ref{fa,,pragma Test_Case}. @node Aspect Thread_Local_Storage,Aspect Universal_Aliasing,Aspect Test_Case,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{15a} +@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{159} @section Aspect Thread_Local_Storage @geindex Thread_Local_Storage -This boolean aspect is equivalent to @ref{fd,,pragma Thread_Local_Storage}. +This boolean aspect is equivalent to @ref{fc,,pragma Thread_Local_Storage}. @node Aspect Universal_Aliasing,Aspect Universal_Data,Aspect Thread_Local_Storage,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{15b} +@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{15a} @section Aspect Universal_Aliasing @geindex Universal_Aliasing -This boolean aspect is equivalent to @ref{107,,pragma Universal_Aliasing}. +This boolean aspect is equivalent to @ref{106,,pragma Universal_Aliasing}. @node Aspect Universal_Data,Aspect Unmodified,Aspect Universal_Aliasing,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-universal-data}@anchor{15c} +@anchor{gnat_rm/implementation_defined_aspects aspect-universal-data}@anchor{15b} @section Aspect Universal_Data @geindex Universal_Data -This aspect is equivalent to @ref{109,,pragma Universal_Data}. +This aspect is equivalent to @ref{108,,pragma Universal_Data}. @node Aspect Unmodified,Aspect Unreferenced,Aspect Universal_Data,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{15d} +@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{15c} @section Aspect Unmodified @geindex Unmodified -This boolean aspect is equivalent to @ref{10c,,pragma Unmodified}. +This boolean aspect is equivalent to @ref{10b,,pragma Unmodified}. @node Aspect Unreferenced,Aspect Unreferenced_Objects,Aspect Unmodified,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{15e} +@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{15d} @section Aspect Unreferenced @geindex Unreferenced -This boolean aspect is equivalent to @ref{10d,,pragma Unreferenced}. Note that -in the case of formal parameters, it is not permitted to have aspects for -a formal parameter, so in this case the pragma form must be used. +This boolean aspect is equivalent to @ref{10c,,pragma Unreferenced}. + +When using the @code{-gnatX} switch, this aspect is also supported on formal +parameters, which is in particular the only form possible for expression +functions. @node Aspect Unreferenced_Objects,Aspect Value_Size,Aspect Unreferenced,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{15f} +@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{15e} @section Aspect Unreferenced_Objects @geindex Unreferenced_Objects -This boolean aspect is equivalent to @ref{10f,,pragma Unreferenced_Objects}. +This boolean aspect is equivalent to @ref{10e,,pragma Unreferenced_Objects}. @node Aspect Value_Size,Aspect Volatile_Full_Access,Aspect Unreferenced_Objects,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{160} +@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{15f} @section Aspect Value_Size @geindex Value_Size -This aspect is equivalent to @ref{161,,attribute Value_Size}. +This aspect is equivalent to @ref{160,,attribute Value_Size}. @node Aspect Volatile_Full_Access,Aspect Volatile_Function,Aspect Value_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{162} +@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{161} @section Aspect Volatile_Full_Access @geindex Volatile_Full_Access -This boolean aspect is equivalent to @ref{11a,,pragma Volatile_Full_Access}. +This boolean aspect is equivalent to @ref{119,,pragma Volatile_Full_Access}. @node Aspect Volatile_Function,Aspect Warnings,Aspect Volatile_Full_Access,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{163} +@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{162} @section Aspect Volatile_Function @geindex Volatile_Function -This boolean aspect is equivalent to @ref{11c,,pragma Volatile_Function}. +This boolean aspect is equivalent to @ref{11b,,pragma Volatile_Function}. @node Aspect Warnings,,Aspect Volatile_Function,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{164} +@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{163} @section Aspect Warnings @geindex Warnings -This aspect is equivalent to the two argument form of @ref{11e,,pragma Warnings}, +This aspect is equivalent to the two argument form of @ref{11d,,pragma Warnings}, where the first argument is @code{ON} or @code{OFF} and the second argument is the entity. @node Implementation Defined Attributes,Standard and Implementation Defined Restrictions,Implementation Defined Aspects,Top -@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{165}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{166} +@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{164}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{165} @chapter Implementation Defined Attributes @@ -10082,6 +10050,7 @@ consideration, you should minimize the use of these attributes. * Attribute Machine_Size:: * Attribute Mantissa:: * Attribute Maximum_Alignment:: +* Attribute Max_Integer_Size:: * Attribute Mechanism_Code:: * Attribute Null_Parameter:: * Attribute Object_Size:: @@ -10119,7 +10088,7 @@ consideration, you should minimize the use of these attributes. @end menu @node Attribute Abort_Signal,Attribute Address_Size,,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{167} +@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{166} @section Attribute Abort_Signal @@ -10133,7 +10102,7 @@ completely outside the normal semantics of Ada, for a user program to intercept the abort exception). @node Attribute Address_Size,Attribute Asm_Input,Attribute Abort_Signal,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{168} +@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{167} @section Attribute Address_Size @@ -10149,7 +10118,7 @@ reference to System.Address'Size is nonstatic because Address is a private type. @node Attribute Asm_Input,Attribute Asm_Output,Attribute Address_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{169} +@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{168} @section Attribute Asm_Input @@ -10163,10 +10132,10 @@ to be a static expression, and is the constraint for the parameter, value to be used as the input argument. The possible values for the constant are the same as those used in the RTL, and are dependent on the configuration file used to built the GCC back end. -@ref{16a,,Machine Code Insertions} +@ref{169,,Machine Code Insertions} @node Attribute Asm_Output,Attribute Atomic_Always_Lock_Free,Attribute Asm_Input,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{16b} +@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{16a} @section Attribute Asm_Output @@ -10182,10 +10151,10 @@ result. The possible values for constraint are the same as those used in the RTL, and are dependent on the configuration file used to build the GCC back end. If there are no output operands, then this argument may either be omitted, or explicitly given as @code{No_Output_Operands}. -@ref{16a,,Machine Code Insertions} +@ref{169,,Machine Code Insertions} @node Attribute Atomic_Always_Lock_Free,Attribute Bit,Attribute Asm_Output,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{16c} +@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{16b} @section Attribute Atomic_Always_Lock_Free @@ -10197,7 +10166,7 @@ and False otherwise. The result indicate whether atomic operations are supported by the target for the given type. @node Attribute Bit,Attribute Bit_Position,Attribute Atomic_Always_Lock_Free,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{16d} +@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{16c} @section Attribute Bit @@ -10228,7 +10197,7 @@ This attribute is designed to be compatible with the DEC Ada 83 definition and implementation of the @code{Bit} attribute. @node Attribute Bit_Position,Attribute Code_Address,Attribute Bit,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{16e} +@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{16d} @section Attribute Bit_Position @@ -10243,7 +10212,7 @@ type @emph{universal_integer}. The value depends only on the field the containing record @code{R}. @node Attribute Code_Address,Attribute Compiler_Version,Attribute Bit_Position,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{16f} +@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{16e} @section Attribute Code_Address @@ -10286,7 +10255,7 @@ the same value as is returned by the corresponding @code{'Address} attribute. @node Attribute Compiler_Version,Attribute Constrained,Attribute Code_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{170} +@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{16f} @section Attribute Compiler_Version @@ -10297,7 +10266,7 @@ prefix) yields a static string identifying the version of the compiler being used to compile the unit containing the attribute reference. @node Attribute Constrained,Attribute Default_Bit_Order,Attribute Compiler_Version,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{171} +@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{170} @section Attribute Constrained @@ -10312,7 +10281,7 @@ record type without discriminants is always @code{True}. This usage is compatible with older Ada compilers, including notably DEC Ada. @node Attribute Default_Bit_Order,Attribute Default_Scalar_Storage_Order,Attribute Constrained,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{172} +@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{171} @section Attribute Default_Bit_Order @@ -10329,7 +10298,7 @@ as a @code{Pos} value (0 for @code{High_Order_First}, 1 for @code{Default_Bit_Order} in package @code{System}. @node Attribute Default_Scalar_Storage_Order,Attribute Deref,Attribute Default_Bit_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{173} +@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{172} @section Attribute Default_Scalar_Storage_Order @@ -10346,7 +10315,7 @@ equal to @code{Default_Bit_Order} if unspecified) as a @code{System.Bit_Order} value. This is a static attribute. @node Attribute Deref,Attribute Descriptor_Size,Attribute Default_Scalar_Storage_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{174} +@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{173} @section Attribute Deref @@ -10359,7 +10328,7 @@ a named access-to-@cite{typ} type, except that it yields a variable, so it can b used on the left side of an assignment. @node Attribute Descriptor_Size,Attribute Elaborated,Attribute Deref,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{175} +@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{174} @section Attribute Descriptor_Size @@ -10388,7 +10357,7 @@ since @code{Positive} has an alignment of 4, the size of the descriptor is which yields a size of 32 bits, i.e. including 16 bits of padding. @node Attribute Elaborated,Attribute Elab_Body,Attribute Descriptor_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{176} +@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{175} @section Attribute Elaborated @@ -10403,7 +10372,7 @@ units has been completed. An exception is for units which need no elaboration, the value is always False for such units. @node Attribute Elab_Body,Attribute Elab_Spec,Attribute Elaborated,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{177} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{176} @section Attribute Elab_Body @@ -10419,7 +10388,7 @@ e.g., if it is necessary to do selective re-elaboration to fix some error. @node Attribute Elab_Spec,Attribute Elab_Subp_Body,Attribute Elab_Body,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{178} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{177} @section Attribute Elab_Spec @@ -10435,7 +10404,7 @@ Ada code, e.g., if it is necessary to do selective re-elaboration to fix some error. @node Attribute Elab_Subp_Body,Attribute Emax,Attribute Elab_Spec,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{179} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{178} @section Attribute Elab_Subp_Body @@ -10449,7 +10418,7 @@ elaboration procedure by the binder in CodePeer mode only and is unrecognized otherwise. @node Attribute Emax,Attribute Enabled,Attribute Elab_Subp_Body,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{17a} +@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{179} @section Attribute Emax @@ -10462,7 +10431,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Enabled,Attribute Enum_Rep,Attribute Emax,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{17b} +@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{17a} @section Attribute Enabled @@ -10486,7 +10455,7 @@ a @code{pragma Suppress} or @code{pragma Unsuppress} before instantiating the package or subprogram, controlling whether the check will be present. @node Attribute Enum_Rep,Attribute Enum_Val,Attribute Enabled,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{17c} +@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{17b} @section Attribute Enum_Rep @@ -10526,7 +10495,7 @@ integer calculation is done at run time, then the call to @code{Enum_Rep} may raise @code{Constraint_Error}. @node Attribute Enum_Val,Attribute Epsilon,Attribute Enum_Rep,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{17d} +@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{17c} @section Attribute Enum_Val @@ -10552,7 +10521,7 @@ absence of an enumeration representation clause. This is a static attribute (i.e., the result is static if the argument is static). @node Attribute Epsilon,Attribute Fast_Math,Attribute Enum_Val,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{17e} +@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{17d} @section Attribute Epsilon @@ -10565,7 +10534,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Fast_Math,Attribute Finalization_Size,Attribute Epsilon,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{17f} +@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{17e} @section Attribute Fast_Math @@ -10576,7 +10545,7 @@ prefix) yields a static Boolean value that is True if pragma @code{Fast_Math} is active, and False otherwise. @node Attribute Finalization_Size,Attribute Fixed_Value,Attribute Fast_Math,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{180} +@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{17f} @section Attribute Finalization_Size @@ -10594,7 +10563,7 @@ class-wide type whose tag denotes a type with no controlled parts. Note that only heap-allocated objects contain finalization data. @node Attribute Fixed_Value,Attribute From_Any,Attribute Finalization_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{181} +@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{180} @section Attribute Fixed_Value @@ -10621,7 +10590,7 @@ This attribute is primarily intended for use in implementation of the input-output functions for fixed-point values. @node Attribute From_Any,Attribute Has_Access_Values,Attribute Fixed_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{182} +@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{181} @section Attribute From_Any @@ -10631,7 +10600,7 @@ This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. @node Attribute Has_Access_Values,Attribute Has_Discriminants,Attribute From_Any,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{183} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{182} @section Attribute Has_Access_Values @@ -10649,7 +10618,7 @@ definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has access values. @node Attribute Has_Discriminants,Attribute Img,Attribute Has_Access_Values,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{184} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{183} @section Attribute Has_Discriminants @@ -10665,7 +10634,7 @@ definitions. If the attribute is applied to a generic private type, it indicates whether or not the corresponding actual type has discriminants. @node Attribute Img,Attribute Initialized,Attribute Has_Discriminants,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{185} +@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{184} @section Attribute Img @@ -10695,7 +10664,7 @@ that returns the appropriate string when called. This means that in an instantiation as a function parameter. @node Attribute Initialized,Attribute Integer_Value,Attribute Img,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{186} +@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{185} @section Attribute Initialized @@ -10705,7 +10674,7 @@ For the syntax and semantics of this attribute, see the SPARK 2014 Reference Manual, section 6.10. @node Attribute Integer_Value,Attribute Invalid_Value,Attribute Initialized,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{187} +@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{186} @section Attribute Integer_Value @@ -10733,7 +10702,7 @@ This attribute is primarily intended for use in implementation of the standard input-output functions for fixed-point values. @node Attribute Invalid_Value,Attribute Iterable,Attribute Integer_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{188} +@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{187} @section Attribute Invalid_Value @@ -10747,7 +10716,7 @@ including the ability to modify the value with the binder -Sxx flag and relevant environment variables at run time. @node Attribute Iterable,Attribute Large,Attribute Invalid_Value,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{189} +@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{188} @section Attribute Iterable @@ -10756,7 +10725,7 @@ relevant environment variables at run time. Equivalent to Aspect Iterable. @node Attribute Large,Attribute Library_Level,Attribute Iterable,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{18a} +@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{189} @section Attribute Large @@ -10769,7 +10738,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Library_Level,Attribute Lock_Free,Attribute Large,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{18b} +@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{18a} @section Attribute Library_Level @@ -10795,7 +10764,7 @@ end Gen; @end example @node Attribute Lock_Free,Attribute Loop_Entry,Attribute Library_Level,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{18c} +@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{18b} @section Attribute Lock_Free @@ -10805,7 +10774,7 @@ end Gen; pragma @code{Lock_Free} applies to P. @node Attribute Loop_Entry,Attribute Machine_Size,Attribute Lock_Free,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18d} +@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18c} @section Attribute Loop_Entry @@ -10835,7 +10804,7 @@ entry. This copy is not performed if the loop is not entered, or if the corresponding pragmas are ignored or disabled. @node Attribute Machine_Size,Attribute Mantissa,Attribute Loop_Entry,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18e} +@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18d} @section Attribute Machine_Size @@ -10845,7 +10814,7 @@ This attribute is identical to the @code{Object_Size} attribute. It is provided for compatibility with the DEC Ada 83 attribute of this name. @node Attribute Mantissa,Attribute Maximum_Alignment,Attribute Machine_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{18f} +@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{18e} @section Attribute Mantissa @@ -10857,8 +10826,8 @@ The @code{Mantissa} attribute is provided for compatibility with Ada 83. See the Ada 83 reference manual for an exact description of the semantics of this attribute. -@node Attribute Maximum_Alignment,Attribute Mechanism_Code,Attribute Mantissa,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{190}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{191} +@node Attribute Maximum_Alignment,Attribute Max_Integer_Size,Attribute Mantissa,Implementation Defined Attributes +@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{18f}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{190} @section Attribute Maximum_Alignment @@ -10873,7 +10842,18 @@ target. This is a static value that can be used to specify the alignment for an object, guaranteeing that it is properly aligned in all cases. -@node Attribute Mechanism_Code,Attribute Null_Parameter,Attribute Maximum_Alignment,Implementation Defined Attributes +@node Attribute Max_Integer_Size,Attribute Mechanism_Code,Attribute Maximum_Alignment,Implementation Defined Attributes +@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{191} +@section Attribute Max_Integer_Size + + +@geindex Max_Integer_Size + +@code{Standard'Max_Integer_Size} (@code{Standard} is the only permissible +prefix) provides the size of the largest supported integer type for +the target. The result is a static constant. + +@node Attribute Mechanism_Code,Attribute Null_Parameter,Attribute Max_Integer_Size,Implementation Defined Attributes @anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{192} @section Attribute Mechanism_Code @@ -10930,7 +10910,7 @@ There is no way of indicating this without the @code{Null_Parameter} attribute. @node Attribute Object_Size,Attribute Old,Attribute Null_Parameter,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{144}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{194} +@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{143}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{194} @section Attribute Object_Size @@ -11191,7 +11171,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Scalar_Storage_Order,Attribute Simple_Storage_Pool,Attribute Safe_Small,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19e}@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{152} +@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19e}@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{151} @section Attribute Scalar_Storage_Order @@ -11314,7 +11294,7 @@ Note that debuggers may be unable to display the correct value of scalar components of a type for which the opposite storage order is specified. @node Attribute Simple_Storage_Pool,Attribute Small,Attribute Scalar_Storage_Order,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{e6}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19f} +@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{e5}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19f} @section Attribute Simple_Storage_Pool @@ -11906,7 +11886,7 @@ gives the result that would be obtained by applying the attribute to the corresponding type. @node Attribute Value_Size,Attribute Wchar_T_Size,Attribute VADS_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b0}@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{161} +@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b0}@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{160} @section Attribute Value_Size @@ -12668,7 +12648,7 @@ only declared at the library level. @geindex No_Local_Timing_Events -[RM D.7] All objects of type Ada.Timing_Events.Timing_Event are +[RM D.7] All objects of type Ada.Real_Time.Timing_Events.Timing_Event are declared at the library level. @node No_Long_Long_Integers,No_Multiple_Elaboration,No_Local_Timing_Events,Partition-Wide Restrictions @@ -13764,11 +13744,11 @@ former provides improved compatibility with other implementations supporting this type. The latter corresponds to the highest precision floating-point type supported by the hardware. On most machines, this will be the same as @code{Long_Float}, but on some machines, it will -correspond to the IEEE extended form. The notable case is all ia32 -(x86) implementations, where @code{Long_Long_Float} corresponds to -the 80-bit extended precision format supported in hardware on this -processor. Note that the 128-bit format on SPARC is not supported, -since this is a software rather than a hardware format. +correspond to the IEEE extended form. The notable case is all x86 +implementations, where @code{Long_Long_Float} corresponds to the 80-bit +extended precision format supported in hardware on this processor. +Note that the 128-bit format on SPARC is not supported, since this +is a software rather than a hardware format. @geindex Multidimensional arrays @@ -15407,8 +15387,7 @@ Manual, and are summarized in Annex M. A requirement for conforming Ada compilers is that they provide documentation describing how the implementation deals with each of these issues. In this chapter you will find each point in Annex M listed, -followed by a description of how GNAT -handles the implementation dependence. +followed by a description of how GNAT handles the implementation dependence. You can use this chapter as a guide to minimizing implementation dependent features in your programs if portability to other compilers @@ -15543,7 +15522,7 @@ further details. @end itemize -@multitable {xxxxxxxxxxxxxxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} +@multitable {xxxxxxxxxxxxxxxxxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} @headitem Type @@ -15558,7 +15537,7 @@ Representation @tab -8 bit signed +8-bit signed @item @@ -15566,7 +15545,7 @@ Representation @tab -(Short) 16 bit signed +16-bit signed @item @@ -15574,7 +15553,7 @@ Representation @tab -32 bit signed +32-bit signed @item @@ -15582,9 +15561,9 @@ Representation @tab -64 bit signed (on most 64 bit targets, -depending on the C definition of long). -32 bit signed (all other targets) +64-bit signed (on most 64-bit targets, +depending on the C definition of long) +32-bit signed (on all other targets) @item @@ -15592,7 +15571,16 @@ depending on the C definition of long). @tab -64 bit signed +64-bit signed + +@item + +@emph{Long_Long_Long_Integer} + +@tab + +128-bit signed (on 64-bit targets) +64-bit signed (on 32-bit targets) @end multitable @@ -15700,7 +15688,7 @@ supported for fixed point types. See 3.5.9(10)." Any combinations are permitted that do not result in a small less than @code{Fine_Delta} and do not result in a mantissa larger than 63 bits. If the mantissa is larger than 53 bits on machines where Long_Long_Float -is 64 bits (true of all architectures except ia32), then the output from +is 64 bits (true of all architectures except x86), then the output from Text_IO is accurate to only 53 bits, rather than the full mantissa. This is because floating-point conversions are used to convert fixed point. @@ -17524,7 +17512,7 @@ perfect result set. See G.2.3(22)." The result is only defined to be in the perfect result set if the result can be computed by a single scaling operation involving a scale factor -representable in 64-bits. +representable in 64 bits. @itemize * @@ -17950,7 +17938,7 @@ For elementary types, the alignment is the minimum of the actual size of objects of the type divided by @code{Storage_Unit}, and the maximum alignment supported by the target. (This maximum alignment is given by the GNAT-specific attribute -@code{Standard'Maximum_Alignment}; see @ref{190,,Attribute Maximum_Alignment}.) +@code{Standard'Maximum_Alignment}; see @ref{18f,,Attribute Maximum_Alignment}.) @geindex Maximum_Alignment attribute @@ -18117,12 +18105,12 @@ type My_Boolean is new Boolean; for My_Boolean'Size use 32; @end example -then values of this type will always be 32 bits long. In the case of -discrete types, the size can be increased up to 64 bits, with the effect -that the entire specified field is used to hold the value, sign- or -zero-extended as appropriate. If more than 64 bits is specified, then -padding space is allocated after the value, and a warning is issued that -there are unused bits. +then values of this type will always be 32-bit long. In the case of discrete +types, the size can be increased up to 64 bits on 32-bit targets and 128 bits +on 64-bit targets, with the effect that the entire specified field is used to +hold the value, sign- or zero-extended as appropriate. If more than 64 bits +or 128 bits resp. is specified, then padding space is allocated after the +value, and a warning is issued that there are unused bits. Similarly the size of records and arrays may be increased, and the effect is to add padding bits after the value. This also causes a warning message @@ -18686,8 +18674,9 @@ of this subtype, and must be a multiple of the alignment value. In addition, component size clauses are allowed which cause the array to be packed, by specifying a smaller value. A first case is for -component size values in the range 1 through 63. The value specified -must not be smaller than the Size of the subtype. GNAT will accurately +component size values in the range 1 through 63 on 32-bit targets, +and 1 through 127 on 64-bit targets. The value specified may not +be smaller than the Size of the subtype. GNAT will accurately honor all packing requests in this range. For example, if we have: @example @@ -19107,7 +19096,8 @@ Any small simple record type with a static size. @end itemize For all these cases, if the component subtype size is in the range -1 through 64, then the effect of the pragma @code{Pack} is exactly as though a +1 through 63 on 32-bit targets, and 1 through 127 on 64-bit targets, +then the effect of the pragma @code{Pack} is exactly as though a component size were specified giving the component subtype size. All other types are non-packable, they occupy an integral number of storage @@ -19137,11 +19127,13 @@ using an explicit @code{Component_Size} setting instead, which never generates a warning, since the intention of the programmer is clear in this case. GNAT treats packed arrays in one of two ways. If the size of the array is -known at compile time and is less than 64 bits, then internally the array -is represented as a single modular type, of exactly the appropriate number -of bits. If the length is greater than 63 bits, or is not known at compile -time, then the packed array is represented as an array of bytes, and the -length is always a multiple of 8 bits. +known at compile time and is at most 64 bits on 32-bit targets, and at most +128 bits on 64-bit targets, then internally the array is represented as a +single modular type, of exactly the appropriate number of bits. If the +length is greater than 64 bits on 32-bit targets, and greater than 128 +bits on 64-bit targets, or is not known at compile time, then the packed +array is represented as an array of bytes, and its length is always a +multiple of 8 bits. Note that to represent a packed array as a modular type, the alignment must be suitable for the modular type involved. For example, on typical machines @@ -19217,7 +19209,7 @@ Components of the following types are considered packable: @item Components of an elementary type are packable unless they are aliased, -independent, or of an atomic type. +independent or atomic. @item Small packed arrays, where the size is statically known, are represented @@ -19227,10 +19219,10 @@ internally as modular integers, and so they are also packable. Small simple records, where the size is statically known, are also packable. @end itemize -For all these cases, if the @code{'Size} value is in the range 1 through 64, the -components occupy the exact number of bits corresponding to this value -and are packed with no padding bits, i.e. they can start on an arbitrary -bit boundary. +For all these cases, if the @code{'Size} value is in the range 1 through 64 on +32-bit targets, and 1 through 128 on 64-bit targets, the components occupy +the exact number of bits corresponding to this value and are packed with no +padding bits, i.e. they can start on an arbitrary bit boundary. All other types are non-packable, they occupy an integral number of storage units and the only effect of pragma @code{Pack} is to remove alignment gaps. @@ -19257,7 +19249,7 @@ end record; pragma Pack (X2); @end example -The representation for the record @code{X2} is as follows: +The representation for the record @code{X2} is as follows on 32-bit targets: @example for X2'Size use 224; @@ -19272,17 +19264,16 @@ end record; @end example Studying this example, we see that the packable fields @code{L1} -and @code{L2} are -of length equal to their sizes, and placed at specific bit boundaries (and -not byte boundaries) to -eliminate padding. But @code{L3} is of a non-packable float type (because +and @code{L2} are of length equal to their sizes, and placed at +specific bit boundaries (and not byte boundaries) to eliminate +padding. But @code{L3} is of a non-packable float type (because it is aliased), so it is on the next appropriate alignment boundary. The next two fields are fully packable, so @code{L4} and @code{L5} are minimally packed with no gaps. However, type @code{Rb2} is a packed -array that is longer than 64 bits, so it is itself non-packable. Thus -the @code{L6} field is aligned to the next byte boundary, and takes an -integral number of bytes, i.e., 72 bits. +array that is longer than 64 bits, so it is itself non-packable on +32-bit targets. Thus the @code{L6} field is aligned to the next byte +boundary, and takes an integral number of bytes, i.e., 72 bits. @node Record Representation Clauses,Handling of Records with Holes,Pragma Pack for Records,Representation Clauses and Pragmas @anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{28b}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{28c} @@ -19303,7 +19294,8 @@ clauses is that the size must be at least the @code{'Size} value of the type (actually the Value_Size). There are no restrictions due to alignment, and such components may freely cross storage boundaries. -Packed arrays with a size up to and including 64 bits are represented +Packed arrays with a size up to and including 64 bits on 32-bit targets, +and up to and including 128 bits on 64-bit targets, are represented internally using a modular type with the appropriate number of bits, and thus the same lack of restriction applies. For example, if you declare: @@ -19316,30 +19308,30 @@ for R'Size use 49; then a component clause for a component of type @code{R} may start on any specified bit boundary, and may specify a value of 49 bits or greater. -For packed bit arrays that are longer than 64 bits, there are two -cases. If the component size is a power of 2 (1,2,4,8,16,32 bits), -including the important case of single bits or boolean values, then -there are no limitations on placement of such components, and they -may start and end at arbitrary bit boundaries. +For packed bit arrays that are longer than 64 bits on 32-bit targets, +and longer than 128 bits on 64-bit targets, there are two cases. If the +component size is a power of 2 (1,2,4,8,16,32,64 bits), including the +important case of single bits or boolean values, then there are no +limitations on placement of such components, and they may start and +end at arbitrary bit boundaries. -If the component size is not a power of 2 (e.g., 3 or 5), then -an array of this type longer than 64 bits must always be placed on -on a storage unit (byte) boundary and occupy an integral number -of storage units (bytes). Any component clause that does not -meet this requirement will be rejected. +If the component size is not a power of 2 (e.g., 3 or 5), then an array +of this type must always be placed on on a storage unit (byte) boundary +and occupy an integral number of storage units (bytes). Any component +clause that does not meet this requirement will be rejected. -Any aliased component, or component of an aliased type, must -have its normal alignment and size. A component clause that -does not meet this requirement will be rejected. +Any aliased component, or component of an aliased type, must have its +normal alignment and size. A component clause that does not meet this +requirement will be rejected. The tag field of a tagged type always occupies an address sized field at the start of the record. No component clause may attempt to overlay this tag. When a tagged type appears as a component, the tag field must have proper alignment -In the case of a record extension @code{T1}, of a type @code{T}, no component clause applied -to the type @code{T1} can specify a storage location that would overlap the first -@code{T'Size} bytes of the record. +In the case of a record extension @code{T1}, of a type @code{T}, no component +clause applied to the type @code{T1} can specify a storage location that +would overlap the first @code{T'Object_Size} bits of the record. For all other component types, including non-bit-packed arrays, the component can be placed at an arbitrary bit boundary, @@ -19370,8 +19362,7 @@ end record; @geindex Handling of Records with Holes As a result of alignment considerations, records may contain "holes" -or gaps -which do not correspond to the data bits of any of the components. +or gaps which do not correspond to the data bits of any of the components. Record representation clauses can also result in holes in records. GNAT does not attempt to clear these holes, so in record objects, @@ -22592,6 +22583,7 @@ of GNAT, and will generate a warning message. * Ada.Strings.Unbounded.Text_IO (a-suteio.ads): Ada Strings Unbounded Text_IO a-suteio ads. * Ada.Strings.Wide_Unbounded.Wide_Text_IO (a-swuwti.ads): Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads. * Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO (a-szuzti.ads): Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads. +* Ada.Task_Initialization (a-tasini.ads): Ada Task_Initialization a-tasini ads. * Ada.Text_IO.C_Streams (a-tiocst.ads): Ada Text_IO C_Streams a-tiocst ads. * Ada.Text_IO.Reset_Standard_Files (a-tirsfi.ads): Ada Text_IO Reset_Standard_Files a-tirsfi ads. * Ada.Wide_Characters.Unicode (a-wichun.ads): Ada Wide_Characters Unicode a-wichun ads. @@ -23189,7 +23181,7 @@ This package provides subprograms for Text_IO for unbounded wide strings, avoiding the necessity for an intermediate operation with ordinary wide strings. -@node Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Text_IO C_Streams a-tiocst ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,The GNAT Library +@node Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Task_Initialization a-tasini ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,The GNAT Library @anchor{gnat_rm/the_gnat_library id29}@anchor{309}@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{30a} @section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads}) @@ -23206,8 +23198,20 @@ This package provides subprograms for Text_IO for unbounded wide wide strings, avoiding the necessity for an intermediate operation with ordinary wide wide strings. -@node Ada Text_IO C_Streams a-tiocst ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id30}@anchor{30c} +@node Ada Task_Initialization a-tasini ads,Ada Text_IO C_Streams a-tiocst ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,The GNAT Library +@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id30}@anchor{30c} +@section @code{Ada.Task_Initialization} (@code{a-tasini.ads}) + + +@geindex Ada.Task_Initialization (a-tasini.ads) + +This package provides a way to set a global initialization handler that +is automatically invoked whenever a task is activated. Handlers are +parameterless procedures. Note that such a handler is only invoked for +those tasks activated after the handler is set. + +@node Ada Text_IO C_Streams a-tiocst ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Task_Initialization a-tasini ads,The GNAT Library +@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id31}@anchor{30e} @section @code{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads}) @@ -23222,7 +23226,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Wide_Characters Unicode a-wichun ads,Ada Text_IO C_Streams a-tiocst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id31}@anchor{30e} +@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{30f}@anchor{gnat_rm/the_gnat_library id32}@anchor{310} @section @code{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads}) @@ -23237,7 +23241,7 @@ execution (for example a standard input file may be redefined to be interactive). @node Ada Wide_Characters Unicode a-wichun ads,Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id32}@anchor{30f}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{310} +@anchor{gnat_rm/the_gnat_library id33}@anchor{311}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{312} @section @code{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads}) @@ -23250,7 +23254,7 @@ This package provides subprograms that allow categorization of Wide_Character values according to Unicode categories. @node Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Characters Unicode a-wichun ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{311}@anchor{gnat_rm/the_gnat_library id33}@anchor{312} +@anchor{gnat_rm/the_gnat_library id34}@anchor{313}@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{314} @section @code{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads}) @@ -23265,7 +23269,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Wide_Characters Unicode a-zchuni ads,Ada Wide_Text_IO C_Streams a-wtcstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id34}@anchor{314} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{315}@anchor{gnat_rm/the_gnat_library id35}@anchor{316} @section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads}) @@ -23280,7 +23284,7 @@ execution (for example a standard input file may be redefined to be interactive). @node Ada Wide_Wide_Characters Unicode a-zchuni ads,Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id35}@anchor{315}@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{316} +@anchor{gnat_rm/the_gnat_library id36}@anchor{317}@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{318} @section @code{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads}) @@ -23293,7 +23297,7 @@ This package provides subprograms that allow categorization of Wide_Wide_Character values according to Unicode categories. @node Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,Ada Wide_Wide_Characters Unicode a-zchuni ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id36}@anchor{317}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{318} +@anchor{gnat_rm/the_gnat_library id37}@anchor{319}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{31a} @section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads}) @@ -23308,7 +23312,7 @@ extracted from a file opened on the Ada side, and an Ada file can be constructed from a stream opened on the C side. @node Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,GNAT Altivec g-altive ads,Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id37}@anchor{319}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{31a} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id38}@anchor{31c} @section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads}) @@ -23323,7 +23327,7 @@ change during execution (for example a standard input file may be redefined to be interactive). @node GNAT Altivec g-altive ads,GNAT Altivec Conversions g-altcon ads,Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id38}@anchor{31c} +@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id39}@anchor{31e} @section @code{GNAT.Altivec} (@code{g-altive.ads}) @@ -23336,7 +23340,7 @@ definitions of constants and types common to all the versions of the binding. @node GNAT Altivec Conversions g-altcon ads,GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec g-altive ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id39}@anchor{31e} +@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id40}@anchor{320} @section @code{GNAT.Altivec.Conversions} (@code{g-altcon.ads}) @@ -23347,7 +23351,7 @@ binding. This package provides the Vector/View conversion routines. @node GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Conversions g-altcon ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id40}@anchor{320} +@anchor{gnat_rm/the_gnat_library id41}@anchor{321}@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{322} @section @code{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads}) @@ -23361,7 +23365,7 @@ library. The hard binding is provided as a separate package. This unit is common to both bindings. @node GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Vector_Views g-alvevi ads,GNAT Altivec Vector_Operations g-alveop ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id41}@anchor{322} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{323}@anchor{gnat_rm/the_gnat_library id42}@anchor{324} @section @code{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads}) @@ -23373,7 +23377,7 @@ This package exposes the various vector types part of the Ada binding to AltiVec facilities. @node GNAT Altivec Vector_Views g-alvevi ads,GNAT Array_Split g-arrspl ads,GNAT Altivec Vector_Types g-alvety ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{323}@anchor{gnat_rm/the_gnat_library id42}@anchor{324} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id43}@anchor{326} @section @code{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads}) @@ -23388,7 +23392,7 @@ vector elements and provides a simple way to initialize vector objects. @node GNAT Array_Split g-arrspl ads,GNAT AWK g-awk ads,GNAT Altivec Vector_Views g-alvevi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id43}@anchor{326} +@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{327}@anchor{gnat_rm/the_gnat_library id44}@anchor{328} @section @code{GNAT.Array_Split} (@code{g-arrspl.ads}) @@ -23401,7 +23405,7 @@ an array wherever the separators appear, and provide direct access to the resulting slices. @node GNAT AWK g-awk ads,GNAT Bind_Environment g-binenv ads,GNAT Array_Split g-arrspl ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id44}@anchor{327}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{328} +@anchor{gnat_rm/the_gnat_library id45}@anchor{329}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{32a} @section @code{GNAT.AWK} (@code{g-awk.ads}) @@ -23416,7 +23420,7 @@ or more files containing formatted data. The file is viewed as a database where each record is a line and a field is a data element in this line. @node GNAT Bind_Environment g-binenv ads,GNAT Branch_Prediction g-brapre ads,GNAT AWK g-awk ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{329}@anchor{gnat_rm/the_gnat_library id45}@anchor{32a} +@anchor{gnat_rm/the_gnat_library id46}@anchor{32b}@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{32c} @section @code{GNAT.Bind_Environment} (@code{g-binenv.ads}) @@ -23429,7 +23433,7 @@ These associations can be specified using the @code{-V} binder command line switch. @node GNAT Branch_Prediction g-brapre ads,GNAT Bounded_Buffers g-boubuf ads,GNAT Bind_Environment g-binenv ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id46}@anchor{32b}@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{32c} +@anchor{gnat_rm/the_gnat_library id47}@anchor{32d}@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{32e} @section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads}) @@ -23440,7 +23444,7 @@ line switch. Provides routines giving hints to the branch predictor of the code generator. @node GNAT Bounded_Buffers g-boubuf ads,GNAT Bounded_Mailboxes g-boumai ads,GNAT Branch_Prediction g-brapre ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id47}@anchor{32d}@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{32e} +@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id48}@anchor{330} @section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads}) @@ -23455,7 +23459,7 @@ useful directly or as parts of the implementations of other abstractions, such as mailboxes. @node GNAT Bounded_Mailboxes g-boumai ads,GNAT Bubble_Sort g-bubsor ads,GNAT Bounded_Buffers g-boubuf ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id48}@anchor{330} +@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id49}@anchor{332} @section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads}) @@ -23468,7 +23472,7 @@ such as mailboxes. Provides a thread-safe asynchronous intertask mailbox communication facility. @node GNAT Bubble_Sort g-bubsor ads,GNAT Bubble_Sort_A g-busora ads,GNAT Bounded_Mailboxes g-boumai ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id49}@anchor{332} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{333}@anchor{gnat_rm/the_gnat_library id50}@anchor{334} @section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads}) @@ -23483,7 +23487,7 @@ data items. Exchange and comparison procedures are provided by passing access-to-procedure values. @node GNAT Bubble_Sort_A g-busora ads,GNAT Bubble_Sort_G g-busorg ads,GNAT Bubble_Sort g-bubsor ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id50}@anchor{333}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{334} +@anchor{gnat_rm/the_gnat_library id51}@anchor{335}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{336} @section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads}) @@ -23499,7 +23503,7 @@ access-to-procedure values. This is an older version, retained for compatibility. Usually @code{GNAT.Bubble_Sort} will be preferable. @node GNAT Bubble_Sort_G g-busorg ads,GNAT Byte_Order_Mark g-byorma ads,GNAT Bubble_Sort_A g-busora ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id51}@anchor{336} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id52}@anchor{338} @section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads}) @@ -23515,7 +23519,7 @@ if the procedures can be inlined, at the expense of duplicating code for multiple instantiations. @node GNAT Byte_Order_Mark g-byorma ads,GNAT Byte_Swapping g-bytswa ads,GNAT Bubble_Sort_G g-busorg ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id52}@anchor{338} +@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id53}@anchor{33a} @section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads}) @@ -23531,7 +23535,7 @@ the encoding of the string. The routine includes detection of special XML sequences for various UCS input formats. @node GNAT Byte_Swapping g-bytswa ads,GNAT Calendar g-calend ads,GNAT Byte_Order_Mark g-byorma ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id53}@anchor{33a} +@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id54}@anchor{33c} @section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads}) @@ -23545,7 +23549,7 @@ General routines for swapping the bytes in 2-, 4-, and 8-byte quantities. Machine-specific implementations are available in some cases. @node GNAT Calendar g-calend ads,GNAT Calendar Time_IO g-catiio ads,GNAT Byte_Swapping g-bytswa ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id54}@anchor{33b}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{33c} +@anchor{gnat_rm/the_gnat_library id55}@anchor{33d}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{33e} @section @code{GNAT.Calendar} (@code{g-calend.ads}) @@ -23559,7 +23563,7 @@ Also provides conversion of @code{Ada.Calendar.Time} values to and from the C @code{timeval} format. @node GNAT Calendar Time_IO g-catiio ads,GNAT CRC32 g-crc32 ads,GNAT Calendar g-calend ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id55}@anchor{33d}@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{33e} +@anchor{gnat_rm/the_gnat_library id56}@anchor{33f}@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{340} @section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads}) @@ -23570,7 +23574,7 @@ C @code{timeval} format. @geindex GNAT.Calendar.Time_IO (g-catiio.ads) @node GNAT CRC32 g-crc32 ads,GNAT Case_Util g-casuti ads,GNAT Calendar Time_IO g-catiio ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id56}@anchor{33f}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{340} +@anchor{gnat_rm/the_gnat_library id57}@anchor{341}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{342} @section @code{GNAT.CRC32} (@code{g-crc32.ads}) @@ -23587,7 +23591,7 @@ of this algorithm see Aug. 1988. Sarwate, D.V. @node GNAT Case_Util g-casuti ads,GNAT CGI g-cgi ads,GNAT CRC32 g-crc32 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id57}@anchor{341}@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{342} +@anchor{gnat_rm/the_gnat_library id58}@anchor{343}@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{344} @section @code{GNAT.Case_Util} (@code{g-casuti.ads}) @@ -23602,7 +23606,7 @@ without the overhead of the full casing tables in @code{Ada.Characters.Handling}. @node GNAT CGI g-cgi ads,GNAT CGI Cookie g-cgicoo ads,GNAT Case_Util g-casuti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id58}@anchor{343}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{344} +@anchor{gnat_rm/the_gnat_library id59}@anchor{345}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{346} @section @code{GNAT.CGI} (@code{g-cgi.ads}) @@ -23617,7 +23621,7 @@ builds a table whose index is the key and provides some services to deal with this table. @node GNAT CGI Cookie g-cgicoo ads,GNAT CGI Debug g-cgideb ads,GNAT CGI g-cgi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id59}@anchor{346} +@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id60}@anchor{348} @section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads}) @@ -23632,7 +23636,7 @@ Common Gateway Interface (CGI). It exports services to deal with Web cookies (piece of information kept in the Web client software). @node GNAT CGI Debug g-cgideb ads,GNAT Command_Line g-comlin ads,GNAT CGI Cookie g-cgicoo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id60}@anchor{348} +@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{349}@anchor{gnat_rm/the_gnat_library id61}@anchor{34a} @section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads}) @@ -23644,7 +23648,7 @@ This is a package to help debugging CGI (Common Gateway Interface) programs written in Ada. @node GNAT Command_Line g-comlin ads,GNAT Compiler_Version g-comver ads,GNAT CGI Debug g-cgideb ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id61}@anchor{349}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{34a} +@anchor{gnat_rm/the_gnat_library id62}@anchor{34b}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{34c} @section @code{GNAT.Command_Line} (@code{g-comlin.ads}) @@ -23657,7 +23661,7 @@ including the ability to scan for named switches with optional parameters and expand file names using wildcard notations. @node GNAT Compiler_Version g-comver ads,GNAT Ctrl_C g-ctrl_c ads,GNAT Command_Line g-comlin ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id62}@anchor{34c} +@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id63}@anchor{34e} @section @code{GNAT.Compiler_Version} (@code{g-comver.ads}) @@ -23675,7 +23679,7 @@ of the compiler if a consistent tool set is used to compile all units of a partition). @node GNAT Ctrl_C g-ctrl_c ads,GNAT Current_Exception g-curexc ads,GNAT Compiler_Version g-comver ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id63}@anchor{34e} +@anchor{gnat_rm/the_gnat_library id64}@anchor{34f}@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{350} @section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads}) @@ -23686,7 +23690,7 @@ of a partition). Provides a simple interface to handle Ctrl-C keyboard events. @node GNAT Current_Exception g-curexc ads,GNAT Debug_Pools g-debpoo ads,GNAT Ctrl_C g-ctrl_c ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id64}@anchor{34f}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{350} +@anchor{gnat_rm/the_gnat_library id65}@anchor{351}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{352} @section @code{GNAT.Current_Exception} (@code{g-curexc.ads}) @@ -23703,7 +23707,7 @@ This is particularly useful in simulating typical facilities for obtaining information about exceptions provided by Ada 83 compilers. @node GNAT Debug_Pools g-debpoo ads,GNAT Debug_Utilities g-debuti ads,GNAT Current_Exception g-curexc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{351}@anchor{gnat_rm/the_gnat_library id65}@anchor{352} +@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id66}@anchor{354} @section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads}) @@ -23720,7 +23724,7 @@ problems. See @code{The GNAT Debug_Pool Facility} section in the @cite{GNAT User's Guide}. @node GNAT Debug_Utilities g-debuti ads,GNAT Decode_String g-decstr ads,GNAT Debug_Pools g-debpoo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id66}@anchor{354} +@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id67}@anchor{356} @section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads}) @@ -23733,7 +23737,7 @@ to and from string images of address values. Supports both C and Ada formats for hexadecimal literals. @node GNAT Decode_String g-decstr ads,GNAT Decode_UTF8_String g-deutst ads,GNAT Debug_Utilities g-debuti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id67}@anchor{355}@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{356} +@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id68}@anchor{358} @section @code{GNAT.Decode_String} (@code{g-decstr.ads}) @@ -23757,7 +23761,7 @@ Useful in conjunction with Unicode character coding. Note there is a preinstantiation for UTF-8. See next entry. @node GNAT Decode_UTF8_String g-deutst ads,GNAT Directory_Operations g-dirope ads,GNAT Decode_String g-decstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id68}@anchor{358} +@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id69}@anchor{35a} @section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads}) @@ -23778,7 +23782,7 @@ preinstantiation for UTF-8. See next entry. A preinstantiation of GNAT.Decode_Strings for UTF-8 encoding. @node GNAT Directory_Operations g-dirope ads,GNAT Directory_Operations Iteration g-diopit ads,GNAT Decode_UTF8_String g-deutst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id69}@anchor{359}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{35a} +@anchor{gnat_rm/the_gnat_library id70}@anchor{35b}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{35c} @section @code{GNAT.Directory_Operations} (@code{g-dirope.ads}) @@ -23791,7 +23795,7 @@ the current directory, making new directories, and scanning the files in a directory. @node GNAT Directory_Operations Iteration g-diopit ads,GNAT Dynamic_HTables g-dynhta ads,GNAT Directory_Operations g-dirope ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id70}@anchor{35b}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{35c} +@anchor{gnat_rm/the_gnat_library id71}@anchor{35d}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{35e} @section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads}) @@ -23803,7 +23807,7 @@ A child unit of GNAT.Directory_Operations providing additional operations for iterating through directories. @node GNAT Dynamic_HTables g-dynhta ads,GNAT Dynamic_Tables g-dyntab ads,GNAT Directory_Operations Iteration g-diopit ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id71}@anchor{35d}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{35e} +@anchor{gnat_rm/the_gnat_library id72}@anchor{35f}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{360} @section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads}) @@ -23821,7 +23825,7 @@ dynamic instances of the hash table, while an instantiation of @code{GNAT.HTable} creates a single instance of the hash table. @node GNAT Dynamic_Tables g-dyntab ads,GNAT Encode_String g-encstr ads,GNAT Dynamic_HTables g-dynhta ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id72}@anchor{360} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{361}@anchor{gnat_rm/the_gnat_library id73}@anchor{362} @section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads}) @@ -23841,7 +23845,7 @@ dynamic instances of the table, while an instantiation of @code{GNAT.Table} creates a single instance of the table type. @node GNAT Encode_String g-encstr ads,GNAT Encode_UTF8_String g-enutst ads,GNAT Dynamic_Tables g-dyntab ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id73}@anchor{361}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{362} +@anchor{gnat_rm/the_gnat_library id74}@anchor{363}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{364} @section @code{GNAT.Encode_String} (@code{g-encstr.ads}) @@ -23863,7 +23867,7 @@ encoding method. Useful in conjunction with Unicode character coding. Note there is a preinstantiation for UTF-8. See next entry. @node GNAT Encode_UTF8_String g-enutst ads,GNAT Exception_Actions g-excact ads,GNAT Encode_String g-encstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{363}@anchor{gnat_rm/the_gnat_library id74}@anchor{364} +@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id75}@anchor{366} @section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads}) @@ -23884,7 +23888,7 @@ Note there is a preinstantiation for UTF-8. See next entry. A preinstantiation of GNAT.Encode_Strings for UTF-8 encoding. @node GNAT Exception_Actions g-excact ads,GNAT Exception_Traces g-exctra ads,GNAT Encode_UTF8_String g-enutst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id75}@anchor{366} +@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id76}@anchor{368} @section @code{GNAT.Exception_Actions} (@code{g-excact.ads}) @@ -23897,7 +23901,7 @@ for specific exceptions, or when any exception is raised. This can be used for instance to force a core dump to ease debugging. @node GNAT Exception_Traces g-exctra ads,GNAT Exceptions g-except ads,GNAT Exception_Actions g-excact ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id76}@anchor{368} +@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{369}@anchor{gnat_rm/the_gnat_library id77}@anchor{36a} @section @code{GNAT.Exception_Traces} (@code{g-exctra.ads}) @@ -23911,7 +23915,7 @@ Provides an interface allowing to control automatic output upon exception occurrences. @node GNAT Exceptions g-except ads,GNAT Expect g-expect ads,GNAT Exception_Traces g-exctra ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id77}@anchor{369}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{36a} +@anchor{gnat_rm/the_gnat_library id78}@anchor{36b}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{36c} @section @code{GNAT.Exceptions} (@code{g-except.ads}) @@ -23932,7 +23936,7 @@ predefined exceptions, and for example allow raising @code{Constraint_Error} with a message from a pure subprogram. @node GNAT Expect g-expect ads,GNAT Expect TTY g-exptty ads,GNAT Exceptions g-except ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id78}@anchor{36b}@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{36c} +@anchor{gnat_rm/the_gnat_library id79}@anchor{36d}@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{36e} @section @code{GNAT.Expect} (@code{g-expect.ads}) @@ -23948,7 +23952,7 @@ It is not implemented for cross ports, and in particular is not implemented for VxWorks or LynxOS. @node GNAT Expect TTY g-exptty ads,GNAT Float_Control g-flocon ads,GNAT Expect g-expect ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id79}@anchor{36d}@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{36e} +@anchor{gnat_rm/the_gnat_library id80}@anchor{36f}@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{370} @section @code{GNAT.Expect.TTY} (@code{g-exptty.ads}) @@ -23960,7 +23964,7 @@ ports. It is not implemented for cross ports, and in particular is not implemented for VxWorks or LynxOS. @node GNAT Float_Control g-flocon ads,GNAT Formatted_String g-forstr ads,GNAT Expect TTY g-exptty ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id80}@anchor{36f}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{370} +@anchor{gnat_rm/the_gnat_library id81}@anchor{371}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{372} @section @code{GNAT.Float_Control} (@code{g-flocon.ads}) @@ -23974,7 +23978,7 @@ library calls may cause this mode to be modified, and the Reset procedure in this package can be used to reestablish the required mode. @node GNAT Formatted_String g-forstr ads,GNAT Heap_Sort g-heasor ads,GNAT Float_Control g-flocon ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id81}@anchor{371}@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{372} +@anchor{gnat_rm/the_gnat_library id82}@anchor{373}@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{374} @section @code{GNAT.Formatted_String} (@code{g-forstr.ads}) @@ -23989,7 +23993,7 @@ derived from Integer, Float or enumerations as values for the formatted string. @node GNAT Heap_Sort g-heasor ads,GNAT Heap_Sort_A g-hesora ads,GNAT Formatted_String g-forstr ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id82}@anchor{374} +@anchor{gnat_rm/the_gnat_library id83}@anchor{375}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{376} @section @code{GNAT.Heap_Sort} (@code{g-heasor.ads}) @@ -24003,7 +24007,7 @@ access-to-procedure values. The algorithm used is a modified heap sort that performs approximately N*log(N) comparisons in the worst case. @node GNAT Heap_Sort_A g-hesora ads,GNAT Heap_Sort_G g-hesorg ads,GNAT Heap_Sort g-heasor ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id83}@anchor{375}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{376} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{377}@anchor{gnat_rm/the_gnat_library id84}@anchor{378} @section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads}) @@ -24019,7 +24023,7 @@ This differs from @code{GNAT.Heap_Sort} in having a less convenient interface, but may be slightly more efficient. @node GNAT Heap_Sort_G g-hesorg ads,GNAT HTable g-htable ads,GNAT Heap_Sort_A g-hesora ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id84}@anchor{377}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{378} +@anchor{gnat_rm/the_gnat_library id85}@anchor{379}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{37a} @section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads}) @@ -24033,7 +24037,7 @@ if the procedures can be inlined, at the expense of duplicating code for multiple instantiations. @node GNAT HTable g-htable ads,GNAT IO g-io ads,GNAT Heap_Sort_G g-hesorg ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id85}@anchor{379}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{37a} +@anchor{gnat_rm/the_gnat_library id86}@anchor{37b}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{37c} @section @code{GNAT.HTable} (@code{g-htable.ads}) @@ -24046,7 +24050,7 @@ data. Provides two approaches, one a simple static approach, and the other allowing arbitrary dynamic hash tables. @node GNAT IO g-io ads,GNAT IO_Aux g-io_aux ads,GNAT HTable g-htable ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id86}@anchor{37b}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{37c} +@anchor{gnat_rm/the_gnat_library id87}@anchor{37d}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{37e} @section @code{GNAT.IO} (@code{g-io.ads}) @@ -24062,7 +24066,7 @@ Standard_Input, and writing characters, strings and integers to either Standard_Output or Standard_Error. @node GNAT IO_Aux g-io_aux ads,GNAT Lock_Files g-locfil ads,GNAT IO g-io ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id87}@anchor{37d}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{37e} +@anchor{gnat_rm/the_gnat_library id88}@anchor{37f}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{380} @section @code{GNAT.IO_Aux} (@code{g-io_aux.ads}) @@ -24076,7 +24080,7 @@ Provides some auxiliary functions for use with Text_IO, including a test for whether a file exists, and functions for reading a line of text. @node GNAT Lock_Files g-locfil ads,GNAT MBBS_Discrete_Random g-mbdira ads,GNAT IO_Aux g-io_aux ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id88}@anchor{37f}@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{380} +@anchor{gnat_rm/the_gnat_library id89}@anchor{381}@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{382} @section @code{GNAT.Lock_Files} (@code{g-locfil.ads}) @@ -24090,7 +24094,7 @@ Provides a general interface for using files as locks. Can be used for providing program level synchronization. @node GNAT MBBS_Discrete_Random g-mbdira ads,GNAT MBBS_Float_Random g-mbflra ads,GNAT Lock_Files g-locfil ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id89}@anchor{381}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{382} +@anchor{gnat_rm/the_gnat_library id90}@anchor{383}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{384} @section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads}) @@ -24102,7 +24106,7 @@ The original implementation of @code{Ada.Numerics.Discrete_Random}. Uses a modified version of the Blum-Blum-Shub generator. @node GNAT MBBS_Float_Random g-mbflra ads,GNAT MD5 g-md5 ads,GNAT MBBS_Discrete_Random g-mbdira ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id90}@anchor{383}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{384} +@anchor{gnat_rm/the_gnat_library id91}@anchor{385}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{386} @section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads}) @@ -24114,7 +24118,7 @@ The original implementation of @code{Ada.Numerics.Float_Random}. Uses a modified version of the Blum-Blum-Shub generator. @node GNAT MD5 g-md5 ads,GNAT Memory_Dump g-memdum ads,GNAT MBBS_Float_Random g-mbflra ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id91}@anchor{385}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{386} +@anchor{gnat_rm/the_gnat_library id92}@anchor{387}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{388} @section @code{GNAT.MD5} (@code{g-md5.ads}) @@ -24127,7 +24131,7 @@ the HMAC-MD5 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT Memory_Dump g-memdum ads,GNAT Most_Recent_Exception g-moreex ads,GNAT MD5 g-md5 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id92}@anchor{387}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{388} +@anchor{gnat_rm/the_gnat_library id93}@anchor{389}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{38a} @section @code{GNAT.Memory_Dump} (@code{g-memdum.ads}) @@ -24140,7 +24144,7 @@ standard output or standard error files. Uses GNAT.IO for actual output. @node GNAT Most_Recent_Exception g-moreex ads,GNAT OS_Lib g-os_lib ads,GNAT Memory_Dump g-memdum ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{389}@anchor{gnat_rm/the_gnat_library id93}@anchor{38a} +@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{38b}@anchor{gnat_rm/the_gnat_library id94}@anchor{38c} @section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads}) @@ -24154,7 +24158,7 @@ various logging purposes, including duplicating functionality of some Ada 83 implementation dependent extensions. @node GNAT OS_Lib g-os_lib ads,GNAT Perfect_Hash_Generators g-pehage ads,GNAT Most_Recent_Exception g-moreex ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{38b}@anchor{gnat_rm/the_gnat_library id94}@anchor{38c} +@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{38d}@anchor{gnat_rm/the_gnat_library id95}@anchor{38e} @section @code{GNAT.OS_Lib} (@code{g-os_lib.ads}) @@ -24170,7 +24174,7 @@ including a portable spawn procedure, and access to environment variables and error return codes. @node GNAT Perfect_Hash_Generators g-pehage ads,GNAT Random_Numbers g-rannum ads,GNAT OS_Lib g-os_lib ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{38d}@anchor{gnat_rm/the_gnat_library id95}@anchor{38e} +@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{38f}@anchor{gnat_rm/the_gnat_library id96}@anchor{390} @section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads}) @@ -24188,7 +24192,7 @@ hashcode are in the same order. These hashing functions are very convenient for use with realtime applications. @node GNAT Random_Numbers g-rannum ads,GNAT Regexp g-regexp ads,GNAT Perfect_Hash_Generators g-pehage ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{38f}@anchor{gnat_rm/the_gnat_library id96}@anchor{390} +@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{391}@anchor{gnat_rm/the_gnat_library id97}@anchor{392} @section @code{GNAT.Random_Numbers} (@code{g-rannum.ads}) @@ -24200,7 +24204,7 @@ Provides random number capabilities which extend those available in the standard Ada library and are more convenient to use. @node GNAT Regexp g-regexp ads,GNAT Registry g-regist ads,GNAT Random_Numbers g-rannum ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{258}@anchor{gnat_rm/the_gnat_library id97}@anchor{391} +@anchor{gnat_rm/the_gnat_library id98}@anchor{393}@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{258} @section @code{GNAT.Regexp} (@code{g-regexp.ads}) @@ -24216,7 +24220,7 @@ simplest of the three pattern matching packages provided, and is particularly suitable for 'file globbing' applications. @node GNAT Registry g-regist ads,GNAT Regpat g-regpat ads,GNAT Regexp g-regexp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id98}@anchor{392}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{393} +@anchor{gnat_rm/the_gnat_library id99}@anchor{394}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{395} @section @code{GNAT.Registry} (@code{g-regist.ads}) @@ -24230,7 +24234,7 @@ registry API, but at a lower level of abstraction, refer to the Win32.Winreg package provided with the Win32Ada binding @node GNAT Regpat g-regpat ads,GNAT Rewrite_Data g-rewdat ads,GNAT Registry g-regist ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id99}@anchor{394}@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{395} +@anchor{gnat_rm/the_gnat_library id100}@anchor{396}@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{397} @section @code{GNAT.Regpat} (@code{g-regpat.ads}) @@ -24245,7 +24249,7 @@ from the original V7 style regular expression library written in C by Henry Spencer (and binary compatible with this C library). @node GNAT Rewrite_Data g-rewdat ads,GNAT Secondary_Stack_Info g-sestin ads,GNAT Regpat g-regpat ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id100}@anchor{396}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{397} +@anchor{gnat_rm/the_gnat_library id101}@anchor{398}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{399} @section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads}) @@ -24259,7 +24263,7 @@ full content to be processed is not loaded into memory all at once. This makes this interface usable for large files or socket streams. @node GNAT Secondary_Stack_Info g-sestin ads,GNAT Semaphores g-semaph ads,GNAT Rewrite_Data g-rewdat ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id101}@anchor{398}@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{399} +@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{39a}@anchor{gnat_rm/the_gnat_library id102}@anchor{39b} @section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads}) @@ -24271,7 +24275,7 @@ Provide the capability to query the high water mark of the current task's secondary stack. @node GNAT Semaphores g-semaph ads,GNAT Serial_Communications g-sercom ads,GNAT Secondary_Stack_Info g-sestin ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id102}@anchor{39a}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{39b} +@anchor{gnat_rm/the_gnat_library id103}@anchor{39c}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{39d} @section @code{GNAT.Semaphores} (@code{g-semaph.ads}) @@ -24282,7 +24286,7 @@ secondary stack. Provides classic counting and binary semaphores using protected types. @node GNAT Serial_Communications g-sercom ads,GNAT SHA1 g-sha1 ads,GNAT Semaphores g-semaph ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{39c}@anchor{gnat_rm/the_gnat_library id103}@anchor{39d} +@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id104}@anchor{39f} @section @code{GNAT.Serial_Communications} (@code{g-sercom.ads}) @@ -24294,7 +24298,7 @@ Provides a simple interface to send and receive data over a serial port. This is only supported on GNU/Linux and Windows. @node GNAT SHA1 g-sha1 ads,GNAT SHA224 g-sha224 ads,GNAT Serial_Communications g-sercom ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id104}@anchor{39f} +@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{3a0}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a1} @section @code{GNAT.SHA1} (@code{g-sha1.ads}) @@ -24307,7 +24311,7 @@ and RFC 3174, and the HMAC-SHA1 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA224 g-sha224 ads,GNAT SHA256 g-sha256 ads,GNAT SHA1 g-sha1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{3a0}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a1} +@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{3a2}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a3} @section @code{GNAT.SHA224} (@code{g-sha224.ads}) @@ -24320,7 +24324,7 @@ and the HMAC-SHA224 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA256 g-sha256 ads,GNAT SHA384 g-sha384 ads,GNAT SHA224 g-sha224 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{3a2}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a3} +@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{3a4}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a5} @section @code{GNAT.SHA256} (@code{g-sha256.ads}) @@ -24333,7 +24337,7 @@ and the HMAC-SHA256 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA384 g-sha384 ads,GNAT SHA512 g-sha512 ads,GNAT SHA256 g-sha256 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3a4}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a5} +@anchor{gnat_rm/the_gnat_library id108}@anchor{3a6}@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3a7} @section @code{GNAT.SHA384} (@code{g-sha384.ads}) @@ -24346,7 +24350,7 @@ and the HMAC-SHA384 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT SHA512 g-sha512 ads,GNAT Signals g-signal ads,GNAT SHA384 g-sha384 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id108}@anchor{3a6}@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3a7} +@anchor{gnat_rm/the_gnat_library id109}@anchor{3a8}@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3a9} @section @code{GNAT.SHA512} (@code{g-sha512.ads}) @@ -24359,7 +24363,7 @@ and the HMAC-SHA512 message authentication function as described in RFC 2104 and FIPS PUB 198. @node GNAT Signals g-signal ads,GNAT Sockets g-socket ads,GNAT SHA512 g-sha512 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id109}@anchor{3a8}@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3a9} +@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id110}@anchor{3ab} @section @code{GNAT.Signals} (@code{g-signal.ads}) @@ -24371,7 +24375,7 @@ Provides the ability to manipulate the blocked status of signals on supported targets. @node GNAT Sockets g-socket ads,GNAT Source_Info g-souinf ads,GNAT Signals g-signal ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id110}@anchor{3ab} +@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id111}@anchor{3ad} @section @code{GNAT.Sockets} (@code{g-socket.ads}) @@ -24386,7 +24390,7 @@ on all native GNAT ports and on VxWorks cross prots. It is not implemented for the LynxOS cross port. @node GNAT Source_Info g-souinf ads,GNAT Spelling_Checker g-speche ads,GNAT Sockets g-socket ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id111}@anchor{3ad} +@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3ae}@anchor{gnat_rm/the_gnat_library id112}@anchor{3af} @section @code{GNAT.Source_Info} (@code{g-souinf.ads}) @@ -24400,7 +24404,7 @@ subprograms yielding the date and time of the current compilation (like the C macros @code{__DATE__} and @code{__TIME__}) @node GNAT Spelling_Checker g-speche ads,GNAT Spelling_Checker_Generic g-spchge ads,GNAT Source_Info g-souinf ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id112}@anchor{3ae}@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3af} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b1} @section @code{GNAT.Spelling_Checker} (@code{g-speche.ads}) @@ -24412,7 +24416,7 @@ Provides a function for determining whether one string is a plausible near misspelling of another string. @node GNAT Spelling_Checker_Generic g-spchge ads,GNAT Spitbol Patterns g-spipat ads,GNAT Spelling_Checker g-speche ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b1} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b3} @section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads}) @@ -24425,7 +24429,7 @@ determining whether one string is a plausible near misspelling of another string. @node GNAT Spitbol Patterns g-spipat ads,GNAT Spitbol g-spitbo ads,GNAT Spelling_Checker_Generic g-spchge ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b3} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b5} @section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads}) @@ -24441,7 +24445,7 @@ the SNOBOL4 dynamic pattern construction and matching capabilities, using the efficient algorithm developed by Robert Dewar for the SPITBOL system. @node GNAT Spitbol g-spitbo ads,GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Patterns g-spipat ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b5} +@anchor{gnat_rm/the_gnat_library id116}@anchor{3b6}@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3b7} @section @code{GNAT.Spitbol} (@code{g-spitbo.ads}) @@ -24456,7 +24460,7 @@ useful for constructing arbitrary mappings from strings in the style of the SNOBOL4 TABLE function. @node GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Table_Integer g-sptain ads,GNAT Spitbol g-spitbo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id116}@anchor{3b6}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3b7} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id117}@anchor{3b9} @section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads}) @@ -24471,7 +24475,7 @@ for type @code{Standard.Boolean}, giving an implementation of sets of string values. @node GNAT Spitbol Table_Integer g-sptain ads,GNAT Spitbol Table_VString g-sptavs ads,GNAT Spitbol Table_Boolean g-sptabo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id117}@anchor{3b9} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3ba}@anchor{gnat_rm/the_gnat_library id118}@anchor{3bb} @section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads}) @@ -24488,7 +24492,7 @@ for type @code{Standard.Integer}, giving an implementation of maps from string to integer values. @node GNAT Spitbol Table_VString g-sptavs ads,GNAT SSE g-sse ads,GNAT Spitbol Table_Integer g-sptain ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id118}@anchor{3ba}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3bb} +@anchor{gnat_rm/the_gnat_library id119}@anchor{3bc}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3bd} @section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads}) @@ -24505,7 +24509,7 @@ a variable length string type, giving an implementation of general maps from strings to strings. @node GNAT SSE g-sse ads,GNAT SSE Vector_Types g-ssvety ads,GNAT Spitbol Table_VString g-sptavs ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id119}@anchor{3bc}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3bd} +@anchor{gnat_rm/the_gnat_library id120}@anchor{3be}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3bf} @section @code{GNAT.SSE} (@code{g-sse.ads}) @@ -24517,7 +24521,7 @@ targets. It exposes vector component types together with a general introduction to the binding contents and use. @node GNAT SSE Vector_Types g-ssvety ads,GNAT String_Hash g-strhas ads,GNAT SSE g-sse ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id120}@anchor{3bf} +@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c1} @section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads}) @@ -24526,7 +24530,7 @@ introduction to the binding contents and use. SSE vector types for use with SSE related intrinsics. @node GNAT String_Hash g-strhas ads,GNAT Strings g-string ads,GNAT SSE Vector_Types g-ssvety ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c1} +@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c3} @section @code{GNAT.String_Hash} (@code{g-strhas.ads}) @@ -24538,7 +24542,7 @@ Provides a generic hash function working on arrays of scalars. Both the scalar type and the hash result type are parameters. @node GNAT Strings g-string ads,GNAT String_Split g-strspl ads,GNAT String_Hash g-strhas ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c3} +@anchor{gnat_rm/the_gnat_library id123}@anchor{3c4}@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3c5} @section @code{GNAT.Strings} (@code{g-string.ads}) @@ -24548,7 +24552,7 @@ Common String access types and related subprograms. Basically it defines a string access and an array of string access types. @node GNAT String_Split g-strspl ads,GNAT Table g-table ads,GNAT Strings g-string ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3c4}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c5} +@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3c6}@anchor{gnat_rm/the_gnat_library id124}@anchor{3c7} @section @code{GNAT.String_Split} (@code{g-strspl.ads}) @@ -24562,7 +24566,7 @@ to the resulting slices. This package is instantiated from @code{GNAT.Array_Split}. @node GNAT Table g-table ads,GNAT Task_Lock g-tasloc ads,GNAT String_Split g-strspl ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id124}@anchor{3c6}@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3c7} +@anchor{gnat_rm/the_gnat_library id125}@anchor{3c8}@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3c9} @section @code{GNAT.Table} (@code{g-table.ads}) @@ -24582,7 +24586,7 @@ while an instantiation of @code{GNAT.Dynamic_Tables} creates a type that can be used to define dynamic instances of the table. @node GNAT Task_Lock g-tasloc ads,GNAT Time_Stamp g-timsta ads,GNAT Table g-table ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id125}@anchor{3c8}@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3c9} +@anchor{gnat_rm/the_gnat_library id126}@anchor{3ca}@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3cb} @section @code{GNAT.Task_Lock} (@code{g-tasloc.ads}) @@ -24599,7 +24603,7 @@ single global task lock. Appropriate for use in situations where contention between tasks is very rarely expected. @node GNAT Time_Stamp g-timsta ads,GNAT Threads g-thread ads,GNAT Task_Lock g-tasloc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id126}@anchor{3ca}@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3cb} +@anchor{gnat_rm/the_gnat_library id127}@anchor{3cc}@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3cd} @section @code{GNAT.Time_Stamp} (@code{g-timsta.ads}) @@ -24614,7 +24618,7 @@ represents the current date and time in ISO 8601 format. This is a very simple routine with minimal code and there are no dependencies on any other unit. @node GNAT Threads g-thread ads,GNAT Traceback g-traceb ads,GNAT Time_Stamp g-timsta ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id127}@anchor{3cc}@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3cd} +@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3ce}@anchor{gnat_rm/the_gnat_library id128}@anchor{3cf} @section @code{GNAT.Threads} (@code{g-thread.ads}) @@ -24631,7 +24635,7 @@ further details if your program has threads that are created by a non-Ada environment which then accesses Ada code. @node GNAT Traceback g-traceb ads,GNAT Traceback Symbolic g-trasym ads,GNAT Threads g-thread ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id128}@anchor{3ce}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3cf} +@anchor{gnat_rm/the_gnat_library id129}@anchor{3d0}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3d1} @section @code{GNAT.Traceback} (@code{g-traceb.ads}) @@ -24643,7 +24647,7 @@ Provides a facility for obtaining non-symbolic traceback information, useful in various debugging situations. @node GNAT Traceback Symbolic g-trasym ads,GNAT UTF_32 g-table ads,GNAT Traceback g-traceb ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id129}@anchor{3d1} +@anchor{gnat_rm/the_gnat_library id130}@anchor{3d2}@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3d3} @section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads}) @@ -24652,7 +24656,7 @@ in various debugging situations. @geindex Trace back facilities @node GNAT UTF_32 g-table ads,GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Traceback Symbolic g-trasym ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id130}@anchor{3d2}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3d3} +@anchor{gnat_rm/the_gnat_library id131}@anchor{3d4}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3d5} @section @code{GNAT.UTF_32} (@code{g-table.ads}) @@ -24671,7 +24675,7 @@ lower case to upper case fold routine corresponding to the Ada 2005 rules for identifier equivalence. @node GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Wide_Spelling_Checker g-wispch ads,GNAT UTF_32 g-table ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3d4}@anchor{gnat_rm/the_gnat_library id131}@anchor{3d5} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3d6}@anchor{gnat_rm/the_gnat_library id132}@anchor{3d7} @section @code{GNAT.Wide_Spelling_Checker} (@code{g-u3spch.ads}) @@ -24684,7 +24688,7 @@ near misspelling of another wide wide string, where the strings are represented using the UTF_32_String type defined in System.Wch_Cnv. @node GNAT Wide_Spelling_Checker g-wispch ads,GNAT Wide_String_Split g-wistsp ads,GNAT Wide_Spelling_Checker g-u3spch ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3d6}@anchor{gnat_rm/the_gnat_library id132}@anchor{3d7} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3d8}@anchor{gnat_rm/the_gnat_library id133}@anchor{3d9} @section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads}) @@ -24696,7 +24700,7 @@ Provides a function for determining whether one wide string is a plausible near misspelling of another wide string. @node GNAT Wide_String_Split g-wistsp ads,GNAT Wide_Wide_Spelling_Checker g-zspche ads,GNAT Wide_Spelling_Checker g-wispch ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id133}@anchor{3d8}@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3d9} +@anchor{gnat_rm/the_gnat_library id134}@anchor{3da}@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3db} @section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads}) @@ -24710,7 +24714,7 @@ to the resulting slices. This package is instantiated from @code{GNAT.Array_Split}. @node GNAT Wide_Wide_Spelling_Checker g-zspche ads,GNAT Wide_Wide_String_Split g-zistsp ads,GNAT Wide_String_Split g-wistsp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3da}@anchor{gnat_rm/the_gnat_library id134}@anchor{3db} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3dc}@anchor{gnat_rm/the_gnat_library id135}@anchor{3dd} @section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads}) @@ -24722,7 +24726,7 @@ Provides a function for determining whether one wide wide string is a plausible near misspelling of another wide wide string. @node GNAT Wide_Wide_String_Split g-zistsp ads,Interfaces C Extensions i-cexten ads,GNAT Wide_Wide_Spelling_Checker g-zspche ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3dc}@anchor{gnat_rm/the_gnat_library id135}@anchor{3dd} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3de}@anchor{gnat_rm/the_gnat_library id136}@anchor{3df} @section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads}) @@ -24736,7 +24740,7 @@ to the resulting slices. This package is instantiated from @code{GNAT.Array_Split}. @node Interfaces C Extensions i-cexten ads,Interfaces C Streams i-cstrea ads,GNAT Wide_Wide_String_Split g-zistsp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3de}@anchor{gnat_rm/the_gnat_library id136}@anchor{3df} +@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3e0}@anchor{gnat_rm/the_gnat_library id137}@anchor{3e1} @section @code{Interfaces.C.Extensions} (@code{i-cexten.ads}) @@ -24747,7 +24751,7 @@ for use with either manually or automatically generated bindings to C libraries. @node Interfaces C Streams i-cstrea ads,Interfaces Packed_Decimal i-pacdec ads,Interfaces C Extensions i-cexten ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3e0}@anchor{gnat_rm/the_gnat_library id137}@anchor{3e1} +@anchor{gnat_rm/the_gnat_library id138}@anchor{3e2}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3e3} @section @code{Interfaces.C.Streams} (@code{i-cstrea.ads}) @@ -24760,7 +24764,7 @@ This package is a binding for the most commonly used operations on C streams. @node Interfaces Packed_Decimal i-pacdec ads,Interfaces VxWorks i-vxwork ads,Interfaces C Streams i-cstrea ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id138}@anchor{3e2}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3e3} +@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3e4}@anchor{gnat_rm/the_gnat_library id139}@anchor{3e5} @section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads}) @@ -24775,7 +24779,7 @@ from a packed decimal format compatible with that used on IBM mainframes. @node Interfaces VxWorks i-vxwork ads,Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces Packed_Decimal i-pacdec ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id139}@anchor{3e4}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3e5} +@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3e6}@anchor{gnat_rm/the_gnat_library id140}@anchor{3e7} @section @code{Interfaces.VxWorks} (@code{i-vxwork.ads}) @@ -24791,7 +24795,7 @@ In particular, it interfaces with the VxWorks hardware interrupt facilities. @node Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces VxWorks IO i-vxwoio ads,Interfaces VxWorks i-vxwork ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3e6}@anchor{gnat_rm/the_gnat_library id140}@anchor{3e7} +@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3e8}@anchor{gnat_rm/the_gnat_library id141}@anchor{3e9} @section @code{Interfaces.VxWorks.Int_Connection} (@code{i-vxinco.ads}) @@ -24807,7 +24811,7 @@ intConnect() with a custom routine for installing interrupt handlers. @node Interfaces VxWorks IO i-vxwoio ads,System Address_Image s-addima ads,Interfaces VxWorks Int_Connection i-vxinco ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3e8}@anchor{gnat_rm/the_gnat_library id141}@anchor{3e9} +@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3ea}@anchor{gnat_rm/the_gnat_library id142}@anchor{3eb} @section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads}) @@ -24830,7 +24834,7 @@ function codes. A particular use of this package is to enable the use of Get_Immediate under VxWorks. @node System Address_Image s-addima ads,System Assertions s-assert ads,Interfaces VxWorks IO i-vxwoio ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3ea}@anchor{gnat_rm/the_gnat_library id142}@anchor{3eb} +@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3ec}@anchor{gnat_rm/the_gnat_library id143}@anchor{3ed} @section @code{System.Address_Image} (@code{s-addima.ads}) @@ -24846,7 +24850,7 @@ function that gives an (implementation dependent) string which identifies an address. @node System Assertions s-assert ads,System Atomic_Counters s-atocou ads,System Address_Image s-addima ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3ec}@anchor{gnat_rm/the_gnat_library id143}@anchor{3ed} +@anchor{gnat_rm/the_gnat_library id144}@anchor{3ee}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3ef} @section @code{System.Assertions} (@code{s-assert.ads}) @@ -24862,7 +24866,7 @@ by an run-time assertion failure, as well as the routine that is used internally to raise this assertion. @node System Atomic_Counters s-atocou ads,System Memory s-memory ads,System Assertions s-assert ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id144}@anchor{3ee}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3ef} +@anchor{gnat_rm/the_gnat_library id145}@anchor{3f0}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3f1} @section @code{System.Atomic_Counters} (@code{s-atocou.ads}) @@ -24876,7 +24880,7 @@ on most targets, including all Alpha, ia64, PowerPC, SPARC V9, x86, and x86_64 platforms. @node System Memory s-memory ads,System Multiprocessors s-multip ads,System Atomic_Counters s-atocou ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3f0}@anchor{gnat_rm/the_gnat_library id145}@anchor{3f1} +@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3f2}@anchor{gnat_rm/the_gnat_library id146}@anchor{3f3} @section @code{System.Memory} (@code{s-memory.ads}) @@ -24894,7 +24898,7 @@ calls to this unit may be made for low level allocation uses (for example see the body of @code{GNAT.Tables}). @node System Multiprocessors s-multip ads,System Multiprocessors Dispatching_Domains s-mudido ads,System Memory s-memory ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id146}@anchor{3f2}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f3} +@anchor{gnat_rm/the_gnat_library id147}@anchor{3f4}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f5} @section @code{System.Multiprocessors} (@code{s-multip.ads}) @@ -24907,7 +24911,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is technically an implementation-defined addition). @node System Multiprocessors Dispatching_Domains s-mudido ads,System Partition_Interface s-parint ads,System Multiprocessors s-multip ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3f4}@anchor{gnat_rm/the_gnat_library id147}@anchor{3f5} +@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3f6}@anchor{gnat_rm/the_gnat_library id148}@anchor{3f7} @section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads}) @@ -24920,7 +24924,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is technically an implementation-defined addition). @node System Partition_Interface s-parint ads,System Pool_Global s-pooglo ads,System Multiprocessors Dispatching_Domains s-mudido ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id148}@anchor{3f6}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3f7} +@anchor{gnat_rm/the_gnat_library id149}@anchor{3f8}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3f9} @section @code{System.Partition_Interface} (@code{s-parint.ads}) @@ -24933,7 +24937,7 @@ is used primarily in a distribution context when using Annex E with @code{GLADE}. @node System Pool_Global s-pooglo ads,System Pool_Local s-pooloc ads,System Partition_Interface s-parint ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id149}@anchor{3f8}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3f9} +@anchor{gnat_rm/the_gnat_library id150}@anchor{3fa}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3fb} @section @code{System.Pool_Global} (@code{s-pooglo.ads}) @@ -24950,7 +24954,7 @@ declared. It uses malloc/free to allocate/free and does not attempt to do any automatic reclamation. @node System Pool_Local s-pooloc ads,System Restrictions s-restri ads,System Pool_Global s-pooglo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3fa}@anchor{gnat_rm/the_gnat_library id150}@anchor{3fb} +@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3fc}@anchor{gnat_rm/the_gnat_library id151}@anchor{3fd} @section @code{System.Pool_Local} (@code{s-pooloc.ads}) @@ -24967,7 +24971,7 @@ a list of allocated blocks, so that all storage allocated for the pool can be freed automatically when the pool is finalized. @node System Restrictions s-restri ads,System Rident s-rident ads,System Pool_Local s-pooloc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3fc}@anchor{gnat_rm/the_gnat_library id151}@anchor{3fd} +@anchor{gnat_rm/the_gnat_library id152}@anchor{3fe}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3ff} @section @code{System.Restrictions} (@code{s-restri.ads}) @@ -24983,7 +24987,7 @@ compiler determined information on which restrictions are violated by one or more packages in the partition. @node System Rident s-rident ads,System Strings Stream_Ops s-ststop ads,System Restrictions s-restri ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3fe}@anchor{gnat_rm/the_gnat_library id152}@anchor{3ff} +@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{400}@anchor{gnat_rm/the_gnat_library id153}@anchor{401} @section @code{System.Rident} (@code{s-rident.ads}) @@ -24999,7 +25003,7 @@ since the necessary instantiation is included in package System.Restrictions. @node System Strings Stream_Ops s-ststop ads,System Unsigned_Types s-unstyp ads,System Rident s-rident ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id153}@anchor{400}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{401} +@anchor{gnat_rm/the_gnat_library id154}@anchor{402}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{403} @section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads}) @@ -25015,7 +25019,7 @@ stream attributes are applied to string types, but the subprograms in this package can be used directly by application programs. @node System Unsigned_Types s-unstyp ads,System Wch_Cnv s-wchcnv ads,System Strings Stream_Ops s-ststop ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{402}@anchor{gnat_rm/the_gnat_library id154}@anchor{403} +@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{404}@anchor{gnat_rm/the_gnat_library id155}@anchor{405} @section @code{System.Unsigned_Types} (@code{s-unstyp.ads}) @@ -25028,7 +25032,7 @@ also contains some related definitions for other specialized types used by the compiler in connection with packed array types. @node System Wch_Cnv s-wchcnv ads,System Wch_Con s-wchcon ads,System Unsigned_Types s-unstyp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{404}@anchor{gnat_rm/the_gnat_library id155}@anchor{405} +@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{406}@anchor{gnat_rm/the_gnat_library id156}@anchor{407} @section @code{System.Wch_Cnv} (@code{s-wchcnv.ads}) @@ -25049,7 +25053,7 @@ encoding method. It uses definitions in package @code{System.Wch_Con}. @node System Wch_Con s-wchcon ads,,System Wch_Cnv s-wchcnv ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id156}@anchor{406}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{407} +@anchor{gnat_rm/the_gnat_library id157}@anchor{408}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{409} @section @code{System.Wch_Con} (@code{s-wchcon.ads}) @@ -25061,7 +25065,7 @@ in ordinary strings. These definitions are used by the package @code{System.Wch_Cnv}. @node Interfacing to Other Languages,Specialized Needs Annexes,The GNAT Library,Top -@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{408}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{409} +@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{40a}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{40b} @chapter Interfacing to Other Languages @@ -25079,7 +25083,7 @@ provided. @end menu @node Interfacing to C,Interfacing to C++,,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{40a}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{40b} +@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{40c}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{40d} @section Interfacing to C @@ -25219,7 +25223,7 @@ of the length corresponding to the @code{type'Size} value in Ada. @end itemize @node Interfacing to C++,Interfacing to COBOL,Interfacing to C,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{40c}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{47} +@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{40e}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{47} @section Interfacing to C++ @@ -25276,7 +25280,7 @@ The @code{External_Name} is the name of the C++ RTTI symbol. You can then cover a specific C++ exception in an exception handler. @node Interfacing to COBOL,Interfacing to Fortran,Interfacing to C++,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{40d}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{40e} +@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{40f}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{410} @section Interfacing to COBOL @@ -25284,7 +25288,7 @@ Interfacing to COBOL is achieved as described in section B.4 of the Ada Reference Manual. @node Interfacing to Fortran,Interfacing to non-GNAT Ada code,Interfacing to COBOL,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{40f}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{410} +@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{411}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{412} @section Interfacing to Fortran @@ -25294,7 +25298,7 @@ multi-dimensional array causes the array to be stored in column-major order as required for convenient interface to Fortran. @node Interfacing to non-GNAT Ada code,,Interfacing to Fortran,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{411}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{412} +@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{413}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{414} @section Interfacing to non-GNAT Ada code @@ -25318,7 +25322,7 @@ values or simple record types without variants, or simple array types with fixed bounds. @node Specialized Needs Annexes,Implementation of Specific Ada Features,Interfacing to Other Languages,Top -@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{413}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{414} +@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{415}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{416} @chapter Specialized Needs Annexes @@ -25359,7 +25363,7 @@ in Ada 2005) is fully implemented. @end table @node Implementation of Specific Ada Features,Implementation of Ada 2012 Features,Specialized Needs Annexes,Top -@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{415}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{416} +@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{417}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{418} @chapter Implementation of Specific Ada Features @@ -25377,7 +25381,7 @@ facilities. @end menu @node Machine Code Insertions,GNAT Implementation of Tasking,,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{16a}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{417} +@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{169}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{419} @section Machine Code Insertions @@ -25545,7 +25549,7 @@ according to normal visibility rules. In particular if there is no qualification is required. @node GNAT Implementation of Tasking,GNAT Implementation of Shared Passive Packages,Machine Code Insertions,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{418}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{419} +@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{41a}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{41b} @section GNAT Implementation of Tasking @@ -25561,7 +25565,7 @@ to compliance with the Real-Time Systems Annex. @end menu @node Mapping Ada Tasks onto the Underlying Kernel Threads,Ensuring Compliance with the Real-Time Annex,,GNAT Implementation of Tasking -@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{41a}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{41b} +@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{41c}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{41d} @subsection Mapping Ada Tasks onto the Underlying Kernel Threads @@ -25630,7 +25634,7 @@ support this functionality when the parent contains more than one task. @geindex Forking a new process @node Ensuring Compliance with the Real-Time Annex,Support for Locking Policies,Mapping Ada Tasks onto the Underlying Kernel Threads,GNAT Implementation of Tasking -@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{41c}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{41d} +@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{41e}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{41f} @subsection Ensuring Compliance with the Real-Time Annex @@ -25681,7 +25685,7 @@ placed at the end. @c Support_for_Locking_Policies @node Support for Locking Policies,,Ensuring Compliance with the Real-Time Annex,GNAT Implementation of Tasking -@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{41e} +@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{420} @subsection Support for Locking Policies @@ -25715,7 +25719,7 @@ then ceiling locking is used. Otherwise, the @code{Ceiling_Locking} policy is ignored. @node GNAT Implementation of Shared Passive Packages,Code Generation for Array Aggregates,GNAT Implementation of Tasking,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{41f}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{420} +@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{421}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{422} @section GNAT Implementation of Shared Passive Packages @@ -25813,7 +25817,7 @@ This is used to provide the required locking semantics for proper protected object synchronization. @node Code Generation for Array Aggregates,The Size of Discriminated Records with Default Discriminants,GNAT Implementation of Shared Passive Packages,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{421}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{422} +@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{423}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{424} @section Code Generation for Array Aggregates @@ -25844,7 +25848,7 @@ component values and static subtypes also lead to simpler code. @end menu @node Static constant aggregates with static bounds,Constant aggregates with unconstrained nominal types,,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{423}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{424} +@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{425}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{426} @subsection Static constant aggregates with static bounds @@ -25891,7 +25895,7 @@ Zero2: constant two_dim := (others => (others => 0)); @end example @node Constant aggregates with unconstrained nominal types,Aggregates with static bounds,Static constant aggregates with static bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{425}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{426} +@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{428} @subsection Constant aggregates with unconstrained nominal types @@ -25906,7 +25910,7 @@ Cr_Unc : constant One_Unc := (12,24,36); @end example @node Aggregates with static bounds,Aggregates with nonstatic bounds,Constant aggregates with unconstrained nominal types,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{428} +@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{429}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{42a} @subsection Aggregates with static bounds @@ -25934,7 +25938,7 @@ end loop; @end example @node Aggregates with nonstatic bounds,Aggregates in assignment statements,Aggregates with static bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{429}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{42a} +@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{42b}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{42c} @subsection Aggregates with nonstatic bounds @@ -25945,7 +25949,7 @@ have to be applied to sub-arrays individually, if they do not have statically compatible subtypes. @node Aggregates in assignment statements,,Aggregates with nonstatic bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{42b}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{42c} +@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{42d}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{42e} @subsection Aggregates in assignment statements @@ -25987,7 +25991,7 @@ a temporary (created either by the front-end or the code generator) and then that temporary will be copied onto the target. @node The Size of Discriminated Records with Default Discriminants,Strict Conformance to the Ada Reference Manual,Code Generation for Array Aggregates,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{42d}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{42e} +@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{42f}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{430} @section The Size of Discriminated Records with Default Discriminants @@ -26067,7 +26071,7 @@ say) must be consistent, so it is imperative that the object, once created, remain invariant. @node Strict Conformance to the Ada Reference Manual,,The Size of Discriminated Records with Default Discriminants,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{42f}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{430} +@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{431}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{432} @section Strict Conformance to the Ada Reference Manual @@ -26094,7 +26098,7 @@ behavior (although at the cost of a significant performance penalty), so infinite and NaN values are properly generated. @node Implementation of Ada 2012 Features,Obsolescent Features,Implementation of Specific Ada Features,Top -@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{431}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{432} +@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{433}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{434} @chapter Implementation of Ada 2012 Features @@ -28260,7 +28264,7 @@ RM References: H.04 (8/1) @end itemize @node Obsolescent Features,Compatibility and Porting Guide,Implementation of Ada 2012 Features,Top -@anchor{gnat_rm/obsolescent_features id1}@anchor{433}@anchor{gnat_rm/obsolescent_features doc}@anchor{434}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15} +@anchor{gnat_rm/obsolescent_features id1}@anchor{435}@anchor{gnat_rm/obsolescent_features doc}@anchor{436}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15} @chapter Obsolescent Features @@ -28279,7 +28283,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{435}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{436} +@anchor{gnat_rm/obsolescent_features id2}@anchor{437}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{438} @section pragma No_Run_Time @@ -28292,7 +28296,7 @@ preferred usage is to use an appropriately configured run-time that includes just those features that are to be made accessible. @node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id3}@anchor{437}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{438} +@anchor{gnat_rm/obsolescent_features id3}@anchor{439}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{43a} @section pragma Ravenscar @@ -28301,7 +28305,7 @@ The pragma @code{Ravenscar} has exactly the same effect as pragma is part of the new Ada 2005 standard. @node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features -@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{439}@anchor{gnat_rm/obsolescent_features id4}@anchor{43a} +@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{43b}@anchor{gnat_rm/obsolescent_features id4}@anchor{43c} @section pragma Restricted_Run_Time @@ -28311,7 +28315,7 @@ preferred since the Ada 2005 pragma @code{Profile} is intended for this kind of implementation dependent addition. @node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{43b}@anchor{gnat_rm/obsolescent_features id5}@anchor{43c} +@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{43d}@anchor{gnat_rm/obsolescent_features id5}@anchor{43e} @section pragma Task_Info @@ -28337,7 +28341,7 @@ in the spec of package System.Task_Info in the runtime library. @node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features -@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{43d}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{43e} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{43f}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{440} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -28347,7 +28351,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package standard replacement for GNAT's @code{Task_Info} functionality. @node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{43f}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{440} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{441}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{442} @chapter Compatibility and Porting Guide @@ -28369,7 +28373,7 @@ applications developed in other Ada environments. @end menu @node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{441}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{442} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{443}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{444} @section Writing Portable Fixed-Point Declarations @@ -28491,7 +28495,7 @@ If you follow this scheme you will be guaranteed that your fixed-point types will be portable. @node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{443}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{444} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{445}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{446} @section Compatibility with Ada 83 @@ -28519,7 +28523,7 @@ following subsections treat the most likely issues to be encountered. @end menu @node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{445}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{446} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{447}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{448} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -28619,7 +28623,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration. @end itemize @node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{447}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{448} +@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{449}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{44a} @subsection More deterministic semantics @@ -28647,7 +28651,7 @@ which open select branches are executed. @end itemize @node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{449}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{44a} +@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{44b}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{44c} @subsection Changed semantics @@ -28689,7 +28693,7 @@ covers only the restricted range. @end itemize @node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{44b}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{44c} +@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{44d}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{44e} @subsection Other language compatibility issues @@ -28722,7 +28726,7 @@ include @code{pragma Interface} and the floating point type attributes @end itemize @node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{44d}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{44e} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{44f}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{450} @section Compatibility between Ada 95 and Ada 2005 @@ -28794,7 +28798,7 @@ can declare a function returning a value from an anonymous access type. @end itemize @node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{44f}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{450} +@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{451}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{452} @section Implementation-dependent characteristics @@ -28817,7 +28821,7 @@ transition from certain Ada 83 compilers. @end menu @node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{451}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{452} +@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{453}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{454} @subsection Implementation-defined pragmas @@ -28839,7 +28843,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not relevant in a GNAT context and hence are not otherwise implemented. @node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{453}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{454} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{455}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{456} @subsection Implementation-defined attributes @@ -28853,7 +28857,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and @code{Type_Class}. @node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{455}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{456} +@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{457}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{458} @subsection Libraries @@ -28882,7 +28886,7 @@ be preferable to retrofit the application using modular types. @end itemize @node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{457}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{458} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{459}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{45a} @subsection Elaboration order @@ -28918,7 +28922,7 @@ pragmas either globally (as an effect of the @emph{-gnatE} switch) or locally @end itemize @node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{459}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{45a} +@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{45b}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{45c} @subsection Target-specific aspects @@ -28931,10 +28935,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus Ada 2005 and Ada 2012) are sometimes incompatible with typical Ada 83 compiler practices regarding implicit packing, the meaning of the Size attribute, and the size of access values. -GNAT's approach to these issues is described in @ref{45b,,Representation Clauses}. +GNAT's approach to these issues is described in @ref{45d,,Representation Clauses}. @node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{45c}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{45d} +@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{45e}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{45f} @section Compatibility with Other Ada Systems @@ -28977,7 +28981,7 @@ far beyond this minimal set, as described in the next section. @end itemize @node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{45b}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{45e} +@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{45d}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{460} @section Representation Clauses @@ -29070,7 +29074,7 @@ with thin pointers. @end itemize @node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{45f}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{460} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{461}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{462} @section Compatibility with HP Ada 83 @@ -29100,7 +29104,7 @@ extension of package System. @end itemize @node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top -@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{461}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{462} +@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{463}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{464} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index ab47192..47618f6 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Jul 01, 2020 +GNAT User's Guide for Native Platforms , Sep 29, 2020 AdaCore @@ -2850,7 +2850,6 @@ Overflow_Mode Overriding_Renamings Partition_Elaboration_Policy Persistent_BSS -Polling Prefix_Exception_Messages Priority_Specific_Dispatching Profile @@ -9721,19 +9720,6 @@ has no effect if cancelled by a subsequent @code{-gnat-p} switch. Cancel effect of previous @code{-gnatp} switch. @end table -@geindex -gnatP (gcc) - - -@table @asis - -@item @code{-gnatP} - -Enable polling. This is required on some systems (notably Windows NT) to -obtain asynchronous abort and asynchronous transfer of control capability. -See @code{Pragma_Polling} in the @cite{GNAT_Reference_Manual} for full -details. -@end table - @geindex -gnatq (gcc) @@ -12238,7 +12224,14 @@ that no warnings are given for comparisons or subranges for any type. This switch activates warnings for access to variables which may not be properly initialized. The default is that -such warnings are generated. +such warnings are generated. This switch will also be emitted when +initializing an array or record object via the following aggregate: + +@example +Array_Or_Record : XXX := (others => <>); +@end example + +unless the relevant type fully initializes all components. @end table @geindex -gnatwV (gcc) @@ -12252,17 +12245,6 @@ such warnings are generated. This switch suppresses warnings for access to variables which may not be properly initialized. -For variables of a composite type, the warning can also be suppressed in -Ada 2005 by using a default initialization with a box. For example, if -Table is an array of records whose components are only partially uninitialized, -then the following code: - -@example -Tab : Table := (others => <>); -@end example - -will suppress warnings on subsequent statements that access components -of variable Tab. @end table @geindex -gnatw.v (gcc) diff --git a/gcc/ada/gnatvsn.adb b/gcc/ada/gnatvsn.adb index 0e7486c..e918540 100644 --- a/gcc/ada/gnatvsn.adb +++ b/gcc/ada/gnatvsn.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index aacbc22..ddd5b9f 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h index e10f954..ba51fb1 100644 --- a/gcc/ada/gsocket.h +++ b/gcc/ada/gsocket.h @@ -80,6 +80,12 @@ #define FD_SETSIZE 1024 #ifdef __MINGW32__ +/* winsock2.h allows WSAPoll related definitions only when + * _WIN32_WINNT >= 0x0600 */ +#if !defined(_WIN32_WINNT) || _WIN32_WINNT < 0x0600 +#define _WIN32_WINNT 0x0600 +#endif + #include <winsock2.h> #include <ws2tcpip.h> #include <versionhelpers.h> diff --git a/gcc/ada/hostparm.ads b/gcc/ada/hostparm.ads index 1b87a1d..603f401 100644 --- a/gcc/ada/hostparm.ads +++ b/gcc/ada/hostparm.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 2cfda7c..2cde430 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -146,6 +146,8 @@ package body Impunit is ("a-llfwti", T), -- Ada.Long_Long_Float_Wide_Text_IO ("a-llitio", T), -- Ada.Long_Long_Integer_Text_IO ("a-lliwti", F), -- Ada.Long_Long_Integer_Wide_Text_IO + ("a-llltio", T), -- Ada.Long_Long_Long_Integer_Text_IO + ("a-lllwti", F), -- Ada.Long_Long_Long_Integer_Wide_Text_IO ("a-nlcefu", F), -- Ada.Long_Complex_Elementary_Functions ("a-nlcoty", T), -- Ada.Numerics.Long_Complex_Types ("a-nlelfu", T), -- Ada.Numerics.Long_Elementary_Functions @@ -308,6 +310,7 @@ package body Impunit is ("g-sha512", F), -- GNAT.SHA512 ("g-signal", F), -- GNAT.Signals ("g-socket", F), -- GNAT.Sockets + ("g-socpol", F), -- GNAT.Sockets.Poll ("g-souinf", F), -- GNAT.Source_Info ("g-speche", F), -- GNAT.Spell_Checker ("g-spchge", F), -- GNAT.Spell_Checker_Generic @@ -502,6 +505,7 @@ package body Impunit is ("a-llctio", T), -- Ada.Long_Long_Complex_Text_IO ("a-llfzti", T), -- Ada.Long_Long_Float_Wide_Wide_Text_IO ("a-llizti", T), -- Ada.Long_Long_Integer_Wide_Wide_Text_IO + ("a-lllzti", T), -- Ada.Long_Long_Long_Integer_Wide_Wide_Text_IO ("a-nlcoar", T), -- Ada.Numerics.Long_Complex_Arrays ("a-nllcar", T), -- Ada.Numerics.Long_Long_Complex_Arrays ("a-nllrar", T), -- Ada.Numerics.Long_Long_Real_Arrays @@ -687,7 +691,7 @@ package body Impunit is function Get_Kind_Of_File (File : String) return Kind_Of_Unit is pragma Assert (File'First = 1); - Buffer : String (1 .. 8); + Buffer : String (1 .. 9); begin Error_Msg_Strlen := 0; @@ -701,13 +705,6 @@ package body Impunit is return Ada_95_Unit; end if; - -- If length of file name is greater than 12, not predefined. The value - -- 12 here is an 8 char name with extension .ads. - - if File'Length > 12 then - return Not_Predefined_Unit; - end if; - -- Not predefined if file name does not start with a- g- s- i- if File'Length < 3 @@ -721,6 +718,16 @@ package body Impunit is return Not_Predefined_Unit; end if; + -- If length of file name is greater than 12, not predefined. The value + -- 12 here is an 8 char name with extension .ads. The exception of 13 is + -- for the implementation units of the 128-bit types under System. + + if File'Length > 12 + and then not (File'Length = 13 and then File (1) = 's') + then + return Not_Predefined_Unit; + end if; + -- Not predefined if file name does not end in .ads. This can happen -- when non-standard file names are being used. @@ -739,7 +746,7 @@ package body Impunit is -- See if name is in 95 list for J in Non_Imp_File_Names_95'Range loop - if Buffer = Non_Imp_File_Names_95 (J).Fname then + if Buffer (1 .. 8) = Non_Imp_File_Names_95 (J).Fname then return Ada_95_Unit; end if; end loop; @@ -747,7 +754,7 @@ package body Impunit is -- See if name is in 2005 list for J in Non_Imp_File_Names_05'Range loop - if Buffer = Non_Imp_File_Names_05 (J).Fname then + if Buffer (1 .. 8) = Non_Imp_File_Names_05 (J).Fname then return Ada_2005_Unit; end if; end loop; @@ -755,7 +762,7 @@ package body Impunit is -- See if name is in 2012 list for J in Non_Imp_File_Names_12'Range loop - if Buffer = Non_Imp_File_Names_12 (J).Fname then + if Buffer (1 .. 8) = Non_Imp_File_Names_12 (J).Fname then return Ada_2012_Unit; end if; end loop; @@ -763,7 +770,7 @@ package body Impunit is -- See if name is in 202X list for J in Non_Imp_File_Names_2X'Range loop - if Buffer = Non_Imp_File_Names_2X (J).Fname then + if Buffer (1 .. 8) = Non_Imp_File_Names_2X (J).Fname then return Ada_202X_Unit; end if; end loop; @@ -927,13 +934,6 @@ package body Impunit is return True; end if; - -- If length of file name is greater than 12, then it's a user unit - -- and not a GNAT implementation defined unit. - - if Name_Len > 12 then - return True; - end if; - -- Implementation defined if unit in the gnat hierarchy if (Name_Len = 8 and then Name_Buffer (1 .. 8) = "gnat.ads") @@ -955,6 +955,16 @@ package body Impunit is return True; end if; + -- If length of file name is greater than 12, not predefined. The value + -- 12 here is an 8 char name with extension .ads. The exception of 13 is + -- for the implementation units of the 128-bit types under System. + + if Name_Len > 12 + and then not (Name_Len = 13 and then Name_Buffer (1) = 's') + then + return True; + end if; + -- Not impl-defined if file name does not end in .ads. This can happen -- when non-standard file names are being used. diff --git a/gcc/ada/indepsw-aix.adb b/gcc/ada/indepsw-aix.adb index 54c556d..21a4c17 100644 --- a/gcc/ada/indepsw-aix.adb +++ b/gcc/ada/indepsw-aix.adb @@ -14,16 +14,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/indepsw-darwin.adb b/gcc/ada/indepsw-darwin.adb index 3f2c41a..9da4f87 100644 --- a/gcc/ada/indepsw-darwin.adb +++ b/gcc/ada/indepsw-darwin.adb @@ -14,16 +14,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/indepsw-gnu.adb b/gcc/ada/indepsw-gnu.adb index 76138c4..de219b6 100644 --- a/gcc/ada/indepsw-gnu.adb +++ b/gcc/ada/indepsw-gnu.adb @@ -14,16 +14,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/indepsw.adb b/gcc/ada/indepsw.adb index e35b3da..d21bcfe 100644 --- a/gcc/ada/indepsw.adb +++ b/gcc/ada/indepsw.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/indepsw.ads b/gcc/ada/indepsw.ads index 4ac3fd8..2fc13cb 100644 --- a/gcc/ada/indepsw.ads +++ b/gcc/ada/indepsw.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 7293cf2..b4d56b6 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -317,6 +317,7 @@ package body Inline is -- Refined_Global -- Refined_Depends -- Refined_Post + -- Subprogram_Variant -- Test_Case -- Unmodified -- Unreferenced @@ -3728,8 +3729,8 @@ package body Inline is return; end if; - if Nkind (Orig_Bod) = N_Defining_Identifier - or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol + if Nkind (Orig_Bod) in N_Defining_Identifier + | N_Defining_Operator_Symbol then -- Subprogram is renaming_as_body. Calls occurring after the renaming -- can be replaced with calls to the renamed entity directly, because @@ -5119,6 +5120,7 @@ package body Inline is | Name_Refined_Global | Name_Refined_Depends | Name_Refined_Post + | Name_Subprogram_Variant | Name_Test_Case | Name_Unmodified | Name_Unreferenced diff --git a/gcc/ada/krunch.adb b/gcc/ada/krunch.adb index ac9af73..8ed239e 100644 --- a/gcc/ada/krunch.adb +++ b/gcc/ada/krunch.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -73,6 +67,15 @@ begin Curlen := Len - 17; Krlen := 8; + elsif Len >= 27 + and then Buffer (1 .. 27) = "ada-long_long_long_integer_" + then + Startloc := 3; + Buffer (2 .. Len - 2) := Buffer (4 .. Len); + Buffer (18 .. Len - 10) := Buffer (26 .. Len - 2); + Curlen := Len - 10; + Krlen := 8; + elsif Len >= 4 and then Buffer (1 .. 4) = "ada-" then Startloc := 3; Buffer (2 .. Len - 2) := Buffer (4 .. Len); @@ -89,7 +92,23 @@ begin Startloc := 3; Buffer (2 .. Len - 5) := Buffer (7 .. Len); Curlen := Len - 5; - Krlen := 8; + if Buffer (Curlen - 2 .. Curlen) = "128" + or else Buffer (3 .. 9) = "exn_lll" + or else Buffer (3 .. 9) = "exp_lll" + or else Buffer (3 .. 9) = "img_lll" + or else Buffer (3 .. 9) = "val_lll" + or else Buffer (3 .. 9) = "wid_lll" + or else (Buffer (3 .. 6) = "pack" and then Curlen = 10) + then + if Buffer (3 .. 15) = "compare_array" then + Buffer (3 .. 4) := "ca"; + Buffer (5 .. Curlen - 11) := Buffer (16 .. Curlen); + Curlen := Curlen - 11; + end if; + Krlen := 9; + else + Krlen := 8; + end if; elsif Len >= 11 and then Buffer (1 .. 11) = "interfaces-" then Startloc := 3; diff --git a/gcc/ada/krunch.ads b/gcc/ada/krunch.ads index 42896b8..82dc612 100644 --- a/gcc/ada/krunch.ads +++ b/gcc/ada/krunch.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -114,6 +108,12 @@ -- we replace the prefix ada.wide_wide_text_io- by a-zt- and then -- the normal crunching rules are applied. +-- An additional trick is used for Ada.Long_Long_Long_Integer_*_IO, where +-- the Integer word is dropped. + +-- The units implementing the support of 128-bit types are crunched to 9 and +-- System.Compare_Array_* is replaced with System.CA_* before crunching. + -- These are the only irregularity required (so far) to keep the file names -- unique in the standard predefined libraries. diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 73812f6..ad80849 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -378,12 +378,12 @@ package body Layout is Init_Esize (E, S); exit; - -- If the RM_Size is greater than 64 (happens only when - -- strange values are specified by the user, then Esize - -- is simply a copy of RM_Size, it will be further - -- refined later on) + -- If the RM_Size is greater than System_Max_Integer_Size + -- (happens only when strange values are specified by the + -- user), then Esize is simply a copy of RM_Size, it will + -- be further refined later on). - elsif S = 64 then + elsif S = System_Max_Integer_Size then Set_Esize (E, RM_Size (E)); exit; @@ -436,11 +436,11 @@ package body Layout is end if; -- For array base types, set the component size if object size of the - -- component type is known and is a small power of 2 (8, 16, 32, 64), - -- since this is what will always be used, except if a very large - -- alignment was specified and so Adjust_Esize_For_Alignment gave up - -- because, in this case, the object size is not a multiple of the - -- alignment and, therefore, cannot be the component size. + -- component type is known and is a small power of 2 (8, 16, 32, 64 + -- or 128), since this is what will always be used, except if a very + -- large alignment was specified and so Adjust_Esize_For_Alignment + -- gave up because, in this case, the object size is not a multiple + -- of the alignment and, therefore, cannot be the component size. if Ekind (E) = E_Array_Type and then Unknown_Component_Size (E) then declare @@ -455,7 +455,7 @@ package body Layout is and then Known_Static_Esize (CT) and then not (Known_Alignment (CT) and then Alignment_In_Bits (CT) > - Standard_Long_Long_Integer_Size) + System_Max_Integer_Size) then declare S : constant Uint := Esize (CT); @@ -470,7 +470,7 @@ package body Layout is -- For non-packed arrays set the alignment of the array to the -- alignment of the component type if it is unknown. Skip this - -- in atomic/VFA case since a larger alignment may be needed. + -- in full access case since a larger alignment may be needed. if Is_Array_Type (E) and then not Is_Packed (E) @@ -479,7 +479,7 @@ package body Layout is and then Known_Static_Component_Size (E) and then Known_Static_Esize (Component_Type (E)) and then Component_Size (E) = Esize (Component_Type (E)) - and then not Is_Atomic_Or_VFA (E) + and then not Is_Full_Access (E) then Set_Alignment (E, Alignment (Component_Type (E))); end if; @@ -505,11 +505,11 @@ package body Layout is elsif Is_Array_Type (E) then - -- For arrays that are required to be atomic/VFA, we do the same - -- processing as described above for short records, since we - -- really need to have the alignment set for the whole array. + -- For arrays that are required to be full access, we do the same + -- processing as described above for short records, since we really + -- need to have the alignment set for the whole array. - if Is_Atomic_Or_VFA (E) and then not Debug_Flag_Q then + if Is_Full_Access (E) and then not Debug_Flag_Q then Set_Composite_Alignment (E); end if; @@ -615,9 +615,9 @@ package body Layout is and then Is_Record_Type (E) and then Is_Packed (E) then - -- No effect for record with atomic/VFA components + -- No effect for record with full access components - if Is_Atomic_Or_VFA (E) then + if Is_Full_Access (E) then Error_Msg_N ("Optimize_Alignment has no effect for &??", E); if Is_Atomic (E) then @@ -640,7 +640,7 @@ package body Layout is return; end if; - -- No effect if any component is atomic/VFA or is a by-reference type + -- No effect if a component is full access or of a by-reference type declare Ent : Entity_Id; @@ -649,8 +649,8 @@ package body Layout is Ent := First_Component_Or_Discriminant (E); while Present (Ent) loop if Is_By_Reference_Type (Etype (Ent)) - or else Is_Atomic_Or_VFA (Etype (Ent)) - or else Is_Atomic_Or_VFA (Ent) + or else Is_Full_Access (Etype (Ent)) + or else Is_Full_Access (Ent) then Error_Msg_N ("Optimize_Alignment has no effect for &??", E); @@ -660,7 +660,7 @@ package body Layout is & "components present??", E); else Error_Msg_N - ("\pragma is ignored if bolatile full access " + ("\pragma is ignored if volatile full access " & "components present??", E); end if; @@ -756,9 +756,9 @@ package body Layout is -- Further processing for record types only to reduce the alignment -- set by the above processing in some specific cases. We do not - -- do this for atomic/VFA records, since we need max alignment there, + -- do this for full access records, since we need max alignment there, - if Is_Record_Type (E) and then not Is_Atomic_Or_VFA (E) then + if Is_Record_Type (E) and then not Is_Full_Access (E) then -- For records, there is generally no point in setting alignment -- higher than word size since we cannot do better than move by diff --git a/gcc/ada/lib-list.adb b/gcc/ada/lib-list.adb index 3eb5637..3733c0b 100644 --- a/gcc/ada/lib-list.adb +++ b/gcc/ada/lib-list.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/lib-sort.adb b/gcc/ada/lib-sort.adb index dc51b64..5ed478b 100644 --- a/gcc/ada/lib-sort.adb +++ b/gcc/ada/lib-sort.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 6fbcdce..6a63b8f 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -268,17 +268,6 @@ package body Lib.Writ is -- Collect with lines for entries in the context clause of the given -- compilation unit, Cunit. - procedure Update_Tables_From_ALI_File; - -- Given an up to date ALI file (see Up_To_Date_ALI_file_Exists - -- function), update tables from the ALI information, including - -- specifically the Compilation_Switches table. - - function Up_To_Date_ALI_File_Exists return Boolean; - -- If there exists an ALI file that is up to date, then this function - -- initializes the tables in the ALI spec to contain information on - -- this file (using Scan_ALI) and returns True. If no file exists, - -- or the file is not up to date, then False is returned. - procedure Write_Unit_Information (Unit_Num : Unit_Number_Type); -- Write out the library information for one unit for which code is -- generated (includes unit line and with lines). @@ -397,76 +386,6 @@ package body Lib.Writ is end loop; end Collect_Withs; - -------------------------------- - -- Up_To_Date_ALI_File_Exists -- - -------------------------------- - - function Up_To_Date_ALI_File_Exists return Boolean is - Name : File_Name_Type; - Text : Text_Buffer_Ptr; - Id : Sdep_Id; - Sind : Source_File_Index; - - begin - Opt.Check_Object_Consistency := True; - Read_Library_Info (Name, Text); - - -- Return if we could not find an ALI file - - if Text = null then - return False; - end if; - - -- Return if ALI file has bad format - - Initialize_ALI; - - if Scan_ALI (Name, Text, False, Err => True) = No_ALI_Id then - return False; - end if; - - -- If we have an OK ALI file, check if it is up to date - -- Note that we assume that the ALI read has all the entries - -- we have in our table, plus some additional ones (that can - -- come from expansion). - - Id := First_Sdep_Entry; - for J in 1 .. Num_Sdep loop - Sind := Source_Index (Sdep_Table (J)); - - while Sdep.Table (Id).Sfile /= File_Name (Sind) loop - if Id = Sdep.Last then - return False; - else - Id := Id + 1; - end if; - end loop; - - if Sdep.Table (Id).Stamp /= Time_Stamp (Sind) then - return False; - end if; - end loop; - - return True; - end Up_To_Date_ALI_File_Exists; - - --------------------------------- - -- Update_Tables_From_ALI_File -- - --------------------------------- - - procedure Update_Tables_From_ALI_File is - begin - -- Build Compilation_Switches table - - Compilation_Switches.Init; - - for J in First_Arg_Entry .. Args.Last loop - Compilation_Switches.Increment_Last; - Compilation_Switches.Table (Compilation_Switches.Last) := - Args.Table (J); - end loop; - end Update_Tables_From_ALI_File; - ---------------------------- -- Write_Unit_Information -- ---------------------------- @@ -1095,8 +1014,7 @@ package body Lib.Writ is return; end if; - -- Build sorted source dependency table. We do this right away, because - -- it is referenced by Up_To_Date_ALI_File_Exists. + -- Build sorted source dependency table. for Unum in Units.First .. Last_Unit loop if Cunit_Entity (Unum) = Empty @@ -1130,20 +1048,8 @@ package body Lib.Writ is Lib.Sort (Sdep_Table (1 .. Num_Sdep)); - -- If we are not generating code, and there is an up to date ALI file - -- file accessible, read it, and acquire the compilation arguments from - -- this file. In GNATprove mode, always generate the ALI file, which - -- contains a special section for formal verification. - - if Operating_Mode /= Generate_Code and then not GNATprove_Mode then - if Up_To_Date_ALI_File_Exists then - Update_Tables_From_ALI_File; - return; - end if; - end if; - - -- Otherwise acquire compilation arguments and prepare to write out a - -- new ali file. + -- Acquire compilation arguments and prepare to write out a new ali + -- file. Create_Output_Library_Info; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index e7f2e3f..7ec57b4 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -1053,12 +1053,6 @@ package Lib.Writ is -- The Object parameter is true if an object file is created, and false -- otherwise. Note that the pseudo-object file generated in GNATprove mode -- does count as an object file from this point of view. - -- - -- Note: in the case where we are not generating code (-gnatc mode), this - -- routine only writes an ALI file if it cannot find an existing up to - -- date ALI file. If it *can* find an existing up to date ALI file, then - -- it reads this file and sets the Lib.Compilation_Arguments table from - -- the A lines in this file. procedure Add_Preprocessing_Dependency (S : Source_File_Index); -- Indicate that there is a dependency to be added on a preprocessing data diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index ae4b4c7..64b9683 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -53,6 +53,14 @@ package body Lib.Xref is -- Declarations -- ------------------ + package Deferred_References is new Table.Table ( + Table_Component_Type => Deferred_Reference_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 512, + Table_Increment => 200, + Table_Name => "Name_Deferred_References"); + -- The Xref table is used to record references. The Loc field is set -- to No_Location for a definition entry. @@ -199,6 +207,21 @@ package body Lib.Xref is end if; end Add_Entry; + --------------------- + -- Defer_Reference -- + --------------------- + + procedure Defer_Reference (Deferred_Reference : Deferred_Reference_Entry) is + begin + -- If Get_Ignore_Errors, then we are in Preanalyze_Without_Errors, and + -- we should not record cross references, because that will cause + -- duplicates when we call Analyze. + + if not Get_Ignore_Errors then + Deferred_References.Append (Deferred_Reference); + end if; + end Defer_Reference; + ----------- -- Equal -- ----------- @@ -595,6 +618,14 @@ package body Lib.Xref is -- Start of processing for Generate_Reference begin + -- If Get_Ignore_Errors, then we are in Preanalyze_Without_Errors, and + -- we should not record cross references, because that will cause + -- duplicates when we call Analyze. + + if Get_Ignore_Errors then + return; + end if; + -- May happen in case of severe errors if Nkind (E) not in N_Entity then diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index 79dd57b..6a7a9e5 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -591,8 +591,8 @@ package Lib.Xref is -- What we do in such cases is to gather nodes, where we would have liked -- to call Generate_Reference but we couldn't because we didn't know enough - -- into this table, then we deal with generating references later on when - -- we have sufficient information to do it right. + -- into a table, then we deal with generating references later on when we + -- have sufficient information to do it right. type Deferred_Reference_Entry is record E : Entity_Id; @@ -600,13 +600,8 @@ package Lib.Xref is end record; -- One entry, E, N are as required for Generate_Reference call - package Deferred_References is new Table.Table ( - Table_Component_Type => Deferred_Reference_Entry, - Table_Index_Type => Int, - Table_Low_Bound => 0, - Table_Initial => 512, - Table_Increment => 200, - Table_Name => "Name_Deferred_References"); + procedure Defer_Reference (Deferred_Reference : Deferred_Reference_Entry); + -- Add one entry to the deferred reference table procedure Process_Deferred_References; -- This procedure is called from Frontend to process these table entries. diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 806f939..49a352a 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index c4ace09..be517c0 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/libgnarl/s-osinte__aix.adb b/gcc/ada/libgnarl/s-osinte__aix.adb index 2370383..91c4494 100644 --- a/gcc/ada/libgnarl/s-osinte__aix.adb +++ b/gcc/ada/libgnarl/s-osinte__aix.adb @@ -31,10 +31,6 @@ -- This is a AIX (Native) version of this package -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - package body System.OS_Interface is use Interfaces.C; diff --git a/gcc/ada/libgnarl/s-osinte__android.adb b/gcc/ada/libgnarl/s-osinte__android.adb index 00f0d48..5895940 100644 --- a/gcc/ada/libgnarl/s-osinte__android.adb +++ b/gcc/ada/libgnarl/s-osinte__android.adb @@ -31,10 +31,6 @@ -- This is an Android version of this package. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. diff --git a/gcc/ada/libgnarl/s-osinte__darwin.adb b/gcc/ada/libgnarl/s-osinte__darwin.adb index 877bcac..b57a31a 100644 --- a/gcc/ada/libgnarl/s-osinte__darwin.adb +++ b/gcc/ada/libgnarl/s-osinte__darwin.adb @@ -31,10 +31,6 @@ -- This is a Darwin Threads version of this package -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - with Interfaces.C.Extensions; package body System.OS_Interface is diff --git a/gcc/ada/libgnarl/s-osinte__gnu.adb b/gcc/ada/libgnarl/s-osinte__gnu.adb index 8da6ce3..dc0f4ec 100644 --- a/gcc/ada/libgnarl/s-osinte__gnu.adb +++ b/gcc/ada/libgnarl/s-osinte__gnu.adb @@ -31,10 +31,6 @@ -- This is the GNU/Hurd version of this package. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb index 06ec5e6..bcfcf61 100644 --- a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb +++ b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb @@ -33,10 +33,6 @@ -- This is a DCE version of this package. -- Currently HP-UX and SNI use this file -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. diff --git a/gcc/ada/libgnarl/s-osinte__lynxos178.adb b/gcc/ada/libgnarl/s-osinte__lynxos178.adb index 08ed178..79099d7 100644 --- a/gcc/ada/libgnarl/s-osinte__lynxos178.adb +++ b/gcc/ada/libgnarl/s-osinte__lynxos178.adb @@ -31,10 +31,6 @@ -- Version of System.OS_Interface for LynxOS-178 (POSIX Threads) -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It may cause infinite loops and other problems. - package body System.OS_Interface is ------------------ diff --git a/gcc/ada/libgnarl/s-osinte__lynxos178e.ads b/gcc/ada/libgnarl/s-osinte__lynxos178e.ads index 646d301..6d84b35 100644 --- a/gcc/ada/libgnarl/s-osinte__lynxos178e.ads +++ b/gcc/ada/libgnarl/s-osinte__lynxos178e.ads @@ -47,10 +47,6 @@ with System.Multiprocessors; package System.OS_Interface is pragma Preelaborate; - pragma Linker_Options ("-mthreads"); - -- Selects the POSIX 1.c runtime, rather than the non-threading runtime or - -- the deprecated legacy threads library. - subtype int is Interfaces.C.int; subtype short is Interfaces.C.short; subtype long is Interfaces.C.long; diff --git a/gcc/ada/libgnarl/s-osinte__posix.adb b/gcc/ada/libgnarl/s-osinte__posix.adb index 5ff7ae7..4818162 100644 --- a/gcc/ada/libgnarl/s-osinte__posix.adb +++ b/gcc/ada/libgnarl/s-osinte__posix.adb @@ -32,10 +32,6 @@ -- This version is for POSIX-like operating systems -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. diff --git a/gcc/ada/libgnarl/s-osinte__qnx.adb b/gcc/ada/libgnarl/s-osinte__qnx.adb index b02bc83..45b7ea7 100644 --- a/gcc/ada/libgnarl/s-osinte__qnx.adb +++ b/gcc/ada/libgnarl/s-osinte__qnx.adb @@ -32,10 +32,6 @@ -- This version is for QNX operating systems -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. diff --git a/gcc/ada/libgnarl/s-osinte__rtems.adb b/gcc/ada/libgnarl/s-osinte__rtems.adb index bfa5cc5..06cf1ab 100644 --- a/gcc/ada/libgnarl/s-osinte__rtems.adb +++ b/gcc/ada/libgnarl/s-osinte__rtems.adb @@ -40,11 +40,8 @@ -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - with Interfaces.C; use Interfaces.C; + package body System.OS_Interface is ----------------- diff --git a/gcc/ada/libgnarl/s-osinte__solaris.adb b/gcc/ada/libgnarl/s-osinte__solaris.adb index e3bb41e..adfc386 100644 --- a/gcc/ada/libgnarl/s-osinte__solaris.adb +++ b/gcc/ada/libgnarl/s-osinte__solaris.adb @@ -35,10 +35,6 @@ -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - with Interfaces.C; use Interfaces.C; package body System.OS_Interface is diff --git a/gcc/ada/libgnarl/s-osinte__vxworks.adb b/gcc/ada/libgnarl/s-osinte__vxworks.adb index d9de575..e88a9af 100644 --- a/gcc/ada/libgnarl/s-osinte__vxworks.adb +++ b/gcc/ada/libgnarl/s-osinte__vxworks.adb @@ -34,10 +34,6 @@ -- This package encapsulates all direct interfaces to OS services that are -- needed by children of System. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - package body System.OS_Interface is use type Interfaces.C.int; diff --git a/gcc/ada/libgnarl/s-osinte__x32.adb b/gcc/ada/libgnarl/s-osinte__x32.adb index 80f7825..8a7cb4c 100644 --- a/gcc/ada/libgnarl/s-osinte__x32.adb +++ b/gcc/ada/libgnarl/s-osinte__x32.adb @@ -32,14 +32,11 @@ -- This version is for Linux/x32 -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. with Interfaces.C; use Interfaces.C; + package body System.OS_Interface is -------------------- diff --git a/gcc/ada/libgnarl/s-solita.adb b/gcc/ada/libgnarl/s-solita.adb index bdd5f9c..ac35781 100644 --- a/gcc/ada/libgnarl/s-solita.adb +++ b/gcc/ada/libgnarl/s-solita.adb @@ -33,11 +33,6 @@ pragma Style_Checks (All_Checks); -- Turn off subprogram alpha ordering check, since we group soft link bodies -- and dummy soft link bodies together separately in this unit. -pragma Polling (Off); --- Turn polling off for this package. We don't need polling during any of the --- routines in this package, and more to the point, if we try to poll it can --- cause infinite loops. - with Ada.Exceptions; with Ada.Exceptions.Is_Null_Occurrence; diff --git a/gcc/ada/libgnarl/s-taasde.adb b/gcc/ada/libgnarl/s-taasde.adb index dc7dac1..9c4340c 100644 --- a/gcc/ada/libgnarl/s-taasde.adb +++ b/gcc/ada/libgnarl/s-taasde.adb @@ -29,10 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - with Ada.Unchecked_Conversion; with Ada.Task_Identification; diff --git a/gcc/ada/libgnarl/s-taprob.adb b/gcc/ada/libgnarl/s-taprob.adb index 3f8a457..6ce522a 100644 --- a/gcc/ada/libgnarl/s-taprob.adb +++ b/gcc/ada/libgnarl/s-taprob.adb @@ -30,10 +30,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with System.Task_Primitives.Operations; with System.Soft_Links.Tasking; diff --git a/gcc/ada/libgnarl/s-taprop__dummy.adb b/gcc/ada/libgnarl/s-taprop__dummy.adb index b6fa63b..7e9093a 100644 --- a/gcc/ada/libgnarl/s-taprop__dummy.adb +++ b/gcc/ada/libgnarl/s-taprop__dummy.adb @@ -34,10 +34,6 @@ -- This package contains all the GNULL primitives that interface directly with -- the underlying OS. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - package body System.Task_Primitives.Operations is use System.Tasking; diff --git a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb index 99049f1..0e00511 100644 --- a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb +++ b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb @@ -34,10 +34,6 @@ -- This package contains all the GNULL primitives that interface directly with -- the underlying OS. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with Ada.Unchecked_Conversion; with Interfaces.C; diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb index fb11e02..757a6cd 100644 --- a/gcc/ada/libgnarl/s-taprop__linux.adb +++ b/gcc/ada/libgnarl/s-taprop__linux.adb @@ -34,10 +34,6 @@ -- This package contains all the GNULL primitives that interface directly with -- the underlying OS. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with Interfaces.C; use Interfaces; use type Interfaces.C.int; with System.Task_Info; diff --git a/gcc/ada/libgnarl/s-taprop__mingw.adb b/gcc/ada/libgnarl/s-taprop__mingw.adb index 8fa5435..4405231 100644 --- a/gcc/ada/libgnarl/s-taprop__mingw.adb +++ b/gcc/ada/libgnarl/s-taprop__mingw.adb @@ -34,10 +34,6 @@ -- This package contains all the GNULL primitives that interface directly with -- the underlying OS. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with Interfaces.C; with Interfaces.C.Strings; diff --git a/gcc/ada/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb index c983c77..8ecb293 100644 --- a/gcc/ada/libgnarl/s-taprop__posix.adb +++ b/gcc/ada/libgnarl/s-taprop__posix.adb @@ -40,10 +40,6 @@ -- For configurations where SCHED_FIFO and priority ceiling are not a -- requirement, this file can also be used (e.g AiX threads) -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with Ada.Unchecked_Conversion; with Interfaces.C; diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb index 52d353c..e3ad521 100644 --- a/gcc/ada/libgnarl/s-taprop__qnx.adb +++ b/gcc/ada/libgnarl/s-taprop__qnx.adb @@ -40,10 +40,6 @@ -- For configurations where SCHED_FIFO and priority ceiling are not a -- requirement, this file can also be used (e.g AiX threads) -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with Ada.Unchecked_Conversion; with Interfaces.C; diff --git a/gcc/ada/libgnarl/s-taprop__solaris.adb b/gcc/ada/libgnarl/s-taprop__solaris.adb index 8b0183d..3084842 100644 --- a/gcc/ada/libgnarl/s-taprop__solaris.adb +++ b/gcc/ada/libgnarl/s-taprop__solaris.adb @@ -34,10 +34,6 @@ -- This package contains all the GNULL primitives that interface directly with -- the underlying OS. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with Interfaces.C; with System.Multiprocessors; diff --git a/gcc/ada/libgnarl/s-taprop__vxworks.adb b/gcc/ada/libgnarl/s-taprop__vxworks.adb index 32c301d..c9d019e 100644 --- a/gcc/ada/libgnarl/s-taprop__vxworks.adb +++ b/gcc/ada/libgnarl/s-taprop__vxworks.adb @@ -34,10 +34,6 @@ -- This package contains all the GNULL primitives that interface directly with -- the underlying OS. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with Ada.Unchecked_Conversion; with Interfaces.C; diff --git a/gcc/ada/libgnarl/s-tarest.adb b/gcc/ada/libgnarl/s-tarest.adb index ddaa983..4555101 100644 --- a/gcc/ada/libgnarl/s-tarest.adb +++ b/gcc/ada/libgnarl/s-tarest.adb @@ -39,10 +39,6 @@ pragma Style_Checks (All_Checks); -- This package represents the high level tasking interface used by the -- compiler to expand Ada 95 tasking constructs into simpler run time calls. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - with Ada.Exceptions; with System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-tasini.adb b/gcc/ada/libgnarl/s-tasini.adb index cdcb0ba..2080ac2 100644 --- a/gcc/ada/libgnarl/s-tasini.adb +++ b/gcc/ada/libgnarl/s-tasini.adb @@ -33,11 +33,6 @@ pragma Style_Checks (All_Checks); -- Turn off subprogram alpha ordering check, since we group soft link bodies -- and dummy soft link bodies together separately in this unit. -pragma Polling (Off); --- Turn polling off for this package. We don't need polling during any of the --- routines in this package, and more to the point, if we try to poll it can --- cause infinite loops. - with System.Task_Primitives; with System.Task_Primitives.Operations; with System.Soft_Links; diff --git a/gcc/ada/libgnarl/s-taskin.adb b/gcc/ada/libgnarl/s-taskin.adb index 1c6ab4a..16171c1 100644 --- a/gcc/ada/libgnarl/s-taskin.adb +++ b/gcc/ada/libgnarl/s-taskin.adb @@ -29,10 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with System.Task_Primitives.Operations; with System.Storage_Elements; diff --git a/gcc/ada/libgnarl/s-taspri__dummy.ads b/gcc/ada/libgnarl/s-taspri__dummy.ads index 6428ec9..7d87e22 100644 --- a/gcc/ada/libgnarl/s-taspri__dummy.ads +++ b/gcc/ada/libgnarl/s-taspri__dummy.ads @@ -31,10 +31,6 @@ -- This is a no tasking version of this package -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - package System.Task_Primitives is pragma Preelaborate; diff --git a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads index 65eda3c..e5bb2eb 100644 --- a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads +++ b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads @@ -33,10 +33,6 @@ -- This package provides low-level support for most tasking features -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with System.OS_Interface; package System.Task_Primitives is diff --git a/gcc/ada/libgnarl/s-taspri__lynxos.ads b/gcc/ada/libgnarl/s-taspri__lynxos.ads index 1e54e4c..36bb3a5 100644 --- a/gcc/ada/libgnarl/s-taspri__lynxos.ads +++ b/gcc/ada/libgnarl/s-taspri__lynxos.ads @@ -32,10 +32,6 @@ -- This is LynxOS Family version of this package. -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with System.OS_Interface; package System.Task_Primitives is diff --git a/gcc/ada/libgnarl/s-taspri__mingw.ads b/gcc/ada/libgnarl/s-taspri__mingw.ads index ecf0958..8199a36 100644 --- a/gcc/ada/libgnarl/s-taspri__mingw.ads +++ b/gcc/ada/libgnarl/s-taspri__mingw.ads @@ -31,10 +31,6 @@ -- This is a NT (native) version of this package -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with System.OS_Interface; with System.Win32; diff --git a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads index 30475c8..6b19345 100644 --- a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads +++ b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads @@ -35,10 +35,6 @@ -- Note: this file can only be used for POSIX compliant systems -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with System.OS_Interface; package System.Task_Primitives is diff --git a/gcc/ada/libgnarl/s-taspri__posix.ads b/gcc/ada/libgnarl/s-taspri__posix.ads index 89a35ad..5621754 100644 --- a/gcc/ada/libgnarl/s-taspri__posix.ads +++ b/gcc/ada/libgnarl/s-taspri__posix.ads @@ -34,10 +34,6 @@ -- Note: this file can only be used for POSIX compliant systems -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with System.OS_Interface; package System.Task_Primitives is diff --git a/gcc/ada/libgnarl/s-taspri__solaris.ads b/gcc/ada/libgnarl/s-taspri__solaris.ads index bc45168..6e963d5 100644 --- a/gcc/ada/libgnarl/s-taspri__solaris.ads +++ b/gcc/ada/libgnarl/s-taspri__solaris.ads @@ -33,10 +33,6 @@ -- This package provides low-level support for most tasking features -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with Ada.Unchecked_Conversion; with System.OS_Interface; diff --git a/gcc/ada/libgnarl/s-taspri__vxworks.ads b/gcc/ada/libgnarl/s-taspri__vxworks.ads index 92cd88c..2c7aadd 100644 --- a/gcc/ada/libgnarl/s-taspri__vxworks.ads +++ b/gcc/ada/libgnarl/s-taspri__vxworks.ads @@ -31,10 +31,6 @@ -- This is a VxWorks version of this package -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with System.OS_Interface; package System.Task_Primitives is diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb index c594027..aada734 100644 --- a/gcc/ada/libgnarl/s-tassta.adb +++ b/gcc/ada/libgnarl/s-tassta.adb @@ -29,10 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - pragma Partition_Elaboration_Policy (Concurrent); -- This package only implements the concurrent elaboration policy. This pragma -- will enforce it (and detect conflicts with user specified policy). diff --git a/gcc/ada/libgnarl/s-tasuti.adb b/gcc/ada/libgnarl/s-tasuti.adb index 90c5bd9..6dbd1f06 100644 --- a/gcc/ada/libgnarl/s-tasuti.adb +++ b/gcc/ada/libgnarl/s-tasuti.adb @@ -33,10 +33,6 @@ -- These declarations are not part of the GNARLI -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - with System.Tasking.Debug; with System.Task_Primitives.Operations; with System.Tasking.Initialization; diff --git a/gcc/ada/libgnarl/s-tposen.adb b/gcc/ada/libgnarl/s-tposen.adb index 3545435..eb01580 100644 --- a/gcc/ada/libgnarl/s-tposen.adb +++ b/gcc/ada/libgnarl/s-tposen.adb @@ -52,10 +52,6 @@ pragma Style_Checks (All_Checks); -- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue, -- Service_Entry). -pragma Polling (Off); --- Turn off polling, we do not want polling to take place during tasking --- operations. It can cause infinite loops and other problems. - pragma Suppress (All_Checks); -- Why is this required ??? diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb index 0f0c872..a0c356d 100644 --- a/gcc/ada/libgnat/a-cbdlli.adb +++ b/gcc/ada/libgnat/a-cbdlli.adb @@ -28,6 +28,7 @@ ------------------------------------------------------------------------------ with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Bounded_Doubly_Linked_Lists with SPARK_Mode => Off @@ -204,6 +205,18 @@ is Insert (Container, No_Element, New_Item, Count); end Append; + --------------- + -- Append_One -- + --------------- + + procedure Append_One + (Container : in out List; + New_Item : Element_Type) + is + begin + Insert (Container, No_Element, New_Item, 1); + end Append_One; + ------------ -- Assign -- ------------ @@ -505,6 +518,17 @@ is return Position.Container.Nodes (Position.Node).Element; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 10) return List is + begin + return Result : List (Capacity) do + null; + end return; + end Empty; + -------------- -- Finalize -- -------------- @@ -1479,6 +1503,31 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : List) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads index 74639cf..183c01e 100644 --- a/gcc/ada/libgnat/a-cbdlli.ads +++ b/gcc/ada/libgnat/a-cbdlli.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; +private with Ada.Strings.Text_Output; generic type Element_Type is private; @@ -54,8 +55,9 @@ is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; - + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Append_One); pragma Preelaborable_Initialization (List); type Cursor is private; @@ -65,6 +67,8 @@ is No_Element : constant Cursor; + function Empty (Capacity : Count_Type := 10) return List; + function Has_Element (Position : Cursor) return Boolean; package List_Iterator_Interfaces is new @@ -149,6 +153,10 @@ is New_Item : Element_Type; Count : Count_Type := 1); + procedure Append_One + (Container : in out List; + New_Item : Element_Type); + procedure Delete (Container : in out List; Position : in out Cursor; @@ -268,13 +276,16 @@ private type Node_Array is array (Count_Type range <>) of Node_Type; type List (Capacity : Count_Type) is tagged record - Nodes : Node_Array (1 .. Capacity) := (others => <>); + Nodes : Node_Array (1 .. Capacity); Free : Count_Type'Base := -1; First : Count_Type := 0; Last : Count_Type := 0; Length : Count_Type := 0; TC : aliased Tamper_Counts; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : List); procedure Read (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/libgnat/a-cbhama.adb b/gcc/ada/libgnat/a-cbhama.adb index 1881db2..7f0c0e6 100644 --- a/gcc/ada/libgnat/a-cbhama.adb +++ b/gcc/ada/libgnat/a-cbhama.adb @@ -38,6 +38,7 @@ with Ada.Containers.Helpers; use Ada.Containers.Helpers; with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Bounded_Hashed_Maps with SPARK_Mode => Off @@ -363,6 +364,17 @@ is return Position.Container.Nodes (Position.Node).Element; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type) return Map is + begin + return Result : Map (Capacity, 0) do + null; + end return; + end Empty; + ------------------------- -- Equivalent_Key_Node -- ------------------------- @@ -885,6 +897,36 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map) + is + First_Time : Boolean := True; + use System.Put_Images; + + procedure Put_Key_Value (Position : Cursor); + procedure Put_Key_Value (Position : Cursor) is + begin + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Key_Type'Put_Image (S, Key (Position)); + Put_Arrow (S); + Element_Type'Put_Image (S, Element (Position)); + end Put_Key_Value; + + begin + Array_Before (S); + Iterate (V, Put_Key_Value'Access); + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cbhama.ads b/gcc/ada/libgnat/a-cbhama.ads index 86fed4e..7a1d0f6 100644 --- a/gcc/ada/libgnat/a-cbhama.ads +++ b/gcc/ada/libgnat/a-cbhama.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; private with Ada.Streams; private with Ada.Finalization; +private with Ada.Strings.Text_Output; generic type Key_Type is private; @@ -56,7 +57,9 @@ is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Named => Insert); pragma Preelaborable_Initialization (Map); @@ -67,6 +70,8 @@ is -- Map objects declared without an initialization expression are -- initialized to the value Empty_Map. + function Empty (Capacity : Count_Type) return Map; + No_Element : constant Cursor; -- Cursor objects declared without an initialization expression are -- initialized to the value No_Element. @@ -340,7 +345,11 @@ private new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); type Map (Capacity : Count_Type; Modulus : Hash_Type) is - new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; + new HT_Types.Hash_Table_Type (Capacity, Modulus) + with null record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map); use HT_Types, HT_Types.Implementation; use Ada.Streams; diff --git a/gcc/ada/libgnat/a-cbhase.adb b/gcc/ada/libgnat/a-cbhase.adb index a332bd7..293d722 100644 --- a/gcc/ada/libgnat/a-cbhase.adb +++ b/gcc/ada/libgnat/a-cbhase.adb @@ -38,10 +38,12 @@ with Ada.Containers.Helpers; use Ada.Containers.Helpers; with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Bounded_Hashed_Sets with SPARK_Mode => Off is + use Ada.Finalization; pragma Warnings (Off, "variable ""Busy*"" is not referenced"); pragma Warnings (Off, "variable ""Lock*"" is not referenced"); @@ -454,6 +456,17 @@ is end; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 10) return Set is + begin + return Result : Set (Capacity, 0) do + Reserve_Capacity (Result, Capacity); + end return; + end Empty; + --------------------- -- Equivalent_Sets -- --------------------- @@ -1107,6 +1120,31 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads index 01903c7..c82a123 100644 --- a/gcc/ada/libgnat/a-cbhase.ads +++ b/gcc/ada/libgnat/a-cbhase.ads @@ -36,7 +36,8 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; with Ada.Containers.Helpers; private with Ada.Streams; -private with Ada.Finalization; use Ada.Finalization; +private with Ada.Finalization; +private with Ada.Strings.Text_Output; generic type Element_Type is private; @@ -58,7 +59,9 @@ is type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private with Constant_Indexing => Constant_Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Include); pragma Preelaborable_Initialization (Set); @@ -69,6 +72,8 @@ is -- Set objects declared without an initialization expression are -- initialized to the value Empty_Set. + function Empty (Capacity : Count_Type := 10) return Set; + No_Element : constant Cursor; -- Cursor objects declared without an initialization expression are -- initialized to the value No_Element. @@ -498,7 +503,11 @@ private new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); type Set (Capacity : Count_Type; Modulus : Hash_Type) is - new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; + new HT_Types.Hash_Table_Type (Capacity, Modulus) + with null record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set); use HT_Types, HT_Types.Implementation; use Ada.Streams; @@ -590,7 +599,7 @@ private No_Element : constant Cursor := (Container => null, Node => 0); - type Iterator is new Limited_Controlled and + type Iterator is new Ada.Finalization.Limited_Controlled and Set_Iterator_Interfaces.Forward_Iterator with record Container : Set_Access; diff --git a/gcc/ada/libgnat/a-cbmutr.adb b/gcc/ada/libgnat/a-cbmutr.adb index 58db8cf..3b25d20 100644 --- a/gcc/ada/libgnat/a-cbmutr.adb +++ b/gcc/ada/libgnat/a-cbmutr.adb @@ -29,6 +29,7 @@ with Ada.Finalization; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Bounded_Multiway_Trees with SPARK_Mode => Off @@ -2322,6 +2323,49 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree) + is + use System.Put_Images; + + procedure Rec (Position : Cursor); + -- Recursive routine operating on cursors + + procedure Rec (Position : Cursor) is + First_Time : Boolean := True; + begin + Array_Before (S); + + for X in Iterate_Children (V, Position) loop + if First_Time then + First_Time := False; + else + Array_Between (S); + end if; + + Element_Type'Put_Image (S, Element (X)); + if Child_Count (X) > 0 then + Simple_Array_Between (S); + Rec (X); + end if; + end loop; + + Array_After (S); + end Rec; + + begin + if First_Child (Root (V)) = No_Element then + Array_Before (S); + Array_After (S); + else + Rec (First_Child (Root (V))); + end if; + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cbmutr.ads b/gcc/ada/libgnat/a-cbmutr.ads index 653407b..a9fb55a 100644 --- a/gcc/ada/libgnat/a-cbmutr.ads +++ b/gcc/ada/libgnat/a-cbmutr.ads @@ -35,6 +35,7 @@ with Ada.Iterator_Interfaces; with Ada.Containers.Helpers; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Element_Type is private; @@ -302,12 +303,15 @@ private type Element_Array is array (Count_Type range <>) of aliased Element_Type; type Tree (Capacity : Count_Type) is tagged record - Nodes : Tree_Node_Array (0 .. Capacity) := (others => <>); - Elements : Element_Array (1 .. Capacity) := (others => <>); + Nodes : Tree_Node_Array (0 .. Capacity); + Elements : Element_Array (1 .. Capacity); Free : Count_Type'Base := No_Node; TC : aliased Tamper_Counts; Count : Count_Type := 0; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree); procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/libgnat/a-cborma.adb b/gcc/ada/libgnat/a-cborma.adb index 6f59471..5401847 100644 --- a/gcc/ada/libgnat/a-cborma.adb +++ b/gcc/ada/libgnat/a-cborma.adb @@ -38,6 +38,7 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Bounded_Ordered_Maps with SPARK_Mode => Off @@ -572,6 +573,17 @@ is return Container.Nodes (Node).Element; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 10) return Map is + begin + return Result : Map (Capacity) do + null; + end return; + end Empty; + --------------------- -- Equivalent_Keys -- --------------------- @@ -1289,6 +1301,36 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map) + is + First_Time : Boolean := True; + use System.Put_Images; + + procedure Put_Key_Value (Position : Cursor); + procedure Put_Key_Value (Position : Cursor) is + begin + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Key_Type'Put_Image (S, Key (Position)); + Put_Arrow (S); + Element_Type'Put_Image (S, Element (Position)); + end Put_Key_Value; + + begin + Array_Before (S); + Iterate (V, Put_Key_Value'Access); + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cborma.ads b/gcc/ada/libgnat/a-cborma.ads index c199a09..4da71bc 100644 --- a/gcc/ada/libgnat/a-cborma.ads +++ b/gcc/ada/libgnat/a-cborma.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Red_Black_Trees; private with Ada.Streams; private with Ada.Finalization; +private with Ada.Strings.Text_Output; generic type Key_Type is private; @@ -57,7 +58,9 @@ is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Named => Insert); pragma Preelaborable_Initialization (Map); @@ -66,6 +69,8 @@ is Empty_Map : constant Map; + function Empty (Capacity : Count_Type := 10) return Map; + No_Element : constant Cursor; function Has_Element (Position : Cursor) return Boolean; @@ -248,7 +253,11 @@ private new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); type Map (Capacity : Count_Type) is - new Tree_Types.Tree_Type (Capacity) with null record; + new Tree_Types.Tree_Type (Capacity) + with null record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map); use Red_Black_Trees; use Tree_Types, Tree_Types.Implementation; diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb index af4f87f..e4a2de8 100644 --- a/gcc/ada/libgnat/a-cborse.adb +++ b/gcc/ada/libgnat/a-cborse.adb @@ -41,6 +41,7 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Bounded_Ordered_Sets with SPARK_Mode => Off @@ -548,6 +549,17 @@ is return Position.Container.Nodes (Position.Node).Element; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 10) return Set is + begin + return Result : Set (Capacity) do + null; + end return; + end Empty; + ------------------------- -- Equivalent_Elements -- ------------------------- @@ -1628,6 +1640,31 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads index 52b8786..92a6df7 100644 --- a/gcc/ada/libgnat/a-cborse.ads +++ b/gcc/ada/libgnat/a-cborse.ads @@ -37,6 +37,7 @@ with Ada.Containers.Helpers; private with Ada.Containers.Red_Black_Trees; private with Ada.Streams; private with Ada.Finalization; +private with Ada.Strings.Text_Output; generic type Element_Type is private; @@ -56,7 +57,9 @@ is type Set (Capacity : Count_Type) is tagged private with Constant_Indexing => Constant_Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Include); pragma Preelaborable_Initialization (Set); @@ -65,6 +68,8 @@ is Empty_Set : constant Set; + function Empty (Capacity : Count_Type := 10) return Set; + No_Element : constant Cursor; function Has_Element (Position : Cursor) return Boolean; @@ -336,7 +341,11 @@ private new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); type Set (Capacity : Count_Type) is - new Tree_Types.Tree_Type (Capacity) with null record; + new Tree_Types.Tree_Type (Capacity) + with null record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set); use Tree_Types, Tree_Types.Implementation; use Ada.Finalization; diff --git a/gcc/ada/libgnat/a-cbsyqu.ads b/gcc/ada/libgnat/a-cbsyqu.ads index 61504fa..225db21 100644 --- a/gcc/ada/libgnat/a-cbsyqu.ads +++ b/gcc/ada/libgnat/a-cbsyqu.ads @@ -78,7 +78,7 @@ is First, Last : Count_Type := 0; Length : Count_Type := 0; Max_Length : Count_Type := 0; - Elements : Element_Array (1 .. Capacity) := (others => <>); + Elements : Element_Array (1 .. Capacity); end record; end Implementation; diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb index a668db1..f07190e 100644 --- a/gcc/ada/libgnat/a-cdlili.adb +++ b/gcc/ada/libgnat/a-cdlili.adb @@ -30,6 +30,7 @@ with Ada.Unchecked_Deallocation; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Doubly_Linked_Lists with SPARK_Mode => Off @@ -163,6 +164,18 @@ is Insert (Container, No_Element, New_Item, Count); end Append; + --------------- + -- Append_One -- + --------------- + + procedure Append_One + (Container : in out List; + New_Item : Element_Type) + is + begin + Insert (Container, No_Element, New_Item, 1); + end Append_One; + ------------ -- Assign -- ------------ @@ -1255,6 +1268,31 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : List) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cdlili.ads b/gcc/ada/libgnat/a-cdlili.ads index 89216e0..35c4352 100644 --- a/gcc/ada/libgnat/a-cdlili.ads +++ b/gcc/ada/libgnat/a-cdlili.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Element_Type is private; @@ -55,7 +56,9 @@ is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Append_One); pragma Preelaborable_Initialization (List); @@ -63,6 +66,7 @@ is pragma Preelaborable_Initialization (Cursor); Empty_List : constant List; + function Empty return List; No_Element : constant Cursor; @@ -152,6 +156,10 @@ is New_Item : Element_Type; Count : Count_Type := 1); + procedure Append_One + (Container : in out List; + New_Item : Element_Type); + procedure Delete (Container : in out List; Position : in out Cursor; @@ -275,7 +283,10 @@ private Last : Node_Access := null; Length : Count_Type := 0; TC : aliased Tamper_Counts; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : List); overriding procedure Adjust (Container : in out List); @@ -381,6 +392,7 @@ private -- Returns a pointer to the element designated by Position. Empty_List : constant List := (Controlled with others => <>); + function Empty return List is (Empty_List); No_Element : constant Cursor := Cursor'(null, null); diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads index 6131239..f7dbf04 100644 --- a/gcc/ada/libgnat/a-cfdlli.ads +++ b/gcc/ada/libgnat/a-cfdlli.ads @@ -1617,7 +1617,7 @@ private Length : Count_Type := 0; First : Count_Type := 0; Last : Count_Type := 0; - Nodes : Node_Array (1 .. Capacity) := (others => <>); + Nodes : Node_Array (1 .. Capacity); end record; Empty_List : constant List := (0, others => <>); diff --git a/gcc/ada/libgnat/a-cfinve.adb b/gcc/ada/libgnat/a-cfinve.adb index 28e31d1..e424df0 100644 --- a/gcc/ada/libgnat/a-cfinve.adb +++ b/gcc/ada/libgnat/a-cfinve.adb @@ -40,7 +40,7 @@ is -- When growing a container, multiply current capacity by this. Doubling -- leads to amortized linear-time copying. - type Int is range System.Min_Int .. System.Max_Int; + subtype Int is Long_Long_Integer; procedure Free is new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); diff --git a/gcc/ada/libgnat/a-cgcaso.adb b/gcc/ada/libgnat/a-cgcaso.adb index 877abab..ff03b80 100644 --- a/gcc/ada/libgnat/a-cgcaso.adb +++ b/gcc/ada/libgnat/a-cgcaso.adb @@ -29,12 +29,10 @@ -- This algorithm was adapted from GNAT.Heap_Sort_G (see g-hesorg.ad[sb]) -with System; - procedure Ada.Containers.Generic_Constrained_Array_Sort (Container : in out Array_Type) is - type T is range System.Min_Int .. System.Max_Int; + subtype T is Long_Long_Integer; function To_Index (J : T) return Index_Type; pragma Inline (To_Index); diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb index 0898db8..a62338f 100644 --- a/gcc/ada/libgnat/a-cidlli.adb +++ b/gcc/ada/libgnat/a-cidlli.adb @@ -30,6 +30,7 @@ with Ada.Unchecked_Deallocation; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Indefinite_Doubly_Linked_Lists with SPARK_Mode => Off @@ -184,6 +185,18 @@ is Insert (Container, No_Element, New_Item, Count); end Append; + --------------- + -- Append_One -- + --------------- + + procedure Append_One + (Container : in out List; + New_Item : Element_Type) + is + begin + Insert (Container, No_Element, New_Item, 1); + end Append_One; + ------------ -- Assign -- ------------ @@ -1297,6 +1310,34 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : List) + is + First_Time : Boolean := True; + use System.Put_Images; + + procedure Put_Elem (Position : Cursor); + procedure Put_Elem (Position : Cursor) is + begin + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, Element (Position)); + end Put_Elem; + + begin + Array_Before (S); + Iterate (V, Put_Elem'Access); + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cidlli.ads b/gcc/ada/libgnat/a-cidlli.ads index e9220a6..5e63cf2 100644 --- a/gcc/ada/libgnat/a-cidlli.ads +++ b/gcc/ada/libgnat/a-cidlli.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Element_Type (<>) is private; @@ -54,7 +55,9 @@ is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Append_One); pragma Preelaborable_Initialization (List); @@ -62,6 +65,7 @@ is pragma Preelaborable_Initialization (Cursor); Empty_List : constant List; + function Empty return List; No_Element : constant Cursor; @@ -145,6 +149,10 @@ is New_Item : Element_Type; Count : Count_Type := 1); + procedure Append_One + (Container : in out List; + New_Item : Element_Type); + procedure Delete (Container : in out List; Position : in out Cursor; @@ -269,7 +277,10 @@ private Last : Node_Access := null; Length : Count_Type := 0; TC : aliased Tamper_Counts; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : List); overriding procedure Adjust (Container : in out List); @@ -372,6 +383,7 @@ private -- Returns a pointer to the element designated by Position. Empty_List : constant List := List'(Controlled with others => <>); + function Empty return List is (Empty_List); No_Element : constant Cursor := Cursor'(null, null); diff --git a/gcc/ada/libgnat/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb index 9f5aed7..64f662f 100644 --- a/gcc/ada/libgnat/a-cihama.adb +++ b/gcc/ada/libgnat/a-cihama.adb @@ -38,6 +38,7 @@ with Ada.Containers.Helpers; use Ada.Containers.Helpers; with Ada.Unchecked_Deallocation; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Indefinite_Hashed_Maps with SPARK_Mode => Off @@ -384,6 +385,17 @@ is return Position.Node.Element.all; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 1000) return Map is + begin + return Result : Map do + Reserve_Capacity (Result, Capacity); + end return; + end Empty; + ------------------------- -- Equivalent_Key_Node -- ------------------------- @@ -952,6 +964,36 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map) + is + First_Time : Boolean := True; + use System.Put_Images; + + procedure Put_Key_Value (Position : Cursor); + procedure Put_Key_Value (Position : Cursor) is + begin + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Key_Type'Put_Image (S, Key (Position)); + Put_Arrow (S); + Element_Type'Put_Image (S, Element (Position)); + end Put_Key_Value; + + begin + Array_Before (S); + Iterate (V, Put_Key_Value'Access); + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cihama.ads b/gcc/ada/libgnat/a-cihama.ads index fb6f4e0..ccf5f4e 100644 --- a/gcc/ada/libgnat/a-cihama.ads +++ b/gcc/ada/libgnat/a-cihama.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Key_Type (<>) is private; @@ -56,7 +57,9 @@ is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Named => Insert); pragma Preelaborable_Initialization (Map); @@ -67,6 +70,8 @@ is -- Map objects declared without an initialization expression are -- initialized to the value Empty_Map. + function Empty (Capacity : Count_Type := 1000) return Map; + No_Element : constant Cursor; -- Cursor objects declared without an initialization expression are -- initialized to the value No_Element. @@ -328,7 +333,10 @@ private type Map is new Ada.Finalization.Controlled with record HT : HT_Types.Hash_Table_Type; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map); overriding procedure Adjust (Container : in out Map); diff --git a/gcc/ada/libgnat/a-cihase.adb b/gcc/ada/libgnat/a-cihase.adb index b91532d..ebc9152 100644 --- a/gcc/ada/libgnat/a-cihase.adb +++ b/gcc/ada/libgnat/a-cihase.adb @@ -40,6 +40,7 @@ with Ada.Containers.Helpers; use Ada.Containers.Helpers; with Ada.Containers.Prime_Numbers; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Indefinite_Hashed_Sets with SPARK_Mode => Off @@ -505,6 +506,17 @@ is return Position.Node.Element.all; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 1000) return Set is + begin + return Result : Set do + Reserve_Capacity (Result, Capacity); + end return; + end Empty; + --------------------- -- Equivalent_Sets -- --------------------- @@ -1264,6 +1276,31 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cihase.ads b/gcc/ada/libgnat/a-cihase.ads index 926e07f..cdfd86e 100644 --- a/gcc/ada/libgnat/a-cihase.ads +++ b/gcc/ada/libgnat/a-cihase.ads @@ -37,6 +37,7 @@ private with Ada.Containers.Hash_Tables; with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; +private with Ada.Strings.Text_Output; generic type Element_Type (<>) is private; @@ -58,7 +59,9 @@ is type Set is tagged private with Constant_Indexing => Constant_Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Include); pragma Preelaborable_Initialization (Set); @@ -69,6 +72,8 @@ is -- Set objects declared without an initialization expression are -- initialized to the value Empty_Set. + function Empty (Capacity : Count_Type := 1000) return Set; + No_Element : constant Cursor; -- Cursor objects declared without an initialization expression are -- initialized to the value No_Element. @@ -492,7 +497,10 @@ private type Set is new Ada.Finalization.Controlled with record HT : HT_Types.Hash_Table_Type; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set); overriding procedure Adjust (Container : in out Set); diff --git a/gcc/ada/libgnat/a-cimutr.adb b/gcc/ada/libgnat/a-cimutr.adb index 293275a..b358aad 100644 --- a/gcc/ada/libgnat/a-cimutr.adb +++ b/gcc/ada/libgnat/a-cimutr.adb @@ -30,6 +30,7 @@ with Ada.Unchecked_Deallocation; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Indefinite_Multiway_Trees with SPARK_Mode => Off @@ -1875,6 +1876,49 @@ is Process (Position.Node.Element.all); end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree) + is + use System.Put_Images; + + procedure Rec (Position : Cursor); + -- Recursive routine operating on cursors + + procedure Rec (Position : Cursor) is + First_Time : Boolean := True; + begin + Array_Before (S); + + for X in Iterate_Children (V, Position) loop + if First_Time then + First_Time := False; + else + Array_Between (S); + end if; + + Element_Type'Put_Image (S, Element (X)); + if Child_Count (X) > 0 then + Simple_Array_Between (S); + Rec (X); + end if; + end loop; + + Array_After (S); + end Rec; + + begin + if First_Child (Root (V)) = No_Element then + Array_Before (S); + Array_After (S); + else + Rec (First_Child (Root (V))); + end if; + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cimutr.ads b/gcc/ada/libgnat/a-cimutr.ads index 474a1b5..9e03eb9 100644 --- a/gcc/ada/libgnat/a-cimutr.ads +++ b/gcc/ada/libgnat/a-cimutr.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Element_Type (<>) is private; @@ -348,7 +349,10 @@ private Root : aliased Tree_Node_Type; TC : aliased Tamper_Counts; Count : Count_Type := 0; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree); overriding procedure Adjust (Container : in out Tree); diff --git a/gcc/ada/libgnat/a-ciorma.adb b/gcc/ada/libgnat/a-ciorma.adb index 86cd01f..7cfe07d 100644 --- a/gcc/ada/libgnat/a-ciorma.adb +++ b/gcc/ada/libgnat/a-ciorma.adb @@ -38,6 +38,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Keys; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Indefinite_Ordered_Maps with SPARK_Mode => Off @@ -1291,6 +1292,36 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map) + is + First_Time : Boolean := True; + use System.Put_Images; + + procedure Put_Key_Value (Position : Cursor); + procedure Put_Key_Value (Position : Cursor) is + begin + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Key_Type'Put_Image (S, Key (Position)); + Put_Arrow (S); + Element_Type'Put_Image (S, Element (Position)); + end Put_Key_Value; + + begin + Array_Before (S); + Iterate (V, Put_Key_Value'Access); + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-ciorma.ads b/gcc/ada/libgnat/a-ciorma.ads index a7799a6..17f5dfd 100644 --- a/gcc/ada/libgnat/a-ciorma.ads +++ b/gcc/ada/libgnat/a-ciorma.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Key_Type (<>) is private; @@ -57,7 +58,9 @@ is with Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Named => Insert); pragma Preelaborable_Initialization (Map); @@ -66,6 +69,8 @@ is Empty_Map : constant Map; + function Empty return Map; + No_Element : constant Cursor; function Has_Element (Position : Cursor) return Boolean; @@ -256,7 +261,10 @@ private type Map is new Ada.Finalization.Controlled with record Tree : Tree_Types.Tree_Type; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map); overriding procedure Adjust (Container : in out Map); @@ -363,6 +371,7 @@ private -- Returns a pointer to the element designated by Position. Empty_Map : constant Map := (Controlled with others => <>); + function Empty return Map is (Empty_Map); No_Element : constant Cursor := Cursor'(null, null); diff --git a/gcc/ada/libgnat/a-ciormu.adb b/gcc/ada/libgnat/a-ciormu.adb index 110d734..c3672f4 100644 --- a/gcc/ada/libgnat/a-ciormu.adb +++ b/gcc/ada/libgnat/a-ciormu.adb @@ -39,6 +39,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Indefinite_Ordered_Multisets with SPARK_Mode => Off @@ -1657,6 +1658,31 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-ciormu.ads b/gcc/ada/libgnat/a-ciormu.ads index 474ccc7..5667e2c 100644 --- a/gcc/ada/libgnat/a-ciormu.ads +++ b/gcc/ada/libgnat/a-ciormu.ads @@ -35,6 +35,7 @@ private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; with Ada.Iterator_Interfaces; generic @@ -468,7 +469,10 @@ private type Set is new Ada.Finalization.Controlled with record Tree : Tree_Types.Tree_Type; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set); overriding procedure Adjust (Container : in out Set); diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb index 772061d..df56e48 100644 --- a/gcc/ada/libgnat/a-ciorse.adb +++ b/gcc/ada/libgnat/a-ciorse.adb @@ -41,6 +41,7 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with Ada.Unchecked_Deallocation; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Indefinite_Ordered_Sets with SPARK_Mode => Off @@ -1722,6 +1723,31 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads index 1eb8135..1b6e317 100644 --- a/gcc/ada/libgnat/a-ciorse.ads +++ b/gcc/ada/libgnat/a-ciorse.ads @@ -37,6 +37,7 @@ with Ada.Containers.Helpers; private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Element_Type (<>) is private; @@ -56,7 +57,9 @@ is type Set is tagged private with Constant_Indexing => Constant_Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Include); pragma Preelaborable_Initialization (Set); @@ -64,6 +67,7 @@ is pragma Preelaborable_Initialization (Cursor); Empty_Set : constant Set; + function Empty return Set; No_Element : constant Cursor; @@ -357,7 +361,10 @@ private type Set is new Ada.Finalization.Controlled with record Tree : Tree_Types.Tree_Type; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set); overriding procedure Adjust (Container : in out Set); @@ -442,6 +449,7 @@ private -- Returns a pointer to the element designated by Position. Empty_Set : constant Set := (Controlled with others => <>); + function Empty return Set is (Empty_Set); No_Element : constant Cursor := Cursor'(null, null); diff --git a/gcc/ada/libgnat/a-coboho.adb b/gcc/ada/libgnat/a-coboho.adb index eefb106..5d44163 100644 --- a/gcc/ada/libgnat/a-coboho.adb +++ b/gcc/ada/libgnat/a-coboho.adb @@ -26,6 +26,7 @@ ------------------------------------------------------------------------------ with Unchecked_Conversion; +with System.Put_Images; package body Ada.Containers.Bounded_Holders is @@ -64,6 +65,20 @@ package body Ada.Containers.Bounded_Holders is return Get (Left) = Get (Right); end "="; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder) + is + use System.Put_Images; + begin + Array_Before (S); + Element_Type'Put_Image (S, Get (V)); + Array_After (S); + end Put_Image; + --------- -- Get -- --------- diff --git a/gcc/ada/libgnat/a-coboho.ads b/gcc/ada/libgnat/a-coboho.ads index cb24c89..024e6a6 100644 --- a/gcc/ada/libgnat/a-coboho.ads +++ b/gcc/ada/libgnat/a-coboho.ads @@ -30,6 +30,7 @@ ------------------------------------------------------------------------------ private with System; +private with Ada.Strings.Text_Output; generic type Element_Type (<>) is private; @@ -93,11 +94,14 @@ private type Holder is record Data : Storage_Array (1 .. Max_Size_In_Storage_Elements); end record - with Alignment => Standard'Maximum_Alignment; + with Alignment => Standard'Maximum_Alignment, Put_Image => Put_Image; -- We would like to say "Alignment => Element_Type'Alignment", but that -- is illegal because it's not static, so we use the maximum possible -- (default) alignment instead. + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder); + type Element_Access is access all Element_Type; pragma Assert (Element_Access'Size = Standard'Address_Size, "cannot instantiate with an array type"); diff --git a/gcc/ada/libgnat/a-cobove.adb b/gcc/ada/libgnat/a-cobove.adb index fe94ea5..0408741 100644 --- a/gcc/ada/libgnat/a-cobove.adb +++ b/gcc/ada/libgnat/a-cobove.adb @@ -30,6 +30,7 @@ with Ada.Containers.Generic_Array_Sort; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Bounded_Vectors is @@ -350,6 +351,17 @@ package body Ada.Containers.Bounded_Vectors is Container.Insert (Container.Last + 1, New_Item, Count); end Append; + ---------------- + -- Append_One -- + ---------------- + + procedure Append_One (Container : in out Vector; + New_Item : Element_Type) + is + begin + Insert (Container, Last_Index (Container) + 1, New_Item, 1); + end Append_One; + -------------- -- Capacity -- -------------- @@ -696,6 +708,17 @@ package body Ada.Containers.Bounded_Vectors is end if; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 10) return Vector is + begin + return Result : Vector (Capacity) do + Reserve_Capacity (Result, Capacity); + end return; + end Empty; + -------------- -- Finalize -- -------------- @@ -824,6 +847,16 @@ package body Ada.Containers.Bounded_Vectors is return Index_Type'First; end First_Index; + ----------------- + -- New_Vector -- + ----------------- + + function New_Vector (First, Last : Index_Type) return Vector + is + begin + return (To_Vector (Count_Type (Last - First + 1))); + end New_Vector; + --------------------- -- Generic_Sorting -- --------------------- @@ -2097,6 +2130,31 @@ package body Ada.Containers.Bounded_Vectors is Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cobove.ads b/gcc/ada/libgnat/a-cobove.ads index 72da498..ab4ce4e 100644 --- a/gcc/ada/libgnat/a-cobove.ads +++ b/gcc/ada/libgnat/a-cobove.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; with Ada.Containers.Helpers; private with Ada.Streams; private with Ada.Finalization; +private with Ada.Strings.Text_Output; generic type Index_Type is range <>; @@ -58,7 +59,11 @@ package Ada.Containers.Bounded_Vectors is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Append_One, + New_Indexed => New_Vector, + Assign_Indexed => Replace_Element); pragma Preelaborable_Initialization (Vector); @@ -74,8 +79,14 @@ package Ada.Containers.Bounded_Vectors is package Vector_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); + function Empty (Capacity : Count_Type := 10) return Vector; + overriding function "=" (Left, Right : Vector) return Boolean; + function New_Vector (First, Last : Index_Type) return Vector + with Pre => First = Index_Type'First; + -- Ada_2020 aggregate operation. + function To_Vector (Length : Count_Type) return Vector; function To_Vector @@ -243,6 +254,10 @@ package Ada.Containers.Bounded_Vectors is New_Item : Element_Type; Count : Count_Type := 1); + procedure Append_One (Container : in out Vector; + New_Item : Element_Type); + -- Ada_2020 aggregate operation. + procedure Insert_Space (Container : in out Vector; Before : Extended_Index; @@ -377,10 +392,13 @@ private function "=" (L, R : Elements_Array) return Boolean is abstract; type Vector (Capacity : Count_Type) is tagged record - Elements : Elements_Array (1 .. Capacity) := (others => <>); + Elements : Elements_Array (1 .. Capacity); Last : Extended_Index := No_Index; TC : aliased Tamper_Counts; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector); procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/gcc/ada/libgnat/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb index 41c69a8..d467384 100644 --- a/gcc/ada/libgnat/a-cofove.adb +++ b/gcc/ada/libgnat/a-cofove.adb @@ -33,7 +33,7 @@ package body Ada.Containers.Formal_Vectors with SPARK_Mode => Off is - type Int is range System.Min_Int .. System.Max_Int; + subtype Int is Long_Long_Integer; function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; @@ -171,7 +171,7 @@ is elsif Capacity >= LS then C := Capacity; else - raise Capacity_Error; + raise Capacity_Error with "Capacity too small"; end if; return Target : Vector (C) do @@ -956,6 +956,12 @@ is if New_Length > Max_Length then raise Constraint_Error with "Count is out of range"; + + -- Raise Capacity_Error if the new length exceeds the container's + -- capacity. + + elsif New_Length > Container.Capacity then + raise Capacity_Error with "New length is larger than capacity"; end if; J := To_Array_Index (Before); @@ -1104,7 +1110,7 @@ is is begin if Capacity > Container.Capacity then - raise Constraint_Error with "Capacity is out of range"; + raise Capacity_Error with "Capacity is out of range"; end if; end Reserve_Capacity; diff --git a/gcc/ada/libgnat/a-cogeso.adb b/gcc/ada/libgnat/a-cogeso.adb index 7a71772..2b6b05e 100644 --- a/gcc/ada/libgnat/a-cogeso.adb +++ b/gcc/ada/libgnat/a-cogeso.adb @@ -29,10 +29,8 @@ -- This algorithm was adapted from GNAT.Heap_Sort (see g-heasor.ad[sb]) -with System; - procedure Ada.Containers.Generic_Sort (First, Last : Index_Type'Base) is - type T is range System.Min_Int .. System.Max_Int; + subtype T is Long_Long_Integer; function To_Index (J : T) return Index_Type; pragma Inline (To_Index); diff --git a/gcc/ada/libgnat/a-cohama.adb b/gcc/ada/libgnat/a-cohama.adb index 7f2d8e1..1475330 100644 --- a/gcc/ada/libgnat/a-cohama.adb +++ b/gcc/ada/libgnat/a-cohama.adb @@ -38,6 +38,7 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); with Ada.Containers.Helpers; use Ada.Containers.Helpers; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Hashed_Maps with SPARK_Mode => Off @@ -366,6 +367,17 @@ is return Position.Node.Element; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 1000) return Map is + begin + return Result : Map do + Reserve_Capacity (Result, Capacity); + end return; + end Empty; + ------------------------- -- Equivalent_Key_Node -- ------------------------- @@ -870,6 +882,36 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map) + is + First_Time : Boolean := True; + use System.Put_Images; + + procedure Put_Key_Value (Position : Cursor); + procedure Put_Key_Value (Position : Cursor) is + begin + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Key_Type'Put_Image (S, Key (Position)); + Put_Arrow (S); + Element_Type'Put_Image (S, Element (Position)); + end Put_Key_Value; + + begin + Array_Before (S); + Iterate (V, Put_Key_Value'Access); + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cohama.ads b/gcc/ada/libgnat/a-cohama.ads index 9d927bd..21b6935 100644 --- a/gcc/ada/libgnat/a-cohama.ads +++ b/gcc/ada/libgnat/a-cohama.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; -- The language-defined generic package Containers.Hashed_Maps provides -- private types Map and Cursor, and a set of operations for each type. A map @@ -100,7 +101,9 @@ is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Named => Insert); pragma Preelaborable_Initialization (Map); @@ -115,6 +118,8 @@ is -- Cursor objects declared without an initialization expression are -- initialized to the value No_Element. + function Empty (Capacity : Count_Type := 1000) return Map; + function Has_Element (Position : Cursor) return Boolean; -- Returns True if Position designates an element, and returns False -- otherwise. @@ -423,7 +428,10 @@ private type Map is new Ada.Finalization.Controlled with record HT : HT_Types.Hash_Table_Type; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map); overriding procedure Adjust (Container : in out Map); diff --git a/gcc/ada/libgnat/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb index bc4e53f..63e44e1 100644 --- a/gcc/ada/libgnat/a-cohase.adb +++ b/gcc/ada/libgnat/a-cohase.adb @@ -40,6 +40,7 @@ with Ada.Containers.Helpers; use Ada.Containers.Helpers; with Ada.Containers.Prime_Numbers; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Hashed_Sets with SPARK_Mode => Off @@ -467,6 +468,17 @@ is return Position.Node.Element; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 1000) return Set is + begin + return Result : Set do + Reserve_Capacity (Result, Capacity); + end return; + end Empty; + --------------------- -- Equivalent_Sets -- --------------------- @@ -1149,6 +1161,31 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-cohase.ads b/gcc/ada/libgnat/a-cohase.ads index 3645ed0..a0aca52 100644 --- a/gcc/ada/libgnat/a-cohase.ads +++ b/gcc/ada/libgnat/a-cohase.ads @@ -37,6 +37,7 @@ private with Ada.Containers.Hash_Tables; with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Element_Type is private; @@ -59,7 +60,9 @@ is with Constant_Indexing => Constant_Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Include); pragma Preelaborable_Initialization (Set); @@ -80,6 +83,8 @@ is package Set_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); + function Empty (Capacity : Count_Type := 1000) return Set; + function "=" (Left, Right : Set) return Boolean; -- For each element in Left, set equality attempts to find the equal -- element in Right; if a search fails, then set equality immediately @@ -502,7 +507,10 @@ private type Set is new Ada.Finalization.Controlled with record HT : HT_Types.Hash_Table_Type; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set); overriding procedure Adjust (Container : in out Set); diff --git a/gcc/ada/libgnat/a-cohata.ads b/gcc/ada/libgnat/a-cohata.ads index 9033c52..2b98928 100644 --- a/gcc/ada/libgnat/a-cohata.ads +++ b/gcc/ada/libgnat/a-cohata.ads @@ -72,7 +72,7 @@ package Ada.Containers.Hash_Tables is Length : Count_Type := 0; TC : aliased Helpers.Tamper_Counts; Free : Count_Type'Base := -1; - Nodes : Nodes_Type (1 .. Capacity) := (others => <>); + Nodes : Nodes_Type (1 .. Capacity); Buckets : Buckets_Type (1 .. Modulus) := (others => 0); end record; diff --git a/gcc/ada/libgnat/a-coinho.adb b/gcc/ada/libgnat/a-coinho.adb index c5da943..6c99c8d 100644 --- a/gcc/ada/libgnat/a-coinho.adb +++ b/gcc/ada/libgnat/a-coinho.adb @@ -26,6 +26,7 @@ ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; +with System.Put_Images; package body Ada.Containers.Indefinite_Holders is @@ -229,6 +230,22 @@ package body Ada.Containers.Indefinite_Holders is B := B - 1; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder) + is + use System.Put_Images; + begin + Array_Before (S); + if not Is_Empty (V) then + Element_Type'Put_Image (S, Element (V)); + end if; + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-coinho.ads b/gcc/ada/libgnat/a-coinho.ads index bf6165e..372f069 100644 --- a/gcc/ada/libgnat/a-coinho.ads +++ b/gcc/ada/libgnat/a-coinho.ads @@ -31,6 +31,7 @@ private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Element_Type (<>) is private; @@ -115,7 +116,11 @@ private type Holder is new Ada.Finalization.Controlled with record Element : Element_Access; Busy : Natural := 0; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder); + for Holder'Read use Read; for Holder'Write use Write; diff --git a/gcc/ada/libgnat/a-coinho__shared.adb b/gcc/ada/libgnat/a-coinho__shared.adb index 43f5d52..16bb708 100644 --- a/gcc/ada/libgnat/a-coinho__shared.adb +++ b/gcc/ada/libgnat/a-coinho__shared.adb @@ -33,6 +33,7 @@ -- internal shared object and element). with Ada.Unchecked_Deallocation; +with System.Put_Images; package body Ada.Containers.Indefinite_Holders is @@ -319,6 +320,22 @@ package body Ada.Containers.Indefinite_Holders is B := B - 1; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder) + is + use System.Put_Images; + begin + Array_Before (S); + if not Is_Empty (V) then + Element_Type'Put_Image (S, Element (V)); + end if; + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-coinho__shared.ads b/gcc/ada/libgnat/a-coinho__shared.ads index 0345b5e..e7bea85 100644 --- a/gcc/ada/libgnat/a-coinho__shared.ads +++ b/gcc/ada/libgnat/a-coinho__shared.ads @@ -36,6 +36,7 @@ private with Ada.Finalization; private with Ada.Streams; private with System.Atomic_Counters; +private with Ada.Strings.Text_Output; generic type Element_Type (<>) is private; @@ -130,7 +131,11 @@ private type Holder is new Ada.Finalization.Controlled with record Reference : Shared_Holder_Access; Busy : Natural := 0; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Holder); + for Holder'Read use Read; for Holder'Write use Write; diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb index 79e36ae..10711ff 100644 --- a/gcc/ada/libgnat/a-coinve.adb +++ b/gcc/ada/libgnat/a-coinve.adb @@ -31,6 +31,7 @@ with Ada.Containers.Generic_Array_Sort; with Ada.Unchecked_Deallocation; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Indefinite_Vectors with SPARK_Mode => Off @@ -228,6 +229,17 @@ is end if; end Append; + ---------------- + -- Append_One -- + ---------------- + + procedure Append_One (Container : in out Vector; + New_Item : Element_Type) + is + begin + Insert (Container, Last_Index (Container) + 1, New_Item, 1); + end Append_One; + ---------------------- -- Append_Slow_Path -- ---------------------- @@ -733,6 +745,17 @@ is end; end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 10) return Vector is + begin + return Result : Vector do + Reserve_Capacity (Result, Capacity); + end return; + end Empty; + -------------- -- Finalize -- -------------- @@ -872,6 +895,16 @@ is end First_Element; ----------------- + -- New_Vector -- + ----------------- + + function New_Vector (First, Last : Index_Type) return Vector + is + begin + return (To_Vector (Count_Type (Last - First + 1))); + end New_Vector; + + ----------------- -- First_Index -- ----------------- @@ -2628,6 +2661,34 @@ is end if; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector) + is + First_Time : Boolean := True; + use System.Put_Images; + + procedure Put_Elem (Position : Cursor); + procedure Put_Elem (Position : Cursor) is + begin + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, Element (Position)); + end Put_Elem; + + begin + Array_Before (S); + Iterate (V, Put_Elem'Access); + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-coinve.ads b/gcc/ada/libgnat/a-coinve.ads index 075a184..593b63e 100644 --- a/gcc/ada/libgnat/a-coinve.ads +++ b/gcc/ada/libgnat/a-coinve.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Index_Type is range <>; @@ -61,7 +62,11 @@ is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty_Vector, + Add_Unnamed => Append_One, + New_Indexed => New_Vector, + Assign_Indexed => Replace_Element); pragma Preelaborable_Initialization (Vector); @@ -72,6 +77,8 @@ is No_Element : constant Cursor; + function Empty (Capacity : Count_Type := 10) return Vector; + function Has_Element (Position : Cursor) return Boolean; package Vector_Iterator_Interfaces is new @@ -79,6 +86,9 @@ is overriding function "=" (Left, Right : Vector) return Boolean; + function New_Vector (First, Last : Index_Type) return Vector + with Pre => First = Index_Type'First; + function To_Vector (Length : Count_Type) return Vector; function To_Vector @@ -238,6 +248,9 @@ is New_Item : Element_Type; Count : Count_Type := 1); + procedure Append_One (Container : in out Vector; + New_Item : Element_Type); + procedure Insert_Space (Container : in out Vector; Before : Extended_Index; @@ -383,7 +396,10 @@ private Elements : Elements_Access := null; Last : Extended_Index := No_Index; TC : aliased Tamper_Counts; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Vector); overriding procedure Adjust (Container : in out Vector); overriding procedure Finalize (Container : in out Vector); diff --git a/gcc/ada/libgnat/a-comutr.adb b/gcc/ada/libgnat/a-comutr.adb index 76ff751..78f93f0 100644 --- a/gcc/ada/libgnat/a-comutr.adb +++ b/gcc/ada/libgnat/a-comutr.adb @@ -31,6 +31,7 @@ with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Multiway_Trees with SPARK_Mode => Off @@ -1858,6 +1859,49 @@ is Process (Position.Node.Element); end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree) + is + use System.Put_Images; + + procedure Rec (Position : Cursor); + -- Recursive routine operating on cursors + + procedure Rec (Position : Cursor) is + First_Time : Boolean := True; + begin + Array_Before (S); + + for X in Iterate_Children (V, Position) loop + if First_Time then + First_Time := False; + else + Array_Between (S); + end if; + + Element_Type'Put_Image (S, Element (X)); + if Child_Count (X) > 0 then + Simple_Array_Between (S); + Rec (X); + end if; + end loop; + + Array_After (S); + end Rec; + + begin + if First_Child (Root (V)) = No_Element then + Array_Before (S); + Array_After (S); + else + Rec (First_Child (Root (V))); + end if; + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-comutr.ads b/gcc/ada/libgnat/a-comutr.ads index 46934a1..a1f51af 100644 --- a/gcc/ada/libgnat/a-comutr.ads +++ b/gcc/ada/libgnat/a-comutr.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; with Ada.Containers.Helpers; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Element_Type is private; @@ -400,7 +401,10 @@ private Root : aliased Root_Node_Type; TC : aliased Tamper_Counts; Count : Count_Type := 0; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Tree); overriding procedure Adjust (Container : in out Tree); diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb index c2a0a83..a43be97 100644 --- a/gcc/ada/libgnat/a-convec.adb +++ b/gcc/ada/libgnat/a-convec.adb @@ -210,6 +210,17 @@ is end if; end Append; + ---------------- + -- Append_One -- + ---------------- + + procedure Append_One (Container : in out Vector; + New_Item : Element_Type) + is + begin + Insert (Container, Last_Index (Container) + 1, New_Item, 1); + end Append_One; + ---------------------- -- Append_Slow_Path -- ---------------------- @@ -603,6 +614,17 @@ is return Position.Container.Elements.EA (Position.Index); end Element; + ----------- + -- Empty -- + ----------- + + function Empty (Capacity : Count_Type := 10) return Vector is + begin + return Result : Vector do + Reserve_Capacity (Result, Capacity); + end return; + end Empty; + -------------- -- Finalize -- -------------- @@ -742,6 +764,16 @@ is return Index_Type'First; end First_Index; + ----------------- + -- New_Vector -- + ----------------- + + function New_Vector (First, Last : Index_Type) return Vector + is + begin + return (To_Vector (Count_Type (Last - First + 1))); + end New_Vector; + --------------------- -- Generic_Sorting -- --------------------- diff --git a/gcc/ada/libgnat/a-convec.ads b/gcc/ada/libgnat/a-convec.ads index a12e456..f969e6f 100644 --- a/gcc/ada/libgnat/a-convec.ads +++ b/gcc/ada/libgnat/a-convec.ads @@ -93,7 +93,12 @@ is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Append_One, + New_Indexed => New_Vector, + Assign_Indexed => Replace_Element); + pragma Preelaborable_Initialization (Vector); -- Vector type, to be instantiated by users of this package. If an object -- of type Vector is not otherwise initialized, it is initialized to @@ -117,6 +122,8 @@ is Empty_Vector : constant Vector; -- Empty_Vector represents the empty vector object. It has a length of 0. + function Empty (Capacity : Count_Type := 10) return Vector; + overriding function "=" (Left, Right : Vector) return Boolean; -- If Left and Right denote the same vector object, then the function -- returns True. If Left and Right have different lengths, then the @@ -323,6 +330,10 @@ is -- Source is removed from Source and inserted into Target in the original -- order. The length of Source is 0 after a successful call to Move. + function New_Vector (First, Last : Index_Type) return Vector + with Pre => First = Index_Type'First; + -- Ada_2020 aggregate operation. + procedure Insert (Container : in out Vector; Before : Extended_Index; @@ -438,6 +449,10 @@ is -- Equivalent to Insert (Container, Last_Index (Container) + 1, New_Item, -- Count). + procedure Append_One (Container : in out Vector; + New_Item : Element_Type); + -- Ada_2020 aggregate operation. + procedure Insert_Space (Container : in out Vector; Before : Extended_Index; diff --git a/gcc/ada/libgnat/a-coorma.adb b/gcc/ada/libgnat/a-coorma.adb index 4106d58..15d08f5 100644 --- a/gcc/ada/libgnat/a-coorma.adb +++ b/gcc/ada/libgnat/a-coorma.adb @@ -38,6 +38,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Keys; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Ordered_Maps with SPARK_Mode => Off @@ -1214,6 +1215,36 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map) + is + First_Time : Boolean := True; + use System.Put_Images; + + procedure Put_Key_Value (Position : Cursor); + procedure Put_Key_Value (Position : Cursor) is + begin + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Key_Type'Put_Image (S, Key (Position)); + Put_Arrow (S); + Element_Type'Put_Image (S, Element (Position)); + end Put_Key_Value; + + begin + Array_Before (S); + Iterate (V, Put_Key_Value'Access); + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-coorma.ads b/gcc/ada/libgnat/a-coorma.ads index e2d5e1e..7f65a7f 100644 --- a/gcc/ada/libgnat/a-coorma.ads +++ b/gcc/ada/libgnat/a-coorma.ads @@ -36,6 +36,7 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Key_Type is private; @@ -57,12 +58,15 @@ is Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Named => Insert); type Cursor is private; pragma Preelaborable_Initialization (Cursor); Empty_Map : constant Map; + function Empty return Map; No_Element : constant Cursor; @@ -257,7 +261,10 @@ private type Map is new Ada.Finalization.Controlled with record Tree : Tree_Types.Tree_Type; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Map); overriding procedure Adjust (Container : in out Map); @@ -367,6 +374,7 @@ private -- Returns a pointer to the element designated by Position. Empty_Map : constant Map := (Controlled with others => <>); + function Empty return Map is (Empty_Map); No_Element : constant Cursor := Cursor'(null, null); diff --git a/gcc/ada/libgnat/a-coormu.adb b/gcc/ada/libgnat/a-coormu.adb index c02a9f1..c7db472 100644 --- a/gcc/ada/libgnat/a-coormu.adb +++ b/gcc/ada/libgnat/a-coormu.adb @@ -39,6 +39,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Ordered_Multisets with SPARK_Mode => Off @@ -1565,6 +1566,31 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-coormu.ads b/gcc/ada/libgnat/a-coormu.ads index 9c6c3ae..95aec73 100644 --- a/gcc/ada/libgnat/a-coormu.ads +++ b/gcc/ada/libgnat/a-coormu.ads @@ -34,6 +34,7 @@ private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; with Ada.Iterator_Interfaces; generic @@ -472,7 +473,10 @@ private type Set is new Ada.Finalization.Controlled with record Tree : Tree_Types.Tree_Type; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set); overriding procedure Adjust (Container : in out Set); diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb index 15b59dd..8a648e8 100644 --- a/gcc/ada/libgnat/a-coorse.adb +++ b/gcc/ada/libgnat/a-coorse.adb @@ -41,6 +41,7 @@ with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with System; use type System.Address; +with System.Put_Images; package body Ada.Containers.Ordered_Sets with SPARK_Mode => Off @@ -1580,6 +1581,31 @@ is end; end Query_Element; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set) + is + First_Time : Boolean := True; + use System.Put_Images; + begin + Array_Before (S); + + for X of V loop + if First_Time then + First_Time := False; + else + Simple_Array_Between (S); + end if; + + Element_Type'Put_Image (S, X); + end loop; + + Array_After (S); + end Put_Image; + ---------- -- Read -- ---------- diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads index 42e5b49..1ccf290 100644 --- a/gcc/ada/libgnat/a-coorse.ads +++ b/gcc/ada/libgnat/a-coorse.ads @@ -37,6 +37,7 @@ with Ada.Containers.Helpers; private with Ada.Containers.Red_Black_Trees; private with Ada.Finalization; private with Ada.Streams; +private with Ada.Strings.Text_Output; generic type Element_Type is private; @@ -57,6 +58,8 @@ is with Constant_Indexing => Constant_Reference, Default_Iterator => Iterate, Iterator_Element => Element_Type; + -- Aggregate => (Empty => Empty, + -- Add_Unnamed => Include); pragma Preelaborable_Initialization (Set); @@ -66,6 +69,7 @@ is function Has_Element (Position : Cursor) return Boolean; Empty_Set : constant Set; + function Empty return Set; No_Element : constant Cursor; @@ -340,7 +344,10 @@ private type Set is new Ada.Finalization.Controlled with record Tree : Tree_Types.Tree_Type; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set); overriding procedure Adjust (Container : in out Set); @@ -428,6 +435,7 @@ private -- Returns a pointer to the element designated by Position. Empty_Set : constant Set := (Controlled with others => <>); + function Empty return Set is (Empty_Set); No_Element : constant Cursor := Cursor'(null, null); diff --git a/gcc/ada/libgnat/a-crbltr.ads b/gcc/ada/libgnat/a-crbltr.ads index 0ae2abd..4f00bd6 100644 --- a/gcc/ada/libgnat/a-crbltr.ads +++ b/gcc/ada/libgnat/a-crbltr.ads @@ -60,9 +60,7 @@ package Ada.Containers.Red_Black_Trees is -- Note that objects of type Tree_Type are logically initialized (in the -- sense that representation invariants of type are satisfied by dint of -- default initialization), even without the Nodes component also having - -- its own initialization expression. We only initializae the Nodes - -- component here in order to prevent spurious compiler warnings about - -- the container object not being fully initialized. + -- its own initialization expression. type Tree_Type (Capacity : Count_Type) is tagged record First : Count_Type := 0; @@ -71,7 +69,7 @@ package Ada.Containers.Red_Black_Trees is Length : Count_Type := 0; TC : aliased Helpers.Tamper_Counts; Free : Count_Type'Base := -1; - Nodes : Nodes_Type (1 .. Capacity) := (others => <>); + Nodes : Nodes_Type (1 .. Capacity); end record; package Implementation is new Helpers.Generic_Implementation; diff --git a/gcc/ada/libgnat/a-crdlli.ads b/gcc/ada/libgnat/a-crdlli.ads index 7f27497..b30d353 100644 --- a/gcc/ada/libgnat/a-crdlli.ads +++ b/gcc/ada/libgnat/a-crdlli.ads @@ -314,7 +314,7 @@ private type Node_Array is array (Count_Type range <>) of Node_Type; type List (Capacity : Count_Type) is tagged limited record - Nodes : Node_Array (1 .. Capacity) := (others => <>); + Nodes : Node_Array (1 .. Capacity); Free : Count_Type'Base := -1; First : Count_Type := 0; Last : Count_Type := 0; diff --git a/gcc/ada/libgnat/a-direct.adb b/gcc/ada/libgnat/a-direct.adb index b70bf0e..162ace9 100644 --- a/gcc/ada/libgnat/a-direct.adb +++ b/gcc/ada/libgnat/a-direct.adb @@ -30,7 +30,6 @@ ------------------------------------------------------------------------------ with Ada.Calendar; use Ada.Calendar; -with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Directories.Validity; use Ada.Directories.Validity; with Ada.Directories.Hierarchical_File_Names; @@ -70,6 +69,15 @@ package body Ada.Directories is pragma Import (C, Max_Path, "__gnat_max_path_len"); -- The maximum length of a path + function C_Modification_Time (N : System.Address) return Ada.Calendar.Time; + pragma Import (C, C_Modification_Time, "__gnat_file_time"); + -- Get modification time for file with name referenced by N + + Invalid_Time : constant Ada.Calendar.Time := + C_Modification_Time (System.Null_Address); + -- Result returned from C_Modification_Time call when routine unable to get + -- file modification time. + type Search_Data is record Is_Valid : Boolean := False; Name : Unbounded_String; @@ -991,14 +999,9 @@ package body Ada.Directories is ----------------------- function Modification_Time (Name : String) return Time is - Date : OS_Time; - Year : Year_Type; - Month : Month_Type; - Day : Day_Type; - Hour : Hour_Type; - Minute : Minute_Type; - Second : Second_Type; + Date : Time; + C_Name : aliased String (1 .. Name'Length + 1); begin -- First, the invalid cases @@ -1006,19 +1009,15 @@ package body Ada.Directories is raise Name_Error with '"' & Name & """ not a file or directory"; else - Date := File_Time_Stamp (Name); - - -- Break down the time stamp into its constituents relative to GMT. - -- This version of Split does not recognize leap seconds or buffer - -- space for time zone processing. + C_Name := Name & ASCII.NUL; + Date := C_Modification_Time (C_Name'Address); - GM_Split (Date, Year, Month, Day, Hour, Minute, Second); - - -- The result must be in GMT. Ada.Calendar. - -- Formatting.Time_Of with default time zone of zero (0) is the - -- routine of choice. + if Date = Invalid_Time then + raise Use_Error with + "Unable to get modification time of the file """ & Name & '"'; + end if; - return Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0); + return Date; end if; end Modification_Time; diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb index 17f3db6..52e716f 100644 --- a/gcc/ada/libgnat/a-except.adb +++ b/gcc/ada/libgnat/a-except.adb @@ -32,10 +32,6 @@ pragma Style_Checks (All_Checks); -- No subprogram ordering check, due to logical grouping -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with System.Exception_Tables. - with System; use System; with System.Exceptions; use System.Exceptions; with System.Exceptions_Debug; use System.Exceptions_Debug; @@ -668,21 +664,6 @@ package body Ada.Exceptions is Rmsg_36 : constant String := "stream operation not allowed" & NUL; Rmsg_37 : constant String := "build-in-place mismatch" & NUL; - ----------------------- - -- Polling Interface -- - ----------------------- - - type Unsigned is mod 2 ** 32; - - Counter : Unsigned := 0; - pragma Warnings (Off, Counter); - -- This counter is provided for convenience. It can be used in Poll to - -- perform periodic but not systematic operations. - - procedure Poll is separate; - -- The actual polling routine is separate, so that it can easily be - -- replaced with a target dependent version. - -------------------------- -- Code_Address_For_AAA -- -------------------------- diff --git a/gcc/ada/libgnat/a-except.ads b/gcc/ada/libgnat/a-except.ads index 85bb5bd..4d36a84 100644 --- a/gcc/ada/libgnat/a-except.ads +++ b/gcc/ada/libgnat/a-except.ads @@ -36,10 +36,6 @@ -- This is the default version of this package. We also have cert and zfp -- versions. -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with ourself. - with System; with System.Parameters; with System.Standard_Library; @@ -240,31 +236,6 @@ private -- Determine whether the current exception (if it exists) is an instance of -- Standard'Abort_Signal. - ----------------------- - -- Polling Interface -- - ----------------------- - - -- The GNAT compiler has an option to generate polling calls to the Poll - -- routine in this package. Specifying the -gnatP option for a compilation - -- causes a call to Ada.Exceptions.Poll to be generated on every subprogram - -- entry and on every iteration of a loop, thus avoiding the possibility of - -- a case of unbounded time between calls. - - -- This polling interface may be used for instrumentation or debugging - -- purposes (e.g. implementing watchpoints in software or in the debugger). - - -- In the GNAT technology itself, this interface is used to implement - -- immediate asynchronous transfer of control and immediate abort on - -- targets which do not provide for one thread interrupting another. - - -- Note: this used to be in a separate unit called System.Poll, but that - -- caused horrible circular elaboration problems between System.Poll and - -- Ada.Exceptions. - - procedure Poll; - -- Check for asynchronous abort. Note that we do not inline the body. - -- This makes the interface more useful for debugging purposes. - -------------------------- -- Exception_Occurrence -- -------------------------- @@ -330,6 +301,8 @@ private pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); -- Functions for implementing Exception_Occurrence stream attributes + pragma Warnings (Off, "aggregate not fully initialized"); Null_Occurrence : constant Exception_Occurrence := (others => <>); + pragma Warnings (On, "aggregate not fully initialized"); end Ada.Exceptions; diff --git a/gcc/ada/libgnat/a-llltio.ads b/gcc/ada/libgnat/a-llltio.ads new file mode 100644 index 0000000..f107d43 --- /dev/null +++ b/gcc/ada/libgnat/a-llltio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ L O N G _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Long_Long_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Long_Long_Long_Integer); diff --git a/gcc/ada/libgnat/a-lllwti.ads b/gcc/ada/libgnat/a-lllwti.ads new file mode 100644 index 0000000..942fac0 --- /dev/null +++ b/gcc/ada/libgnat/a-lllwti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Long_Long_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Long_Long_Long_Integer); diff --git a/gcc/ada/libgnat/a-lllzti.ads b/gcc/ada/libgnat/a-lllzti.ads new file mode 100644 index 0000000..40be965 --- /dev/null +++ b/gcc/ada/libgnat/a-lllzti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Long_Long_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Long_Long_Integer); diff --git a/gcc/ada/libgnat/a-nagefl.ads b/gcc/ada/libgnat/a-nagefl.ads new file mode 100644 index 0000000..9260391 --- /dev/null +++ b/gcc/ada/libgnat/a-nagefl.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X _ G E N E R I C _ F L O A T -- +-- -- +-- S p e c -- +-- (Generic Wrapper) -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the basic computational interface for the generic +-- elementary functions. The C library version interfaces with the routines +-- in the C mathematical library. + +-- This version here is for use with normal Unix math functions. + +with Ada.Numerics.Aux_Long_Long_Float; +with Ada.Numerics.Aux_Long_Float; +with Ada.Numerics.Aux_Float; +with Ada.Numerics.Aux_Short_Float; + +generic + type T is digits <>; +package Ada.Numerics.Aux_Generic_Float is + pragma Pure; + + package LLF renames Aux_Long_Long_Float; + package LF renames Aux_Long_Float; + package F renames Aux_Float; + package SF renames Aux_Short_Float; + + function Sin (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Sin (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Sin (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Sin (F.T (X))) + else T'Base (SF.Sin (SF.T (X)))); + + function Cos (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Cos (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Cos (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Cos (F.T (X))) + else T'Base (SF.Cos (SF.T (X)))); + + function Tan (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Tan (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Tan (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Tan (F.T (X))) + else T'Base (SF.Tan (SF.T (X)))); + + function Exp (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Exp (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Exp (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Exp (F.T (X))) + else T'Base (SF.Exp (SF.T (X)))); + + function Sqrt (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Sqrt (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Sqrt (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Sqrt (F.T (X))) + else T'Base (SF.Sqrt (SF.T (X)))); + + function Log (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Log (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Log (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Log (F.T (X))) + else T'Base (SF.Log (SF.T (X)))); + + function Acos (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Acos (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Acos (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Acos (F.T (X))) + else T'Base (SF.Acos (SF.T (X)))); + + function Asin (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Asin (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Asin (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Asin (F.T (X))) + else T'Base (SF.Asin (SF.T (X)))); + + function Atan (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Atan (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Atan (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Atan (F.T (X))) + else T'Base (SF.Atan (SF.T (X)))); + + function Sinh (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Sinh (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Sinh (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Sinh (F.T (X))) + else T'Base (SF.Sinh (SF.T (X)))); + + function Cosh (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Cosh (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Cosh (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Cosh (F.T (X))) + else T'Base (SF.Cosh (SF.T (X)))); + + function Tanh (X : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Tanh (LLF.T (X))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Tanh (LF.T (X))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Tanh (F.T (X))) + else T'Base (SF.Tanh (SF.T (X)))); + + function Pow (X, Y : T'Base) return T'Base + is (if T'Base'Digits > LF.T'Digits + then T'Base (LLF.Pow (LLF.T (X), LLF.T (Y))) + elsif T'Base'Digits > F.T'Digits + then T'Base (LF.Pow (LF.T (X), LF.T (Y))) + elsif T'Base'Digits > SF.T'Digits + then T'Base (F.Pow (F.T (X), F.T (Y))) + else T'Base (SF.Pow (SF.T (X), SF.T (Y)))); + +end Ada.Numerics.Aux_Generic_Float; diff --git a/gcc/ada/libgnat/a-naliop.ads b/gcc/ada/libgnat/a-naliop.ads new file mode 100644 index 0000000..81de811 --- /dev/null +++ b/gcc/ada/libgnat/a-naliop.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X _ L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is used to provide target specific linker_options for +-- the support of C Library Math functions as required by other +-- children packages of Ada.Numerics.Aux. + +-- This is a version for default use that links with -lm. An +-- alternate __nolibm version is to be used where no additional +-- libraries are required. + +-- This package should not be directly with'ed by an application program + +package Ada.Numerics.Aux_Linker_Options is + pragma Pure; + pragma Linker_Options ("-lm"); +end Ada.Numerics.Aux_Linker_Options; diff --git a/gcc/ada/libgnat/a-naliop__nolibm.ads b/gcc/ada/libgnat/a-naliop__nolibm.ads new file mode 100644 index 0000000..dc1969a --- /dev/null +++ b/gcc/ada/libgnat/a-naliop__nolibm.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X _ L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is used to provide target specific linker_options for +-- the support of C Library Math functions as required by other +-- children packages of Ada.Numerics.Aux. + +-- This is a version to be used where no additional libraries are +-- required. + +-- This package should not be directly with'ed by an application program + +package Ada.Numerics.Aux_Linker_Options is + pragma Pure; +end Ada.Numerics.Aux_Linker_Options; diff --git a/gcc/ada/libgnat/a-numaux__darwin.ads b/gcc/ada/libgnat/a-nallfl.ads index f2a4428..ca998fa 100644 --- a/gcc/ada/libgnat/a-numaux__darwin.ads +++ b/gcc/ada/libgnat/a-nallfl.ads @@ -2,10 +2,10 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . N U M E R I C S . A U X -- +-- A D A . N U M E R I C S . A U X . L O N G _ L O N G _ F L O A T -- -- -- -- S p e c -- --- (Apple OS X Version) -- +-- (C Math Library Version, Long Long Float) -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- @@ -30,74 +30,58 @@ -- -- ------------------------------------------------------------------------------ --- This version is for use on OS X. It uses the normal Unix math functions, --- except for sine/cosine which have been implemented directly in Ada to get --- the required accuracy. +-- This package provides the basic computational interface for the generic +-- elementary functions. The C library version interfaces with the routines +-- in the C mathematical library, and is thus quite portable. -package Ada.Numerics.Aux is - pragma Pure; - - pragma Linker_Options ("-lm"); - - type Double is new Long_Float; - -- Type Double is the type used to call the C routines +with Ada.Numerics.Aux_Linker_Options; +pragma Warnings (Off, Ada.Numerics.Aux_Linker_Options); - -- The following functions have been implemented in Ada, since - -- the OS X math library didn't meet accuracy requirements for - -- argument reduction. The implementation here has been tailored - -- to match Ada strict mode Numerics requirements while maintaining - -- maximum efficiency. - function Sin (X : Double) return Double; - pragma Inline (Sin); +package Ada.Numerics.Aux_Long_Long_Float is + pragma Pure; - function Cos (X : Double) return Double; - pragma Inline (Cos); + subtype T is Long_Long_Float; -- We import these functions directly from C. Note that we label them -- all as pure functions, because indeed all of them are in fact pure. - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); - pragma Pure_Function (Tan); + function Sin (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sinl"; + + function Cos (X : T) return T with + Import, Convention => Intrinsic, External_Name => "cosl"; + + function Tan (X : T) return T with + Import, Convention => Intrinsic, External_Name => "tanl"; - function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); - pragma Pure_Function (Exp); + function Exp (X : T) return T with + Import, Convention => Intrinsic, External_Name => "expl"; - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); - pragma Pure_Function (Sqrt); + function Sqrt (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sqrtl"; - function Log (X : Double) return Double; - pragma Import (C, Log, "log"); - pragma Pure_Function (Log); + function Log (X : T) return T with + Import, Convention => Intrinsic, External_Name => "logl"; - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); - pragma Pure_Function (Acos); + function Acos (X : T) return T with + Import, Convention => Intrinsic, External_Name => "acosl"; - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); - pragma Pure_Function (Asin); + function Asin (X : T) return T with + Import, Convention => Intrinsic, External_Name => "asinl"; - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); - pragma Pure_Function (Atan); + function Atan (X : T) return T with + Import, Convention => Intrinsic, External_Name => "atanl"; - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); - pragma Pure_Function (Sinh); + function Sinh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sinhl"; - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); - pragma Pure_Function (Cosh); + function Cosh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "coshl"; - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); - pragma Pure_Function (Tanh); + function Tanh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "tanhl"; - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); - pragma Pure_Function (Pow); + function Pow (X, Y : T) return T with + Import, Convention => Intrinsic, External_Name => "powl"; -end Ada.Numerics.Aux; +end Ada.Numerics.Aux_Long_Long_Float; diff --git a/gcc/ada/libgnat/a-wtmoau.ads b/gcc/ada/libgnat/a-nallfl__wraplf.ads index 9fe444e..2d5c71d 100644 --- a/gcc/ada/libgnat/a-wtmoau.ads +++ b/gcc/ada/libgnat/a-nallfl__wraplf.ads @@ -2,9 +2,10 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X -- +-- A D A . N U M E R I C S . A U X . L O N G _ L O N G _ F L O A T -- -- -- -- S p e c -- +-- (Long Long Float Wrapper in terms of Long Float) -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- @@ -29,59 +30,58 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines for Ada.Wide_Text_IO.Modular_IO that --- are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Modular_IO itself, --- except that the generic parameter Num has been replaced by Unsigned or --- Long_Long_Unsigned, and the default parameters have been removed because --- they are supplied explicitly by the calls from within the generic template. - -with System.Unsigned_Types; - -private package Ada.Wide_Text_IO.Modular_Aux is - - package U renames System.Unsigned_Types; - - procedure Get_Uns - (File : File_Type; - Item : out U.Unsigned; - Width : Field); - - procedure Get_LLU - (File : File_Type; - Item : out U.Long_Long_Unsigned; - Width : Field); - - procedure Gets_Uns - (From : String; - Item : out U.Unsigned; - Last : out Positive); - - procedure Gets_LLU - (From : String; - Item : out U.Long_Long_Unsigned; - Last : out Positive); - - procedure Put_Uns - (File : File_Type; - Item : U.Unsigned; - Width : Field; - Base : Number_Base); - - procedure Put_LLU - (File : File_Type; - Item : U.Long_Long_Unsigned; - Width : Field; - Base : Number_Base); - - procedure Puts_Uns - (To : out String; - Item : U.Unsigned; - Base : Number_Base); - - procedure Puts_LLU - (To : out String; - Item : U.Long_Long_Unsigned; - Base : Number_Base); - -end Ada.Wide_Text_IO.Modular_Aux; +-- This package provides the basic computational interface for the +-- generic elementary functions. The functions in this unit are +-- wrappers for those in the Long Float package. + +with Ada.Numerics.Aux_Long_Float; + +package Ada.Numerics.Aux_Long_Long_Float is + pragma Pure; + + subtype T is Long_Long_Float; + package Aux renames Ada.Numerics.Aux_Long_Float; + subtype W is Aux.T; + + -- Use the Aux implementation. + + function Sin (X : T) return T + is (T (Aux.Sin (W (X)))); + + function Cos (X : T) return T + is (T (Aux.Cos (W (X)))); + + function Tan (X : T) return T + is (T (Aux.Tan (W (X)))); + + function Exp (X : T) return T + is (T (Aux.Exp (W (X)))); + + function Sqrt (X : T) return T + is (T (Aux.Sqrt (W (X)))); + + function Log (X : T) return T + is (T (Aux.Log (W (X)))); + + function Acos (X : T) return T + is (T (Aux.Acos (W (X)))); + + function Asin (X : T) return T + is (T (Aux.Asin (W (X)))); + + function Atan (X : T) return T + is (T (Aux.Atan (W (X)))); + + function Sinh (X : T) return T + is (T (Aux.Sinh (W (X)))); + + function Cosh (X : T) return T + is (T (Aux.Cosh (W (X)))); + + function Tanh (X : T) return T + is (T (Aux.Tanh (W (X)))); + + function Pow (X, Y : T) return T + is (T (Aux.Pow (W (X), W (Y)))); + +end Ada.Numerics.Aux_Long_Long_Float; diff --git a/gcc/ada/libgnat/a-numaux__vxworks.ads b/gcc/ada/libgnat/a-nalofl.ads index c291334..4cdf2f4 100644 --- a/gcc/ada/libgnat/a-numaux__vxworks.ads +++ b/gcc/ada/libgnat/a-nalofl.ads @@ -2,10 +2,10 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . N U M E R I C S . A U X -- +-- A D A . N U M E R I C S . A U X _ L O N G _ F L O A T -- -- -- -- S p e c -- --- (C Library Version, VxWorks) -- +-- (C Math Library Version, Long Float) -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- @@ -30,68 +30,58 @@ -- -- ------------------------------------------------------------------------------ --- Version for use on VxWorks (where we have no libm.a library), so the pragma --- Linker_Options ("-lm") is omitted in this version. +-- This package provides the basic computational interface for the generic +-- elementary functions. The C library version interfaces with the routines +-- in the C mathematical library, and is thus quite portable. -package Ada.Numerics.Aux is +with Ada.Numerics.Aux_Linker_Options; +pragma Warnings (Off, Ada.Numerics.Aux_Linker_Options); + +package Ada.Numerics.Aux_Long_Float is pragma Pure; - type Double is new Long_Float; - -- Type Double is the type used to call the C routines + subtype T is Long_Float; -- We import these functions directly from C. Note that we label them -- all as pure functions, because indeed all of them are in fact pure. - function Sin (X : Double) return Double; - pragma Import (C, Sin, "sin"); - pragma Pure_Function (Sin); + function Sin (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sin"; - function Cos (X : Double) return Double; - pragma Import (C, Cos, "cos"); - pragma Pure_Function (Cos); + function Cos (X : T) return T with + Import, Convention => Intrinsic, External_Name => "cos"; - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); - pragma Pure_Function (Tan); + function Tan (X : T) return T with + Import, Convention => Intrinsic, External_Name => "tan"; - function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); - pragma Pure_Function (Exp); + function Exp (X : T) return T with + Import, Convention => Intrinsic, External_Name => "exp"; - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); - pragma Pure_Function (Sqrt); + function Sqrt (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sqrt"; - function Log (X : Double) return Double; - pragma Import (C, Log, "log"); - pragma Pure_Function (Log); + function Log (X : T) return T with + Import, Convention => Intrinsic, External_Name => "log"; - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); - pragma Pure_Function (Acos); + function Acos (X : T) return T with + Import, Convention => Intrinsic, External_Name => "acos"; - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); - pragma Pure_Function (Asin); + function Asin (X : T) return T with + Import, Convention => Intrinsic, External_Name => "asin"; - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); - pragma Pure_Function (Atan); + function Atan (X : T) return T with + Import, Convention => Intrinsic, External_Name => "atan"; - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); - pragma Pure_Function (Sinh); + function Sinh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sinh"; - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); - pragma Pure_Function (Cosh); + function Cosh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "cosh"; - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); - pragma Pure_Function (Tanh); + function Tanh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "tanh"; - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); - pragma Pure_Function (Pow); + function Pow (X, Y : T) return T with + Import, Convention => Intrinsic, External_Name => "pow"; -end Ada.Numerics.Aux; +end Ada.Numerics.Aux_Long_Float; diff --git a/gcc/ada/libgnat/a-ztmoau.ads b/gcc/ada/libgnat/a-nashfl.ads index 9d53154..eaee862 100644 --- a/gcc/ada/libgnat/a-ztmoau.ads +++ b/gcc/ada/libgnat/a-nashfl.ads @@ -2,9 +2,10 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X -- +-- A D A . N U M E R I C S . A U X _ S H O R T _ F L O A T -- -- -- -- S p e c -- +-- (Short Float Wrapper in terms of Float) -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- @@ -29,60 +30,58 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines for Ada.Wide_Wide_Text_IO.Modular_IO --- that are shared among separate instantiations of this package. The --- routines in this package are identical semantically to those in Modular_IO --- itself, except that the generic parameter Num has been replaced by --- Unsigned or Long_Long_Unsigned, and the default parameters have been --- removed because they are supplied explicitly by the calls from within the --- generic template. - -with System.Unsigned_Types; - -private package Ada.Wide_Wide_Text_IO.Modular_Aux is - - package U renames System.Unsigned_Types; - - procedure Get_Uns - (File : File_Type; - Item : out U.Unsigned; - Width : Field); - - procedure Get_LLU - (File : File_Type; - Item : out U.Long_Long_Unsigned; - Width : Field); - - procedure Gets_Uns - (From : String; - Item : out U.Unsigned; - Last : out Positive); - - procedure Gets_LLU - (From : String; - Item : out U.Long_Long_Unsigned; - Last : out Positive); - - procedure Put_Uns - (File : File_Type; - Item : U.Unsigned; - Width : Field; - Base : Number_Base); - - procedure Put_LLU - (File : File_Type; - Item : U.Long_Long_Unsigned; - Width : Field; - Base : Number_Base); - - procedure Puts_Uns - (To : out String; - Item : U.Unsigned; - Base : Number_Base); - - procedure Puts_LLU - (To : out String; - Item : U.Long_Long_Unsigned; - Base : Number_Base); - -end Ada.Wide_Wide_Text_IO.Modular_Aux; +-- This package provides the basic computational interface for the +-- generic elementary functions. The functions in this unit are +-- wrappers for those in the Float package. + +with Ada.Numerics.Aux_Float; + +package Ada.Numerics.Aux_Short_Float is + pragma Pure; + + subtype T is Short_Float; + package Aux renames Ada.Numerics.Aux_Float; + subtype W is Aux.T; + + -- Use the Aux implementation. + + function Sin (X : T) return T + is (T (Aux.Sin (W (X)))); + + function Cos (X : T) return T + is (T (Aux.Cos (W (X)))); + + function Tan (X : T) return T + is (T (Aux.Tan (W (X)))); + + function Exp (X : T) return T + is (T (Aux.Exp (W (X)))); + + function Sqrt (X : T) return T + is (T (Aux.Sqrt (W (X)))); + + function Log (X : T) return T + is (T (Aux.Log (W (X)))); + + function Acos (X : T) return T + is (T (Aux.Acos (W (X)))); + + function Asin (X : T) return T + is (T (Aux.Asin (W (X)))); + + function Atan (X : T) return T + is (T (Aux.Atan (W (X)))); + + function Sinh (X : T) return T + is (T (Aux.Sinh (W (X)))); + + function Cosh (X : T) return T + is (T (Aux.Cosh (W (X)))); + + function Tanh (X : T) return T + is (T (Aux.Tanh (W (X)))); + + function Pow (X, Y : T) return T + is (T (Aux.Pow (W (X), W (Y)))); + +end Ada.Numerics.Aux_Short_Float; diff --git a/gcc/ada/libgnat/a-nashfl__wraplf.ads b/gcc/ada/libgnat/a-nashfl__wraplf.ads new file mode 100644 index 0000000..ca5b48d --- /dev/null +++ b/gcc/ada/libgnat/a-nashfl__wraplf.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X _ S H O R T _ F L O A T -- +-- -- +-- S p e c -- +-- (Short Float Wrapper in terms of Long Float) -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the basic computational interface for the +-- generic elementary functions. The functions in this unit are +-- wrappers for those in the Long Float package. + +with Ada.Numerics.Aux_Long_Float; + +package Ada.Numerics.Aux_Short_Float is + pragma Pure; + + subtype T is Short_Float; + package Aux renames Ada.Numerics.Aux_Long_Float; + subtype W is Aux.T; + + -- Use the Aux implementation. + + function Sin (X : T) return T + is (T (Aux.Sin (W (X)))); + + function Cos (X : T) return T + is (T (Aux.Cos (W (X)))); + + function Tan (X : T) return T + is (T (Aux.Tan (W (X)))); + + function Exp (X : T) return T + is (T (Aux.Exp (W (X)))); + + function Sqrt (X : T) return T + is (T (Aux.Sqrt (W (X)))); + + function Log (X : T) return T + is (T (Aux.Log (W (X)))); + + function Acos (X : T) return T + is (T (Aux.Acos (W (X)))); + + function Asin (X : T) return T + is (T (Aux.Asin (W (X)))); + + function Atan (X : T) return T + is (T (Aux.Atan (W (X)))); + + function Sinh (X : T) return T + is (T (Aux.Sinh (W (X)))); + + function Cosh (X : T) return T + is (T (Aux.Cosh (W (X)))); + + function Tanh (X : T) return T + is (T (Aux.Tanh (W (X)))); + + function Pow (X, Y : T) return T + is (T (Aux.Pow (W (X), W (Y)))); + +end Ada.Numerics.Aux_Short_Float; diff --git a/gcc/ada/libgnat/a-nbnbin.adb b/gcc/ada/libgnat/a-nbnbin.adb index b919d86..70df2c2 100644 --- a/gcc/ada/libgnat/a-nbnbin.adb +++ b/gcc/ada/libgnat/a-nbnbin.adb @@ -238,8 +238,8 @@ package body Ada.Numerics.Big_Numbers.Big_Integers is function From_String (Arg : String) return Big_Integer is Result : Big_Integer; begin - -- ??? only support Long_Long_Integer, good enough for now - Set_Bignum (Result, To_Bignum (Long_Long_Integer'Value (Arg))); + -- ??? only support Long_Long_Long_Integer, good enough for now + Set_Bignum (Result, To_Bignum (Long_Long_Long_Integer'Value (Arg))); return Result; end From_String; diff --git a/gcc/ada/libgnat/a-ngcefu.adb b/gcc/ada/libgnat/a-ngcefu.adb index 46af6f8..d47a14f 100644 --- a/gcc/ada/libgnat/a-ngcefu.adb +++ b/gcc/ada/libgnat/a-ngcefu.adb @@ -481,11 +481,12 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is --------- function Exp (X : Complex) return Complex is + ImX : constant Real'Base := Im (X); EXP_RE_X : constant Real'Base := Exp (Re (X)); begin - return Compose_From_Cartesian (EXP_RE_X * Cos (Im (X)), - EXP_RE_X * Sin (Im (X))); + return Compose_From_Cartesian (EXP_RE_X * Cos (ImX), + EXP_RE_X * Sin (ImX)); end Exp; function Exp (X : Imaginary) return Complex is diff --git a/gcc/ada/libgnat/a-ngcoty.adb b/gcc/ada/libgnat/a-ngcoty.adb index 6785ccf..b369dfc 100644 --- a/gcc/ada/libgnat/a-ngcoty.adb +++ b/gcc/ada/libgnat/a-ngcoty.adb @@ -29,10 +29,12 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Aux; use Ada.Numerics.Aux; +with Ada.Numerics.Aux_Generic_Float; package body Ada.Numerics.Generic_Complex_Types is + package Aux is new Ada.Numerics.Aux_Generic_Float (Real); + subtype R is Real'Base; Two_Pi : constant R := R (2.0) * Pi; @@ -440,7 +442,7 @@ package body Ada.Numerics.Generic_Complex_Types is end if; else - arg := R (Atan (Double (abs (b / a)))); + arg := Aux.Atan (abs (b / a)); if a > 0.0 then if b > 0.0 then @@ -507,8 +509,8 @@ package body Ada.Numerics.Generic_Complex_Types is if Modulus = 0.0 then return (0.0, 0.0); else - return (Modulus * R (Cos (Double (Argument))), - Modulus * R (Sin (Double (Argument)))); + return (Modulus * Aux.Cos (Argument), + Modulus * Aux.Sin (Argument)); end if; end Compose_From_Polar; @@ -536,8 +538,8 @@ package body Ada.Numerics.Generic_Complex_Types is return (0.0, -Modulus); else Arg := Two_Pi * Argument / Cycle; - return (Modulus * R (Cos (Double (Arg))), - Modulus * R (Sin (Double (Arg)))); + return (Modulus * Aux.Cos (Arg), + Modulus * Aux.Sin (Arg)); end if; else raise Argument_Error; @@ -597,8 +599,8 @@ package body Ada.Numerics.Generic_Complex_Types is exception when Constraint_Error => pragma Assert (X.Re /= 0.0); - return R (Double (abs (X.Re)) - * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2)); + return R (abs (X.Re)) + * Aux.Sqrt (1.0 + (R (X.Im) / R (X.Re)) ** 2); end; begin @@ -612,8 +614,8 @@ package body Ada.Numerics.Generic_Complex_Types is exception when Constraint_Error => pragma Assert (X.Im /= 0.0); - return R (Double (abs (X.Im)) - * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2)); + return R (abs (X.Im)) + * Aux.Sqrt (1.0 + (R (X.Re) / R (X.Im)) ** 2); end; -- Now deal with cases of underflow. If only one of the squares @@ -632,13 +634,11 @@ package body Ada.Numerics.Generic_Complex_Types is else if abs (X.Re) > abs (X.Im) then - return - R (Double (abs (X.Re)) - * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2)); + return R (abs (X.Re)) + * Aux.Sqrt (1.0 + (R (X.Im) / R (X.Re)) ** 2); else - return - R (Double (abs (X.Im)) - * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2)); + return R (abs (X.Im)) + * Aux.Sqrt (1.0 + (R (X.Re) / R (X.Im)) ** 2); end if; end if; @@ -652,7 +652,7 @@ package body Ada.Numerics.Generic_Complex_Types is -- In all other cases, the naive computation will do else - return R (Sqrt (Double (Re2 + Im2))); + return Aux.Sqrt (Re2 + Im2); end if; end Modulus; diff --git a/gcc/ada/libgnat/a-ngelfu.adb b/gcc/ada/libgnat/a-ngelfu.adb index 7e7c662..3f7c3d1 100644 --- a/gcc/ada/libgnat/a-ngelfu.adb +++ b/gcc/ada/libgnat/a-ngelfu.adb @@ -36,13 +36,13 @@ -- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan, sinh, -- cosh, tanh from C library via math.h -with Ada.Numerics.Aux; +with Ada.Numerics.Aux_Generic_Float; package body Ada.Numerics.Generic_Elementary_Functions with SPARK_Mode => Off is - use type Ada.Numerics.Aux.Double; + package Aux is new Ada.Numerics.Aux_Generic_Float (Float_Type); Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696; Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; @@ -50,7 +50,6 @@ is Half_Log_Two : constant := Log_Two / 2; subtype T is Float_Type'Base; - subtype Double is Aux.Double; Two_Pi : constant T := 2.0 * Pi; Half_Pi : constant T := Pi / 2.0; @@ -150,8 +149,7 @@ is Rest := Rest - 0.25; end if; - Result := Result * - Float_Type'Base (Aux.Pow (Double (Left), Double (Rest))); + Result := Result * Aux.Pow (Left, Rest); if Right >= 0.0 then return Result; @@ -159,8 +157,7 @@ is return (1.0 / Result); end if; else - return - Float_Type'Base (Aux.Pow (Double (Left), Double (Right))); + return Aux.Pow (Left, Right); end if; end if; @@ -194,7 +191,7 @@ is return Pi; end if; - Temp := Float_Type'Base (Aux.Acos (Double (X))); + Temp := Aux.Acos (X); if Temp < 0.0 then Temp := Pi + Temp; @@ -332,7 +329,7 @@ is return -(Pi / 2.0); end if; - return Float_Type'Base (Aux.Asin (Double (X))); + return Aux.Asin (X); end Arcsin; -- Arbitrary cycle @@ -515,7 +512,7 @@ is return 1.0; end if; - return Float_Type'Base (Aux.Cos (Double (X))); + return Aux.Cos (X); end Cos; -- Arbitrary cycle @@ -568,7 +565,7 @@ is return 1.0 / X; end if; - return 1.0 / Float_Type'Base (Aux.Tan (Double (X))); + return 1.0 / Aux.Tan (X); end Cot; -- Arbitrary cycle @@ -617,7 +614,7 @@ is return 1.0 / X; end if; - return 1.0 / Float_Type'Base (Aux.Tanh (Double (X))); + return 1.0 / Aux.Tanh (X); end Coth; --------- @@ -632,7 +629,7 @@ is return 1.0; end if; - Result := Float_Type'Base (Aux.Exp (Double (X))); + Result := Aux.Exp (X); -- Deal with case of Exp returning IEEE infinity. If Machine_Overflows -- is False, then we can just leave it as an infinity (and indeed we @@ -716,7 +713,7 @@ is Raw_Atan := (if Z < Sqrt_Epsilon then Z elsif Z = 1.0 then Pi / 4.0 - else Float_Type'Base (Aux.Atan (Double (Z)))); + else Aux.Atan (Z)); if abs Y > abs X then Raw_Atan := Half_Pi - Raw_Atan; @@ -747,7 +744,7 @@ is return 0.0; end if; - return Float_Type'Base (Aux.Log (Double (X))); + return Aux.Log (X); end Log; -- Arbitrary base @@ -767,7 +764,7 @@ is return 0.0; end if; - return Float_Type'Base (Aux.Log (Double (X)) / Aux.Log (Double (Base))); + return Aux.Log (X) / Aux.Log (Base); end Log; --------- @@ -782,7 +779,7 @@ is return X; end if; - return Float_Type'Base (Aux.Sin (Double (X))); + return Aux.Sin (X); end Sin; -- Arbitrary cycle @@ -816,7 +813,7 @@ is -- Could test for 12.0 * abs T = Cycle, and return an exact value in -- those cases. It is not clear this is worth the extra test though. - return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi))); + return Aux.Sin (T / Cycle * Two_Pi); end Sin; ---------- @@ -899,7 +896,7 @@ is return X; end if; - return Float_Type'Base (Aux.Sqrt (Double (X))); + return Aux.Sqrt (X); end Sqrt; --------- @@ -919,7 +916,7 @@ is -- with, it is impossible for X to be exactly pi/2, and the result is -- always in range. - return Float_Type'Base (Aux.Tan (Double (X))); + return Aux.Tan (X); end Tan; -- Arbitrary cycle @@ -992,7 +989,7 @@ is return X + X * R; else - return Float_Type'Base (Aux.Tanh (Double (X))); + return Aux.Tanh (X); end if; end Tanh; diff --git a/gcc/ada/libgnat/a-ngelfu.ads b/gcc/ada/libgnat/a-ngelfu.ads index 1a8e176..70f9b7a 100644 --- a/gcc/ada/libgnat/a-ngelfu.ads +++ b/gcc/ada/libgnat/a-ngelfu.ads @@ -92,6 +92,7 @@ is and then (if Left = 0.0 then "**"'Result = 0.0); function Sin (X : Float_Type'Base) return Float_Type'Base with + Inline, Post => Sin'Result in -1.0 .. 1.0 and then (if X = 0.0 then Sin'Result = 0.0); @@ -101,6 +102,7 @@ is and then (if X = 0.0 then Sin'Result = 0.0); function Cos (X : Float_Type'Base) return Float_Type'Base with + Inline, Post => Cos'Result in -1.0 .. 1.0 and then (if X = 0.0 then Cos'Result = 1.0); diff --git a/gcc/ada/libgnat/a-nuauco.ads b/gcc/ada/libgnat/a-nuauco.ads new file mode 100644 index 0000000..7fd49a8 --- /dev/null +++ b/gcc/ada/libgnat/a-nuauco.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X _ C O M P A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is used to provide the default type for the +-- backward-compatibility Ada.Numerics.Aux interface. This is +-- Long_Float for most platforms, but there is an alternate version +-- for x86 and x86_64 that uses the Long_Long_Float type. + +-- This package should not be directly with'ed by an application program + +with Ada.Numerics.Aux_Long_Float; +package Ada.Numerics.Aux_Compat renames Ada.Numerics.Aux_Long_Float; diff --git a/gcc/ada/libgnat/a-nuauco__x86.ads b/gcc/ada/libgnat/a-nuauco__x86.ads new file mode 100644 index 0000000..f1fbb31 --- /dev/null +++ b/gcc/ada/libgnat/a-nuauco__x86.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X . C O M P A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is used to provide the default type for the +-- backward-compatibility Ada.Numerics.Aux interface. This is a +-- version for x86 and x86_64, that uses the Long_Long_Float type. + +-- This package should not be directly with'ed by an application program + +with Ada.Numerics.Aux_Long_Long_Float; +package Ada.Numerics.Aux_Compat renames Ada.Numerics.Aux_Long_Long_Float; diff --git a/gcc/ada/libgnat/a-numaux__libc-x86.ads b/gcc/ada/libgnat/a-nuaufl.ads index c4647fd..16a34ae 100644 --- a/gcc/ada/libgnat/a-numaux__libc-x86.ads +++ b/gcc/ada/libgnat/a-nuaufl.ads @@ -2,10 +2,10 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . N U M E R I C S . A U X -- +-- A D A . N U M E R I C S . A U X _ F L O A T -- -- -- -- S p e c -- --- (C Library Version for x86) -- +-- (C Math Library Version, Float) -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- @@ -30,68 +30,58 @@ -- -- ------------------------------------------------------------------------------ --- This version is for the x86 using the 80-bit x86 long double format +-- This package provides the basic computational interface for the generic +-- elementary functions. The C library version interfaces with the routines +-- in the C mathematical library, and is thus quite portable. -package Ada.Numerics.Aux is - pragma Pure; +with Ada.Numerics.Aux_Linker_Options; +pragma Warnings (Off, Ada.Numerics.Aux_Linker_Options); - pragma Linker_Options ("-lm"); +package Ada.Numerics.Aux_Float is + pragma Pure; - type Double is new Long_Long_Float; + subtype T is Float; -- We import these functions directly from C. Note that we label them -- all as pure functions, because indeed all of them are in fact pure. - function Sin (X : Double) return Double; - pragma Import (C, Sin, "sinl"); - pragma Pure_Function (Sin); + function Sin (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sinf"; - function Cos (X : Double) return Double; - pragma Import (C, Cos, "cosl"); - pragma Pure_Function (Cos); + function Cos (X : T) return T with + Import, Convention => Intrinsic, External_Name => "cosf"; - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tanl"); - pragma Pure_Function (Tan); + function Tan (X : T) return T with + Import, Convention => Intrinsic, External_Name => "tanf"; - function Exp (X : Double) return Double; - pragma Import (C, Exp, "expl"); - pragma Pure_Function (Exp); + function Exp (X : T) return T with + Import, Convention => Intrinsic, External_Name => "expf"; - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrtl"); - pragma Pure_Function (Sqrt); + function Sqrt (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sqrtf"; - function Log (X : Double) return Double; - pragma Import (C, Log, "logl"); - pragma Pure_Function (Log); + function Log (X : T) return T with + Import, Convention => Intrinsic, External_Name => "logf"; - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acosl"); - pragma Pure_Function (Acos); + function Acos (X : T) return T with + Import, Convention => Intrinsic, External_Name => "acosf"; - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asinl"); - pragma Pure_Function (Asin); + function Asin (X : T) return T with + Import, Convention => Intrinsic, External_Name => "asinf"; - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atanl"); - pragma Pure_Function (Atan); + function Atan (X : T) return T with + Import, Convention => Intrinsic, External_Name => "atanf"; - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinhl"); - pragma Pure_Function (Sinh); + function Sinh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sinhf"; - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "coshl"); - pragma Pure_Function (Cosh); + function Cosh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "coshf"; - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanhl"); - pragma Pure_Function (Tanh); + function Tanh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "tanhf"; - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "powl"); - pragma Pure_Function (Pow); + function Pow (X, Y : T) return T with + Import, Convention => Intrinsic, External_Name => "powf"; -end Ada.Numerics.Aux; +end Ada.Numerics.Aux_Float; diff --git a/gcc/ada/libgnat/a-nuaufl__wraplf.ads b/gcc/ada/libgnat/a-nuaufl__wraplf.ads new file mode 100644 index 0000000..b6eb22c --- /dev/null +++ b/gcc/ada/libgnat/a-nuaufl__wraplf.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X _ F L O A T -- +-- -- +-- S p e c -- +-- (Double-based Version, Float) -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the basic computational interface for the +-- generic elementary functions. The functions in this unit are +-- wrappers for those in the Long_Float package. + +with Ada.Numerics.Aux_Long_Float; + +package Ada.Numerics.Aux_Float is + pragma Pure; + + subtype T is Float; + package Aux renames Ada.Numerics.Aux_Long_Float; + subtype W is Aux.T; + + -- Use the Aux implementation. + + function Sin (X : T) return T + is (T (Aux.Sin (W (X)))); + + function Cos (X : T) return T + is (T (Aux.Cos (W (X)))); + + function Tan (X : T) return T + is (T (Aux.Tan (W (X)))); + + function Exp (X : T) return T + is (T (Aux.Exp (W (X)))); + + function Sqrt (X : T) return T + is (T (Aux.Sqrt (W (X)))); + + function Log (X : T) return T + is (T (Aux.Log (W (X)))); + + function Acos (X : T) return T + is (T (Aux.Acos (W (X)))); + + function Asin (X : T) return T + is (T (Aux.Asin (W (X)))); + + function Atan (X : T) return T + is (T (Aux.Atan (W (X)))); + + function Sinh (X : T) return T + is (T (Aux.Sinh (W (X)))); + + function Cosh (X : T) return T + is (T (Aux.Cosh (W (X)))); + + function Tanh (X : T) return T + is (T (Aux.Tanh (W (X)))); + + function Pow (X, Y : T) return T + is (T (Aux.Pow (W (X), W (Y)))); + +end Ada.Numerics.Aux_Float; diff --git a/gcc/ada/libgnat/a-numaux.ads b/gcc/ada/libgnat/a-numaux.ads index 3ad7067..42ed336 100644 --- a/gcc/ada/libgnat/a-numaux.ads +++ b/gcc/ada/libgnat/a-numaux.ads @@ -5,7 +5,6 @@ -- A D A . N U M E R I C S . A U X -- -- -- -- S p e c -- --- (C Library Version, non-x86) -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- @@ -30,83 +29,60 @@ -- -- ------------------------------------------------------------------------------ --- This package provides the basic computational interface for the generic --- elementary functions. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable, although it may --- not necessarily meet the requirements for accuracy in the numerics annex. --- One advantage of using this package is that it will interface directly to --- hardware instructions, such as the those provided on the Intel x86. +-- This is a backward-compatibility unit, for users of this internal +-- package before the introduction of Aux.Generic_Float. --- This version here is for use with normal Unix math functions. Alternative --- versions are provided for special situations: - --- a-numaux-darwin For PowerPC/Darwin (special handling of sin/cos) --- a-numaux-libc-x86 For the x86, using 80-bit long double format --- a-numaux-x86 For the x86, using 80-bit long double format with --- inline asm statements --- a-numaux-vxworks For use on VxWorks (where we have no libm.a library) +with Ada.Numerics.Aux_Compat; package Ada.Numerics.Aux is pragma Pure; - pragma Linker_Options ("-lm"); + package Aux renames Aux_Compat; + + type Double is new Aux.T; - type Double is new Long_Float; - -- Type Double is the type used to call the C routines + subtype T is Double; + subtype W is Aux.T; - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure. + -- Use the Aux implementation. - function Sin (X : Double) return Double; - pragma Import (C, Sin, "sin"); - pragma Pure_Function (Sin); + function Sin (X : T) return T + is (T (Aux.Sin (W (X)))); - function Cos (X : Double) return Double; - pragma Import (C, Cos, "cos"); - pragma Pure_Function (Cos); + function Cos (X : T) return T + is (T (Aux.Cos (W (X)))); - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); - pragma Pure_Function (Tan); + function Tan (X : T) return T + is (T (Aux.Tan (W (X)))); - function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); - pragma Pure_Function (Exp); + function Exp (X : T) return T + is (T (Aux.Exp (W (X)))); - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); - pragma Pure_Function (Sqrt); + function Sqrt (X : T) return T + is (T (Aux.Sqrt (W (X)))); - function Log (X : Double) return Double; - pragma Import (C, Log, "log"); - pragma Pure_Function (Log); + function Log (X : T) return T + is (T (Aux.Log (W (X)))); - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); - pragma Pure_Function (Acos); + function Acos (X : T) return T + is (T (Aux.Acos (W (X)))); - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); - pragma Pure_Function (Asin); + function Asin (X : T) return T + is (T (Aux.Asin (W (X)))); - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); - pragma Pure_Function (Atan); + function Atan (X : T) return T + is (T (Aux.Atan (W (X)))); - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); - pragma Pure_Function (Sinh); + function Sinh (X : T) return T + is (T (Aux.Sinh (W (X)))); - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); - pragma Pure_Function (Cosh); + function Cosh (X : T) return T + is (T (Aux.Cosh (W (X)))); - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); - pragma Pure_Function (Tanh); + function Tanh (X : T) return T + is (T (Aux.Tanh (W (X)))); - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); - pragma Pure_Function (Pow); + function Pow (X, Y : T) return T + is (T (Aux.Pow (W (X), W (Y)))); end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__darwin.adb b/gcc/ada/libgnat/a-numaux__darwin.adb deleted file mode 100644 index 85fdd24..0000000 --- a/gcc/ada/libgnat/a-numaux__darwin.adb +++ /dev/null @@ -1,211 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- B o d y -- --- (Apple OS X Version) -- --- -- --- Copyright (C) 1998-2020, 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 Ada.Numerics.Aux is - - ----------------------- - -- Local subprograms -- - ----------------------- - - function Is_Nan (X : Double) return Boolean; - -- Return True iff X is a IEEE NaN value - - procedure Reduce (X : in out Double; Q : out Natural); - -- Implement reduction of X by Pi/2. Q is the quadrant of the final - -- result in the range 0..3. The absolute value of X is at most Pi/4. - -- It is needed to avoid a loss of accuracy for sin near Pi and cos - -- near Pi/2 due to the use of an insufficiently precise value of Pi - -- in the range reduction. - - -- The following two functions implement Chebishev approximations - -- of the trigonometric functions in their reduced domain. - -- These approximations have been computed using Maple. - - function Sine_Approx (X : Double) return Double; - function Cosine_Approx (X : Double) return Double; - - pragma Inline (Reduce); - pragma Inline (Sine_Approx); - pragma Inline (Cosine_Approx); - - ------------------- - -- Cosine_Approx -- - ------------------- - - function Cosine_Approx (X : Double) return Double is - XX : constant Double := X * X; - begin - return (((((16#8.DC57FBD05F640#E-08 * XX - - 16#4.9F7D00BF25D80#E-06) * XX - + 16#1.A019F7FDEFCC2#E-04) * XX - - 16#5.B05B058F18B20#E-03) * XX - + 16#A.AAAAAAAA73FA8#E-02) * XX - - 16#7.FFFFFFFFFFDE4#E-01) * XX - - 16#3.655E64869ECCE#E-14 + 1.0; - end Cosine_Approx; - - ----------------- - -- Sine_Approx -- - ----------------- - - function Sine_Approx (X : Double) return Double is - XX : constant Double := X * X; - begin - return (((((16#A.EA2D4ABE41808#E-09 * XX - - 16#6.B974C10F9D078#E-07) * XX - + 16#2.E3BC673425B0E#E-05) * XX - - 16#D.00D00CCA7AF00#E-04) * XX - + 16#2.222222221B190#E-02) * XX - - 16#2.AAAAAAAAAAA44#E-01) * (XX * X) + X; - end Sine_Approx; - - ------------ - -- Is_Nan -- - ------------ - - function Is_Nan (X : Double) return Boolean is - begin - -- The IEEE NaN values are the only ones that do not equal themselves - - return X /= X; - end Is_Nan; - - ------------ - -- Reduce -- - ------------ - - procedure Reduce (X : in out Double; Q : out Natural) is - Half_Pi : constant := Pi / 2.0; - Two_Over_Pi : constant := 2.0 / Pi; - - HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size); - M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant - P1 : constant Double := Double'Leading_Part (Half_Pi, HM); - P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM); - P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM); - P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM); - P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3 - - P4, HM); - P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5); - K : Double; - R : Integer; - - begin - -- For X < 2.0**HM, all products below are computed exactly. - -- Due to cancellation effects all subtractions are exact as well. - -- As no double extended floating-point number has more than 75 - -- zeros after the binary point, the result will be the correctly - -- rounded result of X - K * (Pi / 2.0). - - K := X * Two_Over_Pi; - while abs K >= 2.0**HM loop - K := K * M - (K * M - K); - X := - (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - K := X * Two_Over_Pi; - end loop; - - -- If K is not a number (because X was not finite) raise exception - - if Is_Nan (K) then - raise Constraint_Error; - end if; - - -- Go through an integer temporary so as to use machine instructions - - R := Integer (Double'Rounding (K)); - Q := R mod 4; - K := Double (R); - X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - end Reduce; - - --------- - -- Cos -- - --------- - - function Cos (X : Double) return Double is - Reduced_X : Double := abs X; - Quadrant : Natural range 0 .. 3; - - begin - if Reduced_X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - return Cosine_Approx (Reduced_X); - - when 1 => - return Sine_Approx (-Reduced_X); - - when 2 => - return -Cosine_Approx (Reduced_X); - - when 3 => - return Sine_Approx (Reduced_X); - end case; - end if; - - return Cosine_Approx (Reduced_X); - end Cos; - - --------- - -- Sin -- - --------- - - function Sin (X : Double) return Double is - Reduced_X : Double := X; - Quadrant : Natural range 0 .. 3; - - begin - if abs X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - return Sine_Approx (Reduced_X); - - when 1 => - return Cosine_Approx (Reduced_X); - - when 2 => - return Sine_Approx (-Reduced_X); - - when 3 => - return -Cosine_Approx (Reduced_X); - end case; - end if; - - return Sine_Approx (Reduced_X); - end Sin; - -end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numeri.ads b/gcc/ada/libgnat/a-numeri.ads index 805fa56..6304ce1 100644 --- a/gcc/ada/libgnat/a-numeri.ads +++ b/gcc/ada/libgnat/a-numeri.ads @@ -21,10 +21,13 @@ package Ada.Numerics is Pi : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511; - ["03C0"] : constant := Pi; + -- ["03C0"] : constant := Pi; -- This is the Greek letter Pi (for Ada 2005 AI-388). Note that it is -- conforming to have this constant present even in Ada 95 mode, as there -- is no way for a normal mode Ada 95 program to reference this identifier. + -- ???This is removed for now, because nobody uses it, and it causes + -- trouble for tools other than the compiler. If people want to use the + -- Greek letter in their programs, they can easily define it themselves. e : constant := 2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996; diff --git a/gcc/ada/libgnat/a-stoubu.adb b/gcc/ada/libgnat/a-stoubu.adb index 9fb6c5a..663d4ba 100644 --- a/gcc/ada/libgnat/a-stoubu.adb +++ b/gcc/ada/libgnat/a-stoubu.adb @@ -35,6 +35,8 @@ with Ada.Strings.UTF_Encoding.Wide_Strings; with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; package body Ada.Strings.Text_Output.Buffers is + type Chunk_Access is access all Chunk; + function New_Buffer (Indent_Amount : Natural := Default_Indent_Amount; Chunk_Length : Positive := Default_Chunk_Length) return Buffer @@ -46,13 +48,20 @@ package body Ada.Strings.Text_Output.Buffers is end return; end New_Buffer; + -- We need type conversions of Chunk_Access values in the following two + -- procedures, because the one in Text_Output has Storage_Size => 0, + -- because Text_Output is Pure. We do not run afoul of 13.11.2(16/3), + -- which requires the allocation and deallocation to have the same pool, + -- because the allocation in Full_Method and the deallocation in Destroy + -- use the same access type, and therefore the same pool. + procedure Destroy (S : in out Buffer) is procedure Free is new Unchecked_Deallocation (Chunk, Chunk_Access); - Cur : Chunk_Access := S.Initial_Chunk.Next; + Cur : Chunk_Access := Chunk_Access (S.Initial_Chunk.Next); begin while Cur /= null loop declare - Temp : constant Chunk_Access := Cur.Next; + Temp : constant Chunk_Access := Chunk_Access (Cur.Next); begin Free (Cur); Cur := Temp; @@ -66,7 +75,8 @@ package body Ada.Strings.Text_Output.Buffers is begin pragma Assert (S.Cur_Chunk.Next = null); pragma Assert (S.Last = S.Cur_Chunk.Chars'Length); - S.Cur_Chunk.Next := new Chunk (S.Chunk_Length); + S.Cur_Chunk.Next := + Text_Output.Chunk_Access (Chunk_Access'(new Chunk (S.Chunk_Length))); S.Cur_Chunk := S.Cur_Chunk.Next; S.Num_Extra_Chunks := @ + 1; S.Last := 0; diff --git a/gcc/ada/libgnat/a-stouut.adb b/gcc/ada/libgnat/a-stouut.adb index b5a8f97..2011408 100644 --- a/gcc/ada/libgnat/a-stouut.adb +++ b/gcc/ada/libgnat/a-stouut.adb @@ -142,6 +142,7 @@ package body Ada.Strings.Text_Output.Utils is S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; S.Last := S.Last + Item'Length; + S.Column := S.Column + Item'Length; Full (S); -- ???Seems like maybe we shouldn't call Full until we have MORE -- characters. But then we can't pass Chunk_Length => 1 to @@ -175,6 +176,7 @@ package body Ada.Strings.Text_Output.Utils is S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item; S.Last := S.Last + Item'Length; + S.Column := S.Column + Item'Length; else Put_UTF_8_Outline (S, Item); end if; @@ -191,7 +193,6 @@ package body Ada.Strings.Text_Output.Utils is Put_UTF_8 (S, Item (Line_Start .. Index - 1)); end if; New_Line (S); - S.Column := 1; Line_Start := Index + 1; end if; diff --git a/gcc/ada/libgnat/a-stouut.ads b/gcc/ada/libgnat/a-stouut.ads index 28d7eca..5056080 100644 --- a/gcc/ada/libgnat/a-stouut.ads +++ b/gcc/ada/libgnat/a-stouut.ads @@ -29,7 +29,7 @@ -- -- ------------------------------------------------------------------------------ -package Ada.Strings.Text_Output.Utils with Preelaborate is +package Ada.Strings.Text_Output.Utils with Pure is -- This package provides utility functions on Sink'Class. These are -- intended for use by Put_Image attributes, both the default versions @@ -70,7 +70,8 @@ package Ada.Strings.Text_Output.Utils with Preelaborate is -- Send data that is already UTF-8 encoded (including 7-bit ASCII) to -- S. These are more efficient than Put_String. - procedure New_Line (S : in out Sink'Class) with Inline; + procedure New_Line (S : in out Sink'Class) with + Inline, Post => Column (S) = 1; -- Puts the new-line character. function Column (S : Sink'Class) return Positive with Inline; diff --git a/gcc/ada/libgnat/a-strunb.adb b/gcc/ada/libgnat/a-strunb.adb index 988de42..7d1e6dd 100644 --- a/gcc/ada/libgnat/a-strunb.adb +++ b/gcc/ada/libgnat/a-strunb.adb @@ -778,6 +778,16 @@ package body Ada.Strings.Unbounded is end if; end Overwrite; + --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String) is + begin + String'Put_Image (S, To_String (V)); + end Put_Image; + ----------------------- -- Realloc_For_Chunk -- ----------------------- diff --git a/gcc/ada/libgnat/a-strunb.ads b/gcc/ada/libgnat/a-strunb.ads index 3471dbb..7de9bbc 100644 --- a/gcc/ada/libgnat/a-strunb.ads +++ b/gcc/ada/libgnat/a-strunb.ads @@ -41,6 +41,7 @@ pragma Assertion_Policy (Pre => Ignore); with Ada.Strings.Maps; with Ada.Finalization; +private with Ada.Strings.Text_Output; -- The language-defined package Strings.Unbounded provides a private type -- Unbounded_String and a set of operations. An object of type @@ -744,7 +745,11 @@ private type Unbounded_String is new AF.Controlled with record Reference : String_Access := Null_String'Access; Last : Natural := 0; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String); + -- The Unbounded_String is using a buffered implementation to increase -- speed of the Append/Delete/Insert procedures. The Reference string -- pointer above contains the current string value and extra room at the diff --git a/gcc/ada/libgnat/a-strunb__shared.adb b/gcc/ada/libgnat/a-strunb__shared.adb index 0ff34d8..54a2932 100644 --- a/gcc/ada/libgnat/a-strunb__shared.adb +++ b/gcc/ada/libgnat/a-strunb__shared.adb @@ -1297,6 +1297,16 @@ package body Ada.Strings.Unbounded is end Overwrite; --------------- + -- Put_Image -- + --------------- + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String) is + begin + String'Put_Image (S, To_String (V)); + end Put_Image; + + --------------- -- Reference -- --------------- diff --git a/gcc/ada/libgnat/a-strunb__shared.ads b/gcc/ada/libgnat/a-strunb__shared.ads index 5a5ad93..2cd8166 100644 --- a/gcc/ada/libgnat/a-strunb__shared.ads +++ b/gcc/ada/libgnat/a-strunb__shared.ads @@ -78,6 +78,7 @@ pragma Assertion_Policy (Pre => Ignore); with Ada.Strings.Maps; private with Ada.Finalization; private with System.Atomic_Counters; +private with Ada.Strings.Text_Output; package Ada.Strings.Unbounded with Initial_Condition => Length (Null_Unbounded_String) = 0 @@ -738,7 +739,10 @@ private type Unbounded_String is new AF.Controlled with record Reference : not null Shared_String_Access := Empty_Shared_String'Access; - end record; + end record with Put_Image => Put_Image; + + procedure Put_Image + (S : in out Ada.Strings.Text_Output.Sink'Class; V : Unbounded_String); pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); -- Provide stream routines without dragging in Ada.Streams diff --git a/gcc/ada/libgnat/a-ststun.ads b/gcc/ada/libgnat/a-ststun.ads index 95aca9b..2945bca 100644 --- a/gcc/ada/libgnat/a-ststun.ads +++ b/gcc/ada/libgnat/a-ststun.ads @@ -71,7 +71,7 @@ private EA : Stream_Element_Array (1 .. Last); end record; - Empty_Elements : aliased Elements_Type := (Last => 0, EA => (others => <>)); + Empty_Elements : aliased Elements_Type (0); type Elements_Access is access all Elements_Type; diff --git a/gcc/ada/libgnat/a-stteou.ads b/gcc/ada/libgnat/a-stteou.ads index 924b550..9eaf98a 100644 --- a/gcc/ada/libgnat/a-stteou.ads +++ b/gcc/ada/libgnat/a-stteou.ads @@ -32,7 +32,7 @@ with Ada.Strings.UTF_Encoding; with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; -package Ada.Strings.Text_Output with Preelaborate is +package Ada.Strings.Text_Output with Pure is -- This package provides a "Sink" abstraction, to which characters of type -- Character, Wide_Character, and Wide_Wide_Character can be sent. This @@ -48,7 +48,11 @@ package Ada.Strings.Text_Output with Preelaborate is -- extended. It is designed with particular extensions in mind, and these -- extensions are declared in child packages of this package, because they -- depend on implementation details in the private part of this - -- package. The primary extensions of Sink are: + -- package. + -- + -- Users are not expected to extend type Sink. + -- + -- The primary extensions of Sink are: -- -- Buffer. The characters sent to a Buffer are stored in memory, and can -- be retrieved via Get functions. This is intended for the @@ -141,15 +145,13 @@ package Ada.Strings.Text_Output with Preelaborate is -- slows things down, but increasing it doesn't gain much. private - type String_Access is access all String; - -- For Buffer, the "internal buffer" mentioned above is implemented as a -- linked list of chunks. When the current chunk is full, we allocate a new -- one. For File, there is only one chunk. When it is full, we send the -- data to the file, and empty it. type Chunk; - type Chunk_Access is access all Chunk; + type Chunk_Access is access all Chunk with Storage_Size => 0; type Chunk (Length : Positive) is limited record Next : Chunk_Access := null; Chars : UTF_8_Lines (1 .. Length); diff --git a/gcc/ada/libgnat/a-suenco.adb b/gcc/ada/libgnat/a-suenco.adb index 6d30f84..0b10a63 100644 --- a/gcc/ada/libgnat/a-suenco.adb +++ b/gcc/ada/libgnat/a-suenco.adb @@ -398,7 +398,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is or Shift_Right (yyyyyyyy, 4)); Result (Len + 3) := Character'Val - (2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 4) + (2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 2) or Shift_Right (xxxxxxxx, 6)); Result (Len + 4) := Character'Val diff --git a/gcc/ada/libgnat/a-textio.ads b/gcc/ada/libgnat/a-textio.ads index 6e5e392..36a4b65 100644 --- a/gcc/ada/libgnat/a-textio.ads +++ b/gcc/ada/libgnat/a-textio.ads @@ -36,8 +36,9 @@ -- Preconditions in this unit are meant for analysis only, not for run-time -- checking, so that the expected exceptions are raised. This is enforced by -- setting the corresponding assertion policy to Ignore. These preconditions --- are partial and protect against Status_Error, Mode_Error, and Layout_Error, --- but not against other types of errors. +-- are partial. They protect fully against Status_Error and Mode_Error, +-- partially against Layout_Error (see SPARK User's Guide for details), and +-- not against other types of errors. pragma Assertion_Policy (Pre => Ignore); diff --git a/gcc/ada/libgnat/a-tifiio.adb b/gcc/ada/libgnat/a-tifiio.adb index 4098f0e..440a77d 100644 --- a/gcc/ada/libgnat/a-tifiio.adb +++ b/gcc/ada/libgnat/a-tifiio.adb @@ -580,7 +580,7 @@ package body Ada.Text_IO.Fixed_IO is YY := 10**(Integer'Min (Max_Digits, AA - (J - 1) * Max_Digits)); end if; - Scaled_Divide (XX, YY, Z, Q (J), R => XX, Round => False); + Scaled_Divide64 (XX, YY, Z, Q (J), R => XX, Round => False); end loop; if -E > A then diff --git a/gcc/ada/libgnat/a-tigeau.adb b/gcc/ada/libgnat/a-tigeau.adb index c7f719a..f1ba60a 100644 --- a/gcc/ada/libgnat/a-tigeau.adb +++ b/gcc/ada/libgnat/a-tigeau.adb @@ -322,6 +322,60 @@ package body Ada.Text_IO.Generic_Aux is Load_Extended_Digits (File, Buf, Ptr, Junk); end Load_Extended_Digits; + ------------------ + -- Load_Integer -- + ------------------ + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + + -- Note: it is a bit strange to allow a minus sign here, but it seems + -- consistent with the general behavior expected by the ACVC tests + -- which is to scan past junk and then signal data error, see ACVC + -- test CE3704F, case (6), which is for signed integer exponents, + -- which seems a similar case. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + + -- Deal with based literal. We recognize either the standard '#' or + -- the allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants + -- for the signed case, and there seems no good reason to treat + -- exponents differently for the signed and unsigned cases. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Integer; + --------------- -- Load_Skip -- --------------- diff --git a/gcc/ada/libgnat/a-tigeau.ads b/gcc/ada/libgnat/a-tigeau.ads index 32b5fe3..09334b3 100644 --- a/gcc/ada/libgnat/a-tigeau.ads +++ b/gcc/ada/libgnat/a-tigeau.ads @@ -150,6 +150,12 @@ private package Ada.Text_IO.Generic_Aux is Ptr : in out Integer); -- Same as above, but no indication if character is loaded + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- Loads a possibly signed integer literal value + function Nextc (File : File_Type) return Integer; -- Like Getc, but includes a call to Ungetc, so that the file -- pointer is not moved by the call. diff --git a/gcc/ada/libgnat/a-tiinau.adb b/gcc/ada/libgnat/a-tiinau.adb index d09b456..a0bb5c6 100644 --- a/gcc/ada/libgnat/a-tiinau.adb +++ b/gcc/ada/libgnat/a-tiinau.adb @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . T E X T _ I O . I N T E G E R _ A U X -- +-- A D A . T E X T _ I O . I N T E G E R _ A U X -- -- -- -- B o d y -- -- -- @@ -31,61 +31,15 @@ with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; -with System.Img_BIU; use System.Img_BIU; -with System.Img_Int; use System.Img_Int; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLI; use System.Img_LLI; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Int; use System.Val_Int; -with System.Val_LLI; use System.Val_LLI; - package body Ada.Text_IO.Integer_Aux is - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load a possibly signed - -- integer literal value from the input file into Buf, starting at Ptr + 1. - -- On return, Ptr is set to the last character stored. - - ------------- - -- Get_Int -- - ------------- - - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field) - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer := 1; - Stop : Integer := 0; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Integer (File, Buf, Stop); - end if; - - Item := Scan_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Int; + --------- + -- Get -- + --------- - ------------- - -- Get_LLI -- - ------------- - - procedure Get_LLI + procedure Get (File : File_Type; - Item : out Long_Long_Integer; + Item : out Num; Width : Field) is Buf : String (1 .. Field'Last); @@ -100,130 +54,38 @@ package body Ada.Text_IO.Integer_Aux is Load_Integer (File, Buf, Stop); end if; - Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); + Item := Scan (Buf, Ptr'Access, Stop); Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLI; + end Get; - -------------- - -- Gets_Int -- - -------------- + ---------- + -- Gets -- + ---------- - procedure Gets_Int + procedure Gets (From : String; - Item : out Integer; + Item : out Num; Last : out Positive) is Pos : aliased Integer; begin String_Skip (From, Pos); - Item := Scan_Integer (From, Pos'Access, From'Last); + Item := Scan (From, Pos'Access, From'Last); Last := Pos - 1; exception when Constraint_Error => raise Data_Error; - end Gets_Int; - - -------------- - -- Gets_LLI -- - -------------- - - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLI; - - ------------------ - -- Load_Integer -- - ------------------ - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - Load_Digits (File, Buf, Ptr, Loaded); - - if Loaded then - - -- Deal with based literal. We recognize either the standard '#' or - -- the allowed alternative replacement ':' (see RM J.2(3)). + end Gets; - Load (File, Buf, Ptr, '#', ':', Loaded); + --------- + -- Put -- + --------- - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - -- Deal with exponent - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Integer; - - ------------- - -- Put_Int -- - ------------- - - procedure Put_Int - (File : File_Type; - Item : Integer; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Integer'Max (Field'Last, Width)); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Integer (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Integer (Item, Width, Buf, Ptr); - else - Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_Int; - - ------------- - -- Put_LLI -- - ------------- - - procedure Put_LLI + procedure Put (File : File_Type; - Item : Long_Long_Integer; + Item : Num; Width : Field; Base : Number_Base) is @@ -232,49 +94,23 @@ package body Ada.Text_IO.Integer_Aux is begin if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Integer (Item, Buf, Ptr); + Set_Image (Item, Buf, Ptr); elsif Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); + Set_Image_Width (Item, Width, Buf, Ptr); else - Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); + Set_Image_Based (Item, Base, Width, Buf, Ptr); end if; Put_Item (File, Buf (1 .. Ptr)); - end Put_LLI; - - -------------- - -- Puts_Int -- - -------------- - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base) - is - Buf : String (1 .. Integer'Max (Field'Last, To'Length)); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Int; + end Put; - -------------- - -- Puts_LLI -- - -------------- + ---------- + -- Puts -- + ---------- - procedure Puts_LLI + procedure Puts (To : out String; - Item : Long_Long_Integer; + Item : Num; Base : Number_Base) is Buf : String (1 .. Integer'Max (Field'Last, To'Length)); @@ -282,9 +118,9 @@ package body Ada.Text_IO.Integer_Aux is begin if Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); + Set_Image_Width (Item, To'Length, Buf, Ptr); else - Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); + Set_Image_Based (Item, Base, To'Length, Buf, Ptr); end if; if Ptr > To'Length then @@ -292,6 +128,6 @@ package body Ada.Text_IO.Integer_Aux is else To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); end if; - end Puts_LLI; + end Puts; end Ada.Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-tiinau.ads b/gcc/ada/libgnat/a-tiinau.ads index fda5b68..e149221 100644 --- a/gcc/ada/libgnat/a-tiinau.ads +++ b/gcc/ada/libgnat/a-tiinau.ads @@ -29,55 +29,45 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines for Ada.Text_IO.Integer_IO that are --- shared among separate instantiations of this package. The routines in --- this package are identical semantically to those in Integer_IO itself, --- except that the generic parameter Num has been replaced by Integer or --- Long_Long_Integer, and the default parameters have been removed because --- they are supplied explicitly by the calls from within the generic template. +-- This package contains the implementation for Ada.Text_IO.Integer_IO and +-- Ada.Text_IO.Modular_IO. The routines in this package are identical +-- semantically to those in Integer_IO and Modular_IO themselves, except that +-- the default parameters have been removed because they are supplied +-- explicitly by the calls from within these units. -private package Ada.Text_IO.Integer_Aux is +private generic + type Num is (<>); - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field); + with function Scan + (Str : String; Ptr : not null access Integer; Max : Integer) return Num; + with procedure Set_Image + (V : Num; S : in out String; P : in out Natural); + with procedure Set_Image_Width + (V : Num; W : Integer; S : out String; P : in out Natural); + with procedure Set_Image_Based + (V : Num; B : Natural; W : Integer; S : out String; P : in out Natural); + +package Ada.Text_IO.Integer_Aux is - procedure Get_LLI + procedure Get (File : File_Type; - Item : out Long_Long_Integer; + Item : out Num; Width : Field); - procedure Put_Int - (File : File_Type; - Item : Integer; - Width : Field; - Base : Number_Base); + procedure Gets + (From : String; + Item : out Num; + Last : out Positive); - procedure Put_LLI + procedure Put (File : File_Type; - Item : Long_Long_Integer; + Item : Num; Width : Field; Base : Number_Base); - procedure Gets_Int - (From : String; - Item : out Integer; - Last : out Positive); - - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive); - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base); - - procedure Puts_LLI + procedure Puts (To : out String; - Item : Long_Long_Integer; + Item : Num; Base : Number_Base); end Ada.Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-tiinio.adb b/gcc/ada/libgnat/a-tiinio.adb index c71b4bf..4133bec 100644 --- a/gcc/ada/libgnat/a-tiinio.adb +++ b/gcc/ada/libgnat/a-tiinio.adb @@ -30,10 +30,32 @@ ------------------------------------------------------------------------------ with Ada.Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Int; use System.Img_Int; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLI; use System.Img_LLI; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Int; use System.Val_Int; +with System.Val_LLI; use System.Val_LLI; package body Ada.Text_IO.Integer_IO is - package Aux renames Ada.Text_IO.Integer_Aux; + package Aux_Int is new + Ada.Text_IO.Integer_Aux + (Integer, + Scan_Integer, + Set_Image_Integer, + Set_Image_Width_Integer, + Set_Image_Based_Integer); + + package Aux_LLI is new + Ada.Text_IO.Integer_Aux + (Long_Long_Integer, + Scan_Long_Long_Integer, + Set_Image_Long_Long_Integer, + Set_Image_Width_Long_Long_Integer, + Set_Image_Based_Long_Long_Integer); Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; -- Throughout this generic body, we distinguish between the case where type @@ -57,9 +79,9 @@ package body Ada.Text_IO.Integer_IO is begin if Need_LLI then - Aux.Get_LLI (File, Long_Long_Integer (Item), Width); + Aux_LLI.Get (File, Long_Long_Integer (Item), Width); else - Aux.Get_Int (File, Integer (Item), Width); + Aux_Int.Get (File, Integer (Item), Width); end if; exception @@ -70,20 +92,8 @@ package body Ada.Text_IO.Integer_IO is (Item : out Num; Width : Field := 0) is - -- We depend on a range check to get Data_Error - - pragma Unsuppress (Range_Check); - pragma Unsuppress (Overflow_Check); - begin - if Need_LLI then - Aux.Get_LLI (Current_In, Long_Long_Integer (Item), Width); - else - Aux.Get_Int (Current_In, Integer (Item), Width); - end if; - - exception - when Constraint_Error => raise Data_Error; + Get (Current_In, Item, Width); end Get; procedure Get @@ -98,9 +108,9 @@ package body Ada.Text_IO.Integer_IO is begin if Need_LLI then - Aux.Gets_LLI (From, Long_Long_Integer (Item), Last); + Aux_LLI.Gets (From, Long_Long_Integer (Item), Last); else - Aux.Gets_Int (From, Integer (Item), Last); + Aux_Int.Gets (From, Integer (Item), Last); end if; exception @@ -119,9 +129,9 @@ package body Ada.Text_IO.Integer_IO is is begin if Need_LLI then - Aux.Put_LLI (File, Long_Long_Integer (Item), Width, Base); + Aux_LLI.Put (File, Long_Long_Integer (Item), Width, Base); else - Aux.Put_Int (File, Integer (Item), Width, Base); + Aux_Int.Put (File, Integer (Item), Width, Base); end if; end Put; @@ -131,11 +141,7 @@ package body Ada.Text_IO.Integer_IO is Base : Number_Base := Default_Base) is begin - if Need_LLI then - Aux.Put_LLI (Current_Out, Long_Long_Integer (Item), Width, Base); - else - Aux.Put_Int (Current_Out, Integer (Item), Width, Base); - end if; + Put (Current_Out, Item, Width, Base); end Put; procedure Put @@ -145,9 +151,9 @@ package body Ada.Text_IO.Integer_IO is is begin if Need_LLI then - Aux.Puts_LLI (To, Long_Long_Integer (Item), Base); + Aux_LLI.Puts (To, Long_Long_Integer (Item), Base); else - Aux.Puts_Int (To, Integer (Item), Base); + Aux_Int.Puts (To, Integer (Item), Base); end if; end Put; diff --git a/gcc/ada/libgnat/a-tiinio__128.adb b/gcc/ada/libgnat/a-tiinio__128.adb new file mode 100644 index 0000000..e82b447 --- /dev/null +++ b/gcc/ada/libgnat/a-tiinio__128.adb @@ -0,0 +1,182 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Int; use System.Img_Int; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLI; use System.Img_LLI; +with System.Img_LLW; use System.Img_LLW; +with System.Img_LLLB; use System.Img_LLLB; +with System.Img_LLLI; use System.Img_LLLI; +with System.Img_LLLW; use System.Img_LLLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Int; use System.Val_Int; +with System.Val_LLI; use System.Val_LLI; +with System.Val_LLLI; use System.Val_LLLI; + +package body Ada.Text_IO.Integer_IO is + + package Aux_Int is new + Ada.Text_IO.Integer_Aux + (Integer, + Scan_Integer, + Set_Image_Integer, + Set_Image_Width_Integer, + Set_Image_Based_Integer); + + package Aux_LLI is new + Ada.Text_IO.Integer_Aux + (Long_Long_Integer, + Scan_Long_Long_Integer, + Set_Image_Long_Long_Integer, + Set_Image_Width_Long_Long_Integer, + Set_Image_Based_Long_Long_Integer); + + package Aux_LLLI is new + Ada.Text_IO.Integer_Aux + (Long_Long_Long_Integer, + Scan_Long_Long_Long_Integer, + Set_Image_Long_Long_Long_Integer, + Set_Image_Width_Long_Long_Long_Integer, + Set_Image_Based_Long_Long_Long_Integer); + + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; + Need_LLLI : constant Boolean := Num'Base'Size > Long_Long_Integer'Size; + -- Throughout this generic body, we distinguish between cases where type + -- Integer is acceptable, where type Long_Long_Integer is acceptable and + -- where type Long_Long_Long_Integer is needed. These boolean constants + -- are used to test for these cases and since they are constant, only code + -- for the relevant case will be included in the instance. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + + begin + if Need_LLLI then + Aux_LLLI.Get (File, Long_Long_Long_Integer (Item), Width); + elsif Need_LLI then + Aux_LLI.Get (File, Long_Long_Integer (Item), Width); + else + Aux_Int.Get (File, Integer (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_In, Item, Width); + end Get; + + procedure Get + (From : String; + Item : out Num; + Last : out Positive) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + + begin + if Need_LLLI then + Aux_LLLI.Gets (From, Long_Long_Long_Integer (Item), Last); + elsif Need_LLI then + Aux_LLI.Gets (From, Long_Long_Integer (Item), Last); + else + Aux_Int.Gets (From, Integer (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLLI then + Aux_LLLI.Put (File, Long_Long_Long_Integer (Item), Width, Base); + elsif Need_LLI then + Aux_LLI.Put (File, Long_Long_Integer (Item), Width, Base); + else + Aux_Int.Put (File, Integer (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Out, Item, Width, Base); + end Put; + + procedure Put + (To : out String; + Item : Num; + Base : Number_Base := Default_Base) + is + begin + if Need_LLLI then + Aux_LLLI.Puts (To, Long_Long_Long_Integer (Item), Base); + elsif Need_LLI then + Aux_LLI.Puts (To, Long_Long_Integer (Item), Base); + else + Aux_Int.Puts (To, Integer (Item), Base); + end if; + end Put; + +end Ada.Text_IO.Integer_IO; diff --git a/gcc/ada/libgnat/a-timoau.adb b/gcc/ada/libgnat/a-timoau.adb deleted file mode 100644 index 050b9c8..0000000 --- a/gcc/ada/libgnat/a-timoau.adb +++ /dev/null @@ -1,305 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . M O D U L A R _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2020, 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. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; - -with System.Img_BIU; use System.Img_BIU; -with System.Img_Uns; use System.Img_Uns; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLU; use System.Img_LLU; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Uns; use System.Val_Uns; -with System.Val_LLU; use System.Val_LLU; - -package body Ada.Text_IO.Modular_Aux is - - use System.Unsigned_Types; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load an possibly signed - -- modular literal value from the input file into Buf, starting at Ptr + 1. - -- Ptr is left set to the last character stored. - - ------------- - -- Get_LLU -- - ------------- - - procedure Get_LLU - (File : File_Type; - Item : out Long_Long_Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLU; - - ------------- - -- Get_Uns -- - ------------- - - procedure Get_Uns - (File : File_Type; - Item : out Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Uns; - - -------------- - -- Gets_LLU -- - -------------- - - procedure Gets_LLU - (From : String; - Item : out Long_Long_Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLU; - - -------------- - -- Gets_Uns -- - -------------- - - procedure Gets_Uns - (From : String; - Item : out Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_Uns; - - ------------------ - -- Load_Modular -- - ------------------ - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - - -- Note: it is a bit strange to allow a minus sign here, but it seems - -- consistent with the general behavior expected by the ACVC tests - -- which is to scan past junk and then signal data error, see ACVC - -- test CE3704F, case (6), which is for signed integer exponents, - -- which seems a similar case. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr, Loaded); - - if Loaded then - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants - -- for the signed case, and there seems no good reason to treat - -- exponents differently for the signed and unsigned cases. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Modular; - - ------------- - -- Put_LLU -- - ------------- - - procedure Put_LLU - (File : File_Type; - Item : Long_Long_Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLU; - - ------------- - -- Put_Uns -- - ------------- - - procedure Put_Uns - (File : File_Type; - Item : Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_Uns; - - -------------- - -- Puts_LLU -- - -------------- - - procedure Puts_LLU - (To : out String; - Item : Long_Long_Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_LLU; - - -------------- - -- Puts_Uns -- - -------------- - - procedure Puts_Uns - (To : out String; - Item : Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Uns; - -end Ada.Text_IO.Modular_Aux; diff --git a/gcc/ada/libgnat/a-timoio.adb b/gcc/ada/libgnat/a-timoio.adb index 0cdeef1..83dbafa 100644 --- a/gcc/ada/libgnat/a-timoio.adb +++ b/gcc/ada/libgnat/a-timoio.adb @@ -29,13 +29,39 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Text_IO.Modular_Aux; - -with System.Unsigned_Types; use System.Unsigned_Types; +with Ada.Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Uns; use System.Img_Uns; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLU; use System.Img_LLU; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Uns; use System.Val_Uns; +with System.Val_LLU; use System.Val_LLU; package body Ada.Text_IO.Modular_IO is - package Aux renames Ada.Text_IO.Modular_Aux; + package Aux_Uns is new + Ada.Text_IO.Integer_Aux + (Unsigned, + Scan_Unsigned, + Set_Image_Unsigned, + Set_Image_Width_Unsigned, + Set_Image_Based_Unsigned); + + package Aux_LLU is new + Ada.Text_IO.Integer_Aux + (Long_Long_Unsigned, + Scan_Long_Long_Unsigned, + Set_Image_Long_Long_Unsigned, + Set_Image_Width_Long_Long_Unsigned, + Set_Image_Based_Long_Long_Unsigned); + + Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size; + -- Throughout this generic body, we distinguish between the case where type + -- Unsigned is acceptable, and where a Long_Long_Unsigned is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. --------- -- Get -- @@ -46,13 +72,15 @@ package body Ada.Text_IO.Modular_IO is Item : out Num; Width : Field := 0) is + -- We depend on a range check to get Data_Error + pragma Unsuppress (Range_Check); begin - if Num'Size > Unsigned'Size then - Aux.Get_LLU (File, Long_Long_Unsigned (Item), Width); + if Need_LLU then + Aux_LLU.Get (File, Long_Long_Unsigned (Item), Width); else - Aux.Get_Uns (File, Unsigned (Item), Width); + Aux_Uns.Get (File, Unsigned (Item), Width); end if; exception @@ -63,17 +91,8 @@ package body Ada.Text_IO.Modular_IO is (Item : out Num; Width : Field := 0) is - pragma Unsuppress (Range_Check); - begin - if Num'Size > Unsigned'Size then - Aux.Get_LLU (Current_In, Long_Long_Unsigned (Item), Width); - else - Aux.Get_Uns (Current_In, Unsigned (Item), Width); - end if; - - exception - when Constraint_Error => raise Data_Error; + Get (Current_In, Item, Width); end Get; procedure Get @@ -81,13 +100,15 @@ package body Ada.Text_IO.Modular_IO is Item : out Num; Last : out Positive) is + -- We depend on a range check to get Data_Error + pragma Unsuppress (Range_Check); begin - if Num'Size > Unsigned'Size then - Aux.Gets_LLU (From, Long_Long_Unsigned (Item), Last); + if Need_LLU then + Aux_LLU.Gets (From, Long_Long_Unsigned (Item), Last); else - Aux.Gets_Uns (From, Unsigned (Item), Last); + Aux_Uns.Gets (From, Unsigned (Item), Last); end if; exception @@ -105,10 +126,10 @@ package body Ada.Text_IO.Modular_IO is Base : Number_Base := Default_Base) is begin - if Num'Size > Unsigned'Size then - Aux.Put_LLU (File, Long_Long_Unsigned (Item), Width, Base); + if Need_LLU then + Aux_LLU.Put (File, Long_Long_Unsigned (Item), Width, Base); else - Aux.Put_Uns (File, Unsigned (Item), Width, Base); + Aux_Uns.Put (File, Unsigned (Item), Width, Base); end if; end Put; @@ -118,11 +139,7 @@ package body Ada.Text_IO.Modular_IO is Base : Number_Base := Default_Base) is begin - if Num'Size > Unsigned'Size then - Aux.Put_LLU (Current_Out, Long_Long_Unsigned (Item), Width, Base); - else - Aux.Put_Uns (Current_Out, Unsigned (Item), Width, Base); - end if; + Put (Current_Out, Item, Width, Base); end Put; procedure Put @@ -131,10 +148,10 @@ package body Ada.Text_IO.Modular_IO is Base : Number_Base := Default_Base) is begin - if Num'Size > Unsigned'Size then - Aux.Puts_LLU (To, Long_Long_Unsigned (Item), Base); + if Need_LLU then + Aux_LLU.Puts (To, Long_Long_Unsigned (Item), Base); else - Aux.Puts_Uns (To, Unsigned (Item), Base); + Aux_Uns.Puts (To, Unsigned (Item), Base); end if; end Put; diff --git a/gcc/ada/libgnat/a-timoio__128.adb b/gcc/ada/libgnat/a-timoio__128.adb new file mode 100644 index 0000000..45856e2 --- /dev/null +++ b/gcc/ada/libgnat/a-timoio__128.adb @@ -0,0 +1,180 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Uns; use System.Img_Uns; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLU; use System.Img_LLU; +with System.Img_LLW; use System.Img_LLW; +with System.Img_LLLB; use System.Img_LLLB; +with System.Img_LLLU; use System.Img_LLLU; +with System.Img_LLLW; use System.Img_LLLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Uns; use System.Val_Uns; +with System.Val_LLU; use System.Val_LLU; +with System.Val_LLLU; use System.Val_LLLU; + +package body Ada.Text_IO.Modular_IO is + + package Aux_Uns is new + Ada.Text_IO.Integer_Aux + (Unsigned, + Scan_Unsigned, + Set_Image_Unsigned, + Set_Image_Width_Unsigned, + Set_Image_Based_Unsigned); + + package Aux_LLU is new + Ada.Text_IO.Integer_Aux + (Long_Long_Unsigned, + Scan_Long_Long_Unsigned, + Set_Image_Long_Long_Unsigned, + Set_Image_Width_Long_Long_Unsigned, + Set_Image_Based_Long_Long_Unsigned); + + package Aux_LLLU is new + Ada.Text_IO.Integer_Aux + (Long_Long_Long_Unsigned, + Scan_Long_Long_Long_Unsigned, + Set_Image_Long_Long_Long_Unsigned, + Set_Image_Width_Long_Long_Long_Unsigned, + Set_Image_Based_Long_Long_Long_Unsigned); + + Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size; + Need_LLLU : constant Boolean := Num'Base'Size > Long_Long_Unsigned'Size; + -- Throughout this generic body, we distinguish between cases where type + -- Unsigned is acceptable, where type Long_Long_Unsigned is acceptable and + -- where type Long_Long_Long_Unsigned is needed. These boolean constants + -- are used to test for these cases and since they are constant, only code + -- for the relevant case will be included in the instance. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + + begin + if Need_LLLU then + Aux_LLLU.Get (File, Long_Long_Long_Unsigned (Item), Width); + elsif Need_LLU then + Aux_LLU.Get (File, Long_Long_Unsigned (Item), Width); + else + Aux_Uns.Get (File, Unsigned (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_In, Item, Width); + end Get; + + procedure Get + (From : String; + Item : out Num; + Last : out Positive) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + + begin + if Need_LLLU then + Aux_LLLU.Gets (From, Long_Long_Long_Unsigned (Item), Last); + elsif Need_LLU then + Aux_LLU.Gets (From, Long_Long_Unsigned (Item), Last); + else + Aux_Uns.Gets (From, Unsigned (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLLU then + Aux_LLLU.Put (File, Long_Long_Long_Unsigned (Item), Width, Base); + elsif Need_LLU then + Aux_LLU.Put (File, Long_Long_Unsigned (Item), Width, Base); + else + Aux_Uns.Put (File, Unsigned (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Out, Item, Width, Base); + end Put; + + procedure Put + (To : out String; + Item : Num; + Base : Number_Base := Default_Base) + is + begin + if Need_LLLU then + Aux_LLLU.Puts (To, Long_Long_Long_Unsigned (Item), Base); + elsif Need_LLU then + Aux_LLU.Puts (To, Long_Long_Unsigned (Item), Base); + else + Aux_Uns.Puts (To, Unsigned (Item), Base); + end if; + end Put; + +end Ada.Text_IO.Modular_IO; diff --git a/gcc/ada/libgnat/a-wtgeau.adb b/gcc/ada/libgnat/a-wtgeau.adb index 45eef92..9d24070 100644 --- a/gcc/ada/libgnat/a-wtgeau.adb +++ b/gcc/ada/libgnat/a-wtgeau.adb @@ -348,6 +348,60 @@ package body Ada.Wide_Text_IO.Generic_Aux is Load_Extended_Digits (File, Buf, Ptr, Junk); end Load_Extended_Digits; + ------------------ + -- Load_Integer -- + ------------------ + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + + -- Note: it is a bit strange to allow a minus sign here, but it seems + -- consistent with the general behavior expected by the ACVC tests + -- which is to scan past junk and then signal data error, see ACVC + -- test CE3704F, case (6), which is for signed integer exponents, + -- which seems a similar case. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + + -- Deal with based literal. We recognize either the standard '#' or + -- the allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants + -- for the signed case, and there seems no good reason to treat + -- exponents differently for the signed and unsigned cases. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Integer; + --------------- -- Load_Skip -- --------------- diff --git a/gcc/ada/libgnat/a-wtgeau.ads b/gcc/ada/libgnat/a-wtgeau.ads index ba8509b..9577ac2 100644 --- a/gcc/ada/libgnat/a-wtgeau.ads +++ b/gcc/ada/libgnat/a-wtgeau.ads @@ -149,6 +149,12 @@ package Ada.Wide_Text_IO.Generic_Aux is Ptr : in out Integer); -- Same as above, but no indication if character is loaded + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- Loads a possibly signed integer literal value + procedure Put_Item (File : File_Type; Str : String); -- This routine is like Wide_Text_IO.Put, except that it checks for -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used @@ -169,7 +175,7 @@ package Ada.Wide_Text_IO.Generic_Aux is procedure String_Skip (Str : String; Ptr : out Integer); -- Used in the Get from string procedures to skip leading blanks in the -- string. Ptr is set to the index of the first non-blank. If the string - -- is all blanks, then the excption End_Error is raised, Note that blank + -- is all blanks, then the exception End_Error is raised, Note that blank -- is defined as a space or horizontal tab (RM A.10.6(5)). procedure Ungetc (ch : Integer; File : File_Type); diff --git a/gcc/ada/libgnat/a-wtinau.adb b/gcc/ada/libgnat/a-wtinau.adb index 53e8163..b614b39 100644 --- a/gcc/ada/libgnat/a-wtinau.adb +++ b/gcc/ada/libgnat/a-wtinau.adb @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . W I D E _ T E X T _ I O . I N T E G E R _ A U X -- +-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ A U X -- -- -- -- B o d y -- -- -- @@ -31,61 +31,15 @@ with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; -with System.Img_BIU; use System.Img_BIU; -with System.Img_Int; use System.Img_Int; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLI; use System.Img_LLI; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Int; use System.Val_Int; -with System.Val_LLI; use System.Val_LLI; - package body Ada.Wide_Text_IO.Integer_Aux is - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load an possibly signed - -- integer literal value from the input file into Buf, starting at Ptr + 1. - -- On return, Ptr is set to the last character stored. - - ------------- - -- Get_Int -- - ------------- - - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field) - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer := 1; - Stop : Integer := 0; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Integer (File, Buf, Stop); - end if; - - Item := Scan_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Int; - - ------------- - -- Get_LLI -- - ------------- + --------- + -- Get -- + --------- - procedure Get_LLI + procedure Get (File : File_Type; - Item : out Long_Long_Integer; + Item : out Num; Width : Field) is Buf : String (1 .. Field'Last); @@ -100,189 +54,73 @@ package body Ada.Wide_Text_IO.Integer_Aux is Load_Integer (File, Buf, Stop); end if; - Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); + Item := Scan (Buf, Ptr'Access, Stop); Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLI; + end Get; - -------------- - -- Gets_Int -- - -------------- + ---------- + -- Gets -- + ---------- - procedure Gets_Int + procedure Gets (From : String; - Item : out Integer; + Item : out Num; Last : out Positive) is Pos : aliased Integer; begin String_Skip (From, Pos); - Item := Scan_Integer (From, Pos'Access, From'Last); + Item := Scan (From, Pos'Access, From'Last); Last := Pos - 1; exception when Constraint_Error => raise Data_Error; - end Gets_Int; - - -------------- - -- Gets_LLI -- - -------------- - - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLI; - - ------------------ - -- Load_Integer -- - ------------------ - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - Load_Digits (File, Buf, Ptr, Loaded); + end Gets; - if Loaded then + --------- + -- Put -- + --------- - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Integer; - - ------------- - -- Put_Int -- - ------------- - - procedure Put_Int + procedure Put (File : File_Type; - Item : Integer; + Item : Num; Width : Field; Base : Number_Base) is - Buf : String (1 .. Field'Last); + Buf : String (1 .. Integer'Max (Field'Last, Width)); Ptr : Natural := 0; begin if Base = 10 and then Width = 0 then - Set_Image_Integer (Item, Buf, Ptr); + Set_Image (Item, Buf, Ptr); elsif Base = 10 then - Set_Image_Width_Integer (Item, Width, Buf, Ptr); + Set_Image_Width (Item, Width, Buf, Ptr); else - Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); + Set_Image_Based (Item, Base, Width, Buf, Ptr); end if; Put_Item (File, Buf (1 .. Ptr)); - end Put_Int; - - ------------- - -- Put_LLI -- - ------------- - - procedure Put_LLI - (File : File_Type; - Item : Long_Long_Integer; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Integer (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLI; - - -------------- - -- Puts_Int -- - -------------- - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Int; + end Put; - -------------- - -- Puts_LLI -- - -------------- + ---------- + -- Puts -- + ---------- - procedure Puts_LLI + procedure Puts (To : out String; - Item : Long_Long_Integer; + Item : Num; Base : Number_Base) is - Buf : String (1 .. Field'Last); + Buf : String (1 .. Integer'Max (Field'Last, To'Length)); Ptr : Natural := 0; begin if Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); + Set_Image_Width (Item, To'Length, Buf, Ptr); else - Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); + Set_Image_Based (Item, Base, To'Length, Buf, Ptr); end if; if Ptr > To'Length then @@ -290,6 +128,6 @@ package body Ada.Wide_Text_IO.Integer_Aux is else To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); end if; - end Puts_LLI; + end Puts; end Ada.Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-wtinau.ads b/gcc/ada/libgnat/a-wtinau.ads index 691a877..f139f77 100644 --- a/gcc/ada/libgnat/a-wtinau.ads +++ b/gcc/ada/libgnat/a-wtinau.ads @@ -29,55 +29,45 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines for Ada.Wide_Text_IO.Integer_IO that --- are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Integer_IO itself, --- except that the generic parameter Num has been replaced by Integer or --- Long_Long_Integer, and the default parameters have been removed because --- they are supplied explicitly by the calls from within the generic template. +-- This package contains the implementation for Ada.Wide_Text_IO.Integer_IO +-- and Ada.Wide_Text_IO.Modular_IO. The routines in this package are identical +-- semantically to those in Integer_IO and Modular_IO themselves, except that +-- the default parameters have been removed because they are supplied +-- explicitly by the calls from within these units. -private package Ada.Wide_Text_IO.Integer_Aux is +private generic + type Num is (<>); - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field); + with function Scan + (Str : String; Ptr : not null access Integer; Max : Integer) return Num; + with procedure Set_Image + (V : Num; S : in out String; P : in out Natural); + with procedure Set_Image_Width + (V : Num; W : Integer; S : out String; P : in out Natural); + with procedure Set_Image_Based + (V : Num; B : Natural; W : Integer; S : out String; P : in out Natural); - procedure Get_LLI +package Ada.Wide_Text_IO.Integer_Aux is + + procedure Get (File : File_Type; - Item : out Long_Long_Integer; + Item : out Num; Width : Field); - procedure Gets_Int + procedure Gets (From : String; - Item : out Integer; + Item : out Num; Last : out Positive); - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive); - - procedure Put_Int + procedure Put (File : File_Type; - Item : Integer; + Item : Num; Width : Field; Base : Number_Base); - procedure Put_LLI - (File : File_Type; - Item : Long_Long_Integer; - Width : Field; - Base : Number_Base); - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base); - - procedure Puts_LLI + procedure Puts (To : out String; - Item : Long_Long_Integer; + Item : Num; Base : Number_Base); end Ada.Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-wtinio.adb b/gcc/ada/libgnat/a-wtinio.adb index bc03227..a3f666e 100644 --- a/gcc/ada/libgnat/a-wtinio.adb +++ b/gcc/ada/libgnat/a-wtinio.adb @@ -30,11 +30,35 @@ ------------------------------------------------------------------------------ with Ada.Wide_Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Int; use System.Img_Int; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLI; use System.Img_LLI; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Int; use System.Val_Int; +with System.Val_LLI; use System.Val_LLI; with System.WCh_Con; use System.WCh_Con; with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Text_IO.Integer_IO is + package Aux_Int is new + Ada.Wide_Text_IO.Integer_Aux + (Integer, + Scan_Integer, + Set_Image_Integer, + Set_Image_Width_Integer, + Set_Image_Based_Integer); + + package Aux_LLI is new + Ada.Wide_Text_IO.Integer_Aux + (Long_Long_Integer, + Scan_Long_Long_Integer, + Set_Image_Long_Long_Integer, + Set_Image_Width_Long_Long_Integer, + Set_Image_Based_Long_Long_Integer); + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; -- Throughout this generic body, we distinguish between the case where type -- Integer is acceptable, and where a Long_Long_Integer is needed. This @@ -44,8 +68,6 @@ package body Ada.Wide_Text_IO.Integer_IO is subtype TFT is Ada.Wide_Text_IO.File_Type; -- File type required for calls to routines in Aux - package Aux renames Ada.Wide_Text_IO.Integer_Aux; - --------- -- Get -- --------- @@ -55,11 +77,16 @@ package body Ada.Wide_Text_IO.Integer_IO is Item : out Num; Width : Field := 0) is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + begin if Need_LLI then - Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width); + Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width); else - Aux.Get_Int (TFT (File), Integer (Item), Width); + Aux_Int.Get (TFT (File), Integer (Item), Width); end if; exception @@ -79,6 +106,11 @@ package body Ada.Wide_Text_IO.Integer_IO is Item : out Num; Last : out Positive) is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + S : constant String := Wide_String_To_String (From, WCEM_Upper); -- String on which we do the actual conversion. Note that the method -- used for wide character encoding is irrelevant, since if there is @@ -87,9 +119,9 @@ package body Ada.Wide_Text_IO.Integer_IO is begin if Need_LLI then - Aux.Gets_LLI (S, Long_Long_Integer (Item), Last); + Aux_LLI.Gets (S, Long_Long_Integer (Item), Last); else - Aux.Gets_Int (S, Integer (Item), Last); + Aux_Int.Gets (S, Integer (Item), Last); end if; exception @@ -108,9 +140,9 @@ package body Ada.Wide_Text_IO.Integer_IO is is begin if Need_LLI then - Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base); + Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base); else - Aux.Put_Int (TFT (File), Integer (Item), Width, Base); + Aux_Int.Put (TFT (File), Integer (Item), Width, Base); end if; end Put; @@ -132,9 +164,9 @@ package body Ada.Wide_Text_IO.Integer_IO is begin if Need_LLI then - Aux.Puts_LLI (S, Long_Long_Integer (Item), Base); + Aux_LLI.Puts (S, Long_Long_Integer (Item), Base); else - Aux.Puts_Int (S, Integer (Item), Base); + Aux_Int.Puts (S, Integer (Item), Base); end if; for J in S'Range loop diff --git a/gcc/ada/libgnat/a-wtinio__128.adb b/gcc/ada/libgnat/a-wtinio__128.adb new file mode 100644 index 0000000..edc78c3 --- /dev/null +++ b/gcc/ada/libgnat/a-wtinio__128.adb @@ -0,0 +1,199 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Int; use System.Img_Int; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLI; use System.Img_LLI; +with System.Img_LLW; use System.Img_LLW; +with System.Img_LLLB; use System.Img_LLLB; +with System.Img_LLLI; use System.Img_LLLI; +with System.Img_LLLW; use System.Img_LLLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Int; use System.Val_Int; +with System.Val_LLI; use System.Val_LLI; +with System.Val_LLLI; use System.Val_LLLI; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Integer_IO is + + package Aux_Int is new + Ada.Wide_Text_IO.Integer_Aux + (Integer, + Scan_Integer, + Set_Image_Integer, + Set_Image_Width_Integer, + Set_Image_Based_Integer); + + package Aux_LLI is new + Ada.Wide_Text_IO.Integer_Aux + (Long_Long_Integer, + Scan_Long_Long_Integer, + Set_Image_Long_Long_Integer, + Set_Image_Width_Long_Long_Integer, + Set_Image_Based_Long_Long_Integer); + + package Aux_LLLI is new + Ada.Wide_Text_IO.Integer_Aux + (Long_Long_Long_Integer, + Scan_Long_Long_Long_Integer, + Set_Image_Long_Long_Long_Integer, + Set_Image_Width_Long_Long_Long_Integer, + Set_Image_Based_Long_Long_Long_Integer); + + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; + Need_LLLI : constant Boolean := Num'Base'Size > Long_Long_Integer'Size; + -- Throughout this generic body, we distinguish between cases where type + -- Integer is acceptable, where type Long_Long_Integer is acceptable and + -- where type Long_Long_Long_Integer is needed. These boolean constants + -- are used to test for these cases and since they are constant, only code + -- for the relevant case will be included in the instance. + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + + begin + if Need_LLLI then + Aux_LLLI.Get (TFT (File), Long_Long_Long_Integer (Item), Width); + elsif Need_LLI then + Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width); + else + Aux_Int.Get (TFT (File), Integer (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need_LLLI then + Aux_LLLI.Gets (S, Long_Long_Long_Integer (Item), Last); + elsif Need_LLI then + Aux_LLI.Gets (S, Long_Long_Integer (Item), Last); + else + Aux_Int.Gets (S, Integer (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLLI then + Aux_LLLI.Put (TFT (File), Long_Long_Long_Integer (Item), Width, Base); + elsif Need_LLI then + Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base); + else + Aux_Int.Put (TFT (File), Integer (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Need_LLLI then + Aux_LLLI.Puts (S, Long_Long_Long_Integer (Item), Base); + elsif Need_LLI then + Aux_LLI.Puts (S, Long_Long_Integer (Item), Base); + else + Aux_Int.Puts (S, Integer (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/libgnat/a-wtmoau.adb b/gcc/ada/libgnat/a-wtmoau.adb deleted file mode 100644 index 9039798..0000000 --- a/gcc/ada/libgnat/a-wtmoau.adb +++ /dev/null @@ -1,305 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2020, 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. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; - -with System.Img_BIU; use System.Img_BIU; -with System.Img_Uns; use System.Img_Uns; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLU; use System.Img_LLU; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Uns; use System.Val_Uns; -with System.Val_LLU; use System.Val_LLU; - -package body Ada.Wide_Text_IO.Modular_Aux is - - use System.Unsigned_Types; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load an possibly signed - -- modular literal value from the input file into Buf, starting at Ptr + 1. - -- Ptr is left set to the last character stored. - - ------------- - -- Get_LLU -- - ------------- - - procedure Get_LLU - (File : File_Type; - Item : out Long_Long_Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLU; - - ------------- - -- Get_Uns -- - ------------- - - procedure Get_Uns - (File : File_Type; - Item : out Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Uns; - - -------------- - -- Gets_LLU -- - -------------- - - procedure Gets_LLU - (From : String; - Item : out Long_Long_Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLU; - - -------------- - -- Gets_Uns -- - -------------- - - procedure Gets_Uns - (From : String; - Item : out Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_Uns; - - ------------------ - -- Load_Modular -- - ------------------ - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - - -- Note: it is a bit strange to allow a minus sign here, but it seems - -- consistent with the general behavior expected by the ACVC tests - -- which is to scan past junk and then signal data error, see ACVC - -- test CE3704F, case (6), which is for signed integer exponents, - -- which seems a similar case. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr, Loaded); - - if Loaded then - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants - -- for the signed case, and there seems no good reason to treat - -- exponents differently for the signed and unsigned cases. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Modular; - - ------------- - -- Put_LLU -- - ------------- - - procedure Put_LLU - (File : File_Type; - Item : Long_Long_Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLU; - - ------------- - -- Put_Uns -- - ------------- - - procedure Put_Uns - (File : File_Type; - Item : Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_Uns; - - -------------- - -- Puts_LLU -- - -------------- - - procedure Puts_LLU - (To : out String; - Item : Long_Long_Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_LLU; - - -------------- - -- Puts_Uns -- - -------------- - - procedure Puts_Uns - (To : out String; - Item : Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Uns; - -end Ada.Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/libgnat/a-wtmoio.adb b/gcc/ada/libgnat/a-wtmoio.adb index 629f95d..702dcbb 100644 --- a/gcc/ada/libgnat/a-wtmoio.adb +++ b/gcc/ada/libgnat/a-wtmoio.adb @@ -29,19 +29,45 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Wide_Text_IO.Modular_Aux; - -with System.Unsigned_Types; use System.Unsigned_Types; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; +with Ada.Wide_Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Uns; use System.Img_Uns; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLU; use System.Img_LLU; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Uns; use System.Val_Uns; +with System.Val_LLU; use System.Val_LLU; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Text_IO.Modular_IO is + package Aux_Uns is new + Ada.Wide_Text_IO.Integer_Aux + (Unsigned, + Scan_Unsigned, + Set_Image_Unsigned, + Set_Image_Width_Unsigned, + Set_Image_Based_Unsigned); + + package Aux_LLU is new + Ada.Wide_Text_IO.Integer_Aux + (Long_Long_Unsigned, + Scan_Long_Long_Unsigned, + Set_Image_Long_Long_Unsigned, + Set_Image_Width_Long_Long_Unsigned, + Set_Image_Based_Long_Long_Unsigned); + + Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size; + -- Throughout this generic body, we distinguish between the case where type + -- Unsigned is acceptable, and where a Long_Long_Unsigned is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. + subtype TFT is Ada.Wide_Text_IO.File_Type; -- File type required for calls to routines in Aux - package Aux renames Ada.Wide_Text_IO.Modular_Aux; - --------- -- Get -- --------- @@ -51,11 +77,15 @@ package body Ada.Wide_Text_IO.Modular_IO is Item : out Num; Width : Field := 0) is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + begin - if Num'Size > Unsigned'Size then - Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width); + if Need_LLU then + Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width); else - Aux.Get_Uns (TFT (File), Unsigned (Item), Width); + Aux_Uns.Get (TFT (File), Unsigned (Item), Width); end if; exception @@ -75,6 +105,10 @@ package body Ada.Wide_Text_IO.Modular_IO is Item : out Num; Last : out Positive) is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + S : constant String := Wide_String_To_String (From, WCEM_Upper); -- String on which we do the actual conversion. Note that the method -- used for wide character encoding is irrelevant, since if there is @@ -82,10 +116,10 @@ package body Ada.Wide_Text_IO.Modular_IO is -- Aux.Gets will raise Data_Error in any case. begin - if Num'Size > Unsigned'Size then - Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last); + if Need_LLU then + Aux_LLU.Gets (S, Long_Long_Unsigned (Item), Last); else - Aux.Gets_Uns (S, Unsigned (Item), Last); + Aux_Uns.Gets (S, Unsigned (Item), Last); end if; exception @@ -103,10 +137,10 @@ package body Ada.Wide_Text_IO.Modular_IO is Base : Number_Base := Default_Base) is begin - if Num'Size > Unsigned'Size then - Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base); + if Need_LLU then + Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base); else - Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base); + Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base); end if; end Put; @@ -127,10 +161,10 @@ package body Ada.Wide_Text_IO.Modular_IO is S : String (To'First .. To'Last); begin - if Num'Size > Unsigned'Size then - Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base); + if Need_LLU then + Aux_LLU.Puts (S, Long_Long_Unsigned (Item), Base); else - Aux.Puts_Uns (S, Unsigned (Item), Base); + Aux_Uns.Puts (S, Unsigned (Item), Base); end if; for J in S'Range loop diff --git a/gcc/ada/libgnat/a-wtmoio__128.adb b/gcc/ada/libgnat/a-wtmoio__128.adb new file mode 100644 index 0000000..661faec --- /dev/null +++ b/gcc/ada/libgnat/a-wtmoio__128.adb @@ -0,0 +1,197 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Uns; use System.Img_Uns; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLU; use System.Img_LLU; +with System.Img_LLW; use System.Img_LLW; +with System.Img_LLLB; use System.Img_LLLB; +with System.Img_LLLU; use System.Img_LLLU; +with System.Img_LLLW; use System.Img_LLLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Uns; use System.Val_Uns; +with System.Val_LLU; use System.Val_LLU; +with System.Val_LLLU; use System.Val_LLLU; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Modular_IO is + + package Aux_Uns is new + Ada.Wide_Text_IO.Integer_Aux + (Unsigned, + Scan_Unsigned, + Set_Image_Unsigned, + Set_Image_Width_Unsigned, + Set_Image_Based_Unsigned); + + package Aux_LLU is new + Ada.Wide_Text_IO.Integer_Aux + (Long_Long_Unsigned, + Scan_Long_Long_Unsigned, + Set_Image_Long_Long_Unsigned, + Set_Image_Width_Long_Long_Unsigned, + Set_Image_Based_Long_Long_Unsigned); + + package Aux_LLLU is new + Ada.Wide_Text_IO.Integer_Aux + (Long_Long_Long_Unsigned, + Scan_Long_Long_Long_Unsigned, + Set_Image_Long_Long_Long_Unsigned, + Set_Image_Width_Long_Long_Long_Unsigned, + Set_Image_Based_Long_Long_Long_Unsigned); + + Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size; + Need_LLLU : constant Boolean := Num'Base'Size > Long_Long_Unsigned'Size; + -- Throughout this generic body, we distinguish between cases where type + -- Unsigned is acceptable, where type Long_Long_Unsigned is acceptable and + -- where type Long_Long_Long_Unsigned is needed. These boolean constants + -- are used to test for these cases and since they are constant, only code + -- for the relevant case will be included in the instance. + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + + begin + if Need_LLLU then + Aux_LLLU.Get (File, Long_Long_Long_Unsigned (Item), Width); + elsif Need_LLU then + Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width); + else + Aux_Uns.Get (TFT (File), Unsigned (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need_LLLU then + Aux_LLLU.Gets (S, Long_Long_Long_Unsigned (Item), Last); + elsif Need_LLU then + Aux_LLU.Gets (S, Long_Long_Unsigned (Item), Last); + else + Aux_Uns.Gets (S, Unsigned (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLLU then + Aux_LLLU.Put (File, Long_Long_Long_Unsigned (Item), Width, Base); + elsif Need_LLU then + Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base); + else + Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Need_LLLU then + Aux_LLLU.Puts (S, Long_Long_Long_Unsigned (Item), Base); + elsif Need_LLU then + Aux_LLU.Puts (S, Long_Long_Unsigned (Item), Base); + else + Aux_Uns.Puts (S, Unsigned (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/libgnat/a-ztgeau.adb b/gcc/ada/libgnat/a-ztgeau.adb index dbd8926..be7aecc 100644 --- a/gcc/ada/libgnat/a-ztgeau.adb +++ b/gcc/ada/libgnat/a-ztgeau.adb @@ -348,6 +348,60 @@ package body Ada.Wide_Wide_Text_IO.Generic_Aux is Load_Extended_Digits (File, Buf, Ptr, Junk); end Load_Extended_Digits; + ------------------ + -- Load_Integer -- + ------------------ + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + + -- Note: it is a bit strange to allow a minus sign here, but it seems + -- consistent with the general behavior expected by the ACVC tests + -- which is to scan past junk and then signal data error, see ACVC + -- test CE3704F, case (6), which is for signed integer exponents, + -- which seems a similar case. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + + -- Deal with based literal. We recognize either the standard '#' or + -- the allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants + -- for the signed case, and there seems no good reason to treat + -- exponents differently for the signed and unsigned cases. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Integer; + --------------- -- Load_Skip -- --------------- diff --git a/gcc/ada/libgnat/a-ztgeau.ads b/gcc/ada/libgnat/a-ztgeau.ads index 2c5c306..68d4a33 100644 --- a/gcc/ada/libgnat/a-ztgeau.ads +++ b/gcc/ada/libgnat/a-ztgeau.ads @@ -149,6 +149,12 @@ package Ada.Wide_Wide_Text_IO.Generic_Aux is Ptr : in out Integer); -- Same as above, but no indication if character is loaded + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- Loads a possibly signed integer literal value + procedure Put_Item (File : File_Type; Str : String); -- This routine is like Wide_Wide_Text_IO.Put, except that it checks for -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used @@ -169,7 +175,7 @@ package Ada.Wide_Wide_Text_IO.Generic_Aux is procedure String_Skip (Str : String; Ptr : out Integer); -- Used in the Get from string procedures to skip leading blanks in the -- string. Ptr is set to the index of the first non-blank. If the string - -- is all blanks, then the excption End_Error is raised, Note that blank + -- is all blanks, then the exception End_Error is raised, Note that blank -- is defined as a space or horizontal tab (RM A.10.6(5)). procedure Ungetc (ch : Integer; File : File_Type); diff --git a/gcc/ada/libgnat/a-ztinau.adb b/gcc/ada/libgnat/a-ztinau.adb index e7e290e..f7b49a1 100644 --- a/gcc/ada/libgnat/a-ztinau.adb +++ b/gcc/ada/libgnat/a-ztinau.adb @@ -31,61 +31,15 @@ with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; -with System.Img_BIU; use System.Img_BIU; -with System.Img_Int; use System.Img_Int; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLI; use System.Img_LLI; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Int; use System.Val_Int; -with System.Val_LLI; use System.Val_LLI; - package body Ada.Wide_Wide_Text_IO.Integer_Aux is - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load an possibly signed - -- integer literal value from the input file into Buf, starting at Ptr + 1. - -- On return, Ptr is set to the last character stored. - - ------------- - -- Get_Int -- - ------------- - - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field) - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer := 1; - Stop : Integer := 0; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Integer (File, Buf, Stop); - end if; - - Item := Scan_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Int; - - ------------- - -- Get_LLI -- - ------------- + --------- + -- Get -- + --------- - procedure Get_LLI + procedure Get (File : File_Type; - Item : out Long_Long_Integer; + Item : out Num; Width : Field) is Buf : String (1 .. Field'Last); @@ -100,189 +54,73 @@ package body Ada.Wide_Wide_Text_IO.Integer_Aux is Load_Integer (File, Buf, Stop); end if; - Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); + Item := Scan (Buf, Ptr'Access, Stop); Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLI; + end Get; - -------------- - -- Gets_Int -- - -------------- + ---------- + -- Gets -- + ---------- - procedure Gets_Int + procedure Gets (From : String; - Item : out Integer; + Item : out Num; Last : out Positive) is Pos : aliased Integer; begin String_Skip (From, Pos); - Item := Scan_Integer (From, Pos'Access, From'Last); + Item := Scan (From, Pos'Access, From'Last); Last := Pos - 1; exception when Constraint_Error => raise Data_Error; - end Gets_Int; - - -------------- - -- Gets_LLI -- - -------------- - - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLI; - - ------------------ - -- Load_Integer -- - ------------------ - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - Load_Digits (File, Buf, Ptr, Loaded); + end Gets; - if Loaded then + --------- + -- Put -- + --------- - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Integer; - - ------------- - -- Put_Int -- - ------------- - - procedure Put_Int + procedure Put (File : File_Type; - Item : Integer; + Item : Num; Width : Field; Base : Number_Base) is - Buf : String (1 .. Field'Last); + Buf : String (1 .. Integer'Max (Field'Last, Width)); Ptr : Natural := 0; begin if Base = 10 and then Width = 0 then - Set_Image_Integer (Item, Buf, Ptr); + Set_Image (Item, Buf, Ptr); elsif Base = 10 then - Set_Image_Width_Integer (Item, Width, Buf, Ptr); + Set_Image_Width (Item, Width, Buf, Ptr); else - Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); + Set_Image_Based (Item, Base, Width, Buf, Ptr); end if; Put_Item (File, Buf (1 .. Ptr)); - end Put_Int; - - ------------- - -- Put_LLI -- - ------------- - - procedure Put_LLI - (File : File_Type; - Item : Long_Long_Integer; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Integer (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLI; - - -------------- - -- Puts_Int -- - -------------- - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Int; + end Put; - -------------- - -- Puts_LLI -- - -------------- + ---------- + -- Puts -- + ---------- - procedure Puts_LLI + procedure Puts (To : out String; - Item : Long_Long_Integer; + Item : Num; Base : Number_Base) is - Buf : String (1 .. Field'Last); + Buf : String (1 .. Integer'Max (Field'Last, To'Length)); Ptr : Natural := 0; begin if Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); + Set_Image_Width (Item, To'Length, Buf, Ptr); else - Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); + Set_Image_Based (Item, Base, To'Length, Buf, Ptr); end if; if Ptr > To'Length then @@ -290,6 +128,6 @@ package body Ada.Wide_Wide_Text_IO.Integer_Aux is else To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); end if; - end Puts_LLI; + end Puts; end Ada.Wide_Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-ztinau.ads b/gcc/ada/libgnat/a-ztinau.ads index 49eb3c5..914f120 100644 --- a/gcc/ada/libgnat/a-ztinau.ads +++ b/gcc/ada/libgnat/a-ztinau.ads @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X -- -- -- -- S p e c -- -- -- @@ -29,55 +29,45 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines for Ada.Wide_Wide_Text_IO.Integer_IO --- that are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Integer_IO itself, --- except that the generic parameter Num has been replaced by Integer or --- Long_Long_Integer, and the default parameters have been removed because --- they are supplied explicitly by the calls from within the generic template. +-- This package contains implementation for Ada.Wide_Wide.Text_IO.Integer_IO +-- and Ada.Wide_Wide_Text_IO.Modular_IO. The routines in this package are +-- identical semantically to those in Integer_IO and Modular_IO themselves, +-- except that the default parameters have been removed because they are +-- supplied explicitly by the calls from within these units. -private package Ada.Wide_Wide_Text_IO.Integer_Aux is +private generic + type Num is (<>); - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field); + with function Scan + (Str : String; Ptr : not null access Integer; Max : Integer) return Num; + with procedure Set_Image + (V : Num; S : in out String; P : in out Natural); + with procedure Set_Image_Width + (V : Num; W : Integer; S : out String; P : in out Natural); + with procedure Set_Image_Based + (V : Num; B : Natural; W : Integer; S : out String; P : in out Natural); - procedure Get_LLI +package Ada.Wide_Wide_Text_IO.Integer_Aux is + + procedure Get (File : File_Type; - Item : out Long_Long_Integer; + Item : out Num; Width : Field); - procedure Gets_Int + procedure Gets (From : String; - Item : out Integer; + Item : out Num; Last : out Positive); - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive); - - procedure Put_Int + procedure Put (File : File_Type; - Item : Integer; + Item : Num; Width : Field; Base : Number_Base); - procedure Put_LLI - (File : File_Type; - Item : Long_Long_Integer; - Width : Field; - Base : Number_Base); - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base); - - procedure Puts_LLI + procedure Puts (To : out String; - Item : Long_Long_Integer; + Item : Num; Base : Number_Base); end Ada.Wide_Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-ztinio.adb b/gcc/ada/libgnat/a-ztinio.adb index c0726ce..ab8741e 100644 --- a/gcc/ada/libgnat/a-ztinio.adb +++ b/gcc/ada/libgnat/a-ztinio.adb @@ -30,11 +30,35 @@ ------------------------------------------------------------------------------ with Ada.Wide_Wide_Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Int; use System.Img_Int; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLI; use System.Img_LLI; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Int; use System.Val_Int; +with System.Val_LLI; use System.Val_LLI; with System.WCh_Con; use System.WCh_Con; with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Wide_Text_IO.Integer_IO is + package Aux_Int is new + Ada.Wide_Wide_Text_IO.Integer_Aux + (Integer, + Scan_Integer, + Set_Image_Integer, + Set_Image_Width_Integer, + Set_Image_Based_Integer); + + package Aux_LLI is new + Ada.Wide_Wide_Text_IO.Integer_Aux + (Long_Long_Integer, + Scan_Long_Long_Integer, + Set_Image_Long_Long_Integer, + Set_Image_Width_Long_Long_Integer, + Set_Image_Based_Long_Long_Integer); + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; -- Throughout this generic body, we distinguish between the case where type -- Integer is acceptable, and where a Long_Long_Integer is needed. This @@ -44,8 +68,6 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; -- File type required for calls to routines in Aux - package Aux renames Ada.Wide_Wide_Text_IO.Integer_Aux; - --------- -- Get -- --------- @@ -55,11 +77,16 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is Item : out Num; Width : Field := 0) is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + begin if Need_LLI then - Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width); + Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width); else - Aux.Get_Int (TFT (File), Integer (Item), Width); + Aux_Int.Get (TFT (File), Integer (Item), Width); end if; exception @@ -79,6 +106,11 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is Item : out Num; Last : out Positive) is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); -- String on which we do the actual conversion. Note that the method -- used for wide character encoding is irrelevant, since if there is @@ -87,9 +119,9 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is begin if Need_LLI then - Aux.Gets_LLI (S, Long_Long_Integer (Item), Last); + Aux_LLI.Gets (S, Long_Long_Integer (Item), Last); else - Aux.Gets_Int (S, Integer (Item), Last); + Aux_Int.Gets (S, Integer (Item), Last); end if; exception @@ -108,9 +140,9 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is is begin if Need_LLI then - Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base); + Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base); else - Aux.Put_Int (TFT (File), Integer (Item), Width, Base); + Aux_Int.Put (TFT (File), Integer (Item), Width, Base); end if; end Put; @@ -132,9 +164,9 @@ package body Ada.Wide_Wide_Text_IO.Integer_IO is begin if Need_LLI then - Aux.Puts_LLI (S, Long_Long_Integer (Item), Base); + Aux_LLI.Puts (S, Long_Long_Integer (Item), Base); else - Aux.Puts_Int (S, Integer (Item), Base); + Aux_Int.Puts (S, Integer (Item), Base); end if; for J in S'Range loop diff --git a/gcc/ada/libgnat/a-ztinio__128.adb b/gcc/ada/libgnat/a-ztinio__128.adb new file mode 100644 index 0000000..c809eeb --- /dev/null +++ b/gcc/ada/libgnat/a-ztinio__128.adb @@ -0,0 +1,199 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Int; use System.Img_Int; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLI; use System.Img_LLI; +with System.Img_LLW; use System.Img_LLW; +with System.Img_LLLB; use System.Img_LLLB; +with System.Img_LLLI; use System.Img_LLLI; +with System.Img_LLLW; use System.Img_LLLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Int; use System.Val_Int; +with System.Val_LLI; use System.Val_LLI; +with System.Val_LLLI; use System.Val_LLLI; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Integer_IO is + + package Aux_Int is new + Ada.Wide_Wide_Text_IO.Integer_Aux + (Integer, + Scan_Integer, + Set_Image_Integer, + Set_Image_Width_Integer, + Set_Image_Based_Integer); + + package Aux_LLI is new + Ada.Wide_Wide_Text_IO.Integer_Aux + (Long_Long_Integer, + Scan_Long_Long_Integer, + Set_Image_Long_Long_Integer, + Set_Image_Width_Long_Long_Integer, + Set_Image_Based_Long_Long_Integer); + + package Aux_LLLI is new + Ada.Wide_Wide_Text_IO.Integer_Aux + (Long_Long_Long_Integer, + Scan_Long_Long_Long_Integer, + Set_Image_Long_Long_Long_Integer, + Set_Image_Width_Long_Long_Long_Integer, + Set_Image_Based_Long_Long_Long_Integer); + + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; + Need_LLLI : constant Boolean := Num'Base'Size > Long_Long_Integer'Size; + -- Throughout this generic body, we distinguish between cases where type + -- Integer is acceptable, where type Long_Long_Integer is acceptable and + -- where type Long_Long_Long_Integer is needed. These boolean constants + -- are used to test for these cases and since they are constant, only code + -- for the relevant case will be included in the instance. + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + + begin + if Need_LLLI then + Aux_LLLI.Get (TFT (File), Long_Long_Long_Integer (Item), Width); + elsif Need_LLI then + Aux_LLI.Get (TFT (File), Long_Long_Integer (Item), Width); + else + Aux_Int.Get (TFT (File), Integer (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need_LLLI then + Aux_LLLI.Gets (S, Long_Long_Long_Integer (Item), Last); + elsif Need_LLI then + Aux_LLI.Gets (S, Long_Long_Integer (Item), Last); + else + Aux_Int.Gets (S, Integer (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLLI then + Aux_LLLI.Put (TFT (File), Long_Long_Long_Integer (Item), Width, Base); + elsif Need_LLI then + Aux_LLI.Put (TFT (File), Long_Long_Integer (Item), Width, Base); + else + Aux_Int.Put (TFT (File), Integer (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Need_LLLI then + Aux_LLLI.Puts (S, Long_Long_Long_Integer (Item), Base); + elsif Need_LLI then + Aux_LLI.Puts (S, Long_Long_Integer (Item), Base); + else + Aux_Int.Puts (S, Integer (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/libgnat/a-ztmoau.adb b/gcc/ada/libgnat/a-ztmoau.adb deleted file mode 100644 index 2f179e2..0000000 --- a/gcc/ada/libgnat/a-ztmoau.adb +++ /dev/null @@ -1,305 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2020, 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. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; - -with System.Img_BIU; use System.Img_BIU; -with System.Img_Uns; use System.Img_Uns; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLU; use System.Img_LLU; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Uns; use System.Val_Uns; -with System.Val_LLU; use System.Val_LLU; - -package body Ada.Wide_Wide_Text_IO.Modular_Aux is - - use System.Unsigned_Types; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load an possibly signed - -- modular literal value from the input file into Buf, starting at Ptr + 1. - -- Ptr is left set to the last character stored. - - ------------- - -- Get_LLU -- - ------------- - - procedure Get_LLU - (File : File_Type; - Item : out Long_Long_Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLU; - - ------------- - -- Get_Uns -- - ------------- - - procedure Get_Uns - (File : File_Type; - Item : out Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Uns; - - -------------- - -- Gets_LLU -- - -------------- - - procedure Gets_LLU - (From : String; - Item : out Long_Long_Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLU; - - -------------- - -- Gets_Uns -- - -------------- - - procedure Gets_Uns - (From : String; - Item : out Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_Uns; - - ------------------ - -- Load_Modular -- - ------------------ - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - - -- Note: it is a bit strange to allow a minus sign here, but it seems - -- consistent with the general behavior expected by the ACVC tests - -- which is to scan past junk and then signal data error, see ACVC - -- test CE3704F, case (6), which is for signed integer exponents, - -- which seems a similar case. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr, Loaded); - - if Loaded then - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants - -- for the signed case, and there seems no good reason to treat - -- exponents differently for the signed and unsigned cases. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Modular; - - ------------- - -- Put_LLU -- - ------------- - - procedure Put_LLU - (File : File_Type; - Item : Long_Long_Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLU; - - ------------- - -- Put_Uns -- - ------------- - - procedure Put_Uns - (File : File_Type; - Item : Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_Uns; - - -------------- - -- Puts_LLU -- - -------------- - - procedure Puts_LLU - (To : out String; - Item : Long_Long_Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_LLU; - - -------------- - -- Puts_Uns -- - -------------- - - procedure Puts_Uns - (To : out String; - Item : Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Uns; - -end Ada.Wide_Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/libgnat/a-ztmoio.adb b/gcc/ada/libgnat/a-ztmoio.adb index bf9d42b..d2f81e2 100644 --- a/gcc/ada/libgnat/a-ztmoio.adb +++ b/gcc/ada/libgnat/a-ztmoio.adb @@ -29,19 +29,45 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Wide_Wide_Text_IO.Modular_Aux; - -with System.Unsigned_Types; use System.Unsigned_Types; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; +with Ada.Wide_Wide_Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Uns; use System.Img_Uns; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLU; use System.Img_LLU; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Uns; use System.Val_Uns; +with System.Val_LLU; use System.Val_LLU; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; package body Ada.Wide_Wide_Text_IO.Modular_IO is + package Aux_Uns is new + Ada.Wide_Wide_Text_IO.Integer_Aux + (Unsigned, + Scan_Unsigned, + Set_Image_Unsigned, + Set_Image_Width_Unsigned, + Set_Image_Based_Unsigned); + + package Aux_LLU is new + Ada.Wide_Wide_Text_IO.Integer_Aux + (Long_Long_Unsigned, + Scan_Long_Long_Unsigned, + Set_Image_Long_Long_Unsigned, + Set_Image_Width_Long_Long_Unsigned, + Set_Image_Based_Long_Long_Unsigned); + + Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size; + -- Throughout this generic body, we distinguish between the case where type + -- Unsigned is acceptable, and where a Long_Long_Unsigned is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; -- File type required for calls to routines in Aux - package Aux renames Ada.Wide_Wide_Text_IO.Modular_Aux; - --------- -- Get -- --------- @@ -51,11 +77,15 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is Item : out Num; Width : Field := 0) is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + begin - if Num'Size > Unsigned'Size then - Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width); + if Need_LLU then + Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width); else - Aux.Get_Uns (TFT (File), Unsigned (Item), Width); + Aux_Uns.Get (TFT (File), Unsigned (Item), Width); end if; exception @@ -75,6 +105,10 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is Item : out Num; Last : out Positive) is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); -- String on which we do the actual conversion. Note that the method -- used for wide character encoding is irrelevant, since if there is @@ -82,10 +116,10 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is -- Aux.Gets will raise Data_Error in any case. begin - if Num'Size > Unsigned'Size then - Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last); + if Need_LLU then + Aux_LLU.Gets (S, Long_Long_Unsigned (Item), Last); else - Aux.Gets_Uns (S, Unsigned (Item), Last); + Aux_Uns.Gets (S, Unsigned (Item), Last); end if; exception @@ -103,10 +137,10 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is Base : Number_Base := Default_Base) is begin - if Num'Size > Unsigned'Size then - Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base); + if Need_LLU then + Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base); else - Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base); + Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base); end if; end Put; @@ -127,10 +161,10 @@ package body Ada.Wide_Wide_Text_IO.Modular_IO is S : String (To'First .. To'Last); begin - if Num'Size > Unsigned'Size then - Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base); + if Need_LLU then + Aux_LLU.Puts (S, Long_Long_Unsigned (Item), Base); else - Aux.Puts_Uns (S, Unsigned (Item), Base); + Aux_Uns.Puts (S, Unsigned (Item), Base); end if; for J in S'Range loop diff --git a/gcc/ada/libgnat/a-ztmoio__128.adb b/gcc/ada/libgnat/a-ztmoio__128.adb new file mode 100644 index 0000000..e6e11de --- /dev/null +++ b/gcc/ada/libgnat/a-ztmoio__128.adb @@ -0,0 +1,197 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Integer_Aux; +with System.Img_BIU; use System.Img_BIU; +with System.Img_Uns; use System.Img_Uns; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLU; use System.Img_LLU; +with System.Img_LLW; use System.Img_LLW; +with System.Img_LLLB; use System.Img_LLLB; +with System.Img_LLLU; use System.Img_LLLU; +with System.Img_LLLW; use System.Img_LLLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Uns; use System.Val_Uns; +with System.Val_LLU; use System.Val_LLU; +with System.Val_LLLU; use System.Val_LLLU; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Modular_IO is + + package Aux_Uns is new + Ada.Wide_Wide_Text_IO.Integer_Aux + (Unsigned, + Scan_Unsigned, + Set_Image_Unsigned, + Set_Image_Width_Unsigned, + Set_Image_Based_Unsigned); + + package Aux_LLU is new + Ada.Wide_Wide_Text_IO.Integer_Aux + (Long_Long_Unsigned, + Scan_Long_Long_Unsigned, + Set_Image_Long_Long_Unsigned, + Set_Image_Width_Long_Long_Unsigned, + Set_Image_Based_Long_Long_Unsigned); + + package Aux_LLLU is new + Ada.Wide_Wide_Text_IO.Integer_Aux + (Long_Long_Long_Unsigned, + Scan_Long_Long_Long_Unsigned, + Set_Image_Long_Long_Long_Unsigned, + Set_Image_Width_Long_Long_Long_Unsigned, + Set_Image_Based_Long_Long_Long_Unsigned); + + Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size; + Need_LLLU : constant Boolean := Num'Base'Size > Long_Long_Unsigned'Size; + -- Throughout this generic body, we distinguish between cases where type + -- Unsigned is acceptable, where type Long_Long_Unsigned is acceptable and + -- where type Long_Long_Long_Unsigned is needed. These boolean constants + -- are used to test for these cases and since they are constant, only code + -- for the relevant case will be included in the instance. + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + + begin + if Need_LLLU then + Aux_LLLU.Get (File, Long_Long_Long_Unsigned (Item), Width); + elsif Need_LLU then + Aux_LLU.Get (TFT (File), Long_Long_Unsigned (Item), Width); + else + Aux_Uns.Get (TFT (File), Unsigned (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need_LLLU then + Aux_LLLU.Gets (S, Long_Long_Long_Unsigned (Item), Last); + elsif Need_LLU then + Aux_LLU.Gets (S, Long_Long_Unsigned (Item), Last); + else + Aux_Uns.Gets (S, Unsigned (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLLU then + Aux_LLLU.Put (File, Long_Long_Long_Unsigned (Item), Width, Base); + elsif Need_LLU then + Aux_LLU.Put (TFT (File), Long_Long_Unsigned (Item), Width, Base); + else + Aux_Uns.Put (TFT (File), Unsigned (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Need_LLLU then + Aux_LLLU.Puts (S, Long_Long_Long_Unsigned (Item), Base); + elsif Need_LLU then + Aux_LLU.Puts (S, Long_Long_Unsigned (Item), Base); + else + Aux_Uns.Puts (S, Unsigned (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/libgnat/g-arrspl.adb b/gcc/ada/libgnat/g-arrspl.adb index e6f0d99..8770030 100644 --- a/gcc/ada/libgnat/g-arrspl.adb +++ b/gcc/ada/libgnat/g-arrspl.adb @@ -49,7 +49,7 @@ package body GNAT.Array_Split is -- Adjust -- ------------ - procedure Adjust (S : in out Slice_Set) is + overriding procedure Adjust (S : in out Slice_Set) is begin S.D.Ref_Counter := S.D.Ref_Counter + 1; end Adjust; @@ -68,6 +68,16 @@ package body GNAT.Array_Split is Create (S, From, To_Set (Separators), Mode); end Create; + function Create + (From : Element_Sequence; + Separators : Element_Sequence; + Mode : Separator_Mode := Single) return Slice_Set is + begin + return Ret : Slice_Set do + Create (Ret, From, Separators, Mode); + end return; + end Create; + ------------ -- Create -- ------------ @@ -85,6 +95,16 @@ package body GNAT.Array_Split is S := Result; end Create; + function Create + (From : Element_Sequence; + Separators : Element_Set; + Mode : Separator_Mode := Single) return Slice_Set is + begin + return Ret : Slice_Set do + Create (Ret, From, Separators, Mode); + end return; + end Create; + ----------- -- Count -- ----------- @@ -108,7 +128,7 @@ package body GNAT.Array_Split is -- Finalize -- -------------- - procedure Finalize (S : in out Slice_Set) is + overriding procedure Finalize (S : in out Slice_Set) is procedure Free is new Ada.Unchecked_Deallocation (Element_Sequence, Element_Access); @@ -139,7 +159,7 @@ package body GNAT.Array_Split is -- Initialize -- ---------------- - procedure Initialize (S : in out Slice_Set) is + overriding procedure Initialize (S : in out Slice_Set) is begin S.D := new Data'(1, null, 0, null, null); end Initialize; diff --git a/gcc/ada/libgnat/g-arrspl.ads b/gcc/ada/libgnat/g-arrspl.ads index 3383f40..099d499 100644 --- a/gcc/ada/libgnat/g-arrspl.ads +++ b/gcc/ada/libgnat/g-arrspl.ads @@ -72,7 +72,12 @@ package GNAT.Array_Split is -- separator and no empty slice is created. ); - type Slice_Set is private; + type Slice_Set is private + with Iterable => (First => First_Cursor, + Next => Advance, + Has_Element => Has_Element, + Element => Slice); + -- This type uses by-reference semantics. This is a set of slices as -- returned by Create or Set routines below. The abstraction represents -- a set of items. Each item is a part of the original array named a @@ -85,6 +90,10 @@ package GNAT.Array_Split is From : Element_Sequence; Separators : Element_Sequence; Mode : Separator_Mode := Single); + function Create + (From : Element_Sequence; + Separators : Element_Sequence; + Mode : Separator_Mode := Single) return Slice_Set; -- Create a cut array object. From is the source array, and Separators -- is a sequence of Element along which to split the array. The source -- array is sliced at separator boundaries. The separators are not @@ -99,6 +108,10 @@ package GNAT.Array_Split is From : Element_Sequence; Separators : Element_Set; Mode : Separator_Mode := Single); + function Create + (From : Element_Sequence; + Separators : Element_Set; + Mode : Separator_Mode := Single) return Slice_Set; -- Same as above but using a Element_Set procedure Set @@ -117,14 +130,21 @@ package GNAT.Array_Split is type Slice_Number is new Natural; -- Type used to count number of slices - function Slice_Count (S : Slice_Set) return Slice_Number; - pragma Inline (Slice_Count); + function Slice_Count (S : Slice_Set) return Slice_Number with Inline; -- Returns the number of slices (fields) in S + function First_Cursor (Unused : Slice_Set) return Slice_Number is (1); + function Advance + (Unused : Slice_Set; Position : Slice_Number) return Slice_Number + is (Position + 1); + function Has_Element + (Cont : Slice_Set; Position : Slice_Number) return Boolean + is (Position <= Slice_Count (Cont)); + -- Functions used to iterate over a Slice_Set + function Slice (S : Slice_Set; - Index : Slice_Number) return Element_Sequence; - pragma Inline (Slice); + Index : Slice_Number) return Element_Sequence with Inline; -- Returns the slice at position Index. First slice is 1. If Index is 0 -- the whole array is returned including the separators (this is the -- original source array). @@ -184,8 +204,8 @@ private D : Data_Access; end record; - procedure Initialize (S : in out Slice_Set); - procedure Adjust (S : in out Slice_Set); - procedure Finalize (S : in out Slice_Set); + overriding procedure Initialize (S : in out Slice_Set); + overriding procedure Adjust (S : in out Slice_Set); + overriding procedure Finalize (S : in out Slice_Set); end GNAT.Array_Split; diff --git a/gcc/ada/libgnat/g-debpoo.ads b/gcc/ada/libgnat/g-debpoo.ads index ed000fa..88cffe8 100644 --- a/gcc/ada/libgnat/g-debpoo.ads +++ b/gcc/ada/libgnat/g-debpoo.ads @@ -299,7 +299,7 @@ package GNAT.Debug_Pools is -- If Valid is True, Size_In_Storage_Elements is set to the size of this -- chunk of memory. - type Byte_Count is mod System.Max_Binary_Modulus; + type Byte_Count is mod 2 ** Long_Long_Integer'Size; -- Type used for maintaining byte counts, needs to be large enough to -- to accommodate counts allowing for repeated use of the same memory. diff --git a/gcc/ada/libgnat/g-sechas.ads b/gcc/ada/libgnat/g-sechas.ads index 2edc2e3..566a696 100644 --- a/gcc/ada/libgnat/g-sechas.ads +++ b/gcc/ada/libgnat/g-sechas.ads @@ -218,7 +218,9 @@ package GNAT.Secure_Hashes is -- HMAC key end record; + pragma Warnings (Off, "aggregate not fully initialized"); Initial_Context : constant Context (KL => 0) := (others => <>); + pragma Warnings (On, "aggregate not fully initialized"); -- Initial values are provided by default initialization of Context type Hash_Stream (C : access Context) is diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb index 719d9a9..57a8800 100644 --- a/gcc/ada/libgnat/g-socket.adb +++ b/gcc/ada/libgnat/g-socket.adb @@ -186,10 +186,6 @@ package body GNAT.Sockets is else Value); -- Removes dot at the end of error message - procedure Raise_Socket_Error (Error : Integer); - -- Raise Socket_Error with an exception message describing the error code - -- from errno. - procedure Raise_Host_Error (H_Error : Integer; Name : String); -- Raise Host_Error exception with message describing error code (note -- hstrerror seems to be obsolete) from h_errno. Name is the name diff --git a/gcc/ada/libgnat/g-socket.ads b/gcc/ada/libgnat/g-socket.ads index 9167241..bf78777 100644 --- a/gcc/ada/libgnat/g-socket.ads +++ b/gcc/ada/libgnat/g-socket.ads @@ -449,10 +449,10 @@ package GNAT.Sockets is type Selector_Status is (Completed, Expired, Aborted); -- Completion status of a selector operation, indicated as follows: - -- Complete: one of the expected events occurred - -- Expired: no event occurred before the expiration of the timeout - -- Aborted: an external action cancelled the wait operation before - -- any event occurred. + -- Completed: one of the expected events occurred + -- Expired: no event occurred before the expiration of the timeout + -- Aborted: an external action cancelled the wait operation before + -- any event occurred. Socket_Error : exception; -- There is only one exception in this package to deal with an error during @@ -1573,4 +1573,8 @@ private Wait_For_A_Full_Reception : constant Request_Flag_Type := 4; Send_End_Of_Record : constant Request_Flag_Type := 8; + procedure Raise_Socket_Error (Error : Integer); + -- Raise Socket_Error with an exception message describing the error code + -- from errno. + end GNAT.Sockets; diff --git a/gcc/ada/libgnat/g-socpol.adb b/gcc/ada/libgnat/g-socpol.adb new file mode 100644 index 0000000..ab3286c --- /dev/null +++ b/gcc/ada/libgnat/g-socpol.adb @@ -0,0 +1,430 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . P O L L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +with GNAT.Sockets.Thin; + +package body GNAT.Sockets.Poll is + + To_C : constant array (Wait_Event_Type) of Events_Type := + (Input => SOC.POLLIN or SOC.POLLPRI, Output => SOC.POLLOUT); + -- To convert Wait_Event_Type to C I/O events flags + + procedure Set_Mode (Item : out Pollfd; Mode : Wait_Event_Set); + -- Set I/O waiting mode on Item + + procedure Set_Event + (Item : out Pollfd; Event : Wait_Event_Type; Value : Boolean); + -- Set or reset waiting state on I/O event + + procedure Check_Range (Self : Set; Index : Positive) with Inline; + -- raise Constraint_Error if Index is more than number of sockets in Self + + function Status (Item : Pollfd) return Event_Set is + (Input => (Item.REvents and To_C (Input)) /= 0, + Output => (Item.REvents and To_C (Output)) /= 0, + Error => (Item.REvents and SOC.POLLERR) /= 0, + Hang_Up => (Item.REvents and SOC.POLLHUP) /= 0, + Invalid_Request => (Item.REvents and SOC.POLLNVAL) /= 0); + -- Get I/O events from C word + + procedure Wait + (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer); + -- Waits until one or more of the sockets descriptors become ready for some + -- class of I/O operation or error state occurs on one or more of them. + -- Timeout is in milliseconds. Result mean how many sockets ready for I/O + -- or have error state. + + ---------- + -- Wait -- + ---------- + + procedure Wait + (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer) + is separate; + + ------------ + -- Create -- + ------------ + + function Create (Size : Positive) return Set is + begin + return Result : Set (Size); + end Create; + + ------------ + -- To_Set -- + ------------ + + function To_Set + (Socket : Socket_Type; + Events : Wait_Event_Set; + Size : Positive := 1) return Set is + begin + return Result : Set (Size) do + Append (Result, Socket, Events); + end return; + end To_Set; + + ------------ + -- Append -- + ------------ + + procedure Append + (Self : in out Set; Socket : Socket_Type; Events : Wait_Event_Set) is + begin + Insert (Self, Socket, Events, Self.Length + 1); + end Append; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Self : in out Set; + Socket : Socket_Type; + Events : Wait_Event_Set; + Index : Positive; + Keep_Order : Boolean := False) is + begin + if Self.Size <= Self.Length then + raise Constraint_Error with "Socket set is full"; + + elsif Index > Self.Length + 1 then + raise Constraint_Error with "Insert out of range"; + end if; + + if Socket < 0 then + raise Socket_Error with + "Wrong socket descriptor " & Socket_Type'Image (Socket); + end if; + + Self.Length := Self.Length + 1; + + if Index /= Self.Length then + if Keep_Order then + Self.Fds (Index + 1 .. Self.Length) := + Self.Fds (Index .. Self.Length - 1); + else + Self.Fds (Self.Length) := Self.Fds (Index); + end if; + + Self.Fds (Index).Events := 0; + end if; + + Self.Fds (Index).Socket := FD_Type (Socket); + Set_Mode (Self.Fds (Index), Events); + + if FD_Type (Socket) > Self.Max_FD then + Self.Max_FD := FD_Type (Socket); + Self.Max_OK := True; + end if; + end Insert; + + ----------------- + -- Check_Range -- + ----------------- + + procedure Check_Range (Self : Set; Index : Positive) is + begin + if Index > Self.Length then + raise Constraint_Error; + end if; + end Check_Range; + + ---------- + -- Copy -- + ---------- + + procedure Copy (Source : Set; Target : out Set) is + begin + if Target.Size < Source.Length then + raise Constraint_Error with + "Can't copy because size of target less than source length"; + end if; + + Target.Fds (1 .. Source.Length) := Source.Fds (1 .. Source.Length); + + Target.Length := Source.Length; + Target.Max_FD := Source.Max_FD; + Target.Max_OK := Source.Max_OK; + end Copy; + + ---------------- + -- Get_Events -- + ---------------- + + function Get_Events + (Self : Set; Index : Positive) return Wait_Event_Set is + begin + Check_Range (Self, Index); + return + (Input => (Self.Fds (Index).Events and To_C (Input)) /= 0, + Output => (Self.Fds (Index).Events and To_C (Output)) /= 0); + end Get_Events; + + ------------ + -- Growth -- + ------------ + + function Growth (Self : Set) return Set is + begin + return Resize + (Self, + (case Self.Size is + when 1 .. 20 => 32, + when 21 .. 50 => 64, + when 51 .. 99 => Self.Size + Self.Size / 3, + when others => Self.Size + Self.Size / 4)); + end Growth; + + ------------ + -- Remove -- + ------------ + + procedure Remove + (Self : in out Set; Index : Positive; Keep_Order : Boolean := False) is + begin + Check_Range (Self, Index); + + if Self.Max_FD = Self.Fds (Index).Socket then + Self.Max_OK := False; + end if; + + if Index < Self.Length then + if Keep_Order then + Self.Fds (Index .. Self.Length - 1) := + Self.Fds (Index + 1 .. Self.Length); + else + Self.Fds (Index) := Self.Fds (Self.Length); + end if; + end if; + + Self.Length := Self.Length - 1; + end Remove; + + ------------ + -- Resize -- + ------------ + + function Resize (Self : Set; Size : Positive) return Set is + begin + return Result : Set (Size) do + Copy (Self, Result); + end return; + end Resize; + + --------------- + -- Set_Event -- + --------------- + + procedure Set_Event + (Self : in out Set; + Index : Positive; + Event : Wait_Event_Type; + Value : Boolean) is + begin + Check_Range (Self, Index); + Set_Event (Self.Fds (Index), Event, Value); + end Set_Event; + + procedure Set_Event + (Item : out Pollfd; Event : Wait_Event_Type; Value : Boolean) is + begin + if Value then + Item.Events := Item.Events or To_C (Event); + else + Item.Events := Item.Events and not To_C (Event); + end if; + end Set_Event; + + ---------------- + -- Set_Events -- + ---------------- + + procedure Set_Events + (Self : in out Set; + Index : Positive; + Events : Wait_Event_Set) is + begin + Check_Range (Self, Index); + Set_Mode (Self.Fds (Index), Events); + end Set_Events; + + -------------- + -- Set_Mode -- + -------------- + + procedure Set_Mode (Item : out Pollfd; Mode : Wait_Event_Set) is + begin + for J in Mode'Range loop + Set_Event (Item, J, Mode (J)); + end loop; + end Set_Mode; + + ------------ + -- Socket -- + ------------ + + function Socket (Self : Set; Index : Positive) return Socket_Type is + begin + Check_Range (Self, Index); + return Socket_Type (Self.Fds (Index).Socket); + end Socket; + + ----------- + -- State -- + ----------- + + procedure State + (Self : Set; + Index : Positive; + Socket : out Socket_Type; + Status : out Event_Set) is + begin + Check_Range (Self, Index); + Socket := Socket_Type (Self.Fds (Index).Socket); + Status := Poll.Status (Self.Fds (Index)); + end State; + + ---------- + -- Wait -- + ---------- + + procedure Wait (Self : in out Set; Timeout : Duration; Count : out Natural) + is + use Ada.Calendar; + -- Used to calculate partially consumed timeout on EINTR. + -- Better to use Ada.Real_Time, but we can't in current GNAT because + -- Ada.Real_Time is in tasking part of runtime. + + Result : Integer; + Poll_Timeout : Duration := Timeout; + C_Timeout : Interfaces.C.int; + Errno : Integer; + Stamp : constant Time := Clock; + begin + if Self.Length = 0 then + Count := 0; + return; + end if; + + loop + if Poll_Timeout >= Duration (Interfaces.C.int'Last - 8) / 1_000 then + -- Minus 8 is to workaround Linux kernel 2.6.24 bug with close to + -- Integer'Last poll timeout values. + -- syscall (SYS_poll, &ufds, 1, 2147483644); // is waiting + -- syscall (SYS_poll, &ufds, 1, 2147483645); // is not waiting + -- Timeout values close to maximum could be not safe because of + -- possible time conversion boundary errors in the kernel. + -- Use unlimited timeout instead of maximum 24 days timeout for + -- safety reasons. + + C_Timeout := -1; + else + C_Timeout := Interfaces.C.int (Poll_Timeout * 1_000); + end if; + + Wait (Self, C_Timeout, Result); + + exit when Result >= 0; + + Errno := Thin.Socket_Errno; + + -- In case of EINTR error we have to continue waiting for network + -- events. + + if Errno = SOC.EINTR then + if C_Timeout >= 0 then + Poll_Timeout := Timeout - (Clock - Stamp); + + if Poll_Timeout < 0.0 then + Count := 0; + return; + + elsif Poll_Timeout > Timeout then + -- Clock moved back in time. This should not be happen when + -- we use monotonic time. + + Poll_Timeout := Timeout; + end if; + end if; + + else + Raise_Socket_Error (Errno); + end if; + end loop; + + Count := Result; + end Wait; + + ---------- + -- Next -- + ---------- + + procedure Next (Self : Set; Index : in out Natural) is + begin + loop + Index := Index + 1; + + if Index > Self.Length then + Index := 0; + return; + + elsif Self.Fds (Index).REvents /= 0 then + return; + end if; + end loop; + end Next; + + ------------ + -- Status -- + ------------ + + function Status (Self : Set; Index : Positive) return Event_Set is + begin + Check_Range (Self, Index); + return Status (Self.Fds (Index)); + end Status; + + -------------- + -- C_Status -- + -------------- + + function C_Status + (Self : Set; Index : Positive) return Interfaces.C.unsigned is + begin + Check_Range (Self, Index); + return Interfaces.C.unsigned (Self.Fds (Index).REvents); + end C_Status; + +end GNAT.Sockets.Poll; diff --git a/gcc/ada/libgnat/g-socpol.ads b/gcc/ada/libgnat/g-socpol.ads new file mode 100644 index 0000000..c03c578 --- /dev/null +++ b/gcc/ada/libgnat/g-socpol.ads @@ -0,0 +1,216 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . P O L L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface to wait for one of a set of sockets to +-- become ready to perform I/O. + +with System.OS_Constants; + +package GNAT.Sockets.Poll is + + type Event_Type is (Input, Output, Error, Hang_Up, Invalid_Request); + -- I/O events we can expect on socket. + -- Input - socket ready to read; + -- Output - socket available for write; + -- Error - socket is in error state; + -- Hang_Up - peer closed; + -- Invalid_Request - invalid socket; + + type Event_Set is array (Event_Type) of Boolean; + -- The type to get results on events waiting + + subtype Wait_Event_Type is Event_Type range Input .. Output; + type Wait_Event_Set is array (Wait_Event_Type) of Boolean; + -- The type to set events to wait. Note that Error event would be waited + -- anyway. + + ------------------------------- + -- Predefined set of events -- + ------------------------------- + + Input_Event : constant Wait_Event_Set; + -- Wait for input availability only + + Output_Event : constant Wait_Event_Set; + -- Wait for output availability only + + Both_Events : constant Wait_Event_Set; + -- Wait for Input and Output availability + + Error_Event : constant Wait_Event_Set; + -- Wait only for error state on socket + + type Set (Size : Positive) is private; + -- Set of sockets with I/O event set to wait on + + function Create (Size : Positive) return Set; + -- Create empty socket set with defined size + + function To_Set + (Socket : Socket_Type; + Events : Wait_Event_Set; + Size : Positive := 1) return Set; + -- Create socket set and put the Socket there at the first place. + -- Events parameter is defining what state of the socket we are going to + -- wait. + + procedure Append + (Self : in out Set; + Socket : Socket_Type; + Events : Wait_Event_Set); + -- Add Socket and its I/O waiting state at the end of Self + + procedure Insert + (Self : in out Set; + Socket : Socket_Type; + Events : Wait_Event_Set; + Index : Positive; + Keep_Order : Boolean := False); + -- Insert Socket and its I/O waiting state at the Index position. + -- If Keep_Order is True then all next elements moved to the next index up. + -- Otherwise the old element from Index moved to the end of the Self set. + + procedure Remove + (Self : in out Set; Index : Positive; Keep_Order : Boolean := False); + -- Remove socket from Index. If Keep_Order is True then move all next + -- elements after removed one to previous index. If Keep_Order is False + -- then move the last element on place of the removed one. + + procedure Set_Event + (Self : in out Set; + Index : Positive; + Event : Wait_Event_Type; + Value : Boolean); + -- Set I/O waiting event to Value for the socket at Index position + + procedure Set_Events + (Self : in out Set; + Index : Positive; + Events : Wait_Event_Set); + -- Set I/O waiting events for the socket at Index position + + function Get_Events + (Self : Set; Index : Positive) return Wait_Event_Set; + -- Get I/O waiting events for the socket at Index position + + function Length (Self : Set) return Natural; + -- Get the number of sockets currently in the Self set + + function Full (Self : Set) return Boolean; + -- Return True if there is no more space in the Self set for new sockets + + procedure Wait (Self : in out Set; Timeout : Duration; Count : out Natural); + -- Wait no longer than Timeout on the socket set for the I/O events. + -- Count output parameter is the number of elements in the Self set are + -- detected for I/O events. Zero Count mean timeout on wait. + -- The iteration over activated elements in set could be done with routine + -- Next. The kind of I/O events on element could be cheched with State or + -- Status routines. + + procedure Next (Self : Set; Index : in out Natural); + -- Iterate over set looking for the next index with active I/O event state. + -- Put 0 initially into Index. Each iteration increments Index and then + -- checks for state. End of iterations can be detected by 0 in the Index. + + procedure Copy (Source : Set; Target : out Set); + -- Copy sockets and its I/O waiting events from Source set into Target + + function Resize (Self : Set; Size : Positive) return Set; + -- Returns the copy of Source with modified Size + + function Growth (Self : Set) return Set; + -- Returns the copy of Source with increased Size + + function Socket (Self : Set; Index : Positive) return Socket_Type; + -- Returns the Socket from Index position + + function Status (Self : Set; Index : Positive) return Event_Set; + -- Returns I/O events detected in previous Wait call at Index position + + procedure State + (Self : Set; + Index : Positive; + Socket : out Socket_Type; + Status : out Event_Set); + -- Returns Socket and its I/O events detected in previous Wait call at + -- Index position. + + function C_Status + (Self : Set; Index : Positive) return Interfaces.C.unsigned; + -- Return word with I/O events detected flags in previous Wait call at + -- Index position. Possible flags are defined in System.OS_Constants names + -- starting with POLL prefix. + +private + + Input_Event : constant Wait_Event_Set := (Input => True, Output => False); + Output_Event : constant Wait_Event_Set := (Input => False, Output => True); + Both_Events : constant Wait_Event_Set := (others => True); + Error_Event : constant Wait_Event_Set := (others => False); + + package SOC renames System.OS_Constants; + + type nfds_t is mod 2 ** SOC.SIZEOF_nfds_t; + for nfds_t'Size use SOC.SIZEOF_nfds_t; + + FD_Type_Bound : constant := 2 ** (SOC.SIZEOF_fd_type - 1); + + type FD_Type is range -FD_Type_Bound .. FD_Type_Bound - 1; + for FD_Type'Size use SOC.SIZEOF_fd_type; + + type Events_Type is mod 2 ** SOC.SIZEOF_pollfd_events; + for Events_Type'Size use SOC.SIZEOF_pollfd_events; + + type Pollfd is record + Socket : FD_Type; + Events : Events_Type := 0; + REvents : Events_Type := 0; + end record with Convention => C; + + type Poll_Set is array (Positive range <>) of Pollfd with Convention => C; + + type Set (Size : Positive) is record + Length : Natural := 0; + Max_FD : FD_Type := 0; + Max_OK : Boolean; + -- Is the Max_FD actual. It can became inactual after remove socket with + -- Max_FD from set and became actual again after add socket with FD more + -- than Max_FD. + Fds : Poll_Set (1 .. Size); + end record; + + function Length (Self : Set) return Natural + is (Self.Length); + + function Full (Self : Set) return Boolean + is (Self.Size = Self.Length); + +end GNAT.Sockets.Poll; diff --git a/gcc/ada/libgnat/a-numaux__dummy.adb b/gcc/ada/libgnat/g-socpol__dummy.adb index f5d72ec..01c7cc5 100644 --- a/gcc/ada/libgnat/a-numaux__dummy.adb +++ b/gcc/ada/libgnat/g-socpol__dummy.adb @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME COMPONENTS -- +-- GNAT COMPILER COMPONENTS -- -- -- --- A D A . N U M E R I C S . A U X -- +-- G N A T . S O C K E T S . P O L L -- -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 2020, 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/libgnat/g-socpol__dummy.ads b/gcc/ada/libgnat/g-socpol__dummy.ads new file mode 100644 index 0000000..507471e --- /dev/null +++ b/gcc/ada/libgnat/g-socpol__dummy.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . P O L L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is a placeholder for the sockets binding for platforms where +-- it is not implemented. + +package GNAT.Sockets.Thin_Common is + pragma Unimplemented_Unit; +end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/libgnat/g-socthi__mingw.adb b/gcc/ada/libgnat/g-socthi__mingw.adb index f63a6cb..dd8a68c 100644 --- a/gcc/ada/libgnat/g-socthi__mingw.adb +++ b/gcc/ada/libgnat/g-socthi__mingw.adb @@ -375,13 +375,10 @@ package body GNAT.Sockets.Thin is Exceptfds : access Fd_Set; Timeout : Timeval_Access) return C.int is - pragma Warnings (Off, Exceptfds); - - Original_WFS : aliased constant Fd_Set := Writefds.all; - - Res : C.int; - S : aliased C.int; - Last : aliased C.int; + Original_WFS : aliased Fd_Set; + Res : C.int; + S : aliased C.int; + Last : aliased C.int; begin -- Asynchronous connection failures are notified in the exception fd @@ -392,7 +389,8 @@ package body GNAT.Sockets.Thin is -- present in the initial write fd set, then move the socket from the -- exception fd set to the write fd set. - if Writefds /= No_Fd_Set_Access then + if Writefds /= null then + Original_WFS := Writefds.all; -- Add any socket present in write fd set into exception fd set @@ -411,7 +409,7 @@ package body GNAT.Sockets.Thin is Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout); - if Exceptfds /= No_Fd_Set_Access then + if Exceptfds /= null then declare EFSC : aliased Fd_Set := Exceptfds.all; Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB; @@ -448,8 +446,8 @@ package body GNAT.Sockets.Thin is -- exception fd set back to write fd set. Otherwise, ignore -- this event since the user is not watching for it. - if Writefds /= No_Fd_Set_Access - and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0) + if Writefds /= null + and then Is_Socket_In_Set (Original_WFS'Access, S) /= 0 then Insert_Socket_In_Set (Writefds, S); end if; @@ -457,6 +455,7 @@ package body GNAT.Sockets.Thin is end loop; end; end if; + return Res; end C_Select; diff --git a/gcc/ada/libgnat/g-sopowa.adb b/gcc/ada/libgnat/g-sopowa.adb new file mode 100644 index 0000000..fc6e6d9 --- /dev/null +++ b/gcc/ada/libgnat/g-sopowa.adb @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . P O L L . W A I T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Wait implementation on top of native poll call +-- +-- This submodule can be used on systems where poll system call is natively +-- supported. Microsoft Windows supports WSAPoll system call from Vista +-- version and this submodule can be used on such Windows versions too, the +-- System.OS_Constants.Poll_Linkname constant defines appropriate link name +-- for Windows. But we do not use WSAPoll in GNAT.Sockets.Poll implementation +-- for now because it is much slower than select system call, at least in +-- Windows version 10.0.18363.1016. + +separate (GNAT.Sockets.Poll) + +procedure Wait + (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer) +is + + function Poll + (Fds : Poll_Set; + Nfds : nfds_t; + Timeout : Interfaces.C.int) return Integer + with Import, Convention => Stdcall, External_Name => SOC.Poll_Linkname; + +begin + Result := Poll (Fds.Fds, nfds_t (Fds.Length), Timeout); +end Wait; diff --git a/gcc/ada/libgnat/g-sopowa__mingw.adb b/gcc/ada/libgnat/g-sopowa__mingw.adb new file mode 100644 index 0000000..3d66437 --- /dev/null +++ b/gcc/ada/libgnat/g-sopowa__mingw.adb @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . P O L L . W A I T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Wait implementation on top of Windows select call +-- +-- Microsoft Windows from Vista version has WSAPoll function in API which is +-- similar to POSIX poll call, but experiments show that the WSAPoll is much +-- slower than select at least in Windows version 10.0.18363.1016. + +with GNAT.Sockets.Poll.G_Wait; + +separate (GNAT.Sockets.Poll) + +procedure Wait + (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer) +is + use Interfaces; + + type FD_Array is array (1 .. Fds.Length) of FD_Type + with Convention => C; + + type FD_Set_Type is record + Count : C.int; + Set : FD_Array; + end record with Convention => C; + + procedure Reset_Socket_Set (Set : in out FD_Set_Type) with Inline; + + procedure Insert_Socket_In_Set (Set : in out FD_Set_Type; FD : FD_Type) + with Inline; + + function Is_Socket_In_Set (Set : FD_Set_Type; FD : FD_Type) return C.int + with Import, Convention => C, + External_Name => "__gnat_is_socket_in_set"; + + -------------------------- + -- Insert_Socket_In_Set -- + -------------------------- + + procedure Insert_Socket_In_Set (Set : in out FD_Set_Type; FD : FD_Type) is + begin + Set.Count := Set.Count + 1; + Set.Set (Integer (Set.Count)) := FD; + end Insert_Socket_In_Set; + + ---------------------- + -- Reset_Socket_Set -- + ---------------------- + + procedure Reset_Socket_Set (Set : in out FD_Set_Type) is + begin + Set.Count := 0; + end Reset_Socket_Set; + + ---------- + -- Poll -- + ---------- + + procedure Poll is new G_Wait + (FD_Set_Type, Reset_Socket_Set, Insert_Socket_In_Set, Is_Socket_In_Set); + +begin + Poll (Fds, Timeout, Result); +end Wait; diff --git a/gcc/ada/libgnat/g-sopowa__posix.adb b/gcc/ada/libgnat/g-sopowa__posix.adb new file mode 100644 index 0000000..02ccb77 --- /dev/null +++ b/gcc/ada/libgnat/g-sopowa__posix.adb @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . P O L L . W A I T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Wait implementation on top of posix select call + +with GNAT.Sockets.Poll.G_Wait; + +separate (GNAT.Sockets.Poll) + +procedure Wait + (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer) +is + use Interfaces; + + function Get_Max_FD return FD_Type; + -- Check is Max_FD is actual and correct it if necessary + + type FD_Set_Type is array (0 .. Get_Max_FD / C.long'Size) of C.long + with Convention => C; + + procedure Reset_Socket_Set (Set : in out FD_Set_Type); + -- Use own FD_ZERO routine because FD_Set_Type size depend on Fds.Max_FD + + procedure Insert_Socket_In_Set (Set : in out FD_Set_Type; FD : FD_Type) + with Import, Convention => C, + External_Name => "__gnat_insert_socket_in_set"; + + function Is_Socket_In_Set (Set : FD_Set_Type; FD : FD_Type) return C.int + with Import, Convention => C, + External_Name => "__gnat_is_socket_in_set"; + + procedure Reset_Socket_Set (Set : in out FD_Set_Type) is + begin + Set := (others => 0); + end Reset_Socket_Set; + + procedure Poll is new G_Wait + (FD_Set_Type, Reset_Socket_Set, Insert_Socket_In_Set, Is_Socket_In_Set); + + ---------------- + -- Get_Max_FD -- + ---------------- + + function Get_Max_FD return FD_Type is + begin + if not Fds.Max_OK then + Fds.Max_FD := Fds.Fds (Fds.Fds'First).Socket; + + for J in Fds.Fds'First + 1 .. Fds.Length loop + if Fds.Max_FD < Fds.Fds (J).Socket then + Fds.Max_FD := Fds.Fds (J).Socket; + end if; + end loop; + + Fds.Max_OK := True; + end if; + + return Fds.Max_FD; + end Get_Max_FD; + +begin + Poll (Fds, Timeout, Result); +end Wait; diff --git a/gcc/ada/libgnat/g-spogwa.adb b/gcc/ada/libgnat/g-spogwa.adb new file mode 100644 index 0000000..a9135ea --- /dev/null +++ b/gcc/ada/libgnat/g-spogwa.adb @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . P O L L . G _ W A I T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Sockets.Thin_Common; + +procedure GNAT.Sockets.Poll.G_Wait + (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer) +is + use Interfaces; + + use type C.int; + + function C_Select + (Nfds : C.int; + readfds : access FD_Set_Type; + writefds : access FD_Set_Type; + exceptfds : access FD_Set_Type; + timeout : access Thin_Common.Timeval) return Integer + with Import => True, Convention => Stdcall, External_Name => "select"; + + Timeout_V : aliased Thin_Common.Timeval; + Timeout_A : access Thin_Common.Timeval; + + Rfds : aliased FD_Set_Type; + Rcount : Natural := 0; + Wfds : aliased FD_Set_Type; + Wcount : Natural := 0; + Efds : aliased FD_Set_Type; + + Rfdsa : access FD_Set_Type; + Wfdsa : access FD_Set_Type; + + FD_Events : Events_Type; + +begin + -- Setup (convert data from poll to select layout) + + if Timeout >= 0 then + Timeout_A := Timeout_V'Access; + Timeout_V.tv_sec := Thin_Common.time_t (Timeout / 1000); + Timeout_V.tv_usec := Thin_Common.suseconds_t (Timeout rem 1000 * 1000); + end if; + + Reset_Socket_Set (Rfds); + Reset_Socket_Set (Wfds); + Reset_Socket_Set (Efds); + + for J in Fds.Fds'First .. Fds.Length loop + Fds.Fds (J).REvents := 0; + + FD_Events := Fds.Fds (J).Events; + + if (FD_Events and (SOC.POLLIN or SOC.POLLPRI)) /= 0 then + Insert_Socket_In_Set (Rfds, Fds.Fds (J).Socket); + Rcount := Rcount + 1; + end if; + + if (FD_Events and SOC.POLLOUT) /= 0 then + Insert_Socket_In_Set (Wfds, Fds.Fds (J).Socket); + Wcount := Wcount + 1; + end if; + + Insert_Socket_In_Set (Efds, Fds.Fds (J).Socket); + + if Fds.Fds (J).Socket > Fds.Max_FD then + raise Program_Error with "Wrong Max_FD"; + end if; + end loop; + + -- Any non-null descriptor set must contain at least one handle + -- to a socket on Windows (MSDN). + + if Rcount /= 0 then + Rfdsa := Rfds'Access; + end if; + + if Wcount /= 0 then + Wfdsa := Wfds'Access; + end if; + + -- Call OS select + + Result := + C_Select (C.int (Fds.Max_FD + 1), Rfdsa, Wfdsa, Efds'Access, Timeout_A); + + -- Build result (convert back from select to poll layout) + + if Result > 0 then + Result := 0; + + for J in Fds.Fds'First .. Fds.Length loop + if Is_Socket_In_Set (Rfds, Fds.Fds (J).Socket) /= 0 then + -- Do not need "or" with Poll_Ptr (J).REvents because it's zero + + Fds.Fds (J).REvents := SOC.POLLIN; + end if; + + if Is_Socket_In_Set (Wfds, Fds.Fds (J).Socket) /= 0 then + Fds.Fds (J).REvents := Fds.Fds (J).REvents or SOC.POLLOUT; + end if; + + if Is_Socket_In_Set (Efds, Fds.Fds (J).Socket) /= 0 then + Fds.Fds (J).REvents := Fds.Fds (J).REvents or SOC.POLLERR; + end if; + + if Fds.Fds (J).REvents /= 0 then + Result := Result + 1; + end if; + end loop; + end if; +end GNAT.Sockets.Poll.G_Wait; diff --git a/gcc/ada/libgnat/g-spogwa.ads b/gcc/ada/libgnat/g-spogwa.ads new file mode 100644 index 0000000..bde6a69 --- /dev/null +++ b/gcc/ada/libgnat/g-spogwa.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . P O L L . G _ W A I T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C; + +private generic + type FD_Set_Type is private; + with procedure Reset_Socket_Set (Set : in out FD_Set_Type); + with procedure Insert_Socket_In_Set + (Set : in out FD_Set_Type; FD : FD_Type); + with function Is_Socket_In_Set + (Set : FD_Set_Type; FD : FD_Type) return Interfaces.C.int; +procedure GNAT.Sockets.Poll.G_Wait + (Fds : in out Set; Timeout : Interfaces.C.int; Result : out Integer); +-- Common code to implement GNAT.Sockets.Poll.Wait routine on top of posix or +-- win32 select API. +-- Posix and Win32 select has the same API but different socket set structure. +-- C API for select has socket set size defined at compilation stage. This Ada +-- implementation allow to define size of socket set at the execution time. +-- Unlike C select API we do not need allocate socket set for maximum number +-- of sockets when we need to check only few of them. And we are not limited +-- with FD_SETSIZE when we need more sockets to check. diff --git a/gcc/ada/libgnat/i-cexten__128.ads b/gcc/ada/libgnat/i-cexten__128.ads new file mode 100644 index 0000000..0c049f3 --- /dev/null +++ b/gcc/ada/libgnat/i-cexten__128.ads @@ -0,0 +1,851 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . E X T E N S I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains additional C-related definitions, intended for use +-- with either manually or automatically generated bindings to C libraries. + +with System; + +package Interfaces.C.Extensions is + pragma Pure; + + -- Definitions for C "void" and "void *" types + + subtype void is System.Address; + subtype void_ptr is System.Address; + + -- Definitions for C incomplete/unknown structs + + subtype opaque_structure_def is System.Address; + type opaque_structure_def_ptr is access opaque_structure_def; + for opaque_structure_def_ptr'Storage_Size use 0; + + -- Definitions for C++ incomplete/unknown classes + + subtype incomplete_class_def is System.Address; + type incomplete_class_def_ptr is access incomplete_class_def; + for incomplete_class_def_ptr'Storage_Size use 0; + + -- C bool + + type bool is new Boolean; + pragma Convention (C, bool); + + -- 64-bit integer types + + subtype long_long is Interfaces.C.long_long; + subtype unsigned_long_long is Interfaces.C.unsigned_long_long; + + -- 128-bit floating-point type available on x86: + -- typedef float float_128 __attribute__ ((mode (TF))); + + type Float_128 is record + low, high : unsigned_long_long; + end record; + pragma Convention (C_Pass_By_Copy, Float_128); + for Float_128'Alignment use unsigned_long_long'Alignment * 2; + + -- 128-bit complex floating-point type available on x86: + -- typedef _Complex float cfloat_128 __attribute__ ((mode (TC))); + + type CFloat_128 is record + re, im : Float_128; + end record; + pragma Convention (C_Pass_By_Copy, CFloat_128); + + -- Types for bitfields + + type Unsigned_1 is mod 2 ** 1; + for Unsigned_1'Size use 1; + + type Unsigned_2 is mod 2 ** 2; + for Unsigned_2'Size use 2; + + type Unsigned_3 is mod 2 ** 3; + for Unsigned_3'Size use 3; + + type Unsigned_4 is mod 2 ** 4; + for Unsigned_4'Size use 4; + + type Unsigned_5 is mod 2 ** 5; + for Unsigned_5'Size use 5; + + type Unsigned_6 is mod 2 ** 6; + for Unsigned_6'Size use 6; + + type Unsigned_7 is mod 2 ** 7; + for Unsigned_7'Size use 7; + + type Unsigned_8 is mod 2 ** 8; + for Unsigned_8'Size use 8; + + type Unsigned_9 is mod 2 ** 9; + for Unsigned_9'Size use 9; + + type Unsigned_10 is mod 2 ** 10; + for Unsigned_10'Size use 10; + + type Unsigned_11 is mod 2 ** 11; + for Unsigned_11'Size use 11; + + type Unsigned_12 is mod 2 ** 12; + for Unsigned_12'Size use 12; + + type Unsigned_13 is mod 2 ** 13; + for Unsigned_13'Size use 13; + + type Unsigned_14 is mod 2 ** 14; + for Unsigned_14'Size use 14; + + type Unsigned_15 is mod 2 ** 15; + for Unsigned_15'Size use 15; + + type Unsigned_16 is mod 2 ** 16; + for Unsigned_16'Size use 16; + + type Unsigned_17 is mod 2 ** 17; + for Unsigned_17'Size use 17; + + type Unsigned_18 is mod 2 ** 18; + for Unsigned_18'Size use 18; + + type Unsigned_19 is mod 2 ** 19; + for Unsigned_19'Size use 19; + + type Unsigned_20 is mod 2 ** 20; + for Unsigned_20'Size use 20; + + type Unsigned_21 is mod 2 ** 21; + for Unsigned_21'Size use 21; + + type Unsigned_22 is mod 2 ** 22; + for Unsigned_22'Size use 22; + + type Unsigned_23 is mod 2 ** 23; + for Unsigned_23'Size use 23; + + type Unsigned_24 is mod 2 ** 24; + for Unsigned_24'Size use 24; + + type Unsigned_25 is mod 2 ** 25; + for Unsigned_25'Size use 25; + + type Unsigned_26 is mod 2 ** 26; + for Unsigned_26'Size use 26; + + type Unsigned_27 is mod 2 ** 27; + for Unsigned_27'Size use 27; + + type Unsigned_28 is mod 2 ** 28; + for Unsigned_28'Size use 28; + + type Unsigned_29 is mod 2 ** 29; + for Unsigned_29'Size use 29; + + type Unsigned_30 is mod 2 ** 30; + for Unsigned_30'Size use 30; + + type Unsigned_31 is mod 2 ** 31; + for Unsigned_31'Size use 31; + + type Unsigned_32 is mod 2 ** 32; + for Unsigned_32'Size use 32; + + type Unsigned_33 is mod 2 ** 33; + for Unsigned_33'Size use 33; + + type Unsigned_34 is mod 2 ** 34; + for Unsigned_34'Size use 34; + + type Unsigned_35 is mod 2 ** 35; + for Unsigned_35'Size use 35; + + type Unsigned_36 is mod 2 ** 36; + for Unsigned_36'Size use 36; + + type Unsigned_37 is mod 2 ** 37; + for Unsigned_37'Size use 37; + + type Unsigned_38 is mod 2 ** 38; + for Unsigned_38'Size use 38; + + type Unsigned_39 is mod 2 ** 39; + for Unsigned_39'Size use 39; + + type Unsigned_40 is mod 2 ** 40; + for Unsigned_40'Size use 40; + + type Unsigned_41 is mod 2 ** 41; + for Unsigned_41'Size use 41; + + type Unsigned_42 is mod 2 ** 42; + for Unsigned_42'Size use 42; + + type Unsigned_43 is mod 2 ** 43; + for Unsigned_43'Size use 43; + + type Unsigned_44 is mod 2 ** 44; + for Unsigned_44'Size use 44; + + type Unsigned_45 is mod 2 ** 45; + for Unsigned_45'Size use 45; + + type Unsigned_46 is mod 2 ** 46; + for Unsigned_46'Size use 46; + + type Unsigned_47 is mod 2 ** 47; + for Unsigned_47'Size use 47; + + type Unsigned_48 is mod 2 ** 48; + for Unsigned_48'Size use 48; + + type Unsigned_49 is mod 2 ** 49; + for Unsigned_49'Size use 49; + + type Unsigned_50 is mod 2 ** 50; + for Unsigned_50'Size use 50; + + type Unsigned_51 is mod 2 ** 51; + for Unsigned_51'Size use 51; + + type Unsigned_52 is mod 2 ** 52; + for Unsigned_52'Size use 52; + + type Unsigned_53 is mod 2 ** 53; + for Unsigned_53'Size use 53; + + type Unsigned_54 is mod 2 ** 54; + for Unsigned_54'Size use 54; + + type Unsigned_55 is mod 2 ** 55; + for Unsigned_55'Size use 55; + + type Unsigned_56 is mod 2 ** 56; + for Unsigned_56'Size use 56; + + type Unsigned_57 is mod 2 ** 57; + for Unsigned_57'Size use 57; + + type Unsigned_58 is mod 2 ** 58; + for Unsigned_58'Size use 58; + + type Unsigned_59 is mod 2 ** 59; + for Unsigned_59'Size use 59; + + type Unsigned_60 is mod 2 ** 60; + for Unsigned_60'Size use 60; + + type Unsigned_61 is mod 2 ** 61; + for Unsigned_61'Size use 61; + + type Unsigned_62 is mod 2 ** 62; + for Unsigned_62'Size use 62; + + type Unsigned_63 is mod 2 ** 63; + for Unsigned_63'Size use 63; + + type Unsigned_64 is mod 2 ** 64; + for Unsigned_64'Size use 64; + + type Unsigned_65 is mod 2 ** 65; + for Unsigned_65'Size use 65; + + type Unsigned_66 is mod 2 ** 66; + for Unsigned_66'Size use 66; + + type Unsigned_67 is mod 2 ** 67; + for Unsigned_67'Size use 67; + + type Unsigned_68 is mod 2 ** 68; + for Unsigned_68'Size use 68; + + type Unsigned_69 is mod 2 ** 69; + for Unsigned_69'Size use 69; + + type Unsigned_70 is mod 2 ** 70; + for Unsigned_70'Size use 70; + + type Unsigned_71 is mod 2 ** 71; + for Unsigned_71'Size use 71; + + type Unsigned_72 is mod 2 ** 72; + for Unsigned_72'Size use 72; + + type Unsigned_73 is mod 2 ** 73; + for Unsigned_73'Size use 73; + + type Unsigned_74 is mod 2 ** 74; + for Unsigned_74'Size use 74; + + type Unsigned_75 is mod 2 ** 75; + for Unsigned_75'Size use 75; + + type Unsigned_76 is mod 2 ** 76; + for Unsigned_76'Size use 76; + + type Unsigned_77 is mod 2 ** 77; + for Unsigned_77'Size use 77; + + type Unsigned_78 is mod 2 ** 78; + for Unsigned_78'Size use 78; + + type Unsigned_79 is mod 2 ** 79; + for Unsigned_79'Size use 79; + + type Unsigned_80 is mod 2 ** 80; + for Unsigned_80'Size use 80; + + type Unsigned_81 is mod 2 ** 81; + for Unsigned_81'Size use 81; + + type Unsigned_82 is mod 2 ** 82; + for Unsigned_82'Size use 82; + + type Unsigned_83 is mod 2 ** 83; + for Unsigned_83'Size use 83; + + type Unsigned_84 is mod 2 ** 84; + for Unsigned_84'Size use 84; + + type Unsigned_85 is mod 2 ** 85; + for Unsigned_85'Size use 85; + + type Unsigned_86 is mod 2 ** 86; + for Unsigned_86'Size use 86; + + type Unsigned_87 is mod 2 ** 87; + for Unsigned_87'Size use 87; + + type Unsigned_88 is mod 2 ** 88; + for Unsigned_88'Size use 88; + + type Unsigned_89 is mod 2 ** 89; + for Unsigned_89'Size use 89; + + type Unsigned_90 is mod 2 ** 90; + for Unsigned_90'Size use 90; + + type Unsigned_91 is mod 2 ** 91; + for Unsigned_91'Size use 91; + + type Unsigned_92 is mod 2 ** 92; + for Unsigned_92'Size use 92; + + type Unsigned_93 is mod 2 ** 93; + for Unsigned_93'Size use 93; + + type Unsigned_94 is mod 2 ** 94; + for Unsigned_94'Size use 94; + + type Unsigned_95 is mod 2 ** 95; + for Unsigned_95'Size use 95; + + type Unsigned_96 is mod 2 ** 96; + for Unsigned_96'Size use 96; + + type Unsigned_97 is mod 2 ** 97; + for Unsigned_97'Size use 97; + + type Unsigned_98 is mod 2 ** 98; + for Unsigned_98'Size use 98; + + type Unsigned_99 is mod 2 ** 99; + for Unsigned_99'Size use 99; + + type Unsigned_100 is mod 2 ** 100; + for Unsigned_100'Size use 100; + + type Unsigned_101 is mod 2 ** 101; + for Unsigned_101'Size use 101; + + type Unsigned_102 is mod 2 ** 102; + for Unsigned_102'Size use 102; + + type Unsigned_103 is mod 2 ** 103; + for Unsigned_103'Size use 103; + + type Unsigned_104 is mod 2 ** 104; + for Unsigned_104'Size use 104; + + type Unsigned_105 is mod 2 ** 105; + for Unsigned_105'Size use 105; + + type Unsigned_106 is mod 2 ** 106; + for Unsigned_106'Size use 106; + + type Unsigned_107 is mod 2 ** 107; + for Unsigned_107'Size use 107; + + type Unsigned_108 is mod 2 ** 108; + for Unsigned_108'Size use 108; + + type Unsigned_109 is mod 2 ** 109; + for Unsigned_109'Size use 109; + + type Unsigned_110 is mod 2 ** 110; + for Unsigned_110'Size use 110; + + type Unsigned_111 is mod 2 ** 111; + for Unsigned_111'Size use 111; + + type Unsigned_112 is mod 2 ** 112; + for Unsigned_112'Size use 112; + + type Unsigned_113 is mod 2 ** 113; + for Unsigned_113'Size use 113; + + type Unsigned_114 is mod 2 ** 114; + for Unsigned_114'Size use 114; + + type Unsigned_115 is mod 2 ** 115; + for Unsigned_115'Size use 115; + + type Unsigned_116 is mod 2 ** 116; + for Unsigned_116'Size use 116; + + type Unsigned_117 is mod 2 ** 117; + for Unsigned_117'Size use 117; + + type Unsigned_118 is mod 2 ** 118; + for Unsigned_118'Size use 118; + + type Unsigned_119 is mod 2 ** 119; + for Unsigned_119'Size use 119; + + type Unsigned_120 is mod 2 ** 120; + for Unsigned_120'Size use 120; + + type Unsigned_121 is mod 2 ** 121; + for Unsigned_121'Size use 121; + + type Unsigned_122 is mod 2 ** 122; + for Unsigned_122'Size use 122; + + type Unsigned_123 is mod 2 ** 123; + for Unsigned_123'Size use 123; + + type Unsigned_124 is mod 2 ** 124; + for Unsigned_124'Size use 124; + + type Unsigned_125 is mod 2 ** 125; + for Unsigned_125'Size use 125; + + type Unsigned_126 is mod 2 ** 126; + for Unsigned_126'Size use 126; + + type Unsigned_127 is mod 2 ** 127; + for Unsigned_127'Size use 127; + + type Unsigned_128 is mod 2 ** 128; + for Unsigned_128'Size use 128; + + type Signed_2 is range -2 ** 1 .. 2 ** 1 - 1; + for Signed_2'Size use 2; + + type Signed_3 is range -2 ** 2 .. 2 ** 2 - 1; + for Signed_3'Size use 3; + + type Signed_4 is range -2 ** 3 .. 2 ** 3 - 1; + for Signed_4'Size use 4; + + type Signed_5 is range -2 ** 4 .. 2 ** 4 - 1; + for Signed_5'Size use 5; + + type Signed_6 is range -2 ** 5 .. 2 ** 5 - 1; + for Signed_6'Size use 6; + + type Signed_7 is range -2 ** 6 .. 2 ** 6 - 1; + for Signed_7'Size use 7; + + type Signed_8 is range -2 ** 7 .. 2 ** 7 - 1; + for Signed_8'Size use 8; + + type Signed_9 is range -2 ** 8 .. 2 ** 8 - 1; + for Signed_9'Size use 9; + + type Signed_10 is range -2 ** 9 .. 2 ** 9 - 1; + for Signed_10'Size use 10; + + type Signed_11 is range -2 ** 10 .. 2 ** 10 - 1; + for Signed_11'Size use 11; + + type Signed_12 is range -2 ** 11 .. 2 ** 11 - 1; + for Signed_12'Size use 12; + + type Signed_13 is range -2 ** 12 .. 2 ** 12 - 1; + for Signed_13'Size use 13; + + type Signed_14 is range -2 ** 13 .. 2 ** 13 - 1; + for Signed_14'Size use 14; + + type Signed_15 is range -2 ** 14 .. 2 ** 14 - 1; + for Signed_15'Size use 15; + + type Signed_16 is range -2 ** 15 .. 2 ** 15 - 1; + for Signed_16'Size use 16; + + type Signed_17 is range -2 ** 16 .. 2 ** 16 - 1; + for Signed_17'Size use 17; + + type Signed_18 is range -2 ** 17 .. 2 ** 17 - 1; + for Signed_18'Size use 18; + + type Signed_19 is range -2 ** 18 .. 2 ** 18 - 1; + for Signed_19'Size use 19; + + type Signed_20 is range -2 ** 19 .. 2 ** 19 - 1; + for Signed_20'Size use 20; + + type Signed_21 is range -2 ** 20 .. 2 ** 20 - 1; + for Signed_21'Size use 21; + + type Signed_22 is range -2 ** 21 .. 2 ** 21 - 1; + for Signed_22'Size use 22; + + type Signed_23 is range -2 ** 22 .. 2 ** 22 - 1; + for Signed_23'Size use 23; + + type Signed_24 is range -2 ** 23 .. 2 ** 23 - 1; + for Signed_24'Size use 24; + + type Signed_25 is range -2 ** 24 .. 2 ** 24 - 1; + for Signed_25'Size use 25; + + type Signed_26 is range -2 ** 25 .. 2 ** 25 - 1; + for Signed_26'Size use 26; + + type Signed_27 is range -2 ** 26 .. 2 ** 26 - 1; + for Signed_27'Size use 27; + + type Signed_28 is range -2 ** 27 .. 2 ** 27 - 1; + for Signed_28'Size use 28; + + type Signed_29 is range -2 ** 28 .. 2 ** 28 - 1; + for Signed_29'Size use 29; + + type Signed_30 is range -2 ** 29 .. 2 ** 29 - 1; + for Signed_30'Size use 30; + + type Signed_31 is range -2 ** 30 .. 2 ** 30 - 1; + for Signed_31'Size use 31; + + type Signed_32 is range -2 ** 31 .. 2 ** 31 - 1; + for Signed_32'Size use 32; + + type Signed_33 is range -2 ** 32 .. 2 ** 32 - 1; + for Signed_33'Size use 33; + + type Signed_34 is range -2 ** 33 .. 2 ** 33 - 1; + for Signed_34'Size use 34; + + type Signed_35 is range -2 ** 34 .. 2 ** 34 - 1; + for Signed_35'Size use 35; + + type Signed_36 is range -2 ** 35 .. 2 ** 35 - 1; + for Signed_36'Size use 36; + + type Signed_37 is range -2 ** 36 .. 2 ** 36 - 1; + for Signed_37'Size use 37; + + type Signed_38 is range -2 ** 37 .. 2 ** 37 - 1; + for Signed_38'Size use 38; + + type Signed_39 is range -2 ** 38 .. 2 ** 38 - 1; + for Signed_39'Size use 39; + + type Signed_40 is range -2 ** 39 .. 2 ** 39 - 1; + for Signed_40'Size use 40; + + type Signed_41 is range -2 ** 40 .. 2 ** 40 - 1; + for Signed_41'Size use 41; + + type Signed_42 is range -2 ** 41 .. 2 ** 41 - 1; + for Signed_42'Size use 42; + + type Signed_43 is range -2 ** 42 .. 2 ** 42 - 1; + for Signed_43'Size use 43; + + type Signed_44 is range -2 ** 43 .. 2 ** 43 - 1; + for Signed_44'Size use 44; + + type Signed_45 is range -2 ** 44 .. 2 ** 44 - 1; + for Signed_45'Size use 45; + + type Signed_46 is range -2 ** 45 .. 2 ** 45 - 1; + for Signed_46'Size use 46; + + type Signed_47 is range -2 ** 46 .. 2 ** 46 - 1; + for Signed_47'Size use 47; + + type Signed_48 is range -2 ** 47 .. 2 ** 47 - 1; + for Signed_48'Size use 48; + + type Signed_49 is range -2 ** 48 .. 2 ** 48 - 1; + for Signed_49'Size use 49; + + type Signed_50 is range -2 ** 49 .. 2 ** 49 - 1; + for Signed_50'Size use 50; + + type Signed_51 is range -2 ** 50 .. 2 ** 50 - 1; + for Signed_51'Size use 51; + + type Signed_52 is range -2 ** 51 .. 2 ** 51 - 1; + for Signed_52'Size use 52; + + type Signed_53 is range -2 ** 52 .. 2 ** 52 - 1; + for Signed_53'Size use 53; + + type Signed_54 is range -2 ** 53 .. 2 ** 53 - 1; + for Signed_54'Size use 54; + + type Signed_55 is range -2 ** 54 .. 2 ** 54 - 1; + for Signed_55'Size use 55; + + type Signed_56 is range -2 ** 55 .. 2 ** 55 - 1; + for Signed_56'Size use 56; + + type Signed_57 is range -2 ** 56 .. 2 ** 56 - 1; + for Signed_57'Size use 57; + + type Signed_58 is range -2 ** 57 .. 2 ** 57 - 1; + for Signed_58'Size use 58; + + type Signed_59 is range -2 ** 58 .. 2 ** 58 - 1; + for Signed_59'Size use 59; + + type Signed_60 is range -2 ** 59 .. 2 ** 59 - 1; + for Signed_60'Size use 60; + + type Signed_61 is range -2 ** 60 .. 2 ** 60 - 1; + for Signed_61'Size use 61; + + type Signed_62 is range -2 ** 61 .. 2 ** 61 - 1; + for Signed_62'Size use 62; + + type Signed_63 is range -2 ** 62 .. 2 ** 62 - 1; + for Signed_63'Size use 63; + + type Signed_64 is range -2 ** 63 .. 2 ** 63 - 1; + for Signed_64'Size use 64; + + type Signed_65 is range -2 ** 64 .. 2 ** 64 - 1; + for Signed_65'Size use 65; + + type Signed_66 is range -2 ** 65 .. 2 ** 65 - 1; + for Signed_66'Size use 66; + + type Signed_67 is range -2 ** 66 .. 2 ** 66 - 1; + for Signed_67'Size use 67; + + type Signed_68 is range -2 ** 67 .. 2 ** 67 - 1; + for Signed_68'Size use 68; + + type Signed_69 is range -2 ** 68 .. 2 ** 68 - 1; + for Signed_69'Size use 69; + + type Signed_70 is range -2 ** 69 .. 2 ** 69 - 1; + for Signed_70'Size use 70; + + type Signed_71 is range -2 ** 70 .. 2 ** 70 - 1; + for Signed_71'Size use 71; + + type Signed_72 is range -2 ** 71 .. 2 ** 71 - 1; + for Signed_72'Size use 72; + + type Signed_73 is range -2 ** 72 .. 2 ** 72 - 1; + for Signed_73'Size use 73; + + type Signed_74 is range -2 ** 73 .. 2 ** 73 - 1; + for Signed_74'Size use 74; + + type Signed_75 is range -2 ** 74 .. 2 ** 74 - 1; + for Signed_75'Size use 75; + + type Signed_76 is range -2 ** 75 .. 2 ** 75 - 1; + for Signed_76'Size use 76; + + type Signed_77 is range -2 ** 76 .. 2 ** 76 - 1; + for Signed_77'Size use 77; + + type Signed_78 is range -2 ** 77 .. 2 ** 77 - 1; + for Signed_78'Size use 78; + + type Signed_79 is range -2 ** 78 .. 2 ** 78 - 1; + for Signed_79'Size use 79; + + type Signed_80 is range -2 ** 79 .. 2 ** 79 - 1; + for Signed_80'Size use 80; + + type Signed_81 is range -2 ** 80 .. 2 ** 80 - 1; + for Signed_81'Size use 81; + + type Signed_82 is range -2 ** 81 .. 2 ** 81 - 1; + for Signed_82'Size use 82; + + type Signed_83 is range -2 ** 82 .. 2 ** 82 - 1; + for Signed_83'Size use 83; + + type Signed_84 is range -2 ** 83 .. 2 ** 83 - 1; + for Signed_84'Size use 84; + + type Signed_85 is range -2 ** 84 .. 2 ** 84 - 1; + for Signed_85'Size use 85; + + type Signed_86 is range -2 ** 85 .. 2 ** 85 - 1; + for Signed_86'Size use 86; + + type Signed_87 is range -2 ** 86 .. 2 ** 86 - 1; + for Signed_87'Size use 87; + + type Signed_88 is range -2 ** 87 .. 2 ** 87 - 1; + for Signed_88'Size use 88; + + type Signed_89 is range -2 ** 88 .. 2 ** 88 - 1; + for Signed_89'Size use 89; + + type Signed_90 is range -2 ** 89 .. 2 ** 89 - 1; + for Signed_90'Size use 90; + + type Signed_91 is range -2 ** 90 .. 2 ** 90 - 1; + for Signed_91'Size use 91; + + type Signed_92 is range -2 ** 91 .. 2 ** 91 - 1; + for Signed_92'Size use 92; + + type Signed_93 is range -2 ** 92 .. 2 ** 92 - 1; + for Signed_93'Size use 93; + + type Signed_94 is range -2 ** 93 .. 2 ** 93 - 1; + for Signed_94'Size use 94; + + type Signed_95 is range -2 ** 94 .. 2 ** 94 - 1; + for Signed_95'Size use 95; + + type Signed_96 is range -2 ** 95 .. 2 ** 95 - 1; + for Signed_96'Size use 96; + + type Signed_97 is range -2 ** 96 .. 2 ** 96 - 1; + for Signed_97'Size use 97; + + type Signed_98 is range -2 ** 97 .. 2 ** 97 - 1; + for Signed_98'Size use 98; + + type Signed_99 is range -2 ** 98 .. 2 ** 98 - 1; + for Signed_99'Size use 99; + + type Signed_100 is range -2 ** 99 .. 2 ** 99 - 1; + for Signed_100'Size use 100; + + type Signed_101 is range -2 ** 100 .. 2 ** 100 - 1; + for Signed_101'Size use 101; + + type Signed_102 is range -2 ** 101 .. 2 ** 101 - 1; + for Signed_102'Size use 102; + + type Signed_103 is range -2 ** 102 .. 2 ** 102 - 1; + for Signed_103'Size use 103; + + type Signed_104 is range -2 ** 103 .. 2 ** 103 - 1; + for Signed_104'Size use 104; + + type Signed_105 is range -2 ** 104 .. 2 ** 104 - 1; + for Signed_105'Size use 105; + + type Signed_106 is range -2 ** 105 .. 2 ** 105 - 1; + for Signed_106'Size use 106; + + type Signed_107 is range -2 ** 106 .. 2 ** 106 - 1; + for Signed_107'Size use 107; + + type Signed_108 is range -2 ** 107 .. 2 ** 107 - 1; + for Signed_108'Size use 108; + + type Signed_109 is range -2 ** 108 .. 2 ** 108 - 1; + for Signed_109'Size use 109; + + type Signed_110 is range -2 ** 109 .. 2 ** 109 - 1; + for Signed_110'Size use 110; + + type Signed_111 is range -2 ** 110 .. 2 ** 110 - 1; + for Signed_111'Size use 111; + + type Signed_112 is range -2 ** 111 .. 2 ** 111 - 1; + for Signed_112'Size use 112; + + type Signed_113 is range -2 ** 112 .. 2 ** 112 - 1; + for Signed_113'Size use 113; + + type Signed_114 is range -2 ** 113 .. 2 ** 113 - 1; + for Signed_114'Size use 114; + + type Signed_115 is range -2 ** 114 .. 2 ** 114 - 1; + for Signed_115'Size use 115; + + type Signed_116 is range -2 ** 115 .. 2 ** 115 - 1; + for Signed_116'Size use 116; + + type Signed_117 is range -2 ** 116 .. 2 ** 116 - 1; + for Signed_117'Size use 117; + + type Signed_118 is range -2 ** 117 .. 2 ** 117 - 1; + for Signed_118'Size use 118; + + type Signed_119 is range -2 ** 118 .. 2 ** 118 - 1; + for Signed_119'Size use 119; + + type Signed_120 is range -2 ** 119 .. 2 ** 119 - 1; + for Signed_120'Size use 120; + + type Signed_121 is range -2 ** 120 .. 2 ** 120 - 1; + for Signed_121'Size use 121; + + type Signed_122 is range -2 ** 121 .. 2 ** 121 - 1; + for Signed_122'Size use 122; + + type Signed_123 is range -2 ** 122 .. 2 ** 122 - 1; + for Signed_123'Size use 123; + + type Signed_124 is range -2 ** 123 .. 2 ** 123 - 1; + for Signed_124'Size use 124; + + type Signed_125 is range -2 ** 124 .. 2 ** 124 - 1; + for Signed_125'Size use 125; + + type Signed_126 is range -2 ** 125 .. 2 ** 125 - 1; + for Signed_126'Size use 126; + + type Signed_127 is range -2 ** 126 .. 2 ** 126 - 1; + for Signed_127'Size use 127; + + type Signed_128 is range -2 ** 127 .. 2 ** 127 - 1; + for Signed_128'Size use 128; + +end Interfaces.C.Extensions; diff --git a/gcc/ada/libgnat/interfac.ads b/gcc/ada/libgnat/interfac.ads index 9fe7aac..9e7dfba 100644 --- a/gcc/ada/libgnat/interfac.ads +++ b/gcc/ada/libgnat/interfac.ads @@ -33,6 +33,8 @@ -- -- ------------------------------------------------------------------------------ +-- This is the compiler version of this unit + pragma Compiler_Unit_Warning; package Interfaces is diff --git a/gcc/ada/libgnat/interfac__2020.ads b/gcc/ada/libgnat/interfac__2020.ads new file mode 100644 index 0000000..2865fc2 --- /dev/null +++ b/gcc/ada/libgnat/interfac__2020.ads @@ -0,0 +1,231 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2020, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the implementation dependent sections of this file. -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the runtime version of this unit (not used during GNAT build) + +package Interfaces is + pragma No_Elaboration_Code_All; + pragma Pure; + + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + + type Integer_8 is range -2 ** 7 .. 2 ** 7 - 1; + for Integer_8'Size use 8; + + type Integer_16 is range -2 ** 15 .. 2 ** 15 - 1; + for Integer_16'Size use 16; + + type Integer_32 is range -2 ** 31 .. 2 ** 31 - 1; + for Integer_32'Size use 32; + + type Integer_64 is new Long_Long_Integer; + for Integer_64'Size use 64; + -- Note: we use Long_Long_Integer'First instead of -2 ** 63 to allow this + -- unit to compile when using custom target configuration files where the + -- maximum integer is 32 bits. This is useful for static analysis tools + -- such as SPARK or CodePeer. In the normal case Long_Long_Integer is + -- always 64-bits so we get the desired 64-bit type. + + type Integer_128 is new Long_Long_Long_Integer; + -- Note: we use Long_Long_Long_Integer instead of literal bounds to allow + -- this unit to be compiled with compilers not supporting 128-bit integers. + -- We do not put a confirming size clause of 128 bits for the same reason. + + type Unsigned_8 is mod 2 ** 8; + for Unsigned_8'Size use 8; + + type Unsigned_16 is mod 2 ** 16; + for Unsigned_16'Size use 16; + + type Unsigned_24 is mod 2 ** 24; + for Unsigned_24'Size use 24; + -- Declare this type for compatibility with legacy Ada compilers. + -- This is particularly useful in the context of CodePeer analysis. + + type Unsigned_32 is mod 2 ** 32; + for Unsigned_32'Size use 32; + + type Unsigned_64 is mod 2 ** Long_Long_Integer'Size; + for Unsigned_64'Size use 64; + -- See comment on Integer_64 above + + type Unsigned_128 is mod 2 ** Long_Long_Long_Integer'Size; + -- See comment on Integer_128 above + + function Shift_Left + (Value : Unsigned_8; + Amount : Natural) return Unsigned_8 + with Import, Convention => Intrinsic, Static; + + function Shift_Right + (Value : Unsigned_8; + Amount : Natural) return Unsigned_8 + with Import, Convention => Intrinsic, Static; + + function Shift_Right_Arithmetic + (Value : Unsigned_8; + Amount : Natural) return Unsigned_8 + with Import, Convention => Intrinsic, Static; + + function Rotate_Left + (Value : Unsigned_8; + Amount : Natural) return Unsigned_8 + with Import, Convention => Intrinsic, Static; + + function Rotate_Right + (Value : Unsigned_8; + Amount : Natural) return Unsigned_8 + with Import, Convention => Intrinsic, Static; + + function Shift_Left + (Value : Unsigned_16; + Amount : Natural) return Unsigned_16 + with Import, Convention => Intrinsic, Static; + + function Shift_Right + (Value : Unsigned_16; + Amount : Natural) return Unsigned_16 + with Import, Convention => Intrinsic, Static; + + function Shift_Right_Arithmetic + (Value : Unsigned_16; + Amount : Natural) return Unsigned_16 + with Import, Convention => Intrinsic, Static; + + function Rotate_Left + (Value : Unsigned_16; + Amount : Natural) return Unsigned_16 + with Import, Convention => Intrinsic, Static; + + function Rotate_Right + (Value : Unsigned_16; + Amount : Natural) return Unsigned_16 + with Import, Convention => Intrinsic, Static; + + function Shift_Left + (Value : Unsigned_32; + Amount : Natural) return Unsigned_32 + with Import, Convention => Intrinsic, Static; + + function Shift_Right + (Value : Unsigned_32; + Amount : Natural) return Unsigned_32 + with Import, Convention => Intrinsic, Static; + + function Shift_Right_Arithmetic + (Value : Unsigned_32; + Amount : Natural) return Unsigned_32 + with Import, Convention => Intrinsic, Static; + + function Rotate_Left + (Value : Unsigned_32; + Amount : Natural) return Unsigned_32 + with Import, Convention => Intrinsic, Static; + + function Rotate_Right + (Value : Unsigned_32; + Amount : Natural) return Unsigned_32 + with Import, Convention => Intrinsic, Static; + + function Shift_Left + (Value : Unsigned_64; + Amount : Natural) return Unsigned_64 + with Import, Convention => Intrinsic, Static; + + function Shift_Right + (Value : Unsigned_64; + Amount : Natural) return Unsigned_64 + with Import, Convention => Intrinsic, Static; + + function Shift_Right_Arithmetic + (Value : Unsigned_64; + Amount : Natural) return Unsigned_64 + with Import, Convention => Intrinsic, Static; + + function Rotate_Left + (Value : Unsigned_64; + Amount : Natural) return Unsigned_64 + with Import, Convention => Intrinsic, Static; + + function Rotate_Right + (Value : Unsigned_64; + Amount : Natural) return Unsigned_64 + with Import, Convention => Intrinsic, Static; + + function Shift_Left + (Value : Unsigned_128; + Amount : Natural) return Unsigned_128 + with Import, Convention => Intrinsic, Static; + + function Shift_Right + (Value : Unsigned_128; + Amount : Natural) return Unsigned_128 + with Import, Convention => Intrinsic, Static; + + function Shift_Right_Arithmetic + (Value : Unsigned_128; + Amount : Natural) return Unsigned_128 + with Import, Convention => Intrinsic, Static; + + function Rotate_Left + (Value : Unsigned_128; + Amount : Natural) return Unsigned_128 + with Import, Convention => Intrinsic, Static; + + function Rotate_Right + (Value : Unsigned_128; + Amount : Natural) return Unsigned_128 + with Import, Convention => Intrinsic, Static; + + -- IEEE Floating point types + + type IEEE_Float_32 is digits 6; + for IEEE_Float_32'Size use 32; + + type IEEE_Float_64 is digits 15; + for IEEE_Float_64'Size use 64; + + -- If there is an IEEE extended float available on the machine, we assume + -- that it is available as Long_Long_Float. + + -- Note: it is harmless, and explicitly permitted, to include additional + -- types in interfaces, so it is not wrong to have IEEE_Extended_Float + -- defined even if the extended format is not available. + + type IEEE_Extended_Float is new Long_Long_Float; + +end Interfaces; diff --git a/gcc/ada/libgnat/s-aridou.adb b/gcc/ada/libgnat/s-aridou.adb new file mode 100644 index 0000000..05a8c9f --- /dev/null +++ b/gcc/ada/libgnat/s-aridou.adb @@ -0,0 +1,678 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ D O U B L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body System.Arith_Double is + + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + + function To_Uns is new Ada.Unchecked_Conversion (Double_Int, Double_Uns); + function To_Int is new Ada.Unchecked_Conversion (Double_Uns, Double_Int); + + Double_Size : constant Natural := Double_Int'Size; + Single_Size : constant Natural := Double_Int'Size / 2; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function "+" (A, B : Single_Uns) return Double_Uns is + (Double_Uns (A) + Double_Uns (B)); + function "+" (A : Double_Uns; B : Single_Uns) return Double_Uns is + (A + Double_Uns (B)); + -- Length doubling additions + + function "*" (A, B : Single_Uns) return Double_Uns is + (Double_Uns (A) * Double_Uns (B)); + -- Length doubling multiplication + + function "/" (A : Double_Uns; B : Single_Uns) return Double_Uns is + (A / Double_Uns (B)); + -- Length doubling division + + function "&" (Hi, Lo : Single_Uns) return Double_Uns is + (Shift_Left (Double_Uns (Hi), Single_Size) or Double_Uns (Lo)); + -- Concatenate hi, lo values to form double result + + function "abs" (X : Double_Int) return Double_Uns is + (if X = Double_Int'First + then 2 ** (Double_Size - 1) + else Double_Uns (Double_Int'(abs X))); + -- Convert absolute value of X to unsigned. Note that we can't just use + -- the expression of the Else since it overflows for X = Double_Int'First. + + function "rem" (A : Double_Uns; B : Single_Uns) return Double_Uns is + (A rem Double_Uns (B)); + -- Length doubling remainder + + function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean; + -- Determines if (3 * Single_Size)-bit value X1&X2&X3 <= Y1&Y2&Y3 + + function Lo (A : Double_Uns) return Single_Uns is + (Single_Uns (A and (2 ** Single_Size - 1))); + -- Low order half of double value + + function Hi (A : Double_Uns) return Single_Uns is + (Single_Uns (Shift_Right (A, Single_Size))); + -- High order half of double value + + procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns); + -- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 mod 2 ** (3 * Single_Size) + + function To_Neg_Int (A : Double_Uns) return Double_Int; + -- Convert to negative integer equivalent. If the input is in the range + -- 0 .. 2 ** (Double_Size - 1), then the corresponding nonpositive signed + -- integer (obtained by negating the given value) is returned, otherwise + -- constraint error is raised. + + function To_Pos_Int (A : Double_Uns) return Double_Int; + -- Convert to positive integer equivalent. If the input is in the range + -- 0 .. 2 ** (Double_Size - 1) - 1, then the corresponding non-negative + -- signed integer is returned, otherwise constraint error is raised. + + procedure Raise_Error; + pragma No_Return (Raise_Error); + -- Raise constraint error with appropriate message + + -------------------------- + -- Add_With_Ovflo_Check -- + -------------------------- + + function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is + R : constant Double_Int := To_Int (To_Uns (X) + To_Uns (Y)); + + begin + if X >= 0 then + if Y < 0 or else R >= 0 then + return R; + end if; + + else -- X < 0 + if Y > 0 or else R < 0 then + return R; + end if; + end if; + + Raise_Error; + end Add_With_Ovflo_Check; + + ------------------- + -- Double_Divide -- + ------------------- + + procedure Double_Divide + (X, Y, Z : Double_Int; + Q, R : out Double_Int; + Round : Boolean) + is + Xu : constant Double_Uns := abs X; + Yu : constant Double_Uns := abs Y; + + Yhi : constant Single_Uns := Hi (Yu); + Ylo : constant Single_Uns := Lo (Yu); + + Zu : constant Double_Uns := abs Z; + Zhi : constant Single_Uns := Hi (Zu); + Zlo : constant Single_Uns := Lo (Zu); + + T1, T2 : Double_Uns; + Du, Qu, Ru : Double_Uns; + Den_Pos : Boolean; + + begin + if Yu = 0 or else Zu = 0 then + Raise_Error; + end if; + + -- Set final signs (RM 4.5.5(27-30)) + + Den_Pos := (Y < 0) = (Z < 0); + + -- Compute Y * Z. Note that if the result overflows Double_Uns, then + -- the rounded result is zero, except for the very special case where + -- X = -2 ** (Double_Size - 1) and abs(Y*Z) = 2 ** Double_Size, when + -- Round is True. + + if Yhi /= 0 then + if Zhi /= 0 then + + -- Handle the special case when Round is True + + if Yhi = 1 + and then Zhi = 1 + and then Ylo = 0 + and then Zlo = 0 + and then X = Double_Int'First + and then Round + then + Q := (if Den_Pos then -1 else 1); + else + Q := 0; + end if; + + R := X; + return; + else + T2 := Yhi * Zlo; + end if; + + else + T2 := Ylo * Zhi; + end if; + + T1 := Ylo * Zlo; + T2 := T2 + Hi (T1); + + if Hi (T2) /= 0 then + + -- Handle the special case when Round is True + + if Hi (T2) = 1 + and then Lo (T2) = 0 + and then Lo (T1) = 0 + and then X = Double_Int'First + and then Round + then + Q := (if Den_Pos then -1 else 1); + else + Q := 0; + end if; + + R := X; + return; + end if; + + Du := Lo (T2) & Lo (T1); + + -- Check overflow case of largest negative number divided by -1 + + if X = Double_Int'First and then Du = 1 and then not Den_Pos then + Raise_Error; + end if; + + -- Perform the actual division + + pragma Assert (Du /= 0); + -- Multiplication of 2-limb arguments Yu and Zu leads to 4-limb result + -- (where each limb is a single value). Cases where 4 limbs are needed + -- require Yhi/=0 and Zhi/=0 and lead to early exit. Remaining cases + -- where 3 limbs are needed correspond to Hi(T2)/=0 and lead to early + -- exit. Thus, at this point, the result fits in 2 limbs which are + -- exactly Lo(T2) and Lo(T1), which corresponds to the value of Du. + -- As the case where one of Yu or Zu is null also led to early exit, + -- we have Du/=0 here. + Qu := Xu / Du; + Ru := Xu rem Du; + + -- Deal with rounding case + + if Round and then Ru > (Du - Double_Uns'(1)) / Double_Uns'(2) then + Qu := Qu + Double_Uns'(1); + end if; + + -- Case of dividend (X) sign positive + + if X >= 0 then + R := To_Int (Ru); + Q := (if Den_Pos then To_Int (Qu) else -To_Int (Qu)); + + -- Case of dividend (X) sign negative + + -- We perform the unary minus operation on the unsigned value + -- before conversion to signed, to avoid a possible overflow + -- for value -2 ** (Double_Size - 1), both for computing R and Q. + + else + R := To_Int (-Ru); + Q := (if Den_Pos then To_Int (-Qu) else To_Int (Qu)); + end if; + end Double_Divide; + + --------- + -- Le3 -- + --------- + + function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean is + begin + if X1 < Y1 then + return True; + elsif X1 > Y1 then + return False; + elsif X2 < Y2 then + return True; + elsif X2 > Y2 then + return False; + else + return X3 <= Y3; + end if; + end Le3; + + ------------------------------- + -- Multiply_With_Ovflo_Check -- + ------------------------------- + + function Multiply_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is + Xu : constant Double_Uns := abs X; + Xhi : constant Single_Uns := Hi (Xu); + Xlo : constant Single_Uns := Lo (Xu); + + Yu : constant Double_Uns := abs Y; + Yhi : constant Single_Uns := Hi (Yu); + Ylo : constant Single_Uns := Lo (Yu); + + T1, T2 : Double_Uns; + + begin + if Xhi /= 0 then + if Yhi /= 0 then + Raise_Error; + else + T2 := Xhi * Ylo; + end if; + + elsif Yhi /= 0 then + T2 := Xlo * Yhi; + + else -- Yhi = Xhi = 0 + T2 := 0; + end if; + + -- Here we have T2 set to the contribution to the upper half of the + -- result from the upper halves of the input values. + + T1 := Xlo * Ylo; + T2 := T2 + Hi (T1); + + if Hi (T2) /= 0 then + Raise_Error; + end if; + + T2 := Lo (T2) & Lo (T1); + + if X >= 0 then + if Y >= 0 then + return To_Pos_Int (T2); + pragma Annotate (CodePeer, Intentional, "precondition", + "Intentional Unsigned->Signed conversion"); + else + return To_Neg_Int (T2); + end if; + else -- X < 0 + if Y < 0 then + return To_Pos_Int (T2); + pragma Annotate (CodePeer, Intentional, "precondition", + "Intentional Unsigned->Signed conversion"); + else + return To_Neg_Int (T2); + end if; + end if; + + end Multiply_With_Ovflo_Check; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error is + begin + raise Constraint_Error with "Double arithmetic overflow"; + end Raise_Error; + + ------------------- + -- Scaled_Divide -- + ------------------- + + procedure Scaled_Divide + (X, Y, Z : Double_Int; + Q, R : out Double_Int; + Round : Boolean) + is + Xu : constant Double_Uns := abs X; + Xhi : constant Single_Uns := Hi (Xu); + Xlo : constant Single_Uns := Lo (Xu); + + Yu : constant Double_Uns := abs Y; + Yhi : constant Single_Uns := Hi (Yu); + Ylo : constant Single_Uns := Lo (Yu); + + Zu : Double_Uns := abs Z; + Zhi : Single_Uns := Hi (Zu); + Zlo : Single_Uns := Lo (Zu); + + D : array (1 .. 4) of Single_Uns; + -- The dividend, four digits (D(1) is high order) + + Qd : array (1 .. 2) of Single_Uns; + -- The quotient digits, two digits (Qd(1) is high order) + + S1, S2, S3 : Single_Uns; + -- Value to subtract, three digits (S1 is high order) + + Qu : Double_Uns; + Ru : Double_Uns; + -- Unsigned quotient and remainder + + Mask : Single_Uns; + -- Mask of bits used to compute the scaling factor below + + Scale : Natural; + -- Scaling factor used for multiple-precision divide. Dividend and + -- Divisor are multiplied by 2 ** Scale, and the final remainder is + -- divided by the scaling factor. The reason for this scaling is to + -- allow more accurate estimation of quotient digits. + + Shift : Natural; + -- Shift factor used to compute the scaling factor above + + T1, T2, T3 : Double_Uns; + -- Temporary values + + begin + -- First do the multiplication, giving the four digit dividend + + T1 := Xlo * Ylo; + D (4) := Lo (T1); + D (3) := Hi (T1); + + if Yhi /= 0 then + T1 := Xlo * Yhi; + T2 := D (3) + Lo (T1); + D (3) := Lo (T2); + D (2) := Hi (T1) + Hi (T2); + + if Xhi /= 0 then + T1 := Xhi * Ylo; + T2 := D (3) + Lo (T1); + D (3) := Lo (T2); + T3 := D (2) + Hi (T1); + T3 := T3 + Hi (T2); + D (2) := Lo (T3); + D (1) := Hi (T3); + + T1 := (D (1) & D (2)) + Double_Uns'(Xhi * Yhi); + D (1) := Hi (T1); + D (2) := Lo (T1); + + else + D (1) := 0; + end if; + + else + if Xhi /= 0 then + T1 := Xhi * Ylo; + T2 := D (3) + Lo (T1); + D (3) := Lo (T2); + D (2) := Hi (T1) + Hi (T2); + + else + D (2) := 0; + end if; + + D (1) := 0; + end if; + + -- Now it is time for the dreaded multiple precision division. First an + -- easy case, check for the simple case of a one digit divisor. + + if Zhi = 0 then + if D (1) /= 0 or else D (2) >= Zlo then + Raise_Error; + + -- Here we are dividing at most three digits by one digit + + else + T1 := D (2) & D (3); + T2 := Lo (T1 rem Zlo) & D (4); + + Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo); + Ru := T2 rem Zlo; + end if; + + -- If divisor is double digit and dividend is too large, raise error + + elsif (D (1) & D (2)) >= Zu then + Raise_Error; + + -- This is the complex case where we definitely have a double digit + -- divisor and a dividend of at least three digits. We use the classical + -- multiple-precision division algorithm (see section (4.3.1) of Knuth's + -- "The Art of Computer Programming", Vol. 2 for a description + -- (algorithm D). + + else + -- First normalize the divisor so that it has the leading bit on. + -- We do this by finding the appropriate left shift amount. + + Shift := Single_Size / 2; + Mask := Shift_Left (2 ** (Single_Size / 2) - 1, Shift); + Scale := 0; + + while Shift /= 0 loop + if (Hi (Zu) and Mask) = 0 then + Scale := Scale + Shift; + Zu := Shift_Left (Zu, Shift); + end if; + + Shift := Shift / 2; + Mask := Shift_Left (Mask, Shift); + end loop; + + Zhi := Hi (Zu); + Zlo := Lo (Zu); + + pragma Assert (Zhi /= 0); + -- We have Hi(Zu)/=0 before normalization. The sequence of Shift_Left + -- operations results in the leading bit of Zu being 1 by moving the + -- leftmost 1-bit in Zu to leading position, thus Zhi=Hi(Zu)/=0 here. + + -- Note that when we scale up the dividend, it still fits in four + -- digits, since we already tested for overflow, and scaling does + -- not change the invariant that (D (1) & D (2)) < Zu. + + T1 := Shift_Left (D (1) & D (2), Scale); + D (1) := Hi (T1); + T2 := Shift_Left (0 & D (3), Scale); + D (2) := Lo (T1) or Hi (T2); + T3 := Shift_Left (0 & D (4), Scale); + D (3) := Lo (T2) or Hi (T3); + D (4) := Lo (T3); + + -- Loop to compute quotient digits, runs twice for Qd(1) and Qd(2) + + for J in 0 .. 1 loop + + -- Compute next quotient digit. We have to divide three digits by + -- two digits. We estimate the quotient by dividing the leading + -- two digits by the leading digit. Given the scaling we did above + -- which ensured the first bit of the divisor is set, this gives + -- an estimate of the quotient that is at most two too high. + + Qd (J + 1) := (if D (J + 1) = Zhi + then 2 ** Single_Size - 1 + else Lo ((D (J + 1) & D (J + 2)) / Zhi)); + + -- Compute amount to subtract + + T1 := Qd (J + 1) * Zlo; + T2 := Qd (J + 1) * Zhi; + S3 := Lo (T1); + T1 := Hi (T1) + Lo (T2); + S2 := Lo (T1); + S1 := Hi (T1) + Hi (T2); + + -- Adjust quotient digit if it was too high + + -- We use the version of the algorithm in the 2nd Edition of + -- "The Art of Computer Programming". This had a bug not + -- discovered till 1995, see Vol 2 errata: + -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz. + -- Under rare circumstances the expression in the test could + -- overflow. This version was further corrected in 2005, see + -- Vol 2 errata: + -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. + -- This implementation is not impacted by these bugs, due to the + -- use of a word-size comparison done in function Le3 instead of + -- a comparison on two-word integer quantities in the original + -- algorithm. + + loop + exit when Le3 (S1, S2, S3, D (J + 1), D (J + 2), D (J + 3)); + Qd (J + 1) := Qd (J + 1) - 1; + Sub3 (S1, S2, S3, 0, Zhi, Zlo); + end loop; + + -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step + + Sub3 (D (J + 1), D (J + 2), D (J + 3), S1, S2, S3); + end loop; + + -- The two quotient digits are now set, and the remainder of the + -- scaled division is in D3&D4. To get the remainder for the + -- original unscaled division, we rescale this dividend. + + -- We rescale the divisor as well, to make the proper comparison + -- for rounding below. + + Qu := Qd (1) & Qd (2); + Ru := Shift_Right (D (3) & D (4), Scale); + Zu := Shift_Right (Zu, Scale); + end if; + + -- Deal with rounding case + + if Round and then Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) then + + -- Protect against wrapping around when rounding, by signaling + -- an overflow when the quotient is too large. + + if Qu = Double_Uns'Last then + Raise_Error; + end if; + + Qu := Qu + Double_Uns'(1); + end if; + + -- Set final signs (RM 4.5.5(27-30)) + + -- Case of dividend (X * Y) sign positive + + if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then + R := To_Pos_Int (Ru); + Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); + + -- Case of dividend (X * Y) sign negative + + else + R := To_Neg_Int (Ru); + Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); + end if; + end Scaled_Divide; + + ---------- + -- Sub3 -- + ---------- + + procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns) is + begin + if Y3 > X3 then + if X2 = 0 then + X1 := X1 - 1; + end if; + + X2 := X2 - 1; + end if; + + X3 := X3 - Y3; + + if Y2 > X2 then + X1 := X1 - 1; + end if; + + X2 := X2 - Y2; + X1 := X1 - Y1; + end Sub3; + + ------------------------------- + -- Subtract_With_Ovflo_Check -- + ------------------------------- + + function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is + R : constant Double_Int := To_Int (To_Uns (X) - To_Uns (Y)); + + begin + if X >= 0 then + if Y > 0 or else R >= 0 then + return R; + end if; + + else -- X < 0 + if Y <= 0 or else R < 0 then + return R; + end if; + end if; + + Raise_Error; + end Subtract_With_Ovflo_Check; + + ---------------- + -- To_Neg_Int -- + ---------------- + + function To_Neg_Int (A : Double_Uns) return Double_Int is + R : constant Double_Int := + (if A = 2 ** (Double_Size - 1) then Double_Int'First else -To_Int (A)); + -- Note that we can't just use the expression of the Else, because it + -- overflows for A = 2 ** (Double_Size - 1). + begin + if R <= 0 then + return R; + else + Raise_Error; + end if; + end To_Neg_Int; + + ---------------- + -- To_Pos_Int -- + ---------------- + + function To_Pos_Int (A : Double_Uns) return Double_Int is + R : constant Double_Int := To_Int (A); + begin + if R >= 0 then + return R; + else + Raise_Error; + end if; + end To_Pos_Int; + +end System.Arith_Double; diff --git a/gcc/ada/libgnat/s-aridou.ads b/gcc/ada/libgnat/s-aridou.ads new file mode 100644 index 0000000..f9c03e5 --- /dev/null +++ b/gcc/ada/libgnat/s-aridou.ads @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ D O U B L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides software routines for doing arithmetic on "double" +-- signed integer values in cases where either overflow checking is required, +-- or intermediate results are longer than the result type. + +generic + + type Double_Int is range <>; + + type Double_Uns is mod <>; + + type Single_Uns is mod <>; + + with function Shift_Left (A : Double_Uns; B : Natural) return Double_Uns + is <>; + + with function Shift_Right (A : Double_Uns; B : Natural) return Double_Uns + is <>; + + with function Shift_Left (A : Single_Uns; B : Natural) return Single_Uns + is <>; + +package System.Arith_Double is + pragma Pure; + + function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int; + -- Raises Constraint_Error if sum of operands overflows Double_Int, + -- otherwise returns the signed integer sum. + + function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int; + -- Raises Constraint_Error if difference of operands overflows Double_Int, + -- otherwise returns the signed integer difference. + + function Multiply_With_Ovflo_Check (X, Y : Double_Int) return Double_Int; + pragma Convention (C, Multiply_With_Ovflo_Check); + -- Raises Constraint_Error if product of operands overflows Double_Int, + -- otherwise returns the signed integer product. Gigi may also call this + -- routine directly. + + procedure Scaled_Divide + (X, Y, Z : Double_Int; + Q, R : out Double_Int; + Round : Boolean); + -- Performs the division of (X * Y) / Z, storing the quotient in Q + -- and the remainder in R. Constraint_Error is raised if Z is zero, + -- or if the quotient does not fit in Double_Int. Round indicates if + -- the result should be rounded. If Round is False, then Q, R are + -- the normal quotient and remainder from a truncating division. + -- If Round is True, then Q is the rounded quotient. The remainder + -- R is not affected by the setting of the Round flag. + + procedure Double_Divide + (X, Y, Z : Double_Int; + Q, R : out Double_Int; + Round : Boolean); + -- Performs the division X / (Y * Z), storing the quotient in Q and + -- the remainder in R. Constraint_Error is raised if Y or Z is zero, + -- or if the quotient does not fit in Double_Int. Round indicates if the + -- result should be rounded. If Round is False, then Q, R are the normal + -- quotient and remainder from a truncating division. If Round is True, + -- then Q is the rounded quotient. The remainder R is not affected by the + -- setting of the Round flag. + +end System.Arith_Double; diff --git a/gcc/ada/libgnat/s-arit128.adb b/gcc/ada/libgnat/s-arit128.adb new file mode 100644 index 0000000..82c8fc3 --- /dev/null +++ b/gcc/ada/libgnat/s-arit128.adb @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ 1 2 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Arith_Double; + +package body System.Arith_128 is + + subtype Uns128 is Interfaces.Unsigned_128; + subtype Uns64 is Interfaces.Unsigned_64; + + use Interfaces; + + package Impl is new Arith_Double (Int128, Uns128, Uns64); + + function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128 + renames Impl.Add_With_Ovflo_Check; + + function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128 + renames Impl.Subtract_With_Ovflo_Check; + + function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128 + renames Impl.Multiply_With_Ovflo_Check; + + procedure Scaled_Divide128 + (X, Y, Z : Int128; + Q, R : out Int128; + Round : Boolean) + renames Impl.Scaled_Divide; + + procedure Double_Divide128 + (X, Y, Z : Int128; + Q, R : out Int128; + Round : Boolean) + renames Impl.Double_Divide; + +end System.Arith_128; diff --git a/gcc/ada/libgnat/s-arit128.ads b/gcc/ada/libgnat/s-arit128.ads new file mode 100644 index 0000000..55154da --- /dev/null +++ b/gcc/ada/libgnat/s-arit128.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ 1 2 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit provides software routines for doing arithmetic on 128-bit +-- signed integer values in cases where either overflow checking is +-- required, or intermediate results are longer than 128 bits. + +pragma Restrictions (No_Elaboration_Code); +-- Allow direct call from gigi generated code + +with Interfaces; + +package System.Arith_128 is + pragma Pure; + + subtype Int128 is Interfaces.Integer_128; + + function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128; + -- Raises Constraint_Error if sum of operands overflows 128 bits, + -- otherwise returns the 128-bit signed integer sum. + + function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128; + -- Raises Constraint_Error if difference of operands overflows 128 + -- bits, otherwise returns the 128-bit signed integer difference. + + function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128; + pragma Export (C, Multiply_With_Ovflo_Check128, "__gnat_mulv128"); + -- Raises Constraint_Error if product of operands overflows 128 + -- bits, otherwise returns the 128-bit signed integer product. + -- Gigi may also call this routine directly. + + procedure Scaled_Divide128 + (X, Y, Z : Int128; + Q, R : out Int128; + Round : Boolean); + -- Performs the division of (X * Y) / Z, storing the quotient in Q + -- and the remainder in R. Constraint_Error is raised if Z is zero, + -- or if the quotient does not fit in 128 bits. Round indicates if + -- the result should be rounded. If Round is False, then Q, R are + -- the normal quotient and remainder from a truncating division. + -- If Round is True, then Q is the rounded quotient. The remainder + -- R is not affected by the setting of the Round flag. + + procedure Double_Divide128 + (X, Y, Z : Int128; + Q, R : out Int128; + Round : Boolean); + -- Performs the division X / (Y * Z), storing the quotient in Q and + -- the remainder in R. Constraint_Error is raised if Y or Z is zero, + -- or if the quotient does not fit in 128 bits. Round indicates if the + -- result should be rounded. If Round is False, then Q, R are the normal + -- quotient and remainder from a truncating division. If Round is True, + -- then Q is the rounded quotient. The remainder R is not affected by the + -- setting of the Round flag. + +end System.Arith_128; diff --git a/gcc/ada/libgnat/s-arit64.adb b/gcc/ada/libgnat/s-arit64.adb index 060f352..a4d60f2 100644 --- a/gcc/ada/libgnat/s-arit64.adb +++ b/gcc/ada/libgnat/s-arit64.adb @@ -29,630 +29,36 @@ -- -- ------------------------------------------------------------------------------ -with Interfaces; use Interfaces; - -with Ada.Unchecked_Conversion; +with System.Arith_Double; package body System.Arith_64 is - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - - subtype Uns64 is Unsigned_64; - function To_Uns is new Ada.Unchecked_Conversion (Int64, Uns64); - function To_Int is new Ada.Unchecked_Conversion (Uns64, Int64); - - subtype Uns32 is Unsigned_32; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function "+" (A, B : Uns32) return Uns64 is (Uns64 (A) + Uns64 (B)); - function "+" (A : Uns64; B : Uns32) return Uns64 is (A + Uns64 (B)); - -- Length doubling additions - - function "*" (A, B : Uns32) return Uns64 is (Uns64 (A) * Uns64 (B)); - -- Length doubling multiplication - - function "/" (A : Uns64; B : Uns32) return Uns64 is (A / Uns64 (B)); - -- Length doubling division - - function "&" (Hi, Lo : Uns32) return Uns64 is - (Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo)); - -- Concatenate hi, lo values to form 64-bit result - - function "abs" (X : Int64) return Uns64 is - (if X = Int64'First then 2**63 else Uns64 (Int64'(abs X))); - -- Convert absolute value of X to unsigned. Note that we can't just use - -- the expression of the Else, because it overflows for X = Int64'First. - - function "rem" (A : Uns64; B : Uns32) return Uns64 is (A rem Uns64 (B)); - -- Length doubling remainder - - function Le3 (X1, X2, X3 : Uns32; Y1, Y2, Y3 : Uns32) return Boolean; - -- Determines if 96 bit value X1&X2&X3 <= Y1&Y2&Y3 - - function Lo (A : Uns64) return Uns32 is (Uns32 (A and 16#FFFF_FFFF#)); - -- Low order half of 64-bit value - - function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32))); - -- High order half of 64-bit value - - procedure Sub3 (X1, X2, X3 : in out Uns32; Y1, Y2, Y3 : Uns32); - -- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 with mod 2**96 wrap - - function To_Neg_Int (A : Uns64) return Int64 with Inline; - -- Convert to negative integer equivalent. If the input is in the range - -- 0 .. 2 ** 63, then the corresponding negative signed integer (obtained - -- by negating the given value) is returned, otherwise constraint error - -- is raised. - - function To_Pos_Int (A : Uns64) return Int64 with Inline; - -- Convert to positive integer equivalent. If the input is in the range - -- 0 .. 2 ** 63-1, then the corresponding non-negative signed integer is - -- returned, otherwise constraint error is raised. - - procedure Raise_Error with Inline; - pragma No_Return (Raise_Error); - -- Raise constraint error with appropriate message - - -------------------------- - -- Add_With_Ovflo_Check -- - -------------------------- + subtype Uns64 is Interfaces.Unsigned_64; + subtype Uns32 is Interfaces.Unsigned_32; - function Add_With_Ovflo_Check (X, Y : Int64) return Int64 is - R : constant Int64 := To_Int (To_Uns (X) + To_Uns (Y)); + use Interfaces; - begin - if X >= 0 then - if Y < 0 or else R >= 0 then - return R; - end if; + package Impl is new Arith_Double (Int64, Uns64, Uns32); - else -- X < 0 - if Y > 0 or else R < 0 then - return R; - end if; - end if; + function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64 + renames Impl.Add_With_Ovflo_Check; - Raise_Error; - end Add_With_Ovflo_Check; + function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64 + renames Impl.Subtract_With_Ovflo_Check; - ------------------- - -- Double_Divide -- - ------------------- + function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64 + renames Impl.Multiply_With_Ovflo_Check; - procedure Double_Divide + procedure Scaled_Divide64 (X, Y, Z : Int64; Q, R : out Int64; Round : Boolean) - is - Xu : constant Uns64 := abs X; - Yu : constant Uns64 := abs Y; - - Yhi : constant Uns32 := Hi (Yu); - Ylo : constant Uns32 := Lo (Yu); - - Zu : constant Uns64 := abs Z; - Zhi : constant Uns32 := Hi (Zu); - Zlo : constant Uns32 := Lo (Zu); - - T1, T2 : Uns64; - Du, Qu, Ru : Uns64; - Den_Pos : Boolean; - - begin - if Yu = 0 or else Zu = 0 then - Raise_Error; - end if; - - -- Set final signs (RM 4.5.5(27-30)) - - Den_Pos := (Y < 0) = (Z < 0); - - -- Compute Y * Z. Note that if the result overflows 64 bits unsigned, - -- then the rounded result is zero, except for the very special case - -- where X = -2**63 and abs(Y*Z) = 2**64, when Round is True. - - if Yhi /= 0 then - if Zhi /= 0 then - - -- Handle the special case when Round is True - - if Yhi = 1 - and then Zhi = 1 - and then Ylo = 0 - and then Zlo = 0 - and then X = Int64'First - and then Round - then - Q := (if Den_Pos then -1 else 1); - else - Q := 0; - end if; - - R := X; - return; - else - T2 := Yhi * Zlo; - end if; - - else - T2 := Ylo * Zhi; - end if; - - T1 := Ylo * Zlo; - T2 := T2 + Hi (T1); - - if Hi (T2) /= 0 then - - -- Handle the special case when Round is True - - if Hi (T2) = 1 - and then Lo (T2) = 0 - and then Lo (T1) = 0 - and then X = Int64'First - and then Round - then - Q := (if Den_Pos then -1 else 1); - else - Q := 0; - end if; - - R := X; - return; - end if; + renames Impl.Scaled_Divide; - Du := Lo (T2) & Lo (T1); - - -- Check overflow case of largest negative number divided by -1 - - if X = Int64'First and then Du = 1 and then not Den_Pos then - Raise_Error; - end if; - - -- Perform the actual division - - Qu := Xu / Du; - Ru := Xu rem Du; - - -- Deal with rounding case - - if Round and then Ru > (Du - Uns64'(1)) / Uns64'(2) then - Qu := Qu + Uns64'(1); - end if; - - -- Case of dividend (X) sign positive - - if X >= 0 then - R := To_Int (Ru); - Q := (if Den_Pos then To_Int (Qu) else -To_Int (Qu)); - - -- Case of dividend (X) sign negative - - -- We perform the unary minus operation on the unsigned value - -- before conversion to signed, to avoid a possible overflow for - -- value -2**63, both for computing R and Q. - - else - R := To_Int (-Ru); - Q := (if Den_Pos then To_Int (-Qu) else To_Int (Qu)); - end if; - end Double_Divide; - - --------- - -- Le3 -- - --------- - - function Le3 (X1, X2, X3 : Uns32; Y1, Y2, Y3 : Uns32) return Boolean is - begin - if X1 < Y1 then - return True; - elsif X1 > Y1 then - return False; - elsif X2 < Y2 then - return True; - elsif X2 > Y2 then - return False; - else - return X3 <= Y3; - end if; - end Le3; - - ------------------------------- - -- Multiply_With_Ovflo_Check -- - ------------------------------- - - function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64 is - Xu : constant Uns64 := abs X; - Xhi : constant Uns32 := Hi (Xu); - Xlo : constant Uns32 := Lo (Xu); - - Yu : constant Uns64 := abs Y; - Yhi : constant Uns32 := Hi (Yu); - Ylo : constant Uns32 := Lo (Yu); - - T1, T2 : Uns64; - - begin - if Xhi /= 0 then - if Yhi /= 0 then - Raise_Error; - else - T2 := Xhi * Ylo; - end if; - - elsif Yhi /= 0 then - T2 := Xlo * Yhi; - - else -- Yhi = Xhi = 0 - T2 := 0; - end if; - - -- Here we have T2 set to the contribution to the upper half of the - -- result from the upper halves of the input values. - - T1 := Xlo * Ylo; - T2 := T2 + Hi (T1); - - if Hi (T2) /= 0 then - Raise_Error; - end if; - - T2 := Lo (T2) & Lo (T1); - - if X >= 0 then - if Y >= 0 then - return To_Pos_Int (T2); - else - return To_Neg_Int (T2); - end if; - else -- X < 0 - if Y < 0 then - return To_Pos_Int (T2); - else - return To_Neg_Int (T2); - end if; - end if; - - end Multiply_With_Ovflo_Check; - - ----------------- - -- Raise_Error -- - ----------------- - - procedure Raise_Error is - begin - raise Constraint_Error with "64-bit arithmetic overflow"; - end Raise_Error; - - ------------------- - -- Scaled_Divide -- - ------------------- - - procedure Scaled_Divide + procedure Double_Divide64 (X, Y, Z : Int64; Q, R : out Int64; Round : Boolean) - is - Xu : constant Uns64 := abs X; - Xhi : constant Uns32 := Hi (Xu); - Xlo : constant Uns32 := Lo (Xu); - - Yu : constant Uns64 := abs Y; - Yhi : constant Uns32 := Hi (Yu); - Ylo : constant Uns32 := Lo (Yu); - - Zu : Uns64 := abs Z; - Zhi : Uns32 := Hi (Zu); - Zlo : Uns32 := Lo (Zu); - - D : array (1 .. 4) of Uns32; - -- The dividend, four digits (D(1) is high order) - - Qd : array (1 .. 2) of Uns32; - -- The quotient digits, two digits (Qd(1) is high order) - - S1, S2, S3 : Uns32; - -- Value to subtract, three digits (S1 is high order) - - Qu : Uns64; - Ru : Uns64; - -- Unsigned quotient and remainder - - Scale : Natural; - -- Scaling factor used for multiple-precision divide. Dividend and - -- Divisor are multiplied by 2 ** Scale, and the final remainder is - -- divided by the scaling factor. The reason for this scaling is to - -- allow more accurate estimation of quotient digits. - - T1, T2, T3 : Uns64; - -- Temporary values - - begin - -- First do the multiplication, giving the four digit dividend - - T1 := Xlo * Ylo; - D (4) := Lo (T1); - D (3) := Hi (T1); - - if Yhi /= 0 then - T1 := Xlo * Yhi; - T2 := D (3) + Lo (T1); - D (3) := Lo (T2); - D (2) := Hi (T1) + Hi (T2); - - if Xhi /= 0 then - T1 := Xhi * Ylo; - T2 := D (3) + Lo (T1); - D (3) := Lo (T2); - T3 := D (2) + Hi (T1); - T3 := T3 + Hi (T2); - D (2) := Lo (T3); - D (1) := Hi (T3); - - T1 := (D (1) & D (2)) + Uns64'(Xhi * Yhi); - D (1) := Hi (T1); - D (2) := Lo (T1); - - else - D (1) := 0; - end if; - - else - if Xhi /= 0 then - T1 := Xhi * Ylo; - T2 := D (3) + Lo (T1); - D (3) := Lo (T2); - D (2) := Hi (T1) + Hi (T2); - - else - D (2) := 0; - end if; - - D (1) := 0; - end if; - - -- Now it is time for the dreaded multiple precision division. First an - -- easy case, check for the simple case of a one digit divisor. - - if Zhi = 0 then - if D (1) /= 0 or else D (2) >= Zlo then - Raise_Error; - - -- Here we are dividing at most three digits by one digit - - else - T1 := D (2) & D (3); - T2 := Lo (T1 rem Zlo) & D (4); - - Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo); - Ru := T2 rem Zlo; - end if; - - -- If divisor is double digit and dividend is too large, raise error - - elsif (D (1) & D (2)) >= Zu then - Raise_Error; - - -- This is the complex case where we definitely have a double digit - -- divisor and a dividend of at least three digits. We use the classical - -- multiple-precision division algorithm (see section (4.3.1) of Knuth's - -- "The Art of Computer Programming", Vol. 2 for a description - -- (algorithm D). - - else - -- First normalize the divisor so that it has the leading bit on. - -- We do this by finding the appropriate left shift amount. - - Scale := 0; - - if (Zhi and 16#FFFF0000#) = 0 then - Scale := 16; - Zu := Shift_Left (Zu, 16); - end if; - - if (Hi (Zu) and 16#FF00_0000#) = 0 then - Scale := Scale + 8; - Zu := Shift_Left (Zu, 8); - end if; - - if (Hi (Zu) and 16#F000_0000#) = 0 then - Scale := Scale + 4; - Zu := Shift_Left (Zu, 4); - end if; - - if (Hi (Zu) and 16#C000_0000#) = 0 then - Scale := Scale + 2; - Zu := Shift_Left (Zu, 2); - end if; - - if (Hi (Zu) and 16#8000_0000#) = 0 then - Scale := Scale + 1; - Zu := Shift_Left (Zu, 1); - end if; - - Zhi := Hi (Zu); - Zlo := Lo (Zu); - - -- Note that when we scale up the dividend, it still fits in four - -- digits, since we already tested for overflow, and scaling does - -- not change the invariant that (D (1) & D (2)) < Zu. - - T1 := Shift_Left (D (1) & D (2), Scale); - D (1) := Hi (T1); - T2 := Shift_Left (0 & D (3), Scale); - D (2) := Lo (T1) or Hi (T2); - T3 := Shift_Left (0 & D (4), Scale); - D (3) := Lo (T2) or Hi (T3); - D (4) := Lo (T3); - - -- Loop to compute quotient digits, runs twice for Qd(1) and Qd(2) - - for J in 0 .. 1 loop - - -- Compute next quotient digit. We have to divide three digits by - -- two digits. We estimate the quotient by dividing the leading - -- two digits by the leading digit. Given the scaling we did above - -- which ensured the first bit of the divisor is set, this gives - -- an estimate of the quotient that is at most two too high. - - Qd (J + 1) := (if D (J + 1) = Zhi - then 2 ** 32 - 1 - else Lo ((D (J + 1) & D (J + 2)) / Zhi)); - - -- Compute amount to subtract - - T1 := Qd (J + 1) * Zlo; - T2 := Qd (J + 1) * Zhi; - S3 := Lo (T1); - T1 := Hi (T1) + Lo (T2); - S2 := Lo (T1); - S1 := Hi (T1) + Hi (T2); - - -- Adjust quotient digit if it was too high - - -- We use the version of the algorithm in the 2nd Edition of - -- "The Art of Computer Programming". This had a bug not - -- discovered till 1995, see Vol 2 errata: - -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz. - -- Under rare circumstances the expression in the test could - -- overflow. This version was further corrected in 2005, see - -- Vol 2 errata: - -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. - -- This implementation is not impacted by these bugs, due to the - -- use of a word-size comparison done in function Le3 instead of - -- a comparison on two-word integer quantities in the original - -- algorithm. - - loop - exit when Le3 (S1, S2, S3, D (J + 1), D (J + 2), D (J + 3)); - Qd (J + 1) := Qd (J + 1) - 1; - Sub3 (S1, S2, S3, 0, Zhi, Zlo); - end loop; - - -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step - - Sub3 (D (J + 1), D (J + 2), D (J + 3), S1, S2, S3); - end loop; - - -- The two quotient digits are now set, and the remainder of the - -- scaled division is in D3&D4. To get the remainder for the - -- original unscaled division, we rescale this dividend. - - -- We rescale the divisor as well, to make the proper comparison - -- for rounding below. - - Qu := Qd (1) & Qd (2); - Ru := Shift_Right (D (3) & D (4), Scale); - Zu := Shift_Right (Zu, Scale); - end if; - - -- Deal with rounding case - - if Round and then Ru > (Zu - Uns64'(1)) / Uns64'(2) then - - -- Protect against wrapping around when rounding, by signaling - -- an overflow when the quotient is too large. - - if Qu = Uns64'Last then - Raise_Error; - end if; - - Qu := Qu + Uns64 (1); - end if; - - -- Set final signs (RM 4.5.5(27-30)) - - -- Case of dividend (X * Y) sign positive - - if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then - R := To_Pos_Int (Ru); - Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); - - -- Case of dividend (X * Y) sign negative - - else - R := To_Neg_Int (Ru); - Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); - end if; - end Scaled_Divide; - - ---------- - -- Sub3 -- - ---------- - - procedure Sub3 (X1, X2, X3 : in out Uns32; Y1, Y2, Y3 : Uns32) is - begin - if Y3 > X3 then - if X2 = 0 then - X1 := X1 - 1; - end if; - - X2 := X2 - 1; - end if; - - X3 := X3 - Y3; - - if Y2 > X2 then - X1 := X1 - 1; - end if; - - X2 := X2 - Y2; - X1 := X1 - Y1; - end Sub3; - - ------------------------------- - -- Subtract_With_Ovflo_Check -- - ------------------------------- - - function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64 is - R : constant Int64 := To_Int (To_Uns (X) - To_Uns (Y)); - - begin - if X >= 0 then - if Y > 0 or else R >= 0 then - return R; - end if; - - else -- X < 0 - if Y <= 0 or else R < 0 then - return R; - end if; - end if; - - Raise_Error; - end Subtract_With_Ovflo_Check; - - ---------------- - -- To_Neg_Int -- - ---------------- - - function To_Neg_Int (A : Uns64) return Int64 is - R : constant Int64 := (if A = 2**63 then Int64'First else -To_Int (A)); - -- Note that we can't just use the expression of the Else, because it - -- overflows for A = 2**63. - begin - if R <= 0 then - return R; - else - Raise_Error; - end if; - end To_Neg_Int; - - ---------------- - -- To_Pos_Int -- - ---------------- - - function To_Pos_Int (A : Uns64) return Int64 is - R : constant Int64 := To_Int (A); - begin - if R >= 0 then - return R; - else - Raise_Error; - end if; - end To_Pos_Int; + renames Impl.Double_Divide; end System.Arith_64; diff --git a/gcc/ada/libgnat/s-arit64.ads b/gcc/ada/libgnat/s-arit64.ads index 479515f..90d5c25 100644 --- a/gcc/ada/libgnat/s-arit64.ads +++ b/gcc/ada/libgnat/s-arit64.ads @@ -43,42 +43,54 @@ package System.Arith_64 is subtype Int64 is Interfaces.Integer_64; - function Add_With_Ovflo_Check (X, Y : Int64) return Int64; + function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64; -- Raises Constraint_Error if sum of operands overflows 64 bits, -- otherwise returns the 64-bit signed integer sum. - function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64; + function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64; -- Raises Constraint_Error if difference of operands overflows 64 -- bits, otherwise returns the 64-bit signed integer difference. - function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64; - pragma Export (C, Multiply_With_Ovflo_Check, "__gnat_mulv64"); + function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64; + pragma Export (C, Multiply_With_Ovflo_Check64, "__gnat_mulv64"); -- Raises Constraint_Error if product of operands overflows 64 -- bits, otherwise returns the 64-bit signed integer product. - -- GIGI may also call this routine directly. + -- Gigi may also call this routine directly. - procedure Scaled_Divide + procedure Scaled_Divide64 (X, Y, Z : Int64; Q, R : out Int64; Round : Boolean); -- Performs the division of (X * Y) / Z, storing the quotient in Q -- and the remainder in R. Constraint_Error is raised if Z is zero, - -- or if the quotient does not fit in 64-bits. Round indicates if + -- or if the quotient does not fit in 64 bits. Round indicates if -- the result should be rounded. If Round is False, then Q, R are -- the normal quotient and remainder from a truncating division. -- If Round is True, then Q is the rounded quotient. The remainder -- R is not affected by the setting of the Round flag. - procedure Double_Divide + procedure Scaled_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean) renames Scaled_Divide64; + -- Renamed procedure to preserve compatibility with earlier versions + + procedure Double_Divide64 (X, Y, Z : Int64; Q, R : out Int64; Round : Boolean); -- Performs the division X / (Y * Z), storing the quotient in Q and -- the remainder in R. Constraint_Error is raised if Y or Z is zero, - -- or if the quotient does not fit in 64-bits. Round indicates if the + -- or if the quotient does not fit in 64 bits. Round indicates if the -- result should be rounded. If Round is False, then Q, R are the normal -- quotient and remainder from a truncating division. If Round is True, -- then Q is the rounded quotient. The remainder R is not affected by the -- setting of the Round flag. + procedure Double_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean) renames Double_Divide64; + -- Renamed procedure to preserve compatibility with earlier versions + end System.Arith_64; diff --git a/gcc/ada/libgnat/s-bytswa.ads b/gcc/ada/libgnat/s-bytswa.ads index 76d8ded..1eac50d 100644 --- a/gcc/ada/libgnat/s-bytswa.ads +++ b/gcc/ada/libgnat/s-bytswa.ads @@ -33,13 +33,16 @@ -- (supporting alternative byte ordering), and by the GNAT.Byte_Swapping run -- time package which provides user level routines for byte swapping. +with Interfaces; + 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; + subtype U16 is Interfaces.Unsigned_16; + subtype U32 is Interfaces.Unsigned_32; + subtype U64 is Interfaces.Unsigned_64; + subtype U128 is Interfaces.Unsigned_128; function Bswap_16 (X : U16) return U16; pragma Import (Intrinsic, Bswap_16, "__builtin_bswap16"); @@ -50,4 +53,7 @@ package System.Byte_Swapping is function Bswap_64 (X : U64) return U64; pragma Import (Intrinsic, Bswap_64, "__builtin_bswap64"); + function Bswap_128 (X : U128) return U128; + pragma Import (Intrinsic, Bswap_128, "__builtin_bswap128"); + end System.Byte_Swapping; diff --git a/gcc/ada/libgnat/s-carsi8.adb b/gcc/ada/libgnat/s-carsi8.adb index 11ec460..2da7f5a 100644 --- a/gcc/ada/libgnat/s-carsi8.adb +++ b/gcc/ada/libgnat/s-carsi8.adb @@ -97,6 +97,13 @@ package body System.Compare_Array_Signed_8 is end if; end loop; + pragma Assert (Left_Len >= Bytes_Compared_As_Words); + pragma Assert (Right_Len >= Bytes_Compared_As_Words); + -- Left_Len and Right_Len are always greater or equal to + -- Bytes_Compared_As_Words because: + -- * Compare_Len is min (Left_Len, Right_Len) + -- * Words_To_Compare = Compare_Len / 4 + -- * Bytes_Compared_As_Words = Words_To_Compare * 4 return Compare_Array_S8_Unaligned (AddA (Left, Address (Bytes_Compared_As_Words)), AddA (Right, Address (Bytes_Compared_As_Words)), diff --git a/gcc/ada/libgnat/s-carun8.adb b/gcc/ada/libgnat/s-carun8.adb index 412410e..0ed3d26 100644 --- a/gcc/ada/libgnat/s-carun8.adb +++ b/gcc/ada/libgnat/s-carun8.adb @@ -98,6 +98,13 @@ package body System.Compare_Array_Unsigned_8 is end if; end loop; + pragma Assert (Left_Len >= Bytes_Compared_As_Words); + pragma Assert (Right_Len >= Bytes_Compared_As_Words); + -- Left_Len and Right_Len are always greater or equal to + -- Bytes_Compared_As_Words because: + -- * Compare_Len is min (Left_Len, Right_Len) + -- * Words_To_Compare = Compare_Len / 4 + -- * Bytes_Compared_As_Words = Words_To_Compare * 4 return Compare_Array_U8_Unaligned (AddA (Left, Address (Bytes_Compared_As_Words)), AddA (Right, Address (Bytes_Compared_As_Words)), diff --git a/gcc/ada/libgnat/s-casi128.adb b/gcc/ada/libgnat/s-casi128.adb new file mode 100644 index 0000000..96a8f3d --- /dev/null +++ b/gcc/ada/libgnat/s-casi128.adb @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 1 2 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Operations; use System.Address_Operations; + +with Ada.Unchecked_Conversion; + +package body System.Compare_Array_Signed_128 is + + type Word is range -2**127 .. 2**127 - 1; + for Word'Size use 128; + -- Used to process operands by 128-bit words + + type Uword is new Word; + for Uword'Alignment use 1; + -- Used to process operands when unaligned + + type WP is access Word; + type UP is access Uword; + + function W is new Ada.Unchecked_Conversion (Address, WP); + function U is new Ada.Unchecked_Conversion (Address, UP); + + ------------------------ + -- Compare_Array_S128 -- + ------------------------ + + function Compare_Array_S128 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Clen : Natural := Natural'Min (Left_Len, Right_Len); + -- Number of elements left to compare + + L : Address := Left; + R : Address := Right; + -- Pointers to next elements to compare + + begin + -- Case of going by aligned quadruple words + + if ModA (OrA (Left, Right), 16) = 0 then + while Clen /= 0 loop + if W (L).all /= W (R).all then + if W (L).all > W (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 16); + R := AddA (R, 16); + end loop; + + -- Case of going by unaligned quadruple words + + else + while Clen /= 0 loop + if U (L).all /= U (R).all then + if U (L).all > U (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 16); + R := AddA (R, 16); + end loop; + end if; + + -- Here if common section equal, result decided by lengths + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Compare_Array_S128; + +end System.Compare_Array_Signed_128; diff --git a/gcc/ada/libgnat/s-casi128.ads b/gcc/ada/libgnat/s-casi128.ads new file mode 100644 index 0000000..0893bad --- /dev/null +++ b/gcc/ada/libgnat/s-casi128.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 1 2 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on arrays whose +-- elements are 128-bit discrete type values to be treated as signed. + +package System.Compare_Array_Signed_128 is + + -- Note: although the functions in this package are in a sense Pure, the + -- package cannot be declared as Pure, since the arguments are addresses, + -- not the data, and the result is not pure wrt the address values. + + function Compare_Array_S128 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Compare the array starting at address Left of length Left_Len + -- with the array starting at address Right of length Right_Len. + -- The comparison is in the normal Ada semantic sense of array + -- comparison. The result is -1,0,+1 for Left<Right, Left=Right, + -- Left>Right respectively. + +end System.Compare_Array_Signed_128; diff --git a/gcc/ada/libgnat/s-caun128.adb b/gcc/ada/libgnat/s-caun128.adb new file mode 100644 index 0000000..bb69793 --- /dev/null +++ b/gcc/ada/libgnat/s-caun128.adb @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 1 2 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Operations; use System.Address_Operations; + +with Ada.Unchecked_Conversion; + +package body System.Compare_Array_Unsigned_128 is + + type Word is mod 2 ** 128; + -- Used to process operands by 128-bit words + + type Uword is new Word; + for Uword'Alignment use 1; + -- Used to process operands when unaligned + + type WP is access Word; + type UP is access Uword; + + function W is new Ada.Unchecked_Conversion (Address, WP); + function U is new Ada.Unchecked_Conversion (Address, UP); + + ------------------------ + -- Compare_Array_U128 -- + ------------------------ + + function Compare_Array_U128 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Clen : Natural := Natural'Min (Left_Len, Right_Len); + -- Number of elements left to compare + + L : Address := Left; + R : Address := Right; + -- Pointers to next elements to compare + + begin + -- Case of going by aligned quadruple words + + if ModA (OrA (Left, Right), 16) = 0 then + while Clen /= 0 loop + if W (L).all /= W (R).all then + if W (L).all > W (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 16); + R := AddA (R, 16); + end loop; + + -- Case of going by unaligned quadruple words + + else + while Clen /= 0 loop + if U (L).all /= U (R).all then + if U (L).all > U (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 16); + R := AddA (R, 16); + end loop; + end if; + + -- Here if common section equal, result decided by lengths + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Compare_Array_U128; + +end System.Compare_Array_Unsigned_128; diff --git a/gcc/ada/libgnat/s-caun128.ads b/gcc/ada/libgnat/s-caun128.ads new file mode 100644 index 0000000..c96983d --- /dev/null +++ b/gcc/ada/libgnat/s-caun128.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 1 2 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on arrays whose +-- elements are 128-bit discrete type values to be treated as unsigned. + +package System.Compare_Array_Unsigned_128 is + + -- Note: although the functions in this package are in a sense Pure, the + -- package cannot be declared as Pure, since the arguments are addresses, + -- not the data, and the result is not pure wrt the address values. + + function Compare_Array_U128 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Compare the array starting at address Left of length Left_Len + -- with the array starting at address Right of length Right_Len. + -- The comparison is in the normal Ada semantic sense of array + -- comparison. The result is -1,0,+1 for Left<Right, Left=Right, + -- Left>Right respectively. + +end System.Compare_Array_Unsigned_128; diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb index dbd4c53..abb499c 100644 --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -29,10 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on - with Ada.Characters.Handling; with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; with Ada.Unchecked_Deallocation; diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads index 2753be3..072f089 100644 --- a/gcc/ada/libgnat/s-dwalin.ads +++ b/gcc/ada/libgnat/s-dwalin.ads @@ -38,10 +38,6 @@ -- size is a consideration it's possible to strip all other .debug sections, -- which will decrease the size of the object significantly. -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on - with Ada.Exceptions.Traceback; with System.Object_Reader; diff --git a/gcc/ada/libgnat/s-exnint.adb b/gcc/ada/libgnat/s-exnint.adb index fccd675..3914192 100644 --- a/gcc/ada/libgnat/s-exnint.adb +++ b/gcc/ada/libgnat/s-exnint.adb @@ -29,42 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body System.Exn_Int is +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. - ----------------- - -- Exn_Integer -- - ----------------- - - function Exn_Integer (Left : Integer; Right : Natural) return Integer is - pragma Suppress (Division_Check); - pragma Suppress (Overflow_Check); - - Result : Integer := 1; - Factor : Integer := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing base values -1, 0, +1 since - -- the expander does this when the base is a literal, and other cases - -- will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - Factor := Factor * Factor; - end loop; - end if; - - return Result; - end Exn_Integer; - -end System.Exn_Int; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-exnint.ads b/gcc/ada/libgnat/s-exnint.ads index 29303a3..ac64e58 100644 --- a/gcc/ada/libgnat/s-exnint.ads +++ b/gcc/ada/libgnat/s-exnint.ads @@ -31,9 +31,11 @@ -- Integer exponentiation (checks off) +with System.Exponn; + package System.Exn_Int is - pragma Pure; - function Exn_Integer (Left : Integer; Right : Natural) return Integer; + function Exn_Integer is new Exponn (Integer); + pragma Pure_Function (Exn_Integer); end System.Exn_Int; diff --git a/gcc/ada/libgnat/s-exnlli.adb b/gcc/ada/libgnat/s-exnlli.adb index dc486d6..b1c33ea 100644 --- a/gcc/ada/libgnat/s-exnlli.adb +++ b/gcc/ada/libgnat/s-exnlli.adb @@ -29,46 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body System.Exn_LLI is +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. - --------------------------- - -- Exn_Long_Long_Integer -- - --------------------------- - - function Exn_Long_Long_Integer - (Left : Long_Long_Integer; - Right : Natural) - return Long_Long_Integer - is - pragma Suppress (Division_Check); - pragma Suppress (Overflow_Check); - - Result : Long_Long_Integer := 1; - Factor : Long_Long_Integer := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing base values -1, 0, +1 since - -- the expander does this when the base is a literal, and other cases - -- will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - Factor := Factor * Factor; - end loop; - end if; - - return Result; - end Exn_Long_Long_Integer; - -end System.Exn_LLI; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-exnlli.ads b/gcc/ada/libgnat/s-exnlli.ads index f6d94de..3c2786b 100644 --- a/gcc/ada/libgnat/s-exnlli.ads +++ b/gcc/ada/libgnat/s-exnlli.ads @@ -31,12 +31,11 @@ -- Long_Long_Integer exponentiation (checks off) +with System.Exponn; + package System.Exn_LLI is - pragma Pure; - function Exn_Long_Long_Integer - (Left : Long_Long_Integer; - Right : Natural) - return Long_Long_Integer; + function Exn_Long_Long_Integer is new Exponn (Long_Long_Integer); + pragma Pure_Function (Exn_Long_Long_Integer); end System.Exn_LLI; diff --git a/gcc/ada/libgnat/s-exnllli.ads b/gcc/ada/libgnat/s-exnllli.ads new file mode 100644 index 0000000..9573d7d --- /dev/null +++ b/gcc/ada/libgnat/s-exnllli.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ L L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Long_Long_Integer exponentiation (checks off) + +with System.Exponn; + +package System.Exn_LLLI is + + function Exn_Long_Long_Long_Integer is new Exponn (Long_Long_Long_Integer); + pragma Pure_Function (Exn_Long_Long_Long_Integer); + +end System.Exn_LLLI; diff --git a/gcc/ada/libgnat/s-expint.adb b/gcc/ada/libgnat/s-expint.adb index aa3445c..489d768 100644 --- a/gcc/ada/libgnat/s-expint.adb +++ b/gcc/ada/libgnat/s-expint.adb @@ -29,55 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body System.Exp_Int is +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. - ----------------- - -- Exp_Integer -- - ----------------- - - -- Note that negative exponents get a constraint error because the - -- subtype of the Right argument (the exponent) is Natural. - - function Exp_Integer - (Left : Integer; - Right : Natural) - return Integer - is - Result : Integer := 1; - Factor : Integer := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing base values -1, 0, +1 since - -- the expander does this when the base is a literal, and other cases - -- will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - declare - pragma Unsuppress (All_Checks); - begin - Result := Result * Factor; - end; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - - declare - pragma Unsuppress (All_Checks); - begin - Factor := Factor * Factor; - end; - end loop; - end if; - - return Result; - end Exp_Integer; - -end System.Exp_Int; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-expint.ads b/gcc/ada/libgnat/s-expint.ads index 584564a..70d16e0 100644 --- a/gcc/ada/libgnat/s-expint.ads +++ b/gcc/ada/libgnat/s-expint.ads @@ -31,12 +31,11 @@ -- Integer exponentiation (checks on) +with System.Expont; + package System.Exp_Int is - pragma Pure; - function Exp_Integer - (Left : Integer; - Right : Natural) - return Integer; + function Exp_Integer is new Expont (Integer); + pragma Pure_Function (Exp_Integer); end System.Exp_Int; diff --git a/gcc/ada/libgnat/s-explli.adb b/gcc/ada/libgnat/s-explli.adb index 4f244cd..98946dc 100644 --- a/gcc/ada/libgnat/s-explli.adb +++ b/gcc/ada/libgnat/s-explli.adb @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . E X P L L I -- +-- S Y S T E M . E X P _ L L I -- -- -- -- B o d y -- -- -- @@ -29,55 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body System.Exp_LLI is +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. - --------------------------- - -- Exp_Long_Long_Integer -- - --------------------------- - - -- Note that negative exponents get a constraint error because the - -- subtype of the Right argument (the exponent) is Natural. - - function Exp_Long_Long_Integer - (Left : Long_Long_Integer; - Right : Natural) - return Long_Long_Integer - is - Result : Long_Long_Integer := 1; - Factor : Long_Long_Integer := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing base values -1, 0, +1 since - -- the expander does this when the base is a literal, and other cases - -- will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - declare - pragma Unsuppress (All_Checks); - begin - Result := Result * Factor; - end; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - - declare - pragma Unsuppress (All_Checks); - begin - Factor := Factor * Factor; - end; - end loop; - end if; - - return Result; - end Exp_Long_Long_Integer; - -end System.Exp_LLI; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-explli.ads b/gcc/ada/libgnat/s-explli.ads index f1283cd..bf58a9a 100644 --- a/gcc/ada/libgnat/s-explli.ads +++ b/gcc/ada/libgnat/s-explli.ads @@ -29,14 +29,13 @@ -- -- ------------------------------------------------------------------------------ --- Long_Long_Integer exponentiation +-- Long_Long_Integer exponentiation (checks on) + +with System.Expont; package System.Exp_LLI is - pragma Pure; - function Exp_Long_Long_Integer - (Left : Long_Long_Integer; - Right : Natural) - return Long_Long_Integer; + function Exp_Long_Long_Integer is new Expont (Long_Long_Integer); + pragma Pure_Function (Exp_Long_Long_Integer); end System.Exp_LLI; diff --git a/gcc/ada/libgnat/s-expllli.ads b/gcc/ada/libgnat/s-expllli.ads new file mode 100644 index 0000000..0e4375d --- /dev/null +++ b/gcc/ada/libgnat/s-expllli.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ L L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Long_Long_Integer exponentiation (checks on) + +with System.Expont; + +package System.Exp_LLLI is + + function Exp_Long_Long_Long_Integer is new Expont (Long_Long_Long_Integer); + pragma Pure_Function (Exp_Long_Long_Long_Integer); + +end System.Exp_LLLI; diff --git a/gcc/ada/libgnat/s-explllu.ads b/gcc/ada/libgnat/s-explllu.ads new file mode 100644 index 0000000..2f7c6a9 --- /dev/null +++ b/gcc/ada/libgnat/s-explllu.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ L L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This function performs exponentiation of unsigned types with binary modulus +-- values exceeding that of System.Unsigned_Types.Long_Long_Unsigned. +-- The result is always full width, the caller must do a masking operation if +-- the modulus is less than 2 ** Long_Long_Long_Unsigned'Size. + +with System.Exponu; +with System.Unsigned_Types; + +package System.Exp_LLLU is + + subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; + + function Exp_Long_Long_Long_Unsigned is + new Exponu (Long_Long_Long_Unsigned); + pragma Pure_Function (Exp_Long_Long_Long_Unsigned); + +end System.Exp_LLLU; diff --git a/gcc/ada/libgnat/s-expllu.adb b/gcc/ada/libgnat/s-expllu.adb index 5615e4a..3a383f7 100644 --- a/gcc/ada/libgnat/s-expllu.adb +++ b/gcc/ada/libgnat/s-expllu.adb @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . X P _ B M L -- +-- S Y S T E M . E X P _ L L U -- -- -- -- B o d y -- -- -- @@ -29,46 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Exp_LLU is - - ---------------------------- - -- Exp_Long_Long_Unsigned -- - ---------------------------- - - function Exp_Long_Long_Unsigned - (Left : Long_Long_Unsigned; - Right : Natural) - return Long_Long_Unsigned - is - Result : Long_Long_Unsigned := 1; - Factor : Long_Long_Unsigned := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing the cases of base values -1,0,+1 - -- since the expander does this when the base is a literal, and other - -- cases will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - Factor := Factor * Factor; - end loop; - end if; - - return Result; - - end Exp_Long_Long_Unsigned; - -end System.Exp_LLU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-expllu.ads b/gcc/ada/libgnat/s-expllu.ads index 2127aaad..9e30090 100644 --- a/gcc/ada/libgnat/s-expllu.ads +++ b/gcc/ada/libgnat/s-expllu.ads @@ -29,19 +29,19 @@ -- -- ------------------------------------------------------------------------------ --- This function performs exponentiation of unsigned types (with binary --- modulus values exceeding that of Unsigned_Types.Unsigned). The result --- is always full width, the caller must do a masking operation if the --- modulus is less than 2 ** (Long_Long_Unsigned'Size). +-- This function performs exponentiation of unsigned types with binary modulus +-- values exceeding that of System.Unsigned_Types.Unsigned. +-- The result is always full width, the caller must do a masking operation if +-- the modulus is less than 2 ** Long_Long_Unsigned'Size. +with System.Exponu; with System.Unsigned_Types; package System.Exp_LLU is - pragma Pure; - function Exp_Long_Long_Unsigned - (Left : System.Unsigned_Types.Long_Long_Unsigned; - Right : Natural) - return System.Unsigned_Types.Long_Long_Unsigned; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + function Exp_Long_Long_Unsigned is new Exponu (Long_Long_Unsigned); + pragma Pure_Function (Exp_Long_Long_Unsigned); end System.Exp_LLU; diff --git a/gcc/ada/libgnat/s-exponn.adb b/gcc/ada/libgnat/s-exponn.adb new file mode 100644 index 0000000..f1522d0 --- /dev/null +++ b/gcc/ada/libgnat/s-exponn.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P O N N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +function System.Exponn (Left : Int; Right : Natural) return Int is + + -- Note that negative exponents get a constraint error because the + -- subtype of the Right argument (the exponent) is Natural. + + Result : Int := 1; + Factor : Int := Left; + Exp : Natural := Right; + +begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. + + -- Note: it is not worth special casing base values -1, 0, +1 since + -- the expander does this when the base is a literal, and other cases + -- will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + declare + pragma Suppress (Overflow_Check); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + + declare + pragma Suppress (Overflow_Check); + begin + Factor := Factor * Factor; + end; + end loop; + end if; + + return Result; +end System.Exponn; diff --git a/gcc/ada/libgnat/a-excpol.adb b/gcc/ada/libgnat/s-exponn.ads index 27893c3..f4cd18f 100644 --- a/gcc/ada/libgnat/a-excpol.adb +++ b/gcc/ada/libgnat/s-exponn.ads @@ -1,15 +1,14 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . E X C E P T I O N S . P O L L -- +-- S Y S T E M . E X P O N N -- -- -- --- B o d y -- --- (dummy version where polling is not used) -- +-- S p e c -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- --- GNARL is free software; you can redistribute it and/or modify it under -- +-- 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- -- @@ -25,18 +24,15 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -separate (Ada.Exceptions) +-- Signed integer exponentiation (checks off) ----------- --- Poll -- ----------- +generic -procedure Poll is -begin - null; -end Poll; + type Int is range <>; + +function System.Exponn (Left : Int; Right : Natural) return Int; diff --git a/gcc/ada/libgnat/s-expont.adb b/gcc/ada/libgnat/s-expont.adb new file mode 100644 index 0000000..bcdcae4 --- /dev/null +++ b/gcc/ada/libgnat/s-expont.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P O N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +function System.Expont (Left : Int; Right : Natural) return Int is + + -- Note that negative exponents get a constraint error because the + -- subtype of the Right argument (the exponent) is Natural. + + Result : Int := 1; + Factor : Int := Left; + Exp : Natural := Right; + +begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. + + -- Note: it is not worth special casing base values -1, 0, +1 since + -- the expander does this when the base is a literal, and other cases + -- will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + declare + pragma Unsuppress (Overflow_Check); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + + declare + pragma Unsuppress (Overflow_Check); + begin + Factor := Factor * Factor; + end; + end loop; + end if; + + return Result; +end System.Expont; diff --git a/gcc/ada/libgnat/s-expont.ads b/gcc/ada/libgnat/s-expont.ads new file mode 100644 index 0000000..7a519fd --- /dev/null +++ b/gcc/ada/libgnat/s-expont.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P O N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Signed integer exponentiation (checks on) + +generic + + type Int is range <>; + +function System.Expont (Left : Int; Right : Natural) return Int; diff --git a/gcc/ada/libgnat/s-exponu.adb b/gcc/ada/libgnat/s-exponu.adb new file mode 100644 index 0000000..d2b9305 --- /dev/null +++ b/gcc/ada/libgnat/s-exponu.adb @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P O N U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +function System.Exponu (Left : Int; Right : Natural) return Int is + + -- Note that negative exponents get a constraint error because the + -- subtype of the Right argument (the exponent) is Natural. + + Result : Int := 1; + Factor : Int := Left; + Exp : Natural := Right; + +begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. + + -- Note: it is not worth special casing base values -1, 0, +1 since + -- the expander does this when the base is a literal, and other cases + -- will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + end if; + + return Result; +end System.Exponu; diff --git a/gcc/ada/libgnat/s-exponu.ads b/gcc/ada/libgnat/s-exponu.ads new file mode 100644 index 0000000..2a913d6 --- /dev/null +++ b/gcc/ada/libgnat/s-exponu.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P O N U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Modular integer exponentiation + +generic + + type Int is mod <>; + +function System.Exponu (Left : Int; Right : Natural) return Int; diff --git a/gcc/ada/libgnat/s-expuns.adb b/gcc/ada/libgnat/s-expuns.adb index da43763..f513da2 100644 --- a/gcc/ada/libgnat/s-expuns.adb +++ b/gcc/ada/libgnat/s-expuns.adb @@ -29,45 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Exp_Uns is - - ------------------ - -- Exp_Unsigned -- - ------------------ - - function Exp_Unsigned - (Left : Unsigned; - Right : Natural) - return Unsigned - is - Result : Unsigned := 1; - Factor : Unsigned := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing the cases of base values -1,0,+1 - -- since the expander does this when the base is a literal, and other - -- cases will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - Factor := Factor * Factor; - end loop; - end if; - - return Result; - end Exp_Unsigned; - -end System.Exp_Uns; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-expuns.ads b/gcc/ada/libgnat/s-expuns.ads index a0d8085..3826f4f 100644 --- a/gcc/ada/libgnat/s-expuns.ads +++ b/gcc/ada/libgnat/s-expuns.ads @@ -29,19 +29,19 @@ -- -- ------------------------------------------------------------------------------ --- This function performs exponentiation of unsigned types (with binary --- modulus values up to and including that of Unsigned_Types.Unsigned). --- The result is always full width, the caller must do a masking operation --- the modulus is less than 2 ** (Unsigned'Size). +-- This function performs exponentiation of unsigned types with binary modulus +-- values up to and including that of System.Unsigned_Types.Unsigned. +-- The result is always full width, the caller must do a masking operation if +-- the modulus is less than 2 ** Unsigned'Size. +with System.Exponu; with System.Unsigned_Types; package System.Exp_Uns is - pragma Pure; - function Exp_Unsigned - (Left : System.Unsigned_Types.Unsigned; - Right : Natural) - return System.Unsigned_Types.Unsigned; + subtype Unsigned is Unsigned_Types.Unsigned; + + function Exp_Unsigned is new Exponu (Unsigned); + pragma Pure_Function (Exp_Unsigned); end System.Exp_Uns; diff --git a/gcc/ada/libgnat/s-fatgen.adb b/gcc/ada/libgnat/s-fatgen.adb index b544587..a598a12 100644 --- a/gcc/ada/libgnat/s-fatgen.adb +++ b/gcc/ada/libgnat/s-fatgen.adb @@ -172,10 +172,14 @@ package body System.Fat_Gen is elsif X > T'Safe_Last then Frac := Invrad; + pragma Annotate (CodePeer, Intentional, "dead code", + "Check float range."); Expo := T'Machine_Emax + 1; elsif X < T'Safe_First then Frac := -Invrad; + pragma Annotate (CodePeer, Intentional, "dead code", + "Check float range."); Expo := T'Machine_Emax + 2; -- how many extra negative values? else @@ -217,6 +221,8 @@ package body System.Fat_Gen is while Ax < R_Neg_Power (Expbits'Last) loop Ax := Ax * R_Power (Expbits'Last); + pragma Annotate (CodePeer, Intentional, "dead code", + "Check float range."); Ex := Ex - Log_Power (Expbits'Last); end loop; pragma Annotate @@ -424,7 +430,11 @@ package body System.Fat_Gen is -- For infinities, return unchanged elsif X < T'First or else X > T'Last then + pragma Annotate (CodePeer, Intentional, "condition predetermined", + "Check for invalid float"); return X; + pragma Annotate (CodePeer, Intentional, "dead code", + "Check float range."); -- Subtract from the given number a number equivalent to the value -- of its least significant bit. Given that the most significant bit @@ -673,7 +683,11 @@ package body System.Fat_Gen is -- For infinities, return unchanged elsif X < T'First or else X > T'Last then + pragma Annotate (CodePeer, Intentional, "condition predetermined", + "Check for invalid float"); return X; + pragma Annotate (CodePeer, Intentional, "dead code", + "Check float range."); -- Add to the given number a number equivalent to the value -- of its least significant bit. Given that the most significant bit diff --git a/gcc/ada/libgnat/s-fileio.adb b/gcc/ada/libgnat/s-fileio.adb index b6377e3..c574487 100644 --- a/gcc/ada/libgnat/s-fileio.adb +++ b/gcc/ada/libgnat/s-fileio.adb @@ -800,9 +800,9 @@ package body System.File_IO is Text_Encoding : Content_Encoding; - Tempfile : constant Boolean := Name = ""; + Tempfile : constant Boolean := Name = "" and Stream = NULL_Stream; -- Indicates temporary file case, which is indicated by an empty file - -- name. + -- name and no specified Stream. Namelen : constant Integer := max_path_len; -- Length required for file name, not including final ASCII.NUL. diff --git a/gcc/ada/libgnat/s-genbig.adb b/gcc/ada/libgnat/s-genbig.adb index 71aff9b..12167ac 100644 --- a/gcc/ada/libgnat/s-genbig.adb +++ b/gcc/ada/libgnat/s-genbig.adb @@ -1120,7 +1120,33 @@ package body System.Generic_Bignums is -- To_Bignum -- --------------- - function To_Bignum (X : Long_Long_Integer) return Big_Integer is + function To_Bignum (X : Long_Long_Long_Integer) return Big_Integer is + + function Convert_128 + (X : Long_Long_Long_Integer; Neg : Boolean) return Big_Integer; + -- Convert a 128 bits natural integer to a Big_Integer + + ----------------- + -- Convert_128 -- + ----------------- + + function Convert_128 + (X : Long_Long_Long_Integer; Neg : Boolean) return Big_Integer + is + Vector : Digit_Vector (1 .. 4); + High : constant Unsigned_64 := + Unsigned_64 (Shift_Right (Unsigned_128 (X), 64)); + Low : constant Unsigned_64 := + Unsigned_64 (Unsigned_128 (X) and 16#FFFF_FFFF_FFFF_FFFF#); + + begin + Vector (1) := SD (High / Base); + Vector (2) := SD (High mod Base); + Vector (3) := SD (Low / Base); + Vector (4) := SD (Low mod Base); + return Normalize (Vector, Neg); + end Convert_128; + begin if X = 0 then return Allocate_Big_Integer ((1 .. 0 => <>), False); @@ -1130,23 +1156,43 @@ package body System.Generic_Bignums is elsif X in -(2 ** 32 - 1) .. +(2 ** 32 - 1) then return Allocate_Big_Integer ((1 => SD (abs X)), X < 0); - -- Largest negative number annoyance + -- Large negative number annoyance - elsif X = Long_Long_Integer'First then + elsif X = -2 ** 63 then return Allocate_Big_Integer ((2 ** 31, 0), True); + elsif Long_Long_Long_Integer'Size = 128 + and then X = Long_Long_Long_Integer'First + then + return Allocate_Big_Integer ((2 ** 31, 0, 0, 0), True); + -- Other negative numbers elsif X < 0 then - return Allocate_Big_Integer - ((SD ((-X) / Base), SD ((-X) mod Base)), True); + if Long_Long_Long_Integer'Size = 64 then + return Allocate_Big_Integer + ((SD ((-X) / Base), SD ((-X) mod Base)), True); + else + return Convert_128 (-X, True); + end if; -- Positive numbers + else - return Allocate_Big_Integer ((SD (X / Base), SD (X mod Base)), False); + if Long_Long_Long_Integer'Size = 64 then + return Allocate_Big_Integer + ((SD (X / Base), SD (X mod Base)), False); + else + return Convert_128 (X, False); + end if; end if; end To_Bignum; + function To_Bignum (X : Long_Long_Integer) return Big_Integer is + begin + return To_Bignum (Long_Long_Long_Integer (X)); + end To_Bignum; + function To_Bignum (X : Unsigned_64) return Big_Integer is begin if X = 0 then diff --git a/gcc/ada/libgnat/s-genbig.ads b/gcc/ada/libgnat/s-genbig.ads index 003a8fd..81e3843 100644 --- a/gcc/ada/libgnat/s-genbig.ads +++ b/gcc/ada/libgnat/s-genbig.ads @@ -101,6 +101,10 @@ package System.Generic_Bignums is -- Convert Long_Long_Integer to a big integer. No exception can be raised -- for any input argument. + function To_Bignum (X : Long_Long_Long_Integer) return Big_Integer; + -- Convert Long_Long_Long_Integer to a big integer. No exception can be + -- raised. + function To_Bignum (X : Interfaces.Unsigned_64) return Big_Integer; -- Convert Unsigned_64 to a big integer. No exception can be raised for any -- input argument. diff --git a/gcc/ada/libgnat/s-geveop.adb b/gcc/ada/libgnat/s-geveop.adb index 8e59b30..ff62a34 100644 --- a/gcc/ada/libgnat/s-geveop.adb +++ b/gcc/ada/libgnat/s-geveop.adb @@ -66,6 +66,13 @@ package body System.Generic_Vector_Operations is function VP is new Ada.Unchecked_Conversion (Address, Vector_Ptr); function EP is new Ada.Unchecked_Conversion (Address, Element_Ptr); + pragma Assert (VI > 0); + -- VI = VU + -- VU = Vectors.Vector'Size / Storage_Unit + -- Vector'Size = System.Word_Size + -- System.Word_Size is a multiple of Storage_Unit + -- Vector'Size > Storage_Unit + -- VI > 0 SA : constant Address := AddA (XA, To_Address ((Integer_Address (Length) / VI * VI) and Unaligned)); @@ -111,6 +118,13 @@ package body System.Generic_Vector_Operations is function VP is new Ada.Unchecked_Conversion (Address, Vector_Ptr); function EP is new Ada.Unchecked_Conversion (Address, Element_Ptr); + pragma Assert (VI > 0); + -- VI = VU + -- VU = Vectors.Vector'Size / Storage_Unit + -- Vector'Size = System.Word_Size + -- System.Word_Size is a multiple of Storage_Unit + -- Vector'Size > Storage_Unit + -- VI > 0 SA : constant Address := AddA (XA, To_Address ((Integer_Address (Length) / VI * VI) and Unaligned)); diff --git a/gcc/ada/libgnat/s-imageb.adb b/gcc/ada/libgnat/s-imageb.adb new file mode 100644 index 0000000..72e8fb3 --- /dev/null +++ b/gcc/ada/libgnat/s-imageb.adb @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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.Image_B is + + ----------------------------- + -- Set_Image_Based_Integer -- + ----------------------------- + + procedure Set_Image_Based_Integer + (V : Int; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + is + Start : Natural; + + begin + -- Positive case can just use the unsigned circuit directly + + if V >= 0 then + Set_Image_Based_Unsigned (Uns (V), B, W, S, P); + + -- Negative case has to set a minus sign. Note also that we have to be + -- careful not to generate overflow with the largest negative number. + + else + P := P + 1; + S (P) := ' '; + Start := P; + + declare + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + begin + Set_Image_Based_Unsigned (Uns (-V), B, W - 1, S, P); + end; + + -- Set minus sign in last leading blank location. Because of the + -- code above, there must be at least one such location. + + while S (Start + 1) = ' ' loop + Start := Start + 1; + end loop; + + S (Start) := '-'; + end if; + + end Set_Image_Based_Integer; + + ------------------------------ + -- Set_Image_Based_Unsigned -- + ------------------------------ + + procedure Set_Image_Based_Unsigned + (V : Uns; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + is + Start : constant Natural := P; + F, T : Natural; + BU : constant Uns := Uns (B); + Hex : constant array + (Uns range 0 .. 15) of Character := "0123456789ABCDEF"; + + procedure Set_Digits (T : Uns); + -- Set digits of absolute value of T + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits (T : Uns) is + begin + if T >= BU then + Set_Digits (T / BU); + P := P + 1; + S (P) := Hex (T mod BU); + else + P := P + 1; + S (P) := Hex (T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Based_Unsigned + + begin + + if B >= 10 then + P := P + 1; + S (P) := '1'; + end if; + + P := P + 1; + S (P) := Character'Val (Character'Pos ('0') + B mod 10); + + P := P + 1; + S (P) := '#'; + + Set_Digits (V); + + P := P + 1; + S (P) := '#'; + + -- Add leading spaces if required by width parameter + + if P - Start < W then + F := P; + P := Start + W; + T := P; + + while F > Start loop + S (T) := S (F); + T := T - 1; + F := F - 1; + end loop; + + for J in Start + 1 .. T loop + S (J) := ' '; + end loop; + end if; + + end Set_Image_Based_Unsigned; + +end System.Image_B; diff --git a/gcc/ada/libgnat/s-imageb.ads b/gcc/ada/libgnat/s-imageb.ads new file mode 100644 index 0000000..109f5c7 --- /dev/null +++ b/gcc/ada/libgnat/s-imageb.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image in based format of signed and +-- unsigned integers for use by Text_IO.Integer_IO and Text_IO.Modular_IO. + +generic + + type Int is range <>; + + type Uns is mod <>; + +package System.Image_B is + pragma Pure; + + procedure Set_Image_Based_Integer + (V : Int; + B : Natural; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the signed image of V in based format, using base value B (2..16) + -- starting at S (P + 1), updating P to point to the last character stored. + -- The image includes a leading minus sign if necessary, but no leading + -- spaces unless W is positive, in which case leading spaces are output if + -- necessary to ensure that the output string is no less than W characters + -- long. The caller promises that the buffer is large enough and no check + -- is made for this. Constraint_Error will not necessarily be raised if + -- this is violated, since it is perfectly valid to compile this unit with + -- checks off. + + procedure Set_Image_Based_Unsigned + (V : Uns; + B : Natural; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the unsigned image of V in based format, using base value B (2..16) + -- starting at S (P + 1), updating P to point to the last character stored. + -- The image includes no leading spaces unless W is positive, in which case + -- leading spaces are output if necessary to ensure that the output string + -- is no less than W characters long. The caller promises that the buffer + -- is large enough and no check is made for this. Constraint_Error will not + -- necessarily be raised if this is violated, since it is perfectly valid + -- to compile this unit with checks off). + +end System.Image_B; diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb new file mode 100644 index 0000000..c739dfb --- /dev/null +++ b/gcc/ada/libgnat/s-imagei.adb @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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.Image_I is + + subtype Non_Positive is Int range Int'First .. 0; + + procedure Set_Digits + (T : Non_Positive; + S : in out String; + P : in out Natural); + -- Set digits of absolute value of T, which is zero or negative. We work + -- with the negative of the value so that the largest negative number is + -- not a special case. + + ------------------- + -- Image_Integer -- + ------------------- + + procedure Image_Integer + (V : Int; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + + begin + if V >= 0 then + S (1) := ' '; + P := 1; + else + P := 0; + end if; + + Set_Image_Integer (V, S, P); + end Image_Integer; + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits + (T : Non_Positive; + S : in out String; + P : in out Natural) + is + begin + if T <= -10 then + Set_Digits (T / 10, S, P); + pragma Assert (P >= (S'First - 1) and P < S'Last and + P < Natural'Last); + -- No check is done since, as documented in the Set_Image_Integer + -- specification, the caller guarantees that S is long enough to + -- hold the result. + P := P + 1; + S (P) := Character'Val (48 - (T rem 10)); + + else + pragma Assert (P >= (S'First - 1) and P < S'Last and + P < Natural'Last); + -- No check is done since, as documented in the Set_Image_Integer + -- specification, the caller guarantees that S is long enough to + -- hold the result. + P := P + 1; + S (P) := Character'Val (48 - T); + end if; + end Set_Digits; + + ----------------------- + -- Set_Image_Integer -- + ----------------------- + + procedure Set_Image_Integer + (V : Int; + S : in out String; + P : in out Natural) + is + begin + if V >= 0 then + Set_Digits (-V, S, P); + + else + pragma Assert (P >= (S'First - 1) and P < S'Last and + P < Natural'Last); + -- No check is done since, as documented in the specification, + -- the caller guarantees that S is long enough to hold the result. + P := P + 1; + S (P) := '-'; + Set_Digits (V, S, P); + end if; + end Set_Image_Integer; + +end System.Image_I; diff --git a/gcc/ada/libgnat/s-imagei.ads b/gcc/ada/libgnat/s-imagei.ads new file mode 100644 index 0000000..2163af8 --- /dev/null +++ b/gcc/ada/libgnat/s-imagei.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- signed integer types, and also for conversion operations required in +-- Text_IO.Integer_IO for such types. + +generic + + type Int is range <>; + +package System.Image_I is + pragma Pure; + + procedure Image_Integer + (V : Int; + S : in out String; + P : out Natural); + -- Computes Int'Image (V) and stores the result in S (1 .. P) + -- setting the resulting value of P. The caller guarantees that S + -- is long enough to hold the result, and that S'First is 1. + + procedure Set_Image_Integer + (V : Int; + S : in out String; + P : in out Natural); + -- Stores the image of V in S starting at S (P + 1), P is updated to point + -- to the last character stored. The value stored is identical to the value + -- of Int'Image (V) except that no leading space is stored when V is + -- non-negative. The caller guarantees that S is long enough to hold the + -- result. S need not have a lower bound of 1. + +end System.Image_I; diff --git a/gcc/ada/libgnat/s-imageu.adb b/gcc/ada/libgnat/s-imageu.adb new file mode 100644 index 0000000..c995d55 --- /dev/null +++ b/gcc/ada/libgnat/s-imageu.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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.Image_U is + + -------------------- + -- Image_Unsigned -- + -------------------- + + procedure Image_Unsigned + (V : Uns; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + begin + S (1) := ' '; + P := 1; + Set_Image_Unsigned (V, S, P); + end Image_Unsigned; + + ------------------------ + -- Set_Image_Unsigned -- + ------------------------ + + procedure Set_Image_Unsigned + (V : Uns; + S : in out String; + P : in out Natural) + is + begin + if V >= 10 then + Set_Image_Unsigned (V / 10, S, P); + pragma Assert (P >= (S'First - 1) and P < S'Last and + P < Natural'Last); + -- No check is done since, as documented in the specification, + -- the caller guarantees that S is long enough to hold the result. + P := P + 1; + S (P) := Character'Val (48 + (V rem 10)); + + else + pragma Assert (P >= (S'First - 1) and P < S'Last and + P < Natural'Last); + -- No check is done since, as documented in the specification, + -- the caller guarantees that S is long enough to hold the result. + P := P + 1; + S (P) := Character'Val (48 + V); + end if; + end Set_Image_Unsigned; + +end System.Image_U; diff --git a/gcc/ada/libgnat/s-imageu.ads b/gcc/ada/libgnat/s-imageu.ads new file mode 100644 index 0000000..39e738a --- /dev/null +++ b/gcc/ada/libgnat/s-imageu.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- modular integer types, and also for conversion operations required in +-- Text_IO.Modular_IO for such types. + +generic + + type Uns is mod <>; + +package System.Image_U is + pragma Pure; + + procedure Image_Unsigned + (V : Uns; + S : in out String; + P : out Natural); + pragma Inline (Image_Unsigned); + -- Computes Uns'Image (V) and stores the result in S (1 .. P) setting + -- the resulting value of P. The caller guarantees that S is long enough to + -- hold the result, and that S'First is 1. + + procedure Set_Image_Unsigned + (V : Uns; + S : in out String; + P : in out Natural); + -- Stores the image of V in S starting at S (P + 1), P is updated to point + -- to the last character stored. The value stored is identical to the value + -- of Uns'Image (V) except that no leading space is stored. The caller + -- guarantees that S is long enough to hold the result. S need not have a + -- lower bound of 1. + +end System.Image_U; diff --git a/gcc/ada/libgnat/s-imagew.adb b/gcc/ada/libgnat/s-imagew.adb new file mode 100644 index 0000000..dd3b96e --- /dev/null +++ b/gcc/ada/libgnat/s-imagew.adb @@ -0,0 +1,152 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ W -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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.Image_W is + + ----------------------------- + -- Set_Image_Width_Integer -- + ----------------------------- + + procedure Set_Image_Width_Integer + (V : Int; + W : Integer; + S : out String; + P : in out Natural) + is + Start : Natural; + + begin + -- Positive case can just use the unsigned circuit directly + + if V >= 0 then + Set_Image_Width_Unsigned (Uns (V), W, S, P); + + -- Negative case has to set a minus sign. Note also that we have to be + -- careful not to generate overflow with the largest negative number. + + else + P := P + 1; + S (P) := ' '; + Start := P; + + declare + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + begin + Set_Image_Width_Unsigned (Uns (-V), W - 1, S, P); + end; + + -- Set minus sign in last leading blank location. Because of the + -- code above, there must be at least one such location. + + while S (Start + 1) = ' ' loop + Start := Start + 1; + end loop; + + S (Start) := '-'; + end if; + + end Set_Image_Width_Integer; + + ------------------------------ + -- Set_Image_Width_Unsigned -- + ------------------------------ + + procedure Set_Image_Width_Unsigned + (V : Uns; + W : Integer; + S : out String; + P : in out Natural) + is + Start : constant Natural := P; + F, T : Natural; + + procedure Set_Digits (T : Uns); + -- Set digits of absolute value of T + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits (T : Uns) is + begin + if T >= 10 then + Set_Digits (T / 10); + pragma Assert (P >= (S'First - 1) and P < S'Last and + P < Natural'Last); + -- No check is done since, as documented in the specification, + -- the caller guarantees that S is long enough to hold the result. + P := P + 1; + S (P) := Character'Val (T mod 10 + Character'Pos ('0')); + + else + pragma Assert (P >= (S'First - 1) and P < S'Last and + P < Natural'Last); + -- No check is done since, as documented in the specification, + -- the caller guarantees that S is long enough to hold the result. + P := P + 1; + S (P) := Character'Val (T + Character'Pos ('0')); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Width_Unsigned + + begin + Set_Digits (V); + + -- Add leading spaces if required by width parameter + + if P - Start < W then + F := P; + P := P + (W - (P - Start)); + T := P; + + while F > Start loop + pragma Assert (T >= S'First and T <= S'Last and + F >= S'First and F <= S'Last); + -- No check is done since, as documented in the specification, + -- the caller guarantees that S is long enough to hold the result. + S (T) := S (F); + T := T - 1; + F := F - 1; + end loop; + + for J in Start + 1 .. T loop + pragma Assert (J >= S'First and J <= S'Last); + -- No check is done since, as documented in the specification, + -- the caller guarantees that S is long enough to hold the result. + S (J) := ' '; + end loop; + end if; + + end Set_Image_Width_Unsigned; + +end System.Image_W; diff --git a/gcc/ada/libgnat/s-imagew.ads b/gcc/ada/libgnat/s-imagew.ads new file mode 100644 index 0000000..14c0c60 --- /dev/null +++ b/gcc/ada/libgnat/s-imagew.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ W -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image of signed and unsigned +-- integers up to Integer for use by Text_IO.Integer_IO and +-- Text_IO.Modular_IO. + +generic + + type Int is range <>; + + type Uns is mod <>; + +package System.Image_W is + pragma Pure; + + procedure Set_Image_Width_Integer + (V : Int; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the signed image of V in decimal format, starting at S (P + 1), + -- updating P to point to the last character stored. The image includes + -- a leading minus sign if necessary, but no leading spaces unless W is + -- positive, in which case leading spaces are output if necessary to ensure + -- that the output string is no less than W characters long. The caller + -- promises that the buffer is large enough and no check is made for this. + -- Constraint_Error will not necessarily be raised if this is violated, + -- since it is perfectly valid to compile this unit with checks off. + + procedure Set_Image_Width_Unsigned + (V : Uns; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the unsigned image of V in decimal format, starting at S (P + 1), + -- updating P to point to the last character stored. The image includes no + -- leading spaces unless W is positive, in which case leading spaces are + -- output if necessary to ensure that the output string is no less than + -- W characters long. The caller promises that the buffer is large enough + -- and no check is made for this. Constraint_Error will not necessarily be + -- raised if this is violated, since it is perfectly valid to compile this + -- unit with checks off. + +end System.Image_W; diff --git a/gcc/ada/libgnat/s-imenne.adb b/gcc/ada/libgnat/s-imenne.adb index 605b85b..3052ea2 100644 --- a/gcc/ada/libgnat/s-imenne.adb +++ b/gcc/ada/libgnat/s-imenne.adb @@ -49,8 +49,11 @@ package body System.Img_Enum_New is pragma Assert (S'First = 1); type Natural_8 is range 0 .. 2 ** 7 - 1; + subtype Names_Index is + Natural_8 range Natural_8 (Names'First) + .. Natural_8 (Names'Last) + 1; subtype Index is Natural range Natural'First .. Names'Length; - type Index_Table is array (Index) of Natural_8; + type Index_Table is array (Index) of Names_Index; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is @@ -58,9 +61,19 @@ package body System.Img_Enum_New is IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + pragma Assert (Pos in IndexesT'Range); + pragma Assert (Pos + 1 in IndexesT'Range); + Start : constant Natural := Natural (IndexesT (Pos)); Next : constant Natural := Natural (IndexesT (Pos + 1)); + pragma Assert (Next - 1 >= Start); + pragma Assert (Start >= Names'First); + pragma Assert (Next - 1 <= Names'Last); + + pragma Assert (Next - Start <= S'Last); + -- The caller should guarantee that S is large enough to contain the + -- enumeration image. begin S (1 .. Next - Start) := Names (Start .. Next - 1); P := Next - Start; @@ -80,8 +93,11 @@ package body System.Img_Enum_New is pragma Assert (S'First = 1); type Natural_16 is range 0 .. 2 ** 15 - 1; + subtype Names_Index is + Natural_16 range Natural_16 (Names'First) + .. Natural_16 (Names'Last) + 1; subtype Index is Natural range Natural'First .. Names'Length; - type Index_Table is array (Index) of Natural_16; + type Index_Table is array (Index) of Names_Index; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is @@ -89,9 +105,19 @@ package body System.Img_Enum_New is IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + pragma Assert (Pos in IndexesT'Range); + pragma Assert (Pos + 1 in IndexesT'Range); + Start : constant Natural := Natural (IndexesT (Pos)); Next : constant Natural := Natural (IndexesT (Pos + 1)); + pragma Assert (Next - 1 >= Start); + pragma Assert (Start >= Names'First); + pragma Assert (Next - 1 <= Names'Last); + + pragma Assert (Next - Start <= S'Last); + -- The caller should guarantee that S is large enough to contain the + -- enumeration image. begin S (1 .. Next - Start) := Names (Start .. Next - 1); P := Next - Start; @@ -111,8 +137,11 @@ package body System.Img_Enum_New is pragma Assert (S'First = 1); type Natural_32 is range 0 .. 2 ** 31 - 1; + subtype Names_Index is + Natural_32 range Natural_32 (Names'First) + .. Natural_32 (Names'Last) + 1; subtype Index is Natural range Natural'First .. Names'Length; - type Index_Table is array (Index) of Natural_32; + type Index_Table is array (Index) of Names_Index; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is @@ -120,9 +149,19 @@ package body System.Img_Enum_New is IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + pragma Assert (Pos in IndexesT'Range); + pragma Assert (Pos + 1 in IndexesT'Range); + Start : constant Natural := Natural (IndexesT (Pos)); Next : constant Natural := Natural (IndexesT (Pos + 1)); + pragma Assert (Next - 1 >= Start); + pragma Assert (Start >= Names'First); + pragma Assert (Next - 1 <= Names'Last); + + pragma Assert (Next - Start <= S'Last); + -- The caller should guarantee that S is large enough to contain the + -- enumeration image. begin S (1 .. Next - Start) := Names (Start .. Next - 1); P := Next - Start; diff --git a/gcc/ada/libgnat/s-imgbiu.adb b/gcc/ada/libgnat/s-imgbiu.adb index 7b765c0..fbbbcec 100644 --- a/gcc/ada/libgnat/s-imgbiu.adb +++ b/gcc/ada/libgnat/s-imgbiu.adb @@ -29,130 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_BIU is - - ----------------------------- - -- Set_Image_Based_Integer -- - ----------------------------- - - procedure Set_Image_Based_Integer - (V : Integer; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Based_Unsigned (Unsigned (V), B, W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Based_Unsigned (Unsigned (-V), B, W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Based_Integer; - - ------------------------------ - -- Set_Image_Based_Unsigned -- - ------------------------------ - - procedure Set_Image_Based_Unsigned - (V : Unsigned; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - BU : constant Unsigned := Unsigned (B); - Hex : constant array - (Unsigned range 0 .. 15) of Character := "0123456789ABCDEF"; - - procedure Set_Digits (T : Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Unsigned) is - begin - if T >= BU then - Set_Digits (T / BU); - P := P + 1; - S (P) := Hex (T mod BU); - else - P := P + 1; - S (P) := Hex (T); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Based_Unsigned - - begin - - if B >= 10 then - P := P + 1; - S (P) := '1'; - end if; - - P := P + 1; - S (P) := Character'Val (Character'Pos ('0') + B mod 10); - - P := P + 1; - S (P) := '#'; - - Set_Digits (V); - - P := P + 1; - S (P) := '#'; - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := Start + W; - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Based_Unsigned; - -end System.Img_BIU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgbiu.ads b/gcc/ada/libgnat/s-imgbiu.ads index 524e582..9cf24ae 100644 --- a/gcc/ada/libgnat/s-imgbiu.ads +++ b/gcc/ada/libgnat/s-imgbiu.ads @@ -30,43 +30,33 @@ ------------------------------------------------------------------------------ -- Contains the routine for computing the image in based format of signed and --- unsigned integers whose size <= Integer'Size for use by Text_IO.Integer_IO --- and Text_IO.Modular_IO. +-- unsigned integers up to Integer for use by Text_IO.Integer_IO and +-- Text_IO.Modular_IO. +with System.Image_B; with System.Unsigned_Types; package System.Img_BIU is pragma Pure; + subtype Unsigned is Unsigned_Types.Unsigned; + + package Impl is new Image_B (Integer, Unsigned); + procedure Set_Image_Based_Integer (V : Integer; B : Natural; W : Integer; S : out String; - P : in out Natural); - -- Sets the signed image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes a leading minus sign if necessary, but no leading - -- spaces unless W is positive, in which case leading spaces are output if - -- necessary to ensure that the output string is no less than W characters - -- long. The caller promises that the buffer is large enough and no check - -- is made for this. Constraint_Error will not necessarily be raised if - -- this is violated, since it is perfectly valid to compile this unit with - -- checks off. + P : in out Natural) + renames Impl.Set_Image_Based_Integer; procedure Set_Image_Based_Unsigned - (V : System.Unsigned_Types.Unsigned; + (V : Unsigned; B : Natural; W : Integer; S : out String; - P : in out Natural); - -- Sets the unsigned image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes no leading spaces unless W is positive, in which case - -- leading spaces are output if necessary to ensure that the output string - -- is no less than W characters long. The caller promises that the buffer - -- is large enough and no check is made for this. Constraint_Error will not - -- necessarily be raised if this is violated, since it is perfectly valid - -- to compile this unit with checks off). + P : in out Natural) + renames Impl.Set_Image_Based_Unsigned; end System.Img_BIU; diff --git a/gcc/ada/libgnat/s-imgcha.adb b/gcc/ada/libgnat/s-imgcha.adb index a2d7c46..06048eb 100644 --- a/gcc/ada/libgnat/s-imgcha.adb +++ b/gcc/ada/libgnat/s-imgcha.adb @@ -140,8 +140,12 @@ package body System.Img_Char is declare VP : constant Natural := Character'Pos (V); begin - S (1 .. 9) := "RESERVED_"; - S (10) := Character'Val (48 + VP / 100); + pragma Assert (S'First = 1 and S'Last >= 12); + -- As described in the header description, this procedure + -- doesn't check the size of the string provided by the caller + -- and suppose S'First is 1. + S (1 .. 10) := "RESERVED_1"; + -- Since C1_Range is 127..159, the first character is always 1 S (11) := Character'Val (48 + (VP / 10) mod 10); S (12) := Character'Val (48 + VP mod 10); P := 12; diff --git a/gcc/ada/libgnat/s-imgdec.adb b/gcc/ada/libgnat/s-imgdec.adb index 6000d44..840dadb 100644 --- a/gcc/ada/libgnat/s-imgdec.adb +++ b/gcc/ada/libgnat/s-imgdec.adb @@ -72,6 +72,10 @@ package body System.Img_Dec is Aft : Natural; Exp : Natural) is + pragma Assert (NDigs >= 1); + pragma Assert (Digs'First = 1); + pragma Assert (Digs'First < Digs'Last); + Minus : constant Boolean := (Digs (Digs'First) = '-'); -- Set True if input is negative @@ -135,6 +139,10 @@ package body System.Img_Dec is procedure Round (N : Integer) is D : Character; + pragma Assert (NDigs >= 1); + pragma Assert (Digs'First = 1); + pragma Assert (Digs'First < Digs'Last); + begin -- Nothing to do if rounding past the last digit we have @@ -164,10 +172,17 @@ package body System.Img_Dec is else LD := N; + pragma Assert (LD >= 1); + -- In this case, we have N < LD and N >= FD. FD is a Natural, + -- So we can conclude, LD >= 1 ND := LD - 1; + pragma Assert (N + 1 <= Digs'Last); if Digs (N + 1) >= '5' then - for J in reverse 2 .. N loop + for J in reverse Digs'First + 1 .. Digs'First + N - 1 loop + pragma Assert (Digs (J) in '0' .. '9' | ' ' | '-'); + -- Because it is a decimal image, we can assume that + -- it can only contain these characters. D := Character'Succ (Digs (J)); if D <= '9' then @@ -196,6 +211,17 @@ package body System.Img_Dec is procedure Set (C : Character) is begin + pragma Assert (P >= (S'First - 1) and P < S'Last and + P < Natural'Last); + -- No check is done as documented in the header : updating P to + -- point to the last character stored, the caller promises that the + -- buffer is large enough and no check is made for this. + -- Constraint_Error will not necessarily be raised if this + -- requirement is violated, since it is perfectly valid to compile + -- this unit with checks off. + -- + -- Due to codepeer limitation, codepeer should be used with switch: + -- -no-propagation system.img_dec.set_decimal_digits.set P := P + 1; S (P) := C; end Set; @@ -230,6 +256,9 @@ package body System.Img_Dec is procedure Set_Digits (S, E : Natural) is begin + pragma Assert (S >= Digs'First and E <= Digs'Last); + -- S and E should be in the Digs array range + -- TBC: Analysis should be completed for J in S .. E loop Set (Digs (J)); end loop; @@ -254,8 +283,10 @@ package body System.Img_Dec is if Exp > 0 then Set_Blanks_And_Sign (Fore - 1); Round (Digits_After_Point + 2); + Set (Digs (FD)); FD := FD + 1; + pragma Assert (ND >= 1); ND := ND - 1; Set ('.'); @@ -388,6 +419,9 @@ package body System.Img_Dec is else Set_Blanks_And_Sign (Fore - Digits_Before_Point); + pragma Assert (FD + Digits_Before_Point - 1 >= 0); + -- In this branch, we have Digits_Before_Point > 0. It is the + -- else of test (Digits_Before_Point <= 0) Set_Digits (FD, FD + Digits_Before_Point - 1); Set ('.'); Set_Digits (FD + Digits_Before_Point, LD); diff --git a/gcc/ada/libgnat/s-imgint.adb b/gcc/ada/libgnat/s-imgint.adb index 2b94472..acadd1c 100644 --- a/gcc/ada/libgnat/s-imgint.adb +++ b/gcc/ada/libgnat/s-imgint.adb @@ -29,75 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body System.Img_Int is +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. - procedure Set_Digits - (T : Integer; - S : in out String; - P : in out Natural); - -- Set digits of absolute value of T, which is zero or negative. We work - -- with the negative of the value so that the largest negative number is - -- not a special case. - - ------------------- - -- Image_Integer -- - ------------------- - - procedure Image_Integer - (V : Integer; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - - begin - if V >= 0 then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Integer (V, S, P); - end Image_Integer; - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits - (T : Integer; - S : in out String; - P : in out Natural) - is - begin - if T <= -10 then - Set_Digits (T / 10, S, P); - P := P + 1; - S (P) := Character'Val (48 - (T rem 10)); - else - P := P + 1; - S (P) := Character'Val (48 - T); - end if; - end Set_Digits; - - ----------------------- - -- Set_Image_Integer -- - ----------------------- - - procedure Set_Image_Integer - (V : Integer; - S : in out String; - P : in out Natural) - is - begin - if V >= 0 then - Set_Digits (-V, S, P); - else - P := P + 1; - S (P) := '-'; - Set_Digits (V, S, P); - end if; - end Set_Image_Integer; - -end System.Img_Int; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgint.ads b/gcc/ada/libgnat/s-imgint.ads index 6c2c675..08ce31d 100644 --- a/gcc/ada/libgnat/s-imgint.ads +++ b/gcc/ada/libgnat/s-imgint.ads @@ -30,28 +30,26 @@ ------------------------------------------------------------------------------ -- This package contains the routines for supporting the Image attribute for --- signed integer types up to Size Integer'Size, and also for conversion --- operations required in Text_IO.Integer_IO for such types. +-- signed integer types up to Integer, and also for conversion operations +-- required in Text_IO.Integer_IO for such types. + +with System.Image_I; package System.Img_Int is pragma Pure; + package Impl is new Image_I (Integer); + procedure Image_Integer (V : Integer; S : in out String; - P : out Natural); - -- Computes Integer'Image (V) and stores the result in S (1 .. P) - -- setting the resulting value of P. The caller guarantees that S - -- is long enough to hold the result, and that S'First is 1. + P : out Natural) + renames Impl.Image_Integer; procedure Set_Image_Integer (V : Integer; S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Integer'Image (V) except that no leading space is stored when V is - -- non-negative. The caller guarantees that S is long enough to hold the - -- result. S need not have a lower bound of 1. + P : in out Natural) + renames Impl.Set_Image_Integer; end System.Img_Int; diff --git a/gcc/ada/libgnat/s-imgllb.adb b/gcc/ada/libgnat/s-imgllb.adb index 30d6a3c..90ba5ce 100644 --- a/gcc/ada/libgnat/s-imgllb.adb +++ b/gcc/ada/libgnat/s-imgllb.adb @@ -29,133 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_LLB is - - --------------------------------------- - -- Set_Image_Based_Long_Long_Integer -- - --------------------------------------- - - procedure Set_Image_Based_Long_Long_Integer - (V : Long_Long_Integer; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Based_Long_Long_Unsigned - (Long_Long_Unsigned (V), B, W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Based_Long_Long_Unsigned - (Long_Long_Unsigned (-V), B, W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Based_Long_Long_Integer; - - ---------------------------------------- - -- Set_Image_Based_Long_Long_Unsigned -- - ---------------------------------------- - - procedure Set_Image_Based_Long_Long_Unsigned - (V : Long_Long_Unsigned; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - BU : constant Long_Long_Unsigned := Long_Long_Unsigned (B); - Hex : constant array - (Long_Long_Unsigned range 0 .. 15) of Character := - "0123456789ABCDEF"; - - procedure Set_Digits (T : Long_Long_Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Long_Long_Unsigned) is - begin - if T >= BU then - Set_Digits (T / BU); - P := P + 1; - S (P) := Hex (T mod BU); - else - P := P + 1; - S (P) := Hex (T); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Based_Long_Long_Unsigned - - begin - - if B >= 10 then - P := P + 1; - S (P) := '1'; - end if; - - P := P + 1; - S (P) := Character'Val (Character'Pos ('0') + B mod 10); - - P := P + 1; - S (P) := '#'; - - Set_Digits (V); - - P := P + 1; - S (P) := '#'; - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := Start + W; - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Based_Long_Long_Unsigned; - -end System.Img_LLB; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgllb.ads b/gcc/ada/libgnat/s-imgllb.ads index 0232315..bfaf2ee 100644 --- a/gcc/ada/libgnat/s-imgllb.ads +++ b/gcc/ada/libgnat/s-imgllb.ads @@ -30,43 +30,33 @@ ------------------------------------------------------------------------------ -- Contains the routine for computing the image in based format of signed and --- unsigned integers whose size > Integer'Size for use by Text_IO.Integer_IO --- and Text_IO.Modular_IO. +-- unsigned integers larger than Integer for use by Text_IO.Integer_IO and +-- Text_IO.Modular_IO. +with System.Image_B; with System.Unsigned_Types; package System.Img_LLB is pragma Preelaborate; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + package Impl is new Image_B (Long_Long_Integer, Long_Long_Unsigned); + procedure Set_Image_Based_Long_Long_Integer (V : Long_Long_Integer; B : Natural; W : Integer; S : out String; - P : in out Natural); - -- Sets the signed image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes a leading minus sign if necessary, but no leading - -- spaces unless W is positive, in which case leading spaces are output if - -- necessary to ensure that the output string is no less than W characters - -- long. The caller promises that the buffer is large enough and no check - -- is made for this. Constraint_Error will not necessarily be raised if - -- this is violated, since it is perfectly valid to compile this unit with - -- checks off. + P : in out Natural) + renames Impl.Set_Image_Based_Integer; procedure Set_Image_Based_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; + (V : Long_Long_Unsigned; B : Natural; W : Integer; S : out String; - P : in out Natural); - -- Sets the unsigned image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes no leading spaces unless W is positive, in which case - -- leading spaces are output if necessary to ensure that the output string - -- is no less than W characters long. The caller promises that the buffer - -- is large enough and no check is made for this. Constraint_Error will not - -- necessarily be raised if this is violated, since it is perfectly valid - -- to compile this unit with checks off). + P : in out Natural) + renames Impl.Set_Image_Based_Unsigned; end System.Img_LLB; diff --git a/gcc/ada/libgnat/s-imglli.adb b/gcc/ada/libgnat/s-imglli.adb index 4d024ee..cdaeb7e 100644 --- a/gcc/ada/libgnat/s-imglli.adb +++ b/gcc/ada/libgnat/s-imglli.adb @@ -29,74 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body System.Img_LLI is +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. - procedure Set_Digits - (T : Long_Long_Integer; - S : in out String; - P : in out Natural); - -- Set digits of absolute value of T, which is zero or negative. We work - -- with the negative of the value so that the largest negative number is - -- not a special case. - - ----------------------------- - -- Image_Long_Long_Integer -- - ----------------------------- - - procedure Image_Long_Long_Integer - (V : Long_Long_Integer; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - - begin - if V >= 0 then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Long_Long_Integer (V, S, P); - end Image_Long_Long_Integer; - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits - (T : Long_Long_Integer; - S : in out String; - P : in out Natural) - is - begin - if T <= -10 then - Set_Digits (T / 10, S, P); - P := P + 1; - S (P) := Character'Val (48 - (T rem 10)); - else - P := P + 1; - S (P) := Character'Val (48 - T); - end if; - end Set_Digits; - - --------------------------------- - -- Set_Image_Long_Long_Integer -- - -------------------------------- - - procedure Set_Image_Long_Long_Integer - (V : Long_Long_Integer; - S : in out String; - P : in out Natural) is - begin - if V >= 0 then - Set_Digits (-V, S, P); - else - P := P + 1; - S (P) := '-'; - Set_Digits (V, S, P); - end if; - end Set_Image_Long_Long_Integer; - -end System.Img_LLI; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads index b0d3cae..49defc5 100644 --- a/gcc/ada/libgnat/s-imglli.ads +++ b/gcc/ada/libgnat/s-imglli.ads @@ -30,28 +30,26 @@ ------------------------------------------------------------------------------ -- This package contains the routines for supporting the Image attribute for --- signed integer types larger than Size Integer'Size, and also for conversion --- operations required in Text_IO.Integer_IO for such types. +-- signed integer types larger Integer, and also for conversion operations +-- required in Text_IO.Integer_IO for such types. + +with System.Image_I; package System.Img_LLI is pragma Pure; + package Impl is new Image_I (Long_Long_Integer); + procedure Image_Long_Long_Integer (V : Long_Long_Integer; S : in out String; - P : out Natural); - -- Computes Long_Long_Integer'Image (V) and stores the result in - -- S (1 .. P) setting the resulting value of P. The caller guarantees - -- that S is long enough to hold the result, and that S'First is 1. + P : out Natural) + renames Impl.Image_Integer; procedure Set_Image_Long_Long_Integer (V : Long_Long_Integer; S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Long_Long_Integer'Image (V) except that no leading space is stored - -- when V is non-negative. The caller guarantees that S is long enough to - -- hold the result. S need not have a lower bound of 1. + P : in out Natural) + renames Impl.Set_Image_Integer; end System.Img_LLI; diff --git a/gcc/ada/libgnat/a-timoau.ads b/gcc/ada/libgnat/s-imglllb.ads index 247eb14..b246037 100644 --- a/gcc/ada/libgnat/a-timoau.ads +++ b/gcc/ada/libgnat/s-imglllb.ads @@ -2,7 +2,7 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . T E X T _ I O . M O D U L A R _ A U X -- +-- S Y S T E M . I M G _ L L L B -- -- -- -- S p e c -- -- -- @@ -29,59 +29,35 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines for Ada.Text_IO.Modular_IO that are --- shared among separate instantiations of this package. The routines in --- this package are identical semantically to those in Modular_IO itself, --- except that the generic parameter Num has been replaced by Unsigned or --- Long_Long_Unsigned, and the default parameters have been removed because --- they are supplied explicitly by the calls from within the generic template. +-- Contains the routine for computing the image in based format of signed and +-- unsigned integers larger than Long_Long_Integer for use by +-- Text_IO.Integer_IO and Text_IO.Modular_IO. +with System.Image_B; with System.Unsigned_Types; -private package Ada.Text_IO.Modular_Aux is +package System.Img_LLLB is + pragma Preelaborate; - package U renames System.Unsigned_Types; + subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - procedure Get_Uns - (File : File_Type; - Item : out U.Unsigned; - Width : Field); + package Impl is + new Image_B (Long_Long_Long_Integer, Long_Long_Long_Unsigned); - procedure Get_LLU - (File : File_Type; - Item : out U.Long_Long_Unsigned; - Width : Field); + procedure Set_Image_Based_Long_Long_Long_Integer + (V : Long_Long_Long_Integer; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + renames Impl.Set_Image_Based_Integer; - procedure Put_Uns - (File : File_Type; - Item : U.Unsigned; - Width : Field; - Base : Number_Base); + procedure Set_Image_Based_Long_Long_Long_Unsigned + (V : Long_Long_Long_Unsigned; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + renames Impl.Set_Image_Based_Unsigned; - procedure Put_LLU - (File : File_Type; - Item : U.Long_Long_Unsigned; - Width : Field; - Base : Number_Base); - - procedure Gets_Uns - (From : String; - Item : out U.Unsigned; - Last : out Positive); - - procedure Gets_LLU - (From : String; - Item : out U.Long_Long_Unsigned; - Last : out Positive); - - procedure Puts_Uns - (To : out String; - Item : U.Unsigned; - Base : Number_Base); - - procedure Puts_LLU - (To : out String; - Item : U.Long_Long_Unsigned; - Base : Number_Base); - -end Ada.Text_IO.Modular_Aux; +end System.Img_LLLB; diff --git a/gcc/ada/libgnat/s-imgllli.ads b/gcc/ada/libgnat/s-imgllli.ads new file mode 100644 index 0000000..c6d41f9 --- /dev/null +++ b/gcc/ada/libgnat/s-imgllli.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- signed integer types larger than Long_Long_Integer, and also for conversion +-- operations required in Text_IO.Integer_IO for such types. + +with System.Image_I; + +package System.Img_LLLI is + pragma Pure; + + package Impl is new Image_I (Long_Long_Long_Integer); + + procedure Image_Long_Long_Long_Integer + (V : Long_Long_Long_Integer; + S : in out String; + P : out Natural) + renames Impl.Image_Integer; + + procedure Set_Image_Long_Long_Long_Integer + (V : Long_Long_Long_Integer; + S : in out String; + P : in out Natural) + renames Impl.Set_Image_Integer; + +end System.Img_LLLI; diff --git a/gcc/ada/libgnat/s-imglllu.ads b/gcc/ada/libgnat/s-imglllu.ads new file mode 100644 index 0000000..8b6f16a --- /dev/null +++ b/gcc/ada/libgnat/s-imglllu.ads @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- modular integer types larger than Long_Long_Unsigned, and also for +-- conversion operations required in Text_IO.Modular_IO for such types. + +with System.Image_U; +with System.Unsigned_Types; + +package System.Img_LLLU is + pragma Pure; + + subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; + + package Impl is new Image_U (Long_Long_Long_Unsigned); + + procedure Image_Long_Long_Long_Unsigned + (V : Long_Long_Long_Unsigned; + S : in out String; + P : out Natural) + renames Impl.Image_Unsigned; + + procedure Set_Image_Long_Long_Long_Unsigned + (V : Long_Long_Long_Unsigned; + S : in out String; + P : in out Natural) + renames Impl.Set_Image_Unsigned; + +end System.Img_LLLU; diff --git a/gcc/ada/libgnat/s-imglllw.ads b/gcc/ada/libgnat/s-imglllw.ads new file mode 100644 index 0000000..de33f18 --- /dev/null +++ b/gcc/ada/libgnat/s-imglllw.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L W -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image of signed and unsigned +-- integers larger than Integer for use by Text_IO.Integer_IO and +-- Text_IO.Modular_IO. + +with System.Image_W; +with System.Unsigned_Types; + +package System.Img_LLLW is + pragma Pure; + + subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; + + package Impl is + new Image_W (Long_Long_Long_Integer, Long_Long_Long_Unsigned); + + procedure Set_Image_Width_Long_Long_Long_Integer + (V : Long_Long_Long_Integer; + W : Integer; + S : out String; + P : in out Natural) + renames Impl.Set_Image_Width_Integer; + + procedure Set_Image_Width_Long_Long_Long_Unsigned + (V : Long_Long_Long_Unsigned; + W : Integer; + S : out String; + P : in out Natural) + renames Impl.Set_Image_Width_Unsigned; + +end System.Img_LLLW; diff --git a/gcc/ada/libgnat/s-imgllu.adb b/gcc/ada/libgnat/s-imgllu.adb index f62a25d..680b11b 100644 --- a/gcc/ada/libgnat/s-imgllu.adb +++ b/gcc/ada/libgnat/s-imgllu.adb @@ -29,45 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_LLU is - - ------------------------------ - -- Image_Long_Long_Unsigned -- - ------------------------------ - - procedure Image_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - begin - S (1) := ' '; - P := 1; - Set_Image_Long_Long_Unsigned (V, S, P); - end Image_Long_Long_Unsigned; - - ---------------------------------- - -- Set_Image_Long_Long_Unsigned -- - ---------------------------------- - - procedure Set_Image_Long_Long_Unsigned - (V : Long_Long_Unsigned; - S : in out String; - P : in out Natural) - is - begin - if V >= 10 then - Set_Image_Long_Long_Unsigned (V / 10, S, P); - P := P + 1; - S (P) := Character'Val (48 + (V rem 10)); - - else - P := P + 1; - S (P) := Character'Val (48 + V); - end if; - end Set_Image_Long_Long_Unsigned; - -end System.Img_LLU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgllu.ads b/gcc/ada/libgnat/s-imgllu.ads index d54bb33..dabc68d 100644 --- a/gcc/ada/libgnat/s-imgllu.ads +++ b/gcc/ada/libgnat/s-imgllu.ads @@ -30,32 +30,29 @@ ------------------------------------------------------------------------------ -- This package contains the routines for supporting the Image attribute for --- unsigned (modular) integer types larger than Size Unsigned'Size, and also --- for conversion operations required in Text_IO.Modular_IO for such types. +-- modular integer types larger than Unsigned, and also for conversion +-- operations required in Text_IO.Modular_IO for such types. +with System.Image_U; with System.Unsigned_Types; package System.Img_LLU is pragma Pure; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + package Impl is new Image_U (Long_Long_Unsigned); + procedure Image_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; + (V : Long_Long_Unsigned; S : in out String; - P : out Natural); - pragma Inline (Image_Long_Long_Unsigned); - - -- Computes Long_Long_Unsigned'Image (V) and stores the result in - -- S (1 .. P) setting the resulting value of P. The caller guarantees - -- that S is long enough to hold the result, and that S'First is 1. + P : out Natural) + renames Impl.Image_Unsigned; procedure Set_Image_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; + (V : Long_Long_Unsigned; S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Long_Long_Unsigned'Image (V) except that no leading space is stored. - -- The caller guarantees that S is long enough to hold the result. S need - -- not have a lower bound of 1. + P : in out Natural) + renames Impl.Set_Image_Unsigned; end System.Img_LLU; diff --git a/gcc/ada/libgnat/s-imgllw.adb b/gcc/ada/libgnat/s-imgllw.adb index cfd4fc2..5702a93 100644 --- a/gcc/ada/libgnat/s-imgllw.adb +++ b/gcc/ada/libgnat/s-imgllw.adb @@ -29,112 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_LLW is - - --------------------------------------- - -- Set_Image_Width_Long_Long_Integer -- - --------------------------------------- - - procedure Set_Image_Width_Long_Long_Integer - (V : Long_Long_Integer; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Width_Long_Long_Unsigned - (Long_Long_Unsigned (V), W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Width_Long_Long_Unsigned - (Long_Long_Unsigned (-V), W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Width_Long_Long_Integer; - - ---------------------------------------- - -- Set_Image_Width_Long_Long_Unsigned -- - ---------------------------------------- - - procedure Set_Image_Width_Long_Long_Unsigned - (V : Long_Long_Unsigned; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - - procedure Set_Digits (T : Long_Long_Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Long_Long_Unsigned) is - begin - if T >= 10 then - Set_Digits (T / 10); - P := P + 1; - S (P) := Character'Val (T mod 10 + Character'Pos ('0')); - else - P := P + 1; - S (P) := Character'Val (T + Character'Pos ('0')); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Width_Long_Long_Unsigned - - begin - Set_Digits (V); - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := P + (W - (P - Start)); - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Width_Long_Long_Unsigned; - -end System.Img_LLW; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgllw.ads b/gcc/ada/libgnat/s-imgllw.ads index e6e5fb0..12986e5 100644 --- a/gcc/ada/libgnat/s-imgllw.ads +++ b/gcc/ada/libgnat/s-imgllw.ads @@ -30,40 +30,31 @@ ------------------------------------------------------------------------------ -- Contains the routine for computing the image of signed and unsigned --- integers whose size > Integer'Size for use by Text_IO.Integer_IO, +-- integers larger than Integer for use by Text_IO.Integer_IO and -- Text_IO.Modular_IO. +with System.Image_W; with System.Unsigned_Types; package System.Img_LLW is pragma Pure; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + package Impl is new Image_W (Long_Long_Integer, Long_Long_Unsigned); + procedure Set_Image_Width_Long_Long_Integer (V : Long_Long_Integer; W : Integer; S : out String; - P : in out Natural); - -- Sets the signed image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes - -- a leading minus sign if necessary, but no leading spaces unless W is - -- positive, in which case leading spaces are output if necessary to ensure - -- that the output string is no less than W characters long. The caller - -- promises that the buffer is large enough and no check is made for this. - -- Constraint_Error will not necessarily be raised if this is violated, - -- since it is perfectly valid to compile this unit with checks off. + P : in out Natural) + renames Impl.Set_Image_Width_Integer; procedure Set_Image_Width_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; + (V : Long_Long_Unsigned; W : Integer; S : out String; - P : in out Natural); - -- Sets the unsigned image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes no - -- leading spaces unless W is positive, in which case leading spaces are - -- output if necessary to ensure that the output string is no less than - -- W characters long. The caller promises that the buffer is large enough - -- and no check is made for this. Constraint_Error will not necessarily be - -- raised if this is violated, since it is perfectly valid to compile this - -- unit with checks off. + P : in out Natural) + renames Impl.Set_Image_Width_Unsigned; end System.Img_LLW; diff --git a/gcc/ada/libgnat/s-imgrea.adb b/gcc/ada/libgnat/s-imgrea.adb index 68b1fdc..45d0ae5 100644 --- a/gcc/ada/libgnat/s-imgrea.adb +++ b/gcc/ada/libgnat/s-imgrea.adb @@ -29,10 +29,9 @@ -- -- ------------------------------------------------------------------------------ -with System.Img_LLU; use System.Img_LLU; -with System.Img_Uns; use System.Img_Uns; -with System.Powten_Table; use System.Powten_Table; -with System.Unsigned_Types; use System.Unsigned_Types; +with System.Img_LLU; use System.Img_LLU; +with System.Img_Uns; use System.Img_Uns; +with System.Powten_Table; use System.Powten_Table; with System.Float_Control; package body System.Img_Real is @@ -99,6 +98,11 @@ package body System.Img_Real is if (not Is_Negative (V) and then V <= Long_Long_Float'Last) or else (not Long_Long_Float'Signed_Zeros and then V = -0.0) then + pragma Annotate (CodePeer, False_Positive, "condition predetermined", + "CodePeer analysis ignores NaN and Inf values"); + pragma Assert (S'Last > 1); + -- The caller is responsible for S to be large enough for all + -- Image_Floating_Point operation. S (1) := ' '; P := 1; else @@ -372,6 +376,7 @@ package body System.Img_Real is -- be significantly more efficient than the Long_Long_Unsigned one. if X < Powten (Unsdigs) then + pragma Assert (X in 0.0 .. Long_Long_Float (Unsigned'Last)); Ndigs := 0; Set_Image_Unsigned (Unsigned (Long_Long_Float'Truncation (X)), @@ -381,6 +386,10 @@ package body System.Img_Real is -- the Long_Long_Unsigned routine after all. else + pragma Assert (X < Powten (Maxdigs)); + pragma Assert + (X in 0.0 .. Long_Long_Float (Long_Long_Unsigned'Last)); + Ndigs := 0; Set_Image_Long_Long_Unsigned (Long_Long_Unsigned (Long_Long_Float'Truncation (X)), @@ -394,6 +403,12 @@ package body System.Img_Real is procedure Set (C : Character) is begin + pragma Assert (P in S'First - 1 .. S'Last - 1); + -- No check is done as documented in the header: updating P to point + -- to the last character stored, the caller promises that the buffer + -- is large enough and no check is made for this. Constraint_Error + -- will not necessarily be raised if this requirement is violated, + -- since it is perfectly valid to compile this unit with checks off. P := P + 1; S (P) := C; end Set; @@ -424,6 +439,8 @@ package body System.Img_Real is procedure Set_Digs (S, E : Natural) is begin + pragma Assert (S >= Digs'First and E <= Digs'Last); + -- S and E should be in the Digs array range for J in S .. E loop Set (Digs (J)); end loop; @@ -437,9 +454,13 @@ package body System.Img_Real is F : Natural; begin + pragma Assert ((Fore + Aft - N + 1) in Natural); + -- Fore + Aft - N + 1 should be in the Natural range F := Fore + 1 + Aft - N; if Exp /= 0 then + pragma Assert (F + Exp + 1 <= Natural'Last); + -- F + Exp + 1 should be in the Natural range F := F + Exp + 1; end if; @@ -487,15 +508,15 @@ package body System.Img_Real is -- an infinite value, so we print Inf. if V > Long_Long_Float'Last then - pragma Annotate - (CodePeer, Intentional, "test always true", "test for infinity"); - + pragma Annotate (CodePeer, False_Positive, "dead code", + "CodePeer analysis ignores NaN and Inf values"); + pragma Annotate (CodePeer, False_Positive, "test always true", + "CodePeer analysis ignores NaN and Inf values"); Set ('+'); Set ('I'); Set ('n'); Set ('f'); Set_Special_Fill (4); - -- In all other cases we print NaN elsif V < Long_Long_Float'First then @@ -504,7 +525,6 @@ package body System.Img_Real is Set ('n'); Set ('f'); Set_Special_Fill (4); - else Set ('N'); Set ('a'); @@ -597,6 +617,7 @@ package body System.Img_Real is for J in 1 .. Scale + NF loop Ndigs := Ndigs + 1; + pragma Assert (Ndigs <= Digs'Last); Digs (Ndigs) := '0'; end loop; @@ -663,6 +684,7 @@ package body System.Img_Real is for J in 1 .. NFrac - Maxdigs + 1 loop Ndigs := Ndigs + 1; + pragma Assert (Ndigs <= Digs'Last); Digs (Ndigs) := '0'; Scale := Scale - 1; end loop; diff --git a/gcc/ada/libgnat/s-imguns.adb b/gcc/ada/libgnat/s-imguns.adb index 914121d..8db42b4 100644 --- a/gcc/ada/libgnat/s-imguns.adb +++ b/gcc/ada/libgnat/s-imguns.adb @@ -29,45 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_Uns is - - -------------------- - -- Image_Unsigned -- - -------------------- - - procedure Image_Unsigned - (V : System.Unsigned_Types.Unsigned; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - begin - S (1) := ' '; - P := 1; - Set_Image_Unsigned (V, S, P); - end Image_Unsigned; - - ------------------------ - -- Set_Image_Unsigned -- - ------------------------ - - procedure Set_Image_Unsigned - (V : Unsigned; - S : in out String; - P : in out Natural) - is - begin - if V >= 10 then - Set_Image_Unsigned (V / 10, S, P); - P := P + 1; - S (P) := Character'Val (48 + (V rem 10)); - - else - P := P + 1; - S (P) := Character'Val (48 + V); - end if; - end Set_Image_Unsigned; - -end System.Img_Uns; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads index 86e6d99..746fff1 100644 --- a/gcc/ada/libgnat/s-imguns.ads +++ b/gcc/ada/libgnat/s-imguns.ads @@ -30,31 +30,29 @@ ------------------------------------------------------------------------------ -- This package contains the routines for supporting the Image attribute for --- modular integer types up to size Unsigned'Size, and also for conversion --- operations required in Text_IO.Modular_IO for such types. +-- modular integer types up to Unsigned, and also for conversion operations +-- required in Text_IO.Modular_IO for such types. +with System.Image_U; with System.Unsigned_Types; package System.Img_Uns is pragma Pure; + subtype Unsigned is Unsigned_Types.Unsigned; + + package Impl is new Image_U (Unsigned); + procedure Image_Unsigned - (V : System.Unsigned_Types.Unsigned; + (V : Unsigned; S : in out String; - P : out Natural); - pragma Inline (Image_Unsigned); - -- Computes Unsigned'Image (V) and stores the result in S (1 .. P) setting - -- the resulting value of P. The caller guarantees that S is long enough to - -- hold the result, and that S'First is 1. + P : out Natural) + renames Impl.Image_Unsigned; procedure Set_Image_Unsigned - (V : System.Unsigned_Types.Unsigned; + (V : Unsigned; S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Unsigned'Image (V) except that no leading space is stored. The caller - -- guarantees that S is long enough to hold the result. S need not have a - -- lower bound of 1. + P : in out Natural) + renames Impl.Set_Image_Unsigned; end System.Img_Uns; diff --git a/gcc/ada/libgnat/s-imgwiu.adb b/gcc/ada/libgnat/s-imgwiu.adb index 90a8f41..9f04cce 100644 --- a/gcc/ada/libgnat/s-imgwiu.adb +++ b/gcc/ada/libgnat/s-imgwiu.adb @@ -29,110 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Img_WIU is - - ----------------------------- - -- Set_Image_Width_Integer -- - ----------------------------- - - procedure Set_Image_Width_Integer - (V : Integer; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Width_Unsigned (Unsigned (V), W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Width_Unsigned (Unsigned (-V), W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Width_Integer; - - ------------------------------ - -- Set_Image_Width_Unsigned -- - ------------------------------ - - procedure Set_Image_Width_Unsigned - (V : Unsigned; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - - procedure Set_Digits (T : Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Unsigned) is - begin - if T >= 10 then - Set_Digits (T / 10); - P := P + 1; - S (P) := Character'Val (T mod 10 + Character'Pos ('0')); - else - P := P + 1; - S (P) := Character'Val (T + Character'Pos ('0')); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Width_Unsigned - - begin - Set_Digits (V); - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := P + (W - (P - Start)); - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Width_Unsigned; - -end System.Img_WIU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-imgwiu.ads b/gcc/ada/libgnat/s-imgwiu.ads index 6d33599..89515e8 100644 --- a/gcc/ada/libgnat/s-imgwiu.ads +++ b/gcc/ada/libgnat/s-imgwiu.ads @@ -30,40 +30,31 @@ ------------------------------------------------------------------------------ -- Contains the routine for computing the image of signed and unsigned --- integers whose size <= Integer'Size for use by Text_IO.Integer_IO --- and Text_IO.Modular_IO. +-- integers up to Integer for use by Text_IO.Integer_IO and +-- Text_IO.Modular_IO. +with System.Image_W; with System.Unsigned_Types; package System.Img_WIU is pragma Pure; + subtype Unsigned is Unsigned_Types.Unsigned; + + package Impl is new Image_W (Integer, Unsigned); + procedure Set_Image_Width_Integer (V : Integer; W : Integer; S : out String; - P : in out Natural); - -- Sets the signed image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes - -- a leading minus sign if necessary, but no leading spaces unless W is - -- positive, in which case leading spaces are output if necessary to ensure - -- that the output string is no less than W characters long. The caller - -- promises that the buffer is large enough and no check is made for this. - -- Constraint_Error will not necessarily be raised if this is violated, - -- since it is perfectly valid to compile this unit with checks off. + P : in out Natural) + renames Impl.Set_Image_Width_Integer; procedure Set_Image_Width_Unsigned - (V : System.Unsigned_Types.Unsigned; + (V : Unsigned; W : Integer; S : out String; - P : in out Natural); - -- Sets the unsigned image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes no - -- leading spaces unless W is positive, in which case leading spaces are - -- output if necessary to ensure that the output string is no less than - -- W characters long. The caller promises that the buffer is large enough - -- and no check is made for this. Constraint_Error will not necessarily be - -- raised if this is violated, since it is perfectly valid to compile this - -- unit with checks off. + P : in out Natural) + renames Impl.Set_Image_Width_Unsigned; end System.Img_WIU; diff --git a/gcc/ada/libgnat/s-mastop.ads b/gcc/ada/libgnat/s-mastop.ads index c2c23d3..ffe04be 100644 --- a/gcc/ada/libgnat/s-mastop.ads +++ b/gcc/ada/libgnat/s-mastop.ads @@ -31,10 +31,6 @@ pragma Compiler_Unit_Warning; -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with System.Exception_Tables. - with System.Storage_Elements; package System.Machine_State_Operations is diff --git a/gcc/ada/libgnat/s-pack100.adb b/gcc/ada/libgnat/s-pack100.adb new file mode 100644 index 0000000..bae251c --- /dev/null +++ b/gcc/ada/libgnat/s-pack100.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_100 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_100; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_100 or SetU_100 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_100 -- + ------------ + + function Get_100 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_100 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_100; + + ------------- + -- GetU_100 -- + ------------- + + function GetU_100 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_100 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_100; + + ------------ + -- Set_100 -- + ------------ + + procedure Set_100 + (Arr : System.Address; + N : Natural; + E : Bits_100; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_100; + + ------------- + -- SetU_100 -- + ------------- + + procedure SetU_100 + (Arr : System.Address; + N : Natural; + E : Bits_100; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_100; + +end System.Pack_100; diff --git a/gcc/ada/libgnat/s-pack100.ads b/gcc/ada/libgnat/s-pack100.ads new file mode 100644 index 0000000..dfb3e62 --- /dev/null +++ b/gcc/ada/libgnat/s-pack100.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 100 + +package System.Pack_100 is + pragma Preelaborate; + + Bits : constant := 100; + + type Bits_100 is mod 2 ** Bits; + for Bits_100'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_100 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_100 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_100 + (Arr : System.Address; + N : Natural; + E : Bits_100; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_100 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_100 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_100 + (Arr : System.Address; + N : Natural; + E : Bits_100; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_100; diff --git a/gcc/ada/libgnat/s-pack101.adb b/gcc/ada/libgnat/s-pack101.adb new file mode 100644 index 0000000..dfa1cf3 --- /dev/null +++ b/gcc/ada/libgnat/s-pack101.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_101 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_101; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_101 -- + ------------ + + function Get_101 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_101 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_101; + + ------------ + -- Set_101 -- + ------------ + + procedure Set_101 + (Arr : System.Address; + N : Natural; + E : Bits_101; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_101; + +end System.Pack_101; diff --git a/gcc/ada/libgnat/s-pack101.ads b/gcc/ada/libgnat/s-pack101.ads new file mode 100644 index 0000000..2e77051 --- /dev/null +++ b/gcc/ada/libgnat/s-pack101.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 101 + +package System.Pack_101 is + pragma Preelaborate; + + Bits : constant := 101; + + type Bits_101 is mod 2 ** Bits; + for Bits_101'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_101 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_101 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_101 + (Arr : System.Address; + N : Natural; + E : Bits_101; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_101; diff --git a/gcc/ada/libgnat/s-pack102.adb b/gcc/ada/libgnat/s-pack102.adb new file mode 100644 index 0000000..ebf1094 --- /dev/null +++ b/gcc/ada/libgnat/s-pack102.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_102 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_102; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_102 or SetU_102 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_102 -- + ------------ + + function Get_102 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_102 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_102; + + ------------- + -- GetU_102 -- + ------------- + + function GetU_102 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_102 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_102; + + ------------ + -- Set_102 -- + ------------ + + procedure Set_102 + (Arr : System.Address; + N : Natural; + E : Bits_102; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_102; + + ------------- + -- SetU_102 -- + ------------- + + procedure SetU_102 + (Arr : System.Address; + N : Natural; + E : Bits_102; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_102; + +end System.Pack_102; diff --git a/gcc/ada/libgnat/s-pack102.ads b/gcc/ada/libgnat/s-pack102.ads new file mode 100644 index 0000000..065f338 --- /dev/null +++ b/gcc/ada/libgnat/s-pack102.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 102 + +package System.Pack_102 is + pragma Preelaborate; + + Bits : constant := 102; + + type Bits_102 is mod 2 ** Bits; + for Bits_102'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_102 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_102 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_102 + (Arr : System.Address; + N : Natural; + E : Bits_102; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_102 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_102 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_102 + (Arr : System.Address; + N : Natural; + E : Bits_102; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_102; diff --git a/gcc/ada/libgnat/s-pack103.adb b/gcc/ada/libgnat/s-pack103.adb new file mode 100644 index 0000000..b5df31e --- /dev/null +++ b/gcc/ada/libgnat/s-pack103.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_103 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_103; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_103 -- + ------------ + + function Get_103 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_103 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_103; + + ------------ + -- Set_103 -- + ------------ + + procedure Set_103 + (Arr : System.Address; + N : Natural; + E : Bits_103; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_103; + +end System.Pack_103; diff --git a/gcc/ada/libgnat/s-pack103.ads b/gcc/ada/libgnat/s-pack103.ads new file mode 100644 index 0000000..ad12b0e --- /dev/null +++ b/gcc/ada/libgnat/s-pack103.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 103 + +package System.Pack_103 is + pragma Preelaborate; + + Bits : constant := 103; + + type Bits_103 is mod 2 ** Bits; + for Bits_103'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_103 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_103 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_103 + (Arr : System.Address; + N : Natural; + E : Bits_103; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_103; diff --git a/gcc/ada/libgnat/s-pack104.adb b/gcc/ada/libgnat/s-pack104.adb new file mode 100644 index 0000000..573fe4a --- /dev/null +++ b/gcc/ada/libgnat/s-pack104.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_104 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_104; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_104 or SetU_104 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_104 -- + ------------ + + function Get_104 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_104 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_104; + + ------------- + -- GetU_104 -- + ------------- + + function GetU_104 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_104 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_104; + + ------------ + -- Set_104 -- + ------------ + + procedure Set_104 + (Arr : System.Address; + N : Natural; + E : Bits_104; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_104; + + ------------- + -- SetU_104 -- + ------------- + + procedure SetU_104 + (Arr : System.Address; + N : Natural; + E : Bits_104; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_104; + +end System.Pack_104; diff --git a/gcc/ada/libgnat/s-pack104.ads b/gcc/ada/libgnat/s-pack104.ads new file mode 100644 index 0000000..3dee1a7 --- /dev/null +++ b/gcc/ada/libgnat/s-pack104.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 104 + +package System.Pack_104 is + pragma Preelaborate; + + Bits : constant := 104; + + type Bits_104 is mod 2 ** Bits; + for Bits_104'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_104 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_104 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_104 + (Arr : System.Address; + N : Natural; + E : Bits_104; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_104 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_104 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_104 + (Arr : System.Address; + N : Natural; + E : Bits_104; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_104; diff --git a/gcc/ada/libgnat/s-pack105.adb b/gcc/ada/libgnat/s-pack105.adb new file mode 100644 index 0000000..b5e2aab --- /dev/null +++ b/gcc/ada/libgnat/s-pack105.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_105 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_105; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_105 -- + ------------ + + function Get_105 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_105 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_105; + + ------------ + -- Set_105 -- + ------------ + + procedure Set_105 + (Arr : System.Address; + N : Natural; + E : Bits_105; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_105; + +end System.Pack_105; diff --git a/gcc/ada/libgnat/s-pack105.ads b/gcc/ada/libgnat/s-pack105.ads new file mode 100644 index 0000000..2faf652 --- /dev/null +++ b/gcc/ada/libgnat/s-pack105.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 105 + +package System.Pack_105 is + pragma Preelaborate; + + Bits : constant := 105; + + type Bits_105 is mod 2 ** Bits; + for Bits_105'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_105 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_105 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_105 + (Arr : System.Address; + N : Natural; + E : Bits_105; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_105; diff --git a/gcc/ada/libgnat/s-pack106.adb b/gcc/ada/libgnat/s-pack106.adb new file mode 100644 index 0000000..645b5a2 --- /dev/null +++ b/gcc/ada/libgnat/s-pack106.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_106 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_106; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_106 or SetU_106 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_106 -- + ------------ + + function Get_106 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_106 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_106; + + ------------- + -- GetU_106 -- + ------------- + + function GetU_106 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_106 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_106; + + ------------ + -- Set_106 -- + ------------ + + procedure Set_106 + (Arr : System.Address; + N : Natural; + E : Bits_106; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_106; + + ------------- + -- SetU_106 -- + ------------- + + procedure SetU_106 + (Arr : System.Address; + N : Natural; + E : Bits_106; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_106; + +end System.Pack_106; diff --git a/gcc/ada/libgnat/s-pack106.ads b/gcc/ada/libgnat/s-pack106.ads new file mode 100644 index 0000000..27c7efa --- /dev/null +++ b/gcc/ada/libgnat/s-pack106.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 106 + +package System.Pack_106 is + pragma Preelaborate; + + Bits : constant := 106; + + type Bits_106 is mod 2 ** Bits; + for Bits_106'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_106 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_106 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_106 + (Arr : System.Address; + N : Natural; + E : Bits_106; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_106 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_106 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_106 + (Arr : System.Address; + N : Natural; + E : Bits_106; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_106; diff --git a/gcc/ada/libgnat/s-pack107.adb b/gcc/ada/libgnat/s-pack107.adb new file mode 100644 index 0000000..7e1a86a --- /dev/null +++ b/gcc/ada/libgnat/s-pack107.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_107 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_107; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_107 -- + ------------ + + function Get_107 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_107 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_107; + + ------------ + -- Set_107 -- + ------------ + + procedure Set_107 + (Arr : System.Address; + N : Natural; + E : Bits_107; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_107; + +end System.Pack_107; diff --git a/gcc/ada/libgnat/s-pack107.ads b/gcc/ada/libgnat/s-pack107.ads new file mode 100644 index 0000000..3eba81d --- /dev/null +++ b/gcc/ada/libgnat/s-pack107.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 107 + +package System.Pack_107 is + pragma Preelaborate; + + Bits : constant := 107; + + type Bits_107 is mod 2 ** Bits; + for Bits_107'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_107 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_107 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_107 + (Arr : System.Address; + N : Natural; + E : Bits_107; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_107; diff --git a/gcc/ada/libgnat/s-pack108.adb b/gcc/ada/libgnat/s-pack108.adb new file mode 100644 index 0000000..afe28a5 --- /dev/null +++ b/gcc/ada/libgnat/s-pack108.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_108 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_108; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_108 or SetU_108 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_108 -- + ------------ + + function Get_108 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_108 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_108; + + ------------- + -- GetU_108 -- + ------------- + + function GetU_108 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_108 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_108; + + ------------ + -- Set_108 -- + ------------ + + procedure Set_108 + (Arr : System.Address; + N : Natural; + E : Bits_108; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_108; + + ------------- + -- SetU_108 -- + ------------- + + procedure SetU_108 + (Arr : System.Address; + N : Natural; + E : Bits_108; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_108; + +end System.Pack_108; diff --git a/gcc/ada/libgnat/s-pack108.ads b/gcc/ada/libgnat/s-pack108.ads new file mode 100644 index 0000000..e751654 --- /dev/null +++ b/gcc/ada/libgnat/s-pack108.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 108 + +package System.Pack_108 is + pragma Preelaborate; + + Bits : constant := 108; + + type Bits_108 is mod 2 ** Bits; + for Bits_108'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_108 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_108 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_108 + (Arr : System.Address; + N : Natural; + E : Bits_108; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_108 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_108 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_108 + (Arr : System.Address; + N : Natural; + E : Bits_108; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_108; diff --git a/gcc/ada/libgnat/s-pack109.adb b/gcc/ada/libgnat/s-pack109.adb new file mode 100644 index 0000000..e976ed4 --- /dev/null +++ b/gcc/ada/libgnat/s-pack109.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_109 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_109; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_109 -- + ------------ + + function Get_109 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_109 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_109; + + ------------ + -- Set_109 -- + ------------ + + procedure Set_109 + (Arr : System.Address; + N : Natural; + E : Bits_109; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_109; + +end System.Pack_109; diff --git a/gcc/ada/libgnat/s-pack109.ads b/gcc/ada/libgnat/s-pack109.ads new file mode 100644 index 0000000..2ea8b42 --- /dev/null +++ b/gcc/ada/libgnat/s-pack109.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 109 + +package System.Pack_109 is + pragma Preelaborate; + + Bits : constant := 109; + + type Bits_109 is mod 2 ** Bits; + for Bits_109'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_109 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_109 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_109 + (Arr : System.Address; + N : Natural; + E : Bits_109; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_109; diff --git a/gcc/ada/libgnat/s-pack110.adb b/gcc/ada/libgnat/s-pack110.adb new file mode 100644 index 0000000..a85eb3d --- /dev/null +++ b/gcc/ada/libgnat/s-pack110.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_110 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_110; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_110 or SetU_110 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_110 -- + ------------ + + function Get_110 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_110 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_110; + + ------------- + -- GetU_110 -- + ------------- + + function GetU_110 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_110 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_110; + + ------------ + -- Set_110 -- + ------------ + + procedure Set_110 + (Arr : System.Address; + N : Natural; + E : Bits_110; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_110; + + ------------- + -- SetU_110 -- + ------------- + + procedure SetU_110 + (Arr : System.Address; + N : Natural; + E : Bits_110; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_110; + +end System.Pack_110; diff --git a/gcc/ada/libgnat/s-pack110.ads b/gcc/ada/libgnat/s-pack110.ads new file mode 100644 index 0000000..570a994 --- /dev/null +++ b/gcc/ada/libgnat/s-pack110.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 110 + +package System.Pack_110 is + pragma Preelaborate; + + Bits : constant := 110; + + type Bits_110 is mod 2 ** Bits; + for Bits_110'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_110 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_110 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_110 + (Arr : System.Address; + N : Natural; + E : Bits_110; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_110 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_110 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_110 + (Arr : System.Address; + N : Natural; + E : Bits_110; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_110; diff --git a/gcc/ada/libgnat/s-pack111.adb b/gcc/ada/libgnat/s-pack111.adb new file mode 100644 index 0000000..168877b --- /dev/null +++ b/gcc/ada/libgnat/s-pack111.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_111 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_111; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_111 -- + ------------ + + function Get_111 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_111 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_111; + + ------------ + -- Set_111 -- + ------------ + + procedure Set_111 + (Arr : System.Address; + N : Natural; + E : Bits_111; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_111; + +end System.Pack_111; diff --git a/gcc/ada/libgnat/s-pack111.ads b/gcc/ada/libgnat/s-pack111.ads new file mode 100644 index 0000000..784b861 --- /dev/null +++ b/gcc/ada/libgnat/s-pack111.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 111 + +package System.Pack_111 is + pragma Preelaborate; + + Bits : constant := 111; + + type Bits_111 is mod 2 ** Bits; + for Bits_111'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_111 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_111 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_111 + (Arr : System.Address; + N : Natural; + E : Bits_111; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_111; diff --git a/gcc/ada/libgnat/s-pack112.adb b/gcc/ada/libgnat/s-pack112.adb new file mode 100644 index 0000000..b8acf56 --- /dev/null +++ b/gcc/ada/libgnat/s-pack112.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_112 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_112; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_112 or SetU_112 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_112 -- + ------------ + + function Get_112 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_112 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_112; + + ------------- + -- GetU_112 -- + ------------- + + function GetU_112 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_112 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_112; + + ------------ + -- Set_112 -- + ------------ + + procedure Set_112 + (Arr : System.Address; + N : Natural; + E : Bits_112; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_112; + + ------------- + -- SetU_112 -- + ------------- + + procedure SetU_112 + (Arr : System.Address; + N : Natural; + E : Bits_112; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_112; + +end System.Pack_112; diff --git a/gcc/ada/libgnat/s-pack112.ads b/gcc/ada/libgnat/s-pack112.ads new file mode 100644 index 0000000..6b36a8b --- /dev/null +++ b/gcc/ada/libgnat/s-pack112.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 112 + +package System.Pack_112 is + pragma Preelaborate; + + Bits : constant := 112; + + type Bits_112 is mod 2 ** Bits; + for Bits_112'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_112 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_112 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_112 + (Arr : System.Address; + N : Natural; + E : Bits_112; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_112 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_112 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_112 + (Arr : System.Address; + N : Natural; + E : Bits_112; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_112; diff --git a/gcc/ada/libgnat/s-pack113.adb b/gcc/ada/libgnat/s-pack113.adb new file mode 100644 index 0000000..58f84d4 --- /dev/null +++ b/gcc/ada/libgnat/s-pack113.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_113 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_113; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_113 -- + ------------ + + function Get_113 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_113 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_113; + + ------------ + -- Set_113 -- + ------------ + + procedure Set_113 + (Arr : System.Address; + N : Natural; + E : Bits_113; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_113; + +end System.Pack_113; diff --git a/gcc/ada/libgnat/s-pack113.ads b/gcc/ada/libgnat/s-pack113.ads new file mode 100644 index 0000000..2f0bfc2 --- /dev/null +++ b/gcc/ada/libgnat/s-pack113.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 113 + +package System.Pack_113 is + pragma Preelaborate; + + Bits : constant := 113; + + type Bits_113 is mod 2 ** Bits; + for Bits_113'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_113 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_113 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_113 + (Arr : System.Address; + N : Natural; + E : Bits_113; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_113; diff --git a/gcc/ada/libgnat/s-pack114.adb b/gcc/ada/libgnat/s-pack114.adb new file mode 100644 index 0000000..079abeb --- /dev/null +++ b/gcc/ada/libgnat/s-pack114.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_114 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_114; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_114 or SetU_114 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_114 -- + ------------ + + function Get_114 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_114 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_114; + + ------------- + -- GetU_114 -- + ------------- + + function GetU_114 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_114 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_114; + + ------------ + -- Set_114 -- + ------------ + + procedure Set_114 + (Arr : System.Address; + N : Natural; + E : Bits_114; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_114; + + ------------- + -- SetU_114 -- + ------------- + + procedure SetU_114 + (Arr : System.Address; + N : Natural; + E : Bits_114; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_114; + +end System.Pack_114; diff --git a/gcc/ada/libgnat/s-pack114.ads b/gcc/ada/libgnat/s-pack114.ads new file mode 100644 index 0000000..046026e --- /dev/null +++ b/gcc/ada/libgnat/s-pack114.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 114 + +package System.Pack_114 is + pragma Preelaborate; + + Bits : constant := 114; + + type Bits_114 is mod 2 ** Bits; + for Bits_114'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_114 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_114 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_114 + (Arr : System.Address; + N : Natural; + E : Bits_114; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_114 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_114 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_114 + (Arr : System.Address; + N : Natural; + E : Bits_114; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_114; diff --git a/gcc/ada/libgnat/s-pack115.adb b/gcc/ada/libgnat/s-pack115.adb new file mode 100644 index 0000000..0459777 --- /dev/null +++ b/gcc/ada/libgnat/s-pack115.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_115 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_115; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_115 -- + ------------ + + function Get_115 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_115 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_115; + + ------------ + -- Set_115 -- + ------------ + + procedure Set_115 + (Arr : System.Address; + N : Natural; + E : Bits_115; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_115; + +end System.Pack_115; diff --git a/gcc/ada/libgnat/s-pack115.ads b/gcc/ada/libgnat/s-pack115.ads new file mode 100644 index 0000000..a2063a6 --- /dev/null +++ b/gcc/ada/libgnat/s-pack115.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 115 + +package System.Pack_115 is + pragma Preelaborate; + + Bits : constant := 115; + + type Bits_115 is mod 2 ** Bits; + for Bits_115'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_115 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_115 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_115 + (Arr : System.Address; + N : Natural; + E : Bits_115; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_115; diff --git a/gcc/ada/libgnat/s-pack116.adb b/gcc/ada/libgnat/s-pack116.adb new file mode 100644 index 0000000..d03c857 --- /dev/null +++ b/gcc/ada/libgnat/s-pack116.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_116 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_116; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_116 or SetU_116 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_116 -- + ------------ + + function Get_116 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_116 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_116; + + ------------- + -- GetU_116 -- + ------------- + + function GetU_116 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_116 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_116; + + ------------ + -- Set_116 -- + ------------ + + procedure Set_116 + (Arr : System.Address; + N : Natural; + E : Bits_116; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_116; + + ------------- + -- SetU_116 -- + ------------- + + procedure SetU_116 + (Arr : System.Address; + N : Natural; + E : Bits_116; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_116; + +end System.Pack_116; diff --git a/gcc/ada/libgnat/s-pack116.ads b/gcc/ada/libgnat/s-pack116.ads new file mode 100644 index 0000000..3cd556d --- /dev/null +++ b/gcc/ada/libgnat/s-pack116.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 116 + +package System.Pack_116 is + pragma Preelaborate; + + Bits : constant := 116; + + type Bits_116 is mod 2 ** Bits; + for Bits_116'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_116 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_116 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_116 + (Arr : System.Address; + N : Natural; + E : Bits_116; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_116 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_116 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_116 + (Arr : System.Address; + N : Natural; + E : Bits_116; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_116; diff --git a/gcc/ada/libgnat/s-pack117.adb b/gcc/ada/libgnat/s-pack117.adb new file mode 100644 index 0000000..92da470 --- /dev/null +++ b/gcc/ada/libgnat/s-pack117.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_117 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_117; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_117 -- + ------------ + + function Get_117 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_117 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_117; + + ------------ + -- Set_117 -- + ------------ + + procedure Set_117 + (Arr : System.Address; + N : Natural; + E : Bits_117; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_117; + +end System.Pack_117; diff --git a/gcc/ada/libgnat/s-pack117.ads b/gcc/ada/libgnat/s-pack117.ads new file mode 100644 index 0000000..478663a --- /dev/null +++ b/gcc/ada/libgnat/s-pack117.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 117 + +package System.Pack_117 is + pragma Preelaborate; + + Bits : constant := 117; + + type Bits_117 is mod 2 ** Bits; + for Bits_117'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_117 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_117 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_117 + (Arr : System.Address; + N : Natural; + E : Bits_117; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_117; diff --git a/gcc/ada/libgnat/s-pack118.adb b/gcc/ada/libgnat/s-pack118.adb new file mode 100644 index 0000000..aa1d763 --- /dev/null +++ b/gcc/ada/libgnat/s-pack118.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_118 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_118; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_118 or SetU_118 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_118 -- + ------------ + + function Get_118 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_118 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_118; + + ------------- + -- GetU_118 -- + ------------- + + function GetU_118 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_118 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_118; + + ------------ + -- Set_118 -- + ------------ + + procedure Set_118 + (Arr : System.Address; + N : Natural; + E : Bits_118; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_118; + + ------------- + -- SetU_118 -- + ------------- + + procedure SetU_118 + (Arr : System.Address; + N : Natural; + E : Bits_118; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_118; + +end System.Pack_118; diff --git a/gcc/ada/libgnat/s-pack118.ads b/gcc/ada/libgnat/s-pack118.ads new file mode 100644 index 0000000..0902c5c --- /dev/null +++ b/gcc/ada/libgnat/s-pack118.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 118 + +package System.Pack_118 is + pragma Preelaborate; + + Bits : constant := 118; + + type Bits_118 is mod 2 ** Bits; + for Bits_118'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_118 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_118 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_118 + (Arr : System.Address; + N : Natural; + E : Bits_118; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_118 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_118 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_118 + (Arr : System.Address; + N : Natural; + E : Bits_118; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_118; diff --git a/gcc/ada/libgnat/s-pack119.adb b/gcc/ada/libgnat/s-pack119.adb new file mode 100644 index 0000000..9003175 --- /dev/null +++ b/gcc/ada/libgnat/s-pack119.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_119 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_119; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_119 -- + ------------ + + function Get_119 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_119 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_119; + + ------------ + -- Set_119 -- + ------------ + + procedure Set_119 + (Arr : System.Address; + N : Natural; + E : Bits_119; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_119; + +end System.Pack_119; diff --git a/gcc/ada/libgnat/s-pack119.ads b/gcc/ada/libgnat/s-pack119.ads new file mode 100644 index 0000000..75d1c4a --- /dev/null +++ b/gcc/ada/libgnat/s-pack119.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 119 + +package System.Pack_119 is + pragma Preelaborate; + + Bits : constant := 119; + + type Bits_119 is mod 2 ** Bits; + for Bits_119'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_119 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_119 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_119 + (Arr : System.Address; + N : Natural; + E : Bits_119; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_119; diff --git a/gcc/ada/libgnat/s-pack120.adb b/gcc/ada/libgnat/s-pack120.adb new file mode 100644 index 0000000..774085c --- /dev/null +++ b/gcc/ada/libgnat/s-pack120.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_120 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_120; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_120 or SetU_120 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_120 -- + ------------ + + function Get_120 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_120 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_120; + + ------------- + -- GetU_120 -- + ------------- + + function GetU_120 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_120 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_120; + + ------------ + -- Set_120 -- + ------------ + + procedure Set_120 + (Arr : System.Address; + N : Natural; + E : Bits_120; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_120; + + ------------- + -- SetU_120 -- + ------------- + + procedure SetU_120 + (Arr : System.Address; + N : Natural; + E : Bits_120; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_120; + +end System.Pack_120; diff --git a/gcc/ada/libgnat/s-pack120.ads b/gcc/ada/libgnat/s-pack120.ads new file mode 100644 index 0000000..ae5580a --- /dev/null +++ b/gcc/ada/libgnat/s-pack120.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 120 + +package System.Pack_120 is + pragma Preelaborate; + + Bits : constant := 120; + + type Bits_120 is mod 2 ** Bits; + for Bits_120'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_120 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_120 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_120 + (Arr : System.Address; + N : Natural; + E : Bits_120; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_120 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_120 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_120 + (Arr : System.Address; + N : Natural; + E : Bits_120; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_120; diff --git a/gcc/ada/libgnat/s-pack121.adb b/gcc/ada/libgnat/s-pack121.adb new file mode 100644 index 0000000..a44f144 --- /dev/null +++ b/gcc/ada/libgnat/s-pack121.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_121 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_121; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_121 -- + ------------ + + function Get_121 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_121 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_121; + + ------------ + -- Set_121 -- + ------------ + + procedure Set_121 + (Arr : System.Address; + N : Natural; + E : Bits_121; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_121; + +end System.Pack_121; diff --git a/gcc/ada/libgnat/s-pack121.ads b/gcc/ada/libgnat/s-pack121.ads new file mode 100644 index 0000000..5f4f5ed --- /dev/null +++ b/gcc/ada/libgnat/s-pack121.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 121 + +package System.Pack_121 is + pragma Preelaborate; + + Bits : constant := 121; + + type Bits_121 is mod 2 ** Bits; + for Bits_121'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_121 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_121 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_121 + (Arr : System.Address; + N : Natural; + E : Bits_121; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_121; diff --git a/gcc/ada/libgnat/s-pack122.adb b/gcc/ada/libgnat/s-pack122.adb new file mode 100644 index 0000000..13c59ac --- /dev/null +++ b/gcc/ada/libgnat/s-pack122.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_122 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_122; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_122 or SetU_122 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_122 -- + ------------ + + function Get_122 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_122 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_122; + + ------------- + -- GetU_122 -- + ------------- + + function GetU_122 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_122 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_122; + + ------------ + -- Set_122 -- + ------------ + + procedure Set_122 + (Arr : System.Address; + N : Natural; + E : Bits_122; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_122; + + ------------- + -- SetU_122 -- + ------------- + + procedure SetU_122 + (Arr : System.Address; + N : Natural; + E : Bits_122; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_122; + +end System.Pack_122; diff --git a/gcc/ada/libgnat/s-pack122.ads b/gcc/ada/libgnat/s-pack122.ads new file mode 100644 index 0000000..0094896 --- /dev/null +++ b/gcc/ada/libgnat/s-pack122.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 122 + +package System.Pack_122 is + pragma Preelaborate; + + Bits : constant := 122; + + type Bits_122 is mod 2 ** Bits; + for Bits_122'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_122 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_122 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_122 + (Arr : System.Address; + N : Natural; + E : Bits_122; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_122 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_122 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_122 + (Arr : System.Address; + N : Natural; + E : Bits_122; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_122; diff --git a/gcc/ada/libgnat/s-pack123.adb b/gcc/ada/libgnat/s-pack123.adb new file mode 100644 index 0000000..27d7417 --- /dev/null +++ b/gcc/ada/libgnat/s-pack123.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_123 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_123; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_123 -- + ------------ + + function Get_123 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_123 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_123; + + ------------ + -- Set_123 -- + ------------ + + procedure Set_123 + (Arr : System.Address; + N : Natural; + E : Bits_123; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_123; + +end System.Pack_123; diff --git a/gcc/ada/libgnat/s-pack123.ads b/gcc/ada/libgnat/s-pack123.ads new file mode 100644 index 0000000..f40fe87 --- /dev/null +++ b/gcc/ada/libgnat/s-pack123.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 123 + +package System.Pack_123 is + pragma Preelaborate; + + Bits : constant := 123; + + type Bits_123 is mod 2 ** Bits; + for Bits_123'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_123 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_123 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_123 + (Arr : System.Address; + N : Natural; + E : Bits_123; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_123; diff --git a/gcc/ada/libgnat/s-pack124.adb b/gcc/ada/libgnat/s-pack124.adb new file mode 100644 index 0000000..2e6d9c0 --- /dev/null +++ b/gcc/ada/libgnat/s-pack124.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_124 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_124; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_124 or SetU_124 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_124 -- + ------------ + + function Get_124 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_124 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_124; + + ------------- + -- GetU_124 -- + ------------- + + function GetU_124 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_124 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_124; + + ------------ + -- Set_124 -- + ------------ + + procedure Set_124 + (Arr : System.Address; + N : Natural; + E : Bits_124; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_124; + + ------------- + -- SetU_124 -- + ------------- + + procedure SetU_124 + (Arr : System.Address; + N : Natural; + E : Bits_124; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_124; + +end System.Pack_124; diff --git a/gcc/ada/libgnat/s-pack124.ads b/gcc/ada/libgnat/s-pack124.ads new file mode 100644 index 0000000..3a4f159 --- /dev/null +++ b/gcc/ada/libgnat/s-pack124.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 124 + +package System.Pack_124 is + pragma Preelaborate; + + Bits : constant := 124; + + type Bits_124 is mod 2 ** Bits; + for Bits_124'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_124 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_124 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_124 + (Arr : System.Address; + N : Natural; + E : Bits_124; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_124 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_124 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_124 + (Arr : System.Address; + N : Natural; + E : Bits_124; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_124; diff --git a/gcc/ada/libgnat/s-pack125.adb b/gcc/ada/libgnat/s-pack125.adb new file mode 100644 index 0000000..ffc2c1c --- /dev/null +++ b/gcc/ada/libgnat/s-pack125.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_125 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_125; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_125 -- + ------------ + + function Get_125 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_125 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_125; + + ------------ + -- Set_125 -- + ------------ + + procedure Set_125 + (Arr : System.Address; + N : Natural; + E : Bits_125; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_125; + +end System.Pack_125; diff --git a/gcc/ada/libgnat/s-pack125.ads b/gcc/ada/libgnat/s-pack125.ads new file mode 100644 index 0000000..dc4fdc9 --- /dev/null +++ b/gcc/ada/libgnat/s-pack125.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 125 + +package System.Pack_125 is + pragma Preelaborate; + + Bits : constant := 125; + + type Bits_125 is mod 2 ** Bits; + for Bits_125'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_125 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_125 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_125 + (Arr : System.Address; + N : Natural; + E : Bits_125; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_125; diff --git a/gcc/ada/libgnat/s-pack126.adb b/gcc/ada/libgnat/s-pack126.adb new file mode 100644 index 0000000..c566fc9 --- /dev/null +++ b/gcc/ada/libgnat/s-pack126.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_126 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_126; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_126 or SetU_126 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_126 -- + ------------ + + function Get_126 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_126 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_126; + + ------------- + -- GetU_126 -- + ------------- + + function GetU_126 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_126 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_126; + + ------------ + -- Set_126 -- + ------------ + + procedure Set_126 + (Arr : System.Address; + N : Natural; + E : Bits_126; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_126; + + ------------- + -- SetU_126 -- + ------------- + + procedure SetU_126 + (Arr : System.Address; + N : Natural; + E : Bits_126; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_126; + +end System.Pack_126; diff --git a/gcc/ada/libgnat/s-pack126.ads b/gcc/ada/libgnat/s-pack126.ads new file mode 100644 index 0000000..fd83f78 --- /dev/null +++ b/gcc/ada/libgnat/s-pack126.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 126 + +package System.Pack_126 is + pragma Preelaborate; + + Bits : constant := 126; + + type Bits_126 is mod 2 ** Bits; + for Bits_126'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_126 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_126 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_126 + (Arr : System.Address; + N : Natural; + E : Bits_126; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_126 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_126 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_126 + (Arr : System.Address; + N : Natural; + E : Bits_126; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_126; diff --git a/gcc/ada/libgnat/s-pack127.adb b/gcc/ada/libgnat/s-pack127.adb new file mode 100644 index 0000000..3895c1f --- /dev/null +++ b/gcc/ada/libgnat/s-pack127.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_127 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_127; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_127 -- + ------------ + + function Get_127 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_127 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_127; + + ------------ + -- Set_127 -- + ------------ + + procedure Set_127 + (Arr : System.Address; + N : Natural; + E : Bits_127; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_127; + +end System.Pack_127; diff --git a/gcc/ada/libgnat/s-pack127.ads b/gcc/ada/libgnat/s-pack127.ads new file mode 100644 index 0000000..c37ae59 --- /dev/null +++ b/gcc/ada/libgnat/s-pack127.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 127 + +package System.Pack_127 is + pragma Preelaborate; + + Bits : constant := 127; + + type Bits_127 is mod 2 ** Bits; + for Bits_127'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_127 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_127 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_127 + (Arr : System.Address; + N : Natural; + E : Bits_127; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_127; diff --git a/gcc/ada/libgnat/s-pack65.adb b/gcc/ada/libgnat/s-pack65.adb new file mode 100644 index 0000000..c5b7310 --- /dev/null +++ b/gcc/ada/libgnat/s-pack65.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_65 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_65; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_65 -- + ------------ + + function Get_65 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_65 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_65; + + ------------ + -- Set_65 -- + ------------ + + procedure Set_65 + (Arr : System.Address; + N : Natural; + E : Bits_65; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_65; + +end System.Pack_65; diff --git a/gcc/ada/libgnat/s-pack65.ads b/gcc/ada/libgnat/s-pack65.ads new file mode 100644 index 0000000..8752c9c --- /dev/null +++ b/gcc/ada/libgnat/s-pack65.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 65 + +package System.Pack_65 is + pragma Preelaborate; + + Bits : constant := 65; + + type Bits_65 is mod 2 ** Bits; + for Bits_65'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_65 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_65 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_65 + (Arr : System.Address; + N : Natural; + E : Bits_65; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_65; diff --git a/gcc/ada/libgnat/s-pack66.adb b/gcc/ada/libgnat/s-pack66.adb new file mode 100644 index 0000000..5e90ceb --- /dev/null +++ b/gcc/ada/libgnat/s-pack66.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_66 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_66; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_66 or SetU_66 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_66 -- + ------------ + + function Get_66 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_66 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_66; + + ------------- + -- GetU_66 -- + ------------- + + function GetU_66 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_66 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_66; + + ------------ + -- Set_66 -- + ------------ + + procedure Set_66 + (Arr : System.Address; + N : Natural; + E : Bits_66; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_66; + + ------------- + -- SetU_66 -- + ------------- + + procedure SetU_66 + (Arr : System.Address; + N : Natural; + E : Bits_66; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_66; + +end System.Pack_66; diff --git a/gcc/ada/libgnat/s-pack66.ads b/gcc/ada/libgnat/s-pack66.ads new file mode 100644 index 0000000..b45d317 --- /dev/null +++ b/gcc/ada/libgnat/s-pack66.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 66 + +package System.Pack_66 is + pragma Preelaborate; + + Bits : constant := 66; + + type Bits_66 is mod 2 ** Bits; + for Bits_66'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_66 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_66 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_66 + (Arr : System.Address; + N : Natural; + E : Bits_66; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_66 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_66 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_66 + (Arr : System.Address; + N : Natural; + E : Bits_66; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_66; diff --git a/gcc/ada/libgnat/s-pack67.adb b/gcc/ada/libgnat/s-pack67.adb new file mode 100644 index 0000000..d7c77e8 --- /dev/null +++ b/gcc/ada/libgnat/s-pack67.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_67 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_67; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_67 -- + ------------ + + function Get_67 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_67 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_67; + + ------------ + -- Set_67 -- + ------------ + + procedure Set_67 + (Arr : System.Address; + N : Natural; + E : Bits_67; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_67; + +end System.Pack_67; diff --git a/gcc/ada/libgnat/s-pack67.ads b/gcc/ada/libgnat/s-pack67.ads new file mode 100644 index 0000000..f77b651 --- /dev/null +++ b/gcc/ada/libgnat/s-pack67.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 67 + +package System.Pack_67 is + pragma Preelaborate; + + Bits : constant := 67; + + type Bits_67 is mod 2 ** Bits; + for Bits_67'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_67 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_67 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_67 + (Arr : System.Address; + N : Natural; + E : Bits_67; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_67; diff --git a/gcc/ada/libgnat/s-pack68.adb b/gcc/ada/libgnat/s-pack68.adb new file mode 100644 index 0000000..03a0361 --- /dev/null +++ b/gcc/ada/libgnat/s-pack68.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_68 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_68; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_68 or SetU_68 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_68 -- + ------------ + + function Get_68 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_68 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_68; + + ------------- + -- GetU_68 -- + ------------- + + function GetU_68 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_68 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_68; + + ------------ + -- Set_68 -- + ------------ + + procedure Set_68 + (Arr : System.Address; + N : Natural; + E : Bits_68; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_68; + + ------------- + -- SetU_68 -- + ------------- + + procedure SetU_68 + (Arr : System.Address; + N : Natural; + E : Bits_68; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_68; + +end System.Pack_68; diff --git a/gcc/ada/libgnat/s-pack68.ads b/gcc/ada/libgnat/s-pack68.ads new file mode 100644 index 0000000..5565b32 --- /dev/null +++ b/gcc/ada/libgnat/s-pack68.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 68 + +package System.Pack_68 is + pragma Preelaborate; + + Bits : constant := 68; + + type Bits_68 is mod 2 ** Bits; + for Bits_68'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_68 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_68 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_68 + (Arr : System.Address; + N : Natural; + E : Bits_68; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_68 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_68 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_68 + (Arr : System.Address; + N : Natural; + E : Bits_68; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_68; diff --git a/gcc/ada/libgnat/s-pack69.adb b/gcc/ada/libgnat/s-pack69.adb new file mode 100644 index 0000000..f383029 --- /dev/null +++ b/gcc/ada/libgnat/s-pack69.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_69 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_69; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_69 -- + ------------ + + function Get_69 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_69 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_69; + + ------------ + -- Set_69 -- + ------------ + + procedure Set_69 + (Arr : System.Address; + N : Natural; + E : Bits_69; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_69; + +end System.Pack_69; diff --git a/gcc/ada/libgnat/s-pack69.ads b/gcc/ada/libgnat/s-pack69.ads new file mode 100644 index 0000000..76a221d --- /dev/null +++ b/gcc/ada/libgnat/s-pack69.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 69 + +package System.Pack_69 is + pragma Preelaborate; + + Bits : constant := 69; + + type Bits_69 is mod 2 ** Bits; + for Bits_69'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_69 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_69 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_69 + (Arr : System.Address; + N : Natural; + E : Bits_69; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_69; diff --git a/gcc/ada/libgnat/s-pack70.adb b/gcc/ada/libgnat/s-pack70.adb new file mode 100644 index 0000000..7dab227 --- /dev/null +++ b/gcc/ada/libgnat/s-pack70.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_70 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_70; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_70 or SetU_70 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_70 -- + ------------ + + function Get_70 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_70 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_70; + + ------------- + -- GetU_70 -- + ------------- + + function GetU_70 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_70 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_70; + + ------------ + -- Set_70 -- + ------------ + + procedure Set_70 + (Arr : System.Address; + N : Natural; + E : Bits_70; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_70; + + ------------- + -- SetU_70 -- + ------------- + + procedure SetU_70 + (Arr : System.Address; + N : Natural; + E : Bits_70; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_70; + +end System.Pack_70; diff --git a/gcc/ada/libgnat/s-pack70.ads b/gcc/ada/libgnat/s-pack70.ads new file mode 100644 index 0000000..b978d1c --- /dev/null +++ b/gcc/ada/libgnat/s-pack70.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 70 + +package System.Pack_70 is + pragma Preelaborate; + + Bits : constant := 70; + + type Bits_70 is mod 2 ** Bits; + for Bits_70'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_70 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_70 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_70 + (Arr : System.Address; + N : Natural; + E : Bits_70; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_70 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_70 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_70 + (Arr : System.Address; + N : Natural; + E : Bits_70; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_70; diff --git a/gcc/ada/libgnat/s-pack71.adb b/gcc/ada/libgnat/s-pack71.adb new file mode 100644 index 0000000..f3560de --- /dev/null +++ b/gcc/ada/libgnat/s-pack71.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_71 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_71; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_71 -- + ------------ + + function Get_71 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_71 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_71; + + ------------ + -- Set_71 -- + ------------ + + procedure Set_71 + (Arr : System.Address; + N : Natural; + E : Bits_71; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_71; + +end System.Pack_71; diff --git a/gcc/ada/libgnat/s-pack71.ads b/gcc/ada/libgnat/s-pack71.ads new file mode 100644 index 0000000..842a232 --- /dev/null +++ b/gcc/ada/libgnat/s-pack71.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 71 + +package System.Pack_71 is + pragma Preelaborate; + + Bits : constant := 71; + + type Bits_71 is mod 2 ** Bits; + for Bits_71'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_71 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_71 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_71 + (Arr : System.Address; + N : Natural; + E : Bits_71; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_71; diff --git a/gcc/ada/libgnat/s-pack72.adb b/gcc/ada/libgnat/s-pack72.adb new file mode 100644 index 0000000..14fbb15 --- /dev/null +++ b/gcc/ada/libgnat/s-pack72.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_72 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_72; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_72 or SetU_72 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_72 -- + ------------ + + function Get_72 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_72 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_72; + + ------------- + -- GetU_72 -- + ------------- + + function GetU_72 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_72 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_72; + + ------------ + -- Set_72 -- + ------------ + + procedure Set_72 + (Arr : System.Address; + N : Natural; + E : Bits_72; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_72; + + ------------- + -- SetU_72 -- + ------------- + + procedure SetU_72 + (Arr : System.Address; + N : Natural; + E : Bits_72; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_72; + +end System.Pack_72; diff --git a/gcc/ada/libgnat/s-pack72.ads b/gcc/ada/libgnat/s-pack72.ads new file mode 100644 index 0000000..b1add35 --- /dev/null +++ b/gcc/ada/libgnat/s-pack72.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 72 + +package System.Pack_72 is + pragma Preelaborate; + + Bits : constant := 72; + + type Bits_72 is mod 2 ** Bits; + for Bits_72'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_72 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_72 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_72 + (Arr : System.Address; + N : Natural; + E : Bits_72; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_72 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_72 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_72 + (Arr : System.Address; + N : Natural; + E : Bits_72; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_72; diff --git a/gcc/ada/libgnat/s-pack73.adb b/gcc/ada/libgnat/s-pack73.adb new file mode 100644 index 0000000..f4853cb --- /dev/null +++ b/gcc/ada/libgnat/s-pack73.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_73 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_73; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_73 -- + ------------ + + function Get_73 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_73 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_73; + + ------------ + -- Set_73 -- + ------------ + + procedure Set_73 + (Arr : System.Address; + N : Natural; + E : Bits_73; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_73; + +end System.Pack_73; diff --git a/gcc/ada/libgnat/s-pack73.ads b/gcc/ada/libgnat/s-pack73.ads new file mode 100644 index 0000000..5f103de --- /dev/null +++ b/gcc/ada/libgnat/s-pack73.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 73 + +package System.Pack_73 is + pragma Preelaborate; + + Bits : constant := 73; + + type Bits_73 is mod 2 ** Bits; + for Bits_73'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_73 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_73 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_73 + (Arr : System.Address; + N : Natural; + E : Bits_73; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_73; diff --git a/gcc/ada/libgnat/s-pack74.adb b/gcc/ada/libgnat/s-pack74.adb new file mode 100644 index 0000000..984b4c0 --- /dev/null +++ b/gcc/ada/libgnat/s-pack74.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_74 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_74; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_74 or SetU_74 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_74 -- + ------------ + + function Get_74 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_74 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_74; + + ------------- + -- GetU_74 -- + ------------- + + function GetU_74 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_74 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_74; + + ------------ + -- Set_74 -- + ------------ + + procedure Set_74 + (Arr : System.Address; + N : Natural; + E : Bits_74; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_74; + + ------------- + -- SetU_74 -- + ------------- + + procedure SetU_74 + (Arr : System.Address; + N : Natural; + E : Bits_74; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_74; + +end System.Pack_74; diff --git a/gcc/ada/libgnat/s-pack74.ads b/gcc/ada/libgnat/s-pack74.ads new file mode 100644 index 0000000..5dde51b --- /dev/null +++ b/gcc/ada/libgnat/s-pack74.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 74 + +package System.Pack_74 is + pragma Preelaborate; + + Bits : constant := 74; + + type Bits_74 is mod 2 ** Bits; + for Bits_74'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_74 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_74 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_74 + (Arr : System.Address; + N : Natural; + E : Bits_74; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_74 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_74 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_74 + (Arr : System.Address; + N : Natural; + E : Bits_74; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_74; diff --git a/gcc/ada/libgnat/s-pack75.adb b/gcc/ada/libgnat/s-pack75.adb new file mode 100644 index 0000000..6c7c14f --- /dev/null +++ b/gcc/ada/libgnat/s-pack75.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_75 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_75; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_75 -- + ------------ + + function Get_75 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_75 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_75; + + ------------ + -- Set_75 -- + ------------ + + procedure Set_75 + (Arr : System.Address; + N : Natural; + E : Bits_75; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_75; + +end System.Pack_75; diff --git a/gcc/ada/libgnat/s-pack75.ads b/gcc/ada/libgnat/s-pack75.ads new file mode 100644 index 0000000..551833a --- /dev/null +++ b/gcc/ada/libgnat/s-pack75.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 75 + +package System.Pack_75 is + pragma Preelaborate; + + Bits : constant := 75; + + type Bits_75 is mod 2 ** Bits; + for Bits_75'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_75 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_75 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_75 + (Arr : System.Address; + N : Natural; + E : Bits_75; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_75; diff --git a/gcc/ada/libgnat/s-pack76.adb b/gcc/ada/libgnat/s-pack76.adb new file mode 100644 index 0000000..6a7c5fa --- /dev/null +++ b/gcc/ada/libgnat/s-pack76.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_76 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_76; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_76 or SetU_76 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_76 -- + ------------ + + function Get_76 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_76 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_76; + + ------------- + -- GetU_76 -- + ------------- + + function GetU_76 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_76 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_76; + + ------------ + -- Set_76 -- + ------------ + + procedure Set_76 + (Arr : System.Address; + N : Natural; + E : Bits_76; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_76; + + ------------- + -- SetU_76 -- + ------------- + + procedure SetU_76 + (Arr : System.Address; + N : Natural; + E : Bits_76; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_76; + +end System.Pack_76; diff --git a/gcc/ada/libgnat/s-pack76.ads b/gcc/ada/libgnat/s-pack76.ads new file mode 100644 index 0000000..6a600c9 --- /dev/null +++ b/gcc/ada/libgnat/s-pack76.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 76 + +package System.Pack_76 is + pragma Preelaborate; + + Bits : constant := 76; + + type Bits_76 is mod 2 ** Bits; + for Bits_76'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_76 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_76 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_76 + (Arr : System.Address; + N : Natural; + E : Bits_76; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_76 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_76 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_76 + (Arr : System.Address; + N : Natural; + E : Bits_76; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_76; diff --git a/gcc/ada/libgnat/s-pack77.adb b/gcc/ada/libgnat/s-pack77.adb new file mode 100644 index 0000000..f29cdf1 --- /dev/null +++ b/gcc/ada/libgnat/s-pack77.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_77 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_77; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_77 -- + ------------ + + function Get_77 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_77 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_77; + + ------------ + -- Set_77 -- + ------------ + + procedure Set_77 + (Arr : System.Address; + N : Natural; + E : Bits_77; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_77; + +end System.Pack_77; diff --git a/gcc/ada/libgnat/s-pack77.ads b/gcc/ada/libgnat/s-pack77.ads new file mode 100644 index 0000000..9308a78 --- /dev/null +++ b/gcc/ada/libgnat/s-pack77.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 77 + +package System.Pack_77 is + pragma Preelaborate; + + Bits : constant := 77; + + type Bits_77 is mod 2 ** Bits; + for Bits_77'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_77 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_77 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_77 + (Arr : System.Address; + N : Natural; + E : Bits_77; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_77; diff --git a/gcc/ada/libgnat/s-pack78.adb b/gcc/ada/libgnat/s-pack78.adb new file mode 100644 index 0000000..e321c1e --- /dev/null +++ b/gcc/ada/libgnat/s-pack78.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_78 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_78; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_78 or SetU_78 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_78 -- + ------------ + + function Get_78 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_78 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_78; + + ------------- + -- GetU_78 -- + ------------- + + function GetU_78 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_78 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_78; + + ------------ + -- Set_78 -- + ------------ + + procedure Set_78 + (Arr : System.Address; + N : Natural; + E : Bits_78; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_78; + + ------------- + -- SetU_78 -- + ------------- + + procedure SetU_78 + (Arr : System.Address; + N : Natural; + E : Bits_78; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_78; + +end System.Pack_78; diff --git a/gcc/ada/libgnat/s-pack78.ads b/gcc/ada/libgnat/s-pack78.ads new file mode 100644 index 0000000..54fdd95 --- /dev/null +++ b/gcc/ada/libgnat/s-pack78.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 78 + +package System.Pack_78 is + pragma Preelaborate; + + Bits : constant := 78; + + type Bits_78 is mod 2 ** Bits; + for Bits_78'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_78 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_78 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_78 + (Arr : System.Address; + N : Natural; + E : Bits_78; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_78 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_78 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_78 + (Arr : System.Address; + N : Natural; + E : Bits_78; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_78; diff --git a/gcc/ada/libgnat/s-pack79.adb b/gcc/ada/libgnat/s-pack79.adb new file mode 100644 index 0000000..75fb14c --- /dev/null +++ b/gcc/ada/libgnat/s-pack79.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_79 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_79; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_79 -- + ------------ + + function Get_79 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_79 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_79; + + ------------ + -- Set_79 -- + ------------ + + procedure Set_79 + (Arr : System.Address; + N : Natural; + E : Bits_79; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_79; + +end System.Pack_79; diff --git a/gcc/ada/libgnat/s-pack79.ads b/gcc/ada/libgnat/s-pack79.ads new file mode 100644 index 0000000..337be86 --- /dev/null +++ b/gcc/ada/libgnat/s-pack79.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 7 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 79 + +package System.Pack_79 is + pragma Preelaborate; + + Bits : constant := 79; + + type Bits_79 is mod 2 ** Bits; + for Bits_79'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_79 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_79 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_79 + (Arr : System.Address; + N : Natural; + E : Bits_79; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_79; diff --git a/gcc/ada/libgnat/s-pack80.adb b/gcc/ada/libgnat/s-pack80.adb new file mode 100644 index 0000000..d66588b --- /dev/null +++ b/gcc/ada/libgnat/s-pack80.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_80 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_80; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_80 or SetU_80 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_80 -- + ------------ + + function Get_80 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_80 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_80; + + ------------- + -- GetU_80 -- + ------------- + + function GetU_80 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_80 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_80; + + ------------ + -- Set_80 -- + ------------ + + procedure Set_80 + (Arr : System.Address; + N : Natural; + E : Bits_80; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_80; + + ------------- + -- SetU_80 -- + ------------- + + procedure SetU_80 + (Arr : System.Address; + N : Natural; + E : Bits_80; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_80; + +end System.Pack_80; diff --git a/gcc/ada/libgnat/s-pack80.ads b/gcc/ada/libgnat/s-pack80.ads new file mode 100644 index 0000000..c1f0de4 --- /dev/null +++ b/gcc/ada/libgnat/s-pack80.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 80 + +package System.Pack_80 is + pragma Preelaborate; + + Bits : constant := 80; + + type Bits_80 is mod 2 ** Bits; + for Bits_80'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_80 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_80 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_80 + (Arr : System.Address; + N : Natural; + E : Bits_80; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_80 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_80 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_80 + (Arr : System.Address; + N : Natural; + E : Bits_80; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_80; diff --git a/gcc/ada/libgnat/s-pack81.adb b/gcc/ada/libgnat/s-pack81.adb new file mode 100644 index 0000000..5157882 --- /dev/null +++ b/gcc/ada/libgnat/s-pack81.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_81 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_81; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_81 -- + ------------ + + function Get_81 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_81 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_81; + + ------------ + -- Set_81 -- + ------------ + + procedure Set_81 + (Arr : System.Address; + N : Natural; + E : Bits_81; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_81; + +end System.Pack_81; diff --git a/gcc/ada/libgnat/s-pack81.ads b/gcc/ada/libgnat/s-pack81.ads new file mode 100644 index 0000000..9f17734 --- /dev/null +++ b/gcc/ada/libgnat/s-pack81.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 81 + +package System.Pack_81 is + pragma Preelaborate; + + Bits : constant := 81; + + type Bits_81 is mod 2 ** Bits; + for Bits_81'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_81 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_81 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_81 + (Arr : System.Address; + N : Natural; + E : Bits_81; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_81; diff --git a/gcc/ada/libgnat/s-pack82.adb b/gcc/ada/libgnat/s-pack82.adb new file mode 100644 index 0000000..7e409dd --- /dev/null +++ b/gcc/ada/libgnat/s-pack82.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_82 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_82; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_82 or SetU_82 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_82 -- + ------------ + + function Get_82 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_82 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_82; + + ------------- + -- GetU_82 -- + ------------- + + function GetU_82 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_82 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_82; + + ------------ + -- Set_82 -- + ------------ + + procedure Set_82 + (Arr : System.Address; + N : Natural; + E : Bits_82; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_82; + + ------------- + -- SetU_82 -- + ------------- + + procedure SetU_82 + (Arr : System.Address; + N : Natural; + E : Bits_82; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_82; + +end System.Pack_82; diff --git a/gcc/ada/libgnat/s-pack82.ads b/gcc/ada/libgnat/s-pack82.ads new file mode 100644 index 0000000..96a75bf --- /dev/null +++ b/gcc/ada/libgnat/s-pack82.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 82 + +package System.Pack_82 is + pragma Preelaborate; + + Bits : constant := 82; + + type Bits_82 is mod 2 ** Bits; + for Bits_82'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_82 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_82 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_82 + (Arr : System.Address; + N : Natural; + E : Bits_82; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_82 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_82 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_82 + (Arr : System.Address; + N : Natural; + E : Bits_82; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_82; diff --git a/gcc/ada/libgnat/s-pack83.adb b/gcc/ada/libgnat/s-pack83.adb new file mode 100644 index 0000000..5fe2441 --- /dev/null +++ b/gcc/ada/libgnat/s-pack83.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_83 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_83; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_83 -- + ------------ + + function Get_83 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_83 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_83; + + ------------ + -- Set_83 -- + ------------ + + procedure Set_83 + (Arr : System.Address; + N : Natural; + E : Bits_83; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_83; + +end System.Pack_83; diff --git a/gcc/ada/libgnat/s-pack83.ads b/gcc/ada/libgnat/s-pack83.ads new file mode 100644 index 0000000..75ccd5b --- /dev/null +++ b/gcc/ada/libgnat/s-pack83.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 83 + +package System.Pack_83 is + pragma Preelaborate; + + Bits : constant := 83; + + type Bits_83 is mod 2 ** Bits; + for Bits_83'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_83 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_83 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_83 + (Arr : System.Address; + N : Natural; + E : Bits_83; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_83; diff --git a/gcc/ada/libgnat/s-pack84.adb b/gcc/ada/libgnat/s-pack84.adb new file mode 100644 index 0000000..29b6454 --- /dev/null +++ b/gcc/ada/libgnat/s-pack84.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_84 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_84; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_84 or SetU_84 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_84 -- + ------------ + + function Get_84 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_84 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_84; + + ------------- + -- GetU_84 -- + ------------- + + function GetU_84 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_84 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_84; + + ------------ + -- Set_84 -- + ------------ + + procedure Set_84 + (Arr : System.Address; + N : Natural; + E : Bits_84; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_84; + + ------------- + -- SetU_84 -- + ------------- + + procedure SetU_84 + (Arr : System.Address; + N : Natural; + E : Bits_84; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_84; + +end System.Pack_84; diff --git a/gcc/ada/libgnat/s-pack84.ads b/gcc/ada/libgnat/s-pack84.ads new file mode 100644 index 0000000..c3055f9 --- /dev/null +++ b/gcc/ada/libgnat/s-pack84.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 84 + +package System.Pack_84 is + pragma Preelaborate; + + Bits : constant := 84; + + type Bits_84 is mod 2 ** Bits; + for Bits_84'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_84 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_84 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_84 + (Arr : System.Address; + N : Natural; + E : Bits_84; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_84 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_84 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_84 + (Arr : System.Address; + N : Natural; + E : Bits_84; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_84; diff --git a/gcc/ada/libgnat/s-pack85.adb b/gcc/ada/libgnat/s-pack85.adb new file mode 100644 index 0000000..6edf9d1 --- /dev/null +++ b/gcc/ada/libgnat/s-pack85.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_85 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_85; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_85 -- + ------------ + + function Get_85 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_85 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_85; + + ------------ + -- Set_85 -- + ------------ + + procedure Set_85 + (Arr : System.Address; + N : Natural; + E : Bits_85; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_85; + +end System.Pack_85; diff --git a/gcc/ada/libgnat/s-pack85.ads b/gcc/ada/libgnat/s-pack85.ads new file mode 100644 index 0000000..71bb986 --- /dev/null +++ b/gcc/ada/libgnat/s-pack85.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 85 + +package System.Pack_85 is + pragma Preelaborate; + + Bits : constant := 85; + + type Bits_85 is mod 2 ** Bits; + for Bits_85'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_85 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_85 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_85 + (Arr : System.Address; + N : Natural; + E : Bits_85; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_85; diff --git a/gcc/ada/libgnat/s-pack86.adb b/gcc/ada/libgnat/s-pack86.adb new file mode 100644 index 0000000..39e8bca --- /dev/null +++ b/gcc/ada/libgnat/s-pack86.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_86 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_86; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_86 or SetU_86 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_86 -- + ------------ + + function Get_86 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_86 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_86; + + ------------- + -- GetU_86 -- + ------------- + + function GetU_86 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_86 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_86; + + ------------ + -- Set_86 -- + ------------ + + procedure Set_86 + (Arr : System.Address; + N : Natural; + E : Bits_86; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_86; + + ------------- + -- SetU_86 -- + ------------- + + procedure SetU_86 + (Arr : System.Address; + N : Natural; + E : Bits_86; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_86; + +end System.Pack_86; diff --git a/gcc/ada/libgnat/s-pack86.ads b/gcc/ada/libgnat/s-pack86.ads new file mode 100644 index 0000000..0dee449 --- /dev/null +++ b/gcc/ada/libgnat/s-pack86.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 86 + +package System.Pack_86 is + pragma Preelaborate; + + Bits : constant := 86; + + type Bits_86 is mod 2 ** Bits; + for Bits_86'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_86 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_86 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_86 + (Arr : System.Address; + N : Natural; + E : Bits_86; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_86 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_86 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_86 + (Arr : System.Address; + N : Natural; + E : Bits_86; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_86; diff --git a/gcc/ada/libgnat/s-pack87.adb b/gcc/ada/libgnat/s-pack87.adb new file mode 100644 index 0000000..8bfc7b4 --- /dev/null +++ b/gcc/ada/libgnat/s-pack87.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_87 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_87; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_87 -- + ------------ + + function Get_87 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_87 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_87; + + ------------ + -- Set_87 -- + ------------ + + procedure Set_87 + (Arr : System.Address; + N : Natural; + E : Bits_87; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_87; + +end System.Pack_87; diff --git a/gcc/ada/libgnat/s-pack87.ads b/gcc/ada/libgnat/s-pack87.ads new file mode 100644 index 0000000..ad80713 --- /dev/null +++ b/gcc/ada/libgnat/s-pack87.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 87 + +package System.Pack_87 is + pragma Preelaborate; + + Bits : constant := 87; + + type Bits_87 is mod 2 ** Bits; + for Bits_87'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_87 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_87 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_87 + (Arr : System.Address; + N : Natural; + E : Bits_87; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_87; diff --git a/gcc/ada/libgnat/s-pack88.adb b/gcc/ada/libgnat/s-pack88.adb new file mode 100644 index 0000000..638581a --- /dev/null +++ b/gcc/ada/libgnat/s-pack88.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_88 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_88; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_88 or SetU_88 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_88 -- + ------------ + + function Get_88 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_88 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_88; + + ------------- + -- GetU_88 -- + ------------- + + function GetU_88 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_88 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_88; + + ------------ + -- Set_88 -- + ------------ + + procedure Set_88 + (Arr : System.Address; + N : Natural; + E : Bits_88; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_88; + + ------------- + -- SetU_88 -- + ------------- + + procedure SetU_88 + (Arr : System.Address; + N : Natural; + E : Bits_88; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_88; + +end System.Pack_88; diff --git a/gcc/ada/libgnat/s-pack88.ads b/gcc/ada/libgnat/s-pack88.ads new file mode 100644 index 0000000..bd38bd7 --- /dev/null +++ b/gcc/ada/libgnat/s-pack88.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 88 + +package System.Pack_88 is + pragma Preelaborate; + + Bits : constant := 88; + + type Bits_88 is mod 2 ** Bits; + for Bits_88'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_88 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_88 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_88 + (Arr : System.Address; + N : Natural; + E : Bits_88; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_88 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_88 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_88 + (Arr : System.Address; + N : Natural; + E : Bits_88; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_88; diff --git a/gcc/ada/libgnat/s-pack89.adb b/gcc/ada/libgnat/s-pack89.adb new file mode 100644 index 0000000..eff29c0 --- /dev/null +++ b/gcc/ada/libgnat/s-pack89.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_89 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_89; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_89 -- + ------------ + + function Get_89 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_89 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_89; + + ------------ + -- Set_89 -- + ------------ + + procedure Set_89 + (Arr : System.Address; + N : Natural; + E : Bits_89; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_89; + +end System.Pack_89; diff --git a/gcc/ada/libgnat/s-pack89.ads b/gcc/ada/libgnat/s-pack89.ads new file mode 100644 index 0000000..5ab8102 --- /dev/null +++ b/gcc/ada/libgnat/s-pack89.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 8 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 89 + +package System.Pack_89 is + pragma Preelaborate; + + Bits : constant := 89; + + type Bits_89 is mod 2 ** Bits; + for Bits_89'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_89 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_89 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_89 + (Arr : System.Address; + N : Natural; + E : Bits_89; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_89; diff --git a/gcc/ada/libgnat/s-pack90.adb b/gcc/ada/libgnat/s-pack90.adb new file mode 100644 index 0000000..bed4845 --- /dev/null +++ b/gcc/ada/libgnat/s-pack90.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_90 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_90; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_90 or SetU_90 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_90 -- + ------------ + + function Get_90 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_90 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_90; + + ------------- + -- GetU_90 -- + ------------- + + function GetU_90 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_90 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_90; + + ------------ + -- Set_90 -- + ------------ + + procedure Set_90 + (Arr : System.Address; + N : Natural; + E : Bits_90; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_90; + + ------------- + -- SetU_90 -- + ------------- + + procedure SetU_90 + (Arr : System.Address; + N : Natural; + E : Bits_90; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_90; + +end System.Pack_90; diff --git a/gcc/ada/libgnat/s-pack90.ads b/gcc/ada/libgnat/s-pack90.ads new file mode 100644 index 0000000..2960293 --- /dev/null +++ b/gcc/ada/libgnat/s-pack90.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 90 + +package System.Pack_90 is + pragma Preelaborate; + + Bits : constant := 90; + + type Bits_90 is mod 2 ** Bits; + for Bits_90'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_90 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_90 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_90 + (Arr : System.Address; + N : Natural; + E : Bits_90; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_90 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_90 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_90 + (Arr : System.Address; + N : Natural; + E : Bits_90; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_90; diff --git a/gcc/ada/libgnat/s-pack91.adb b/gcc/ada/libgnat/s-pack91.adb new file mode 100644 index 0000000..25c9f14 --- /dev/null +++ b/gcc/ada/libgnat/s-pack91.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_91 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_91; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_91 -- + ------------ + + function Get_91 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_91 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_91; + + ------------ + -- Set_91 -- + ------------ + + procedure Set_91 + (Arr : System.Address; + N : Natural; + E : Bits_91; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_91; + +end System.Pack_91; diff --git a/gcc/ada/libgnat/s-pack91.ads b/gcc/ada/libgnat/s-pack91.ads new file mode 100644 index 0000000..065c1b5 --- /dev/null +++ b/gcc/ada/libgnat/s-pack91.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 91 + +package System.Pack_91 is + pragma Preelaborate; + + Bits : constant := 91; + + type Bits_91 is mod 2 ** Bits; + for Bits_91'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_91 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_91 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_91 + (Arr : System.Address; + N : Natural; + E : Bits_91; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_91; diff --git a/gcc/ada/libgnat/s-pack92.adb b/gcc/ada/libgnat/s-pack92.adb new file mode 100644 index 0000000..b9ea0a6 --- /dev/null +++ b/gcc/ada/libgnat/s-pack92.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_92 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_92; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_92 or SetU_92 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_92 -- + ------------ + + function Get_92 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_92 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_92; + + ------------- + -- GetU_92 -- + ------------- + + function GetU_92 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_92 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_92; + + ------------ + -- Set_92 -- + ------------ + + procedure Set_92 + (Arr : System.Address; + N : Natural; + E : Bits_92; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_92; + + ------------- + -- SetU_92 -- + ------------- + + procedure SetU_92 + (Arr : System.Address; + N : Natural; + E : Bits_92; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_92; + +end System.Pack_92; diff --git a/gcc/ada/libgnat/s-pack92.ads b/gcc/ada/libgnat/s-pack92.ads new file mode 100644 index 0000000..5184bc6 --- /dev/null +++ b/gcc/ada/libgnat/s-pack92.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 92 + +package System.Pack_92 is + pragma Preelaborate; + + Bits : constant := 92; + + type Bits_92 is mod 2 ** Bits; + for Bits_92'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_92 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_92 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_92 + (Arr : System.Address; + N : Natural; + E : Bits_92; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_92 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_92 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_92 + (Arr : System.Address; + N : Natural; + E : Bits_92; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_92; diff --git a/gcc/ada/libgnat/s-pack93.adb b/gcc/ada/libgnat/s-pack93.adb new file mode 100644 index 0000000..1fe486c --- /dev/null +++ b/gcc/ada/libgnat/s-pack93.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_93 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_93; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_93 -- + ------------ + + function Get_93 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_93 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_93; + + ------------ + -- Set_93 -- + ------------ + + procedure Set_93 + (Arr : System.Address; + N : Natural; + E : Bits_93; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_93; + +end System.Pack_93; diff --git a/gcc/ada/libgnat/s-pack93.ads b/gcc/ada/libgnat/s-pack93.ads new file mode 100644 index 0000000..618ab64 --- /dev/null +++ b/gcc/ada/libgnat/s-pack93.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 93 + +package System.Pack_93 is + pragma Preelaborate; + + Bits : constant := 93; + + type Bits_93 is mod 2 ** Bits; + for Bits_93'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_93 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_93 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_93 + (Arr : System.Address; + N : Natural; + E : Bits_93; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_93; diff --git a/gcc/ada/libgnat/s-pack94.adb b/gcc/ada/libgnat/s-pack94.adb new file mode 100644 index 0000000..5a65908 --- /dev/null +++ b/gcc/ada/libgnat/s-pack94.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_94 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_94; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_94 or SetU_94 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_94 -- + ------------ + + function Get_94 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_94 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_94; + + ------------- + -- GetU_94 -- + ------------- + + function GetU_94 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_94 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_94; + + ------------ + -- Set_94 -- + ------------ + + procedure Set_94 + (Arr : System.Address; + N : Natural; + E : Bits_94; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_94; + + ------------- + -- SetU_94 -- + ------------- + + procedure SetU_94 + (Arr : System.Address; + N : Natural; + E : Bits_94; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_94; + +end System.Pack_94; diff --git a/gcc/ada/libgnat/s-pack94.ads b/gcc/ada/libgnat/s-pack94.ads new file mode 100644 index 0000000..692a4dc --- /dev/null +++ b/gcc/ada/libgnat/s-pack94.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 94 + +package System.Pack_94 is + pragma Preelaborate; + + Bits : constant := 94; + + type Bits_94 is mod 2 ** Bits; + for Bits_94'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_94 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_94 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_94 + (Arr : System.Address; + N : Natural; + E : Bits_94; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_94 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_94 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_94 + (Arr : System.Address; + N : Natural; + E : Bits_94; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_94; diff --git a/gcc/ada/libgnat/s-pack95.adb b/gcc/ada/libgnat/s-pack95.adb new file mode 100644 index 0000000..f8d6be6 --- /dev/null +++ b/gcc/ada/libgnat/s-pack95.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_95 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_95; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_95 -- + ------------ + + function Get_95 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_95 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_95; + + ------------ + -- Set_95 -- + ------------ + + procedure Set_95 + (Arr : System.Address; + N : Natural; + E : Bits_95; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_95; + +end System.Pack_95; diff --git a/gcc/ada/libgnat/s-pack95.ads b/gcc/ada/libgnat/s-pack95.ads new file mode 100644 index 0000000..288a787 --- /dev/null +++ b/gcc/ada/libgnat/s-pack95.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 95 + +package System.Pack_95 is + pragma Preelaborate; + + Bits : constant := 95; + + type Bits_95 is mod 2 ** Bits; + for Bits_95'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_95 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_95 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_95 + (Arr : System.Address; + N : Natural; + E : Bits_95; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_95; diff --git a/gcc/ada/libgnat/s-pack96.adb b/gcc/ada/libgnat/s-pack96.adb new file mode 100644 index 0000000..1371ee1 --- /dev/null +++ b/gcc/ada/libgnat/s-pack96.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_96 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_96; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_96 or SetU_96 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_96 -- + ------------ + + function Get_96 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_96 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_96; + + ------------- + -- GetU_96 -- + ------------- + + function GetU_96 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_96 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_96; + + ------------ + -- Set_96 -- + ------------ + + procedure Set_96 + (Arr : System.Address; + N : Natural; + E : Bits_96; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_96; + + ------------- + -- SetU_96 -- + ------------- + + procedure SetU_96 + (Arr : System.Address; + N : Natural; + E : Bits_96; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_96; + +end System.Pack_96; diff --git a/gcc/ada/libgnat/s-pack96.ads b/gcc/ada/libgnat/s-pack96.ads new file mode 100644 index 0000000..355f00a --- /dev/null +++ b/gcc/ada/libgnat/s-pack96.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 96 + +package System.Pack_96 is + pragma Preelaborate; + + Bits : constant := 96; + + type Bits_96 is mod 2 ** Bits; + for Bits_96'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_96 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_96 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_96 + (Arr : System.Address; + N : Natural; + E : Bits_96; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_96 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_96 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_96 + (Arr : System.Address; + N : Natural; + E : Bits_96; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_96; diff --git a/gcc/ada/libgnat/s-pack97.adb b/gcc/ada/libgnat/s-pack97.adb new file mode 100644 index 0000000..000f8ed --- /dev/null +++ b/gcc/ada/libgnat/s-pack97.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_97 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_97; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_97 -- + ------------ + + function Get_97 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_97 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_97; + + ------------ + -- Set_97 -- + ------------ + + procedure Set_97 + (Arr : System.Address; + N : Natural; + E : Bits_97; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_97; + +end System.Pack_97; diff --git a/gcc/ada/libgnat/s-pack97.ads b/gcc/ada/libgnat/s-pack97.ads new file mode 100644 index 0000000..4c8a936 --- /dev/null +++ b/gcc/ada/libgnat/s-pack97.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 97 + +package System.Pack_97 is + pragma Preelaborate; + + Bits : constant := 97; + + type Bits_97 is mod 2 ** Bits; + for Bits_97'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_97 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_97 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_97 + (Arr : System.Address; + N : Natural; + E : Bits_97; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_97; diff --git a/gcc/ada/libgnat/s-pack98.adb b/gcc/ada/libgnat/s-pack98.adb new file mode 100644 index 0000000..1ac4c66 --- /dev/null +++ b/gcc/ada/libgnat/s-pack98.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_98 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_98; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_98 or SetU_98 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_98 -- + ------------ + + function Get_98 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_98 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_98; + + ------------- + -- GetU_98 -- + ------------- + + function GetU_98 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_98 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_98; + + ------------ + -- Set_98 -- + ------------ + + procedure Set_98 + (Arr : System.Address; + N : Natural; + E : Bits_98; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_98; + + ------------- + -- SetU_98 -- + ------------- + + procedure SetU_98 + (Arr : System.Address; + N : Natural; + E : Bits_98; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_98; + +end System.Pack_98; diff --git a/gcc/ada/libgnat/s-pack98.ads b/gcc/ada/libgnat/s-pack98.ads new file mode 100644 index 0000000..239eca1 --- /dev/null +++ b/gcc/ada/libgnat/s-pack98.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 98 + +package System.Pack_98 is + pragma Preelaborate; + + Bits : constant := 98; + + type Bits_98 is mod 2 ** Bits; + for Bits_98'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_98 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_98 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_98 + (Arr : System.Address; + N : Natural; + E : Bits_98; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_98 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_98 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_98 + (Arr : System.Address; + N : Natural; + E : Bits_98; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_98; diff --git a/gcc/ada/libgnat/s-pack99.adb b/gcc/ada/libgnat/s-pack99.adb new file mode 100644 index 0000000..a8bde88 --- /dev/null +++ b/gcc/ada/libgnat/s-pack99.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_99 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_99; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_99 -- + ------------ + + function Get_99 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_99 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_99; + + ------------ + -- Set_99 -- + ------------ + + procedure Set_99 + (Arr : System.Address; + N : Natural; + E : Bits_99; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_99; + +end System.Pack_99; diff --git a/gcc/ada/libgnat/s-pack99.ads b/gcc/ada/libgnat/s-pack99.ads new file mode 100644 index 0000000..fa805c4 --- /dev/null +++ b/gcc/ada/libgnat/s-pack99.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 9 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 99 + +package System.Pack_99 is + pragma Preelaborate; + + Bits : constant := 99; + + type Bits_99 is mod 2 ** Bits; + for Bits_99'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_99 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_99 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_99 + (Arr : System.Address; + N : Natural; + E : Bits_99; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_99; diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb index 4ae612d..925c3b9 100644 --- a/gcc/ada/libgnat/s-putima.adb +++ b/gcc/ada/libgnat/s-putima.adb @@ -93,21 +93,30 @@ package body System.Put_Images is end Generic_Integer_Images; - package Small is new Generic_Integer_Images (Integer, Unsigned, Base => 10); - package Large is new Generic_Integer_Images + package Integer_Images is new Generic_Integer_Images + (Integer, Unsigned, Base => 10); + package LL_Integer_Images is new Generic_Integer_Images (Long_Long_Integer, Long_Long_Unsigned, Base => 10); + package LLL_Integer_Images is new Generic_Integer_Images + (Long_Long_Long_Integer, Long_Long_Long_Unsigned, Base => 10); procedure Put_Image_Integer (S : in out Sink'Class; X : Integer) - renames Small.Put_Image; + renames Integer_Images.Put_Image; procedure Put_Image_Long_Long_Integer (S : in out Sink'Class; X : Long_Long_Integer) - renames Large.Put_Image; + renames LL_Integer_Images.Put_Image; + procedure Put_Image_Long_Long_Long_Integer + (S : in out Sink'Class; X : Long_Long_Long_Integer) + renames LLL_Integer_Images.Put_Image; procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned) - renames Small.Put_Image; + renames Integer_Images.Put_Image; procedure Put_Image_Long_Long_Unsigned (S : in out Sink'Class; X : Long_Long_Unsigned) - renames Large.Put_Image; + renames LL_Integer_Images.Put_Image; + procedure Put_Image_Long_Long_Long_Unsigned + (S : in out Sink'Class; X : Long_Long_Long_Unsigned) + renames LLL_Integer_Images.Put_Image; type Signed_Address is range -2**(Standard'Address_Size - 1) .. 2**(Standard'Address_Size - 1) - 1; @@ -250,6 +259,11 @@ package body System.Put_Images is Put_7bit (S, ')'); end Record_After; + procedure Put_Arrow (S : in out Sink'Class) is + begin + Put_UTF_8 (S, " => "); + end Put_Arrow; + procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String) is begin Put_UTF_8 (S, "{"); diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads index 17e184a..1d2a11d 100644 --- a/gcc/ada/libgnat/s-putima.ads +++ b/gcc/ada/libgnat/s-putima.ads @@ -32,15 +32,16 @@ with Ada.Strings.Text_Output; with System.Unsigned_Types; -package System.Put_Images is +package System.Put_Images with Pure is -- This package contains subprograms that are called by the generated code -- for the 'Put_Image attribute. -- - -- For an integer type that fits in Integer, the actual parameter is + -- For a signed integer type that fits in Integer, the actual parameter is -- converted to Integer, and Put_Image_Integer is called. For larger types, - -- Put_Image_Long_Long_Integer is used. Other numeric types are treated - -- similarly. Access values are unchecked-converted to either Thin_Pointer + -- Put_Image_Long_Long_Integer or Put_Image_Long_Long_Long_Integer is used. + -- For a modular integer type, this is similar with Integer replaced with + -- Unsigned. Access values are unchecked-converted to either Thin_Pointer -- or Fat_Pointer, and Put_Image_Thin_Pointer or Put_Image_Fat_Pointer is -- called. The Before/Between/After procedures are called before printing -- the components of a composite type, between pairs of components, and @@ -54,18 +55,23 @@ package System.Put_Images is procedure Put_Image_Integer (S : in out Sink'Class; X : Integer); procedure Put_Image_Long_Long_Integer (S : in out Sink'Class; X : Long_Long_Integer); + procedure Put_Image_Long_Long_Long_Integer + (S : in out Sink'Class; X : Long_Long_Long_Integer); - subtype Unsigned is System.Unsigned_Types.Unsigned; - subtype Long_Long_Unsigned is System.Unsigned_Types.Long_Long_Unsigned; + subtype Unsigned is Unsigned_Types.Unsigned; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; procedure Put_Image_Unsigned (S : in out Sink'Class; X : Unsigned); procedure Put_Image_Long_Long_Unsigned (S : in out Sink'Class; X : Long_Long_Unsigned); + procedure Put_Image_Long_Long_Long_Unsigned + (S : in out Sink'Class; X : Long_Long_Long_Unsigned); type Byte is new Character with Alignment => 1; type Byte_String is array (Positive range <>) of Byte with Alignment => 1; - type Thin_Pointer is access all Byte; - type Fat_Pointer is access all Byte_String; + type Thin_Pointer is access all Byte with Storage_Size => 0; + type Fat_Pointer is access all Byte_String with Storage_Size => 0; procedure Put_Image_Thin_Pointer (S : in out Sink'Class; X : Thin_Pointer); procedure Put_Image_Fat_Pointer (S : in out Sink'Class; X : Fat_Pointer); -- Print "null", or the address of the designated object as an unsigned @@ -95,6 +101,8 @@ package System.Put_Images is procedure Record_Between (S : in out Sink'Class); procedure Record_After (S : in out Sink'Class); + procedure Put_Arrow (S : in out Sink'Class); + procedure Put_Image_Unknown (S : in out Sink'Class; Type_Name : String); -- For Put_Image of types that don't have the attribute, such as type -- Sink. diff --git a/gcc/ada/libgnat/s-rannum.adb b/gcc/ada/libgnat/s-rannum.adb index 01a6e91..e65e6a7 100644 --- a/gcc/ada/libgnat/s-rannum.adb +++ b/gcc/ada/libgnat/s-rannum.adb @@ -387,6 +387,12 @@ is or Unsigned_64 (Unsigned_32'(Random (Gen))); end Random; + function Random (Gen : Generator) return Unsigned_128 is + begin + return Shift_Left (Unsigned_128 (Unsigned_64'(Random (Gen))), 64) + or Unsigned_128 (Unsigned_64'(Random (Gen))); + end Random; + --------------------- -- Random_Discrete -- --------------------- diff --git a/gcc/ada/libgnat/s-rannum.ads b/gcc/ada/libgnat/s-rannum.ads index 1851b69..6cbba3e 100644 --- a/gcc/ada/libgnat/s-rannum.ads +++ b/gcc/ada/libgnat/s-rannum.ads @@ -76,6 +76,7 @@ is function Random (Gen : Generator) return Interfaces.Unsigned_32; function Random (Gen : Generator) return Interfaces.Unsigned_64; + function Random (Gen : Generator) return Interfaces.Unsigned_128; -- Return pseudo-random numbers uniformly distributed on T'First .. T'Last -- for builtin integer types. diff --git a/gcc/ada/libgnat/s-rident.ads b/gcc/ada/libgnat/s-rident.ads index afec9a4..662721a 100644 --- a/gcc/ada/libgnat/s-rident.ads +++ b/gcc/ada/libgnat/s-rident.ads @@ -551,9 +551,10 @@ package System.Rident is Max_Task_Entries => 0, others => 0)), - Jorvik => + Jorvik | GNAT_Extended_Ravenscar => - -- Restrictions for Jorvik profile .. + -- Restrictions for Jorvik profile, previously known + -- known as the GNAT_Extended_Ravenscar profile. -- Note: the table entries here only represent the -- required restriction profile for Jorvik. The @@ -567,7 +568,12 @@ package System.Rident is -- as follows: -- 1) Ravenscar includes restriction Simple_Barriers; -- Jorvik includes Pure_Barriers instead. - -- 2) The following 6 restrictions are included in + -- 2) The No_Implicit_Heap_Allocations restriction is + -- lifted and replaced with the following + -- restrictions: + -- No_Implicit_Task_Allocations + -- No_Implicit_Protected_Object_Allocations + -- 3) The following 6 restrictions are included in -- Ravenscar but not in Jorvik: -- No_Implicit_Heap_Allocations -- No_Relative_Delay @@ -598,45 +604,6 @@ package System.Rident is -- plus these additional restrictions: - No_Local_Timing_Events => True, - No_Select_Statements => True, - No_Specific_Termination_Handlers => True, - No_Task_Termination => True, - Pure_Barriers => True, - others => False), - - -- Value settings for Ravenscar (same as Restricted) - - Value => - (Max_Asynchronous_Select_Nesting => 0, - Max_Select_Alternatives => 0, - Max_Task_Entries => 0, - others => 0)), - - GNAT_Extended_Ravenscar => - - -- Restrictions for GNAT_Extended_Ravenscar = - -- Restricted profile .. - - (Set => - (No_Abort_Statements => True, - No_Asynchronous_Control => True, - No_Dynamic_Attachment => True, - No_Dynamic_CPU_Assignment => True, - No_Dynamic_Priorities => True, - No_Local_Protected_Objects => True, - No_Protected_Type_Allocators => True, - No_Requeue_Statements => True, - No_Task_Allocators => True, - No_Task_Attributes_Package => True, - No_Task_Hierarchy => True, - No_Terminate_Alternatives => True, - Max_Asynchronous_Select_Nesting => True, - Max_Select_Alternatives => True, - Max_Task_Entries => True, - - -- plus these additional restrictions: - No_Implicit_Task_Allocations => True, No_Implicit_Protected_Object_Allocations => True, diff --git a/gcc/ada/libgnat/s-scaval.adb b/gcc/ada/libgnat/s-scaval.adb index 9815fbd..5a88111 100644 --- a/gcc/ada/libgnat/s-scaval.adb +++ b/gcc/ada/libgnat/s-scaval.adb @@ -33,6 +33,8 @@ with Ada.Unchecked_Conversion; package body System.Scalar_Values is + use Interfaces; + ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/libgnat/s-scaval.ads b/gcc/ada/libgnat/s-scaval.ads index bd9c9c5..6d13262 100644 --- a/gcc/ada/libgnat/s-scaval.ads +++ b/gcc/ada/libgnat/s-scaval.ads @@ -35,6 +35,8 @@ -- are used by the generated code, which are linked to the actual values -- by the use of pragma Import. +with Interfaces; + package System.Scalar_Values is -- Note: logically this package should be Pure since it can be accessed @@ -43,10 +45,10 @@ package System.Scalar_Values is -- access this from generated code, and the compiler knows that it is -- OK to access this unit from generated code. - type Byte1 is mod 2 ** 8; - type Byte2 is mod 2 ** 16; - type Byte4 is mod 2 ** 32; - type Byte8 is mod 2 ** 64; + subtype Byte1 is Interfaces.Unsigned_8; + subtype Byte2 is Interfaces.Unsigned_16; + subtype Byte4 is Interfaces.Unsigned_32; + subtype Byte8 is Interfaces.Unsigned_64; -- The explicit initializations here are not really required, since these -- variables are always set by System.Scalar_Values.Initialize. diff --git a/gcc/ada/libgnat/s-scaval__128.adb b/gcc/ada/libgnat/s-scaval__128.adb new file mode 100644 index 0000000..53110c2 --- /dev/null +++ b/gcc/ada/libgnat/s-scaval__128.adb @@ -0,0 +1,342 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S C A L A R _ V A L U E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body System.Scalar_Values is + + use Interfaces; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Mode1 : Character; Mode2 : Character) is + C1 : Character := Mode1; + C2 : Character := Mode2; + + procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); + pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); + + subtype String2 is String (1 .. 2); + type String2_Ptr is access all String2; + + Env_Value_Ptr : aliased String2_Ptr; + Env_Value_Length : aliased Integer; + + EV_Val : aliased constant String := + "GNAT_INIT_SCALARS" & ASCII.NUL; + + B : Byte1; + + EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size; + -- Set True if we are on an x86 with 96-bit floats for extended + + AFloat : constant Boolean := + Long_Float'Size = 48 and then Long_Long_Float'Size = 48; + -- Set True if we are on an AAMP with 48-bit extended floating point + + type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1; + + for ByteLF'Component_Size use 8; + + -- Type used to hold Long_Float values on all targets and to initialize + -- 48-bit Long_Float values used on AAMP. On AAMP, this type is 6 bytes. + -- On other targets the type is 8 bytes, and type Byte8 is used for + -- values that are then converted to ByteLF. + + pragma Warnings (Off); -- why ??? + function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF); + pragma Warnings (On); + + type ByteLLF is + array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat)) + of Byte1; + + for ByteLLF'Component_Size use 8; + + -- Type used to initialize Long_Long_Float values used on x86 and + -- any other target with the same 80-bit floating-point values that + -- GCC always stores in 96-bits. Note that we are assuming Intel + -- format little-endian addressing for this type. On non-Intel + -- architectures, this is the same length as Byte8 and holds + -- a Long_Float value. + + -- The following variables are used to initialize the float values + -- by overlay. We can't assign directly to the float values, since + -- we may be assigning signalling Nan's that will cause a trap if + -- loaded into a floating-point register. + + IV_Isf : aliased Byte4; -- Initialize short float + IV_Ifl : aliased Byte4; -- Initialize float + IV_Ilf : aliased ByteLF; -- Initialize long float + IV_Ill : aliased ByteLLF; -- Initialize long long float + + for IV_Isf'Address use IS_Isf'Address; + for IV_Ifl'Address use IS_Ifl'Address; + for IV_Ilf'Address use IS_Ilf'Address; + for IV_Ill'Address use IS_Ill'Address; + + -- The following pragmas are used to suppress initialization + + pragma Import (Ada, IV_Isf); + pragma Import (Ada, IV_Ifl); + pragma Import (Ada, IV_Ilf); + pragma Import (Ada, IV_Ill); + + begin + -- Acquire environment variable value if necessary + + if C1 = 'E' and then C2 = 'V' then + Get_Env_Value_Ptr + (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); + + -- Ignore if length is not 2 + + if Env_Value_Length /= 2 then + C1 := 'I'; + C2 := 'N'; + + -- Length is 2, see if it is a valid value + + else + -- Acquire two characters and fold to upper case + + C1 := Env_Value_Ptr (1); + C2 := Env_Value_Ptr (2); + + if C1 in 'a' .. 'z' then + C1 := Character'Val (Character'Pos (C1) - 32); + end if; + + if C2 in 'a' .. 'z' then + C2 := Character'Val (Character'Pos (C2) - 32); + end if; + + -- IN/LO/HI are ok values + + if (C1 = 'I' and then C2 = 'N') + or else + (C1 = 'L' and then C2 = 'O') + or else + (C1 = 'H' and then C2 = 'I') + then + null; + + -- Try for valid hex digits + + elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z') + or else + (C2 in '0' .. '9' or else C2 in 'A' .. 'Z') + then + null; + + -- Otherwise environment value is bad, ignore and use IN (invalid) + + else + C1 := 'I'; + C2 := 'N'; + end if; + end if; + end if; + + -- IN (invalid value) + + if C1 = 'I' and then C2 = 'N' then + IS_Is1 := 16#80#; + IS_Is2 := 16#8000#; + IS_Is4 := 16#8000_0000#; + IS_Is8 := 16#8000_0000_0000_0000#; + IS_Is16 := 16#8000_0000_0000_0000_0000_0000_0000_0000#; + + IS_Iu1 := 16#FF#; + IS_Iu2 := 16#FFFF#; + IS_Iu4 := 16#FFFF_FFFF#; + IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; + IS_Iu16 := 16#FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF#; + + IS_Iz1 := 16#00#; + IS_Iz2 := 16#0000#; + IS_Iz4 := 16#0000_0000#; + IS_Iz8 := 16#0000_0000_0000_0000#; + IS_Iz16 := 16#0000_0000_0000_0000_0000_0000_0000_0000#; + + if AFloat then + IV_Isf := 16#FFFF_FF00#; + IV_Ifl := 16#FFFF_FF00#; + IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#); + + else + IV_Isf := IS_Iu4; + IV_Ifl := IS_Iu4; + IV_Ilf := To_ByteLF (IS_Iu8); + end if; + + if EFloat then + IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0); + end if; + + -- LO (Low values) + + elsif C1 = 'L' and then C2 = 'O' then + IS_Is1 := 16#80#; + IS_Is2 := 16#8000#; + IS_Is4 := 16#8000_0000#; + IS_Is8 := 16#8000_0000_0000_0000#; + IS_Is16 := 16#8000_0000_0000_0000_0000_0000_0000_0000#; + + IS_Iu1 := 16#00#; + IS_Iu2 := 16#0000#; + IS_Iu4 := 16#0000_0000#; + IS_Iu8 := 16#0000_0000_0000_0000#; + IS_Iu16 := 16#0000_0000_0000_0000_0000_0000_0000_0000#; + + IS_Iz1 := 16#00#; + IS_Iz2 := 16#0000#; + IS_Iz4 := 16#0000_0000#; + IS_Iz8 := 16#0000_0000_0000_0000#; + IS_Iz16 := 16#0000_0000_0000_0000_0000_0000_0000_0000#; + + if AFloat then + IV_Isf := 16#0000_0001#; + IV_Ifl := 16#0000_0001#; + IV_Ilf := (1, 0, 0, 0, 0, 0); + + else + IV_Isf := 16#FF80_0000#; + IV_Ifl := 16#FF80_0000#; + IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#); + end if; + + if EFloat then + IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0); + end if; + + -- HI (High values) + + elsif C1 = 'H' and then C2 = 'I' then + IS_Is1 := 16#7F#; + IS_Is2 := 16#7FFF#; + IS_Is4 := 16#7FFF_FFFF#; + IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#; + IS_Is16 := 16#7FFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF#; + + IS_Iu1 := 16#FF#; + IS_Iu2 := 16#FFFF#; + IS_Iu4 := 16#FFFF_FFFF#; + IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; + IS_Iu16 := 16#FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF#; + + IS_Iz1 := 16#FF#; + IS_Iz2 := 16#FFFF#; + IS_Iz4 := 16#FFFF_FFFF#; + IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#; + IS_Iz16 := 16#FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF#; + + if AFloat then + IV_Isf := 16#7FFF_FFFF#; + IV_Ifl := 16#7FFF_FFFF#; + IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#); + + else + IV_Isf := 16#7F80_0000#; + IV_Ifl := 16#7F80_0000#; + IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#); + end if; + + if EFloat then + IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0); + end if; + + -- -Shh (hex byte) + + else + -- Convert the two hex digits (we know they are valid here) + + B := 16 * (Character'Pos (C1) + - (if C1 in '0' .. '9' + then Character'Pos ('0') + else Character'Pos ('A') - 10)) + + (Character'Pos (C2) + - (if C2 in '0' .. '9' + then Character'Pos ('0') + else Character'Pos ('A') - 10)); + + -- Initialize data values from the hex value + + IS_Is1 := B; + IS_Is2 := 2**8 * Byte2 (IS_Is1) + Byte2 (IS_Is1); + IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2); + IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4); + IS_Is16 := 2**64 * Byte16 (IS_Is8) + Byte16 (IS_Is8); + + IS_Iu1 := IS_Is1; + IS_Iu2 := IS_Is2; + IS_Iu4 := IS_Is4; + IS_Iu8 := IS_Is8; + IS_Iu16 := IS_Is16; + + IS_Iz1 := IS_Is1; + IS_Iz2 := IS_Is2; + IS_Iz4 := IS_Is4; + IS_Iz8 := IS_Is8; + IS_Iz16 := IS_Is16; + + IV_Isf := IS_Is4; + IV_Ifl := IS_Is4; + + if AFloat then + IV_Ill := (B, B, B, B, B, B); + else + IV_Ilf := To_ByteLF (IS_Is8); + end if; + + if EFloat then + IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B); + end if; + end if; + + -- If no separate Long_Long_Float, then use Long_Float value as + -- Long_Long_Float initial value. + + if not EFloat then + declare + pragma Warnings (Off); -- why??? + function To_ByteLLF is + new Ada.Unchecked_Conversion (ByteLF, ByteLLF); + pragma Warnings (On); + begin + IV_Ill := To_ByteLLF (IV_Ilf); + end; + end if; + end Initialize; + +end System.Scalar_Values; diff --git a/gcc/ada/libgnat/s-scaval__128.ads b/gcc/ada/libgnat/s-scaval__128.ads new file mode 100644 index 0000000..8eb1b65 --- /dev/null +++ b/gcc/ada/libgnat/s-scaval__128.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S C A L A R _ V A L U E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines the constants used for initializing scalar values +-- when pragma Initialize_Scalars is used. The actual values are defined +-- in the binder generated file. This package contains the Ada names that +-- are used by the generated code, which are linked to the actual values +-- by the use of pragma Import. + +-- This is the 128-bit version of the package + +with Interfaces; + +package System.Scalar_Values is + + -- Note: logically this package should be Pure since it can be accessed + -- from pure units, but the IS_xxx variables below get set at run time, + -- so they have to be library level variables. In fact we only ever + -- access this from generated code, and the compiler knows that it is + -- OK to access this unit from generated code. + + subtype Byte1 is Interfaces.Unsigned_8; + subtype Byte2 is Interfaces.Unsigned_16; + subtype Byte4 is Interfaces.Unsigned_32; + subtype Byte8 is Interfaces.Unsigned_64; + subtype Byte16 is Interfaces.Unsigned_128; + + -- The explicit initializations here are not really required, since these + -- variables are always set by System.Scalar_Values.Initialize. + + IS_Is1 : Byte1 := 0; -- Initialize 1 byte signed + IS_Is2 : Byte2 := 0; -- Initialize 2 byte signed + IS_Is4 : Byte4 := 0; -- Initialize 4 byte signed + IS_Is8 : Byte8 := 0; -- Initialize 8 byte signed + IS_Is16 : Byte16 := 0; -- Initialize 8 byte signed + -- For the above cases, the undefined value (set by the binder -Sin switch) + -- is the largest negative number (1 followed by all zero bits). + + IS_Iu1 : Byte1 := 0; -- Initialize 1 byte unsigned + IS_Iu2 : Byte2 := 0; -- Initialize 2 byte unsigned + IS_Iu4 : Byte4 := 0; -- Initialize 4 byte unsigned + IS_Iu8 : Byte8 := 0; -- Initialize 8 byte unsigned + IS_Iu16 : Byte16 := 0; -- Initialize 8 byte unsigned + -- For the above cases, the undefined value (set by the binder -Sin switch) + -- is the largest unsigned number (all 1 bits). + + IS_Iz1 : Byte1 := 0; -- Initialize 1 byte zeroes + IS_Iz2 : Byte2 := 0; -- Initialize 2 byte zeroes + IS_Iz4 : Byte4 := 0; -- Initialize 4 byte zeroes + IS_Iz8 : Byte8 := 0; -- Initialize 8 byte zeroes + IS_Iz16 : Byte16 := 0; -- Initialize 8 byte zeroes + -- For the above cases, the undefined value (set by the binder -Sin switch) + -- is the zero (all 0 bits). This is used when zero is known to be an + -- invalid value. + + -- The float definitions are aliased, because we use overlays to set them + + IS_Isf : aliased Short_Float := 0.0; -- Initialize short float + IS_Ifl : aliased Float := 0.0; -- Initialize float + IS_Ilf : aliased Long_Float := 0.0; -- Initialize long float + IS_Ill : aliased Long_Long_Float := 0.0; -- Initialize long long float + + procedure Initialize (Mode1 : Character; Mode2 : Character); + -- This procedure is called from the binder when Initialize_Scalars mode + -- is active. The arguments are the two characters from the -S switch, + -- with letters forced upper case. So for example if -S5a is given, then + -- Mode1 will be '5' and Mode2 will be 'A'. If the parameters are EV, + -- then this routine reads the environment variable GNAT_INIT_SCALARS. + -- The possible settings are the same as those for the -S switch (except + -- for EV), i.e. IN/LO/HO/xx, xx = 2 hex digits. If no -S switch is given + -- then the default of IN (invalid values) is passed on the call. + +end System.Scalar_Values; diff --git a/gcc/ada/libgnat/s-soflin.adb b/gcc/ada/libgnat/s-soflin.adb index 7e1a557..48d1338 100644 --- a/gcc/ada/libgnat/s-soflin.adb +++ b/gcc/ada/libgnat/s-soflin.adb @@ -31,10 +31,6 @@ pragma Compiler_Unit_Warning; -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get an --- infinite loop from the code within the Poll routine itself. - pragma Warnings (Off); -- Disable warnings as System.Soft_Links.Initialize is not Preelaborate. It is -- safe to with this unit as its elaboration routine will only be initializing diff --git a/gcc/ada/libgnat/s-stalib.adb b/gcc/ada/libgnat/s-stalib.adb index 61636d1..7c60013 100644 --- a/gcc/ada/libgnat/s-stalib.adb +++ b/gcc/ada/libgnat/s-stalib.adb @@ -36,10 +36,6 @@ pragma Compiler_Unit_Warning; -- of System.Standard_Library, since this would cause order of elaboration -- problems (Elaborate_Body would have the same problem). -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with Ada.Exceptions if polling is on. - pragma Warnings (Off); -- Kill warnings from unused withs. These unused with's are here to make -- sure the relevant units are loaded and properly elaborated. diff --git a/gcc/ada/libgnat/s-stalib.ads b/gcc/ada/libgnat/s-stalib.ads index 5fbedae..b6258ed 100644 --- a/gcc/ada/libgnat/s-stalib.ads +++ b/gcc/ada/libgnat/s-stalib.ads @@ -46,10 +46,6 @@ pragma Compiler_Unit_Warning; -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with Ada.Exceptions if polling is on. - with Ada.Unchecked_Conversion; package System.Standard_Library is diff --git a/gcc/ada/libgnat/s-stchop.adb b/gcc/ada/libgnat/s-stchop.adb index c5c3d35..340d27b 100644 --- a/gcc/ada/libgnat/s-stchop.adb +++ b/gcc/ada/libgnat/s-stchop.adb @@ -61,8 +61,6 @@ package body System.Stack_Checking.Operations is -- cache is pending, that write should be followed by a Poll to prevent -- losing signals. -- - -- Note: This function must be compiled with Polling turned off - -- -- Note: on systems with real thread-local storage, Set_Stack_Info should -- return an access value for such local storage. In those cases the cache -- will always be up-to-date. diff --git a/gcc/ada/libgnat/s-stchop.ads b/gcc/ada/libgnat/s-stchop.ads index d057ddb..185301c 100644 --- a/gcc/ada/libgnat/s-stchop.ads +++ b/gcc/ada/libgnat/s-stchop.ads @@ -36,10 +36,6 @@ pragma Restrictions (No_Elaboration_Code); -- We want to guarantee the absence of elaboration code because the binder -- does not handle references to this package. -pragma Polling (Off); --- Turn off polling, we do not want polling to take place during stack --- checking operations. It causes infinite loops and other problems. - with System.Storage_Elements; package System.Stack_Checking.Operations is diff --git a/gcc/ada/libgnat/s-stchop__limit.ads b/gcc/ada/libgnat/s-stchop__limit.ads index c904606..7330676 100644 --- a/gcc/ada/libgnat/s-stchop__limit.ads +++ b/gcc/ada/libgnat/s-stchop__limit.ads @@ -37,10 +37,6 @@ pragma Restrictions (No_Elaboration_Code); -- We want to guarantee the absence of elaboration code because the binder -- does not handle references to this package. -pragma Polling (Off); --- Turn off polling, we do not want polling to take place during stack --- checking operations. It causes infinite loops and other problems. - package System.Stack_Checking.Operations is pragma Preelaborate; diff --git a/gcc/ada/libgnat/s-traceb.ads b/gcc/ada/libgnat/s-traceb.ads index 1c3151c..094218c 100644 --- a/gcc/ada/libgnat/s-traceb.ads +++ b/gcc/ada/libgnat/s-traceb.ads @@ -35,10 +35,6 @@ pragma Compiler_Unit_Warning; -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with System.Exception_Tables. - with System.Traceback_Entries; package System.Traceback is diff --git a/gcc/ada/libgnat/s-traent.adb b/gcc/ada/libgnat/s-traent.adb index 950b0e5..23d174f 100644 --- a/gcc/ada/libgnat/s-traent.adb +++ b/gcc/ada/libgnat/s-traent.adb @@ -29,10 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with Ada.Exceptions. - pragma Compiler_Unit_Warning; package body System.Traceback_Entries is diff --git a/gcc/ada/libgnat/s-traent.ads b/gcc/ada/libgnat/s-traent.ads index fa2db4e..83ef569 100644 --- a/gcc/ada/libgnat/s-traent.ads +++ b/gcc/ada/libgnat/s-traent.ads @@ -38,10 +38,6 @@ -- version of the package, an entry is a mere code location representing the -- address of a call instruction part of the call-chain. -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with Ada.Exceptions. - pragma Compiler_Unit_Warning; package System.Traceback_Entries is diff --git a/gcc/ada/libgnat/s-trasym.adb b/gcc/ada/libgnat/s-trasym.adb index 0d6639f..bfc3a98 100644 --- a/gcc/ada/libgnat/s-trasym.adb +++ b/gcc/ada/libgnat/s-trasym.adb @@ -33,10 +33,6 @@ -- is not supported. It returns tracebacks as lists of hexadecimal addresses -- of the form "0x...". -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on. - with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; with System.Address_Image; diff --git a/gcc/ada/libgnat/s-trasym.ads b/gcc/ada/libgnat/s-trasym.ads index f0240cd..e974ee9 100644 --- a/gcc/ada/libgnat/s-trasym.ads +++ b/gcc/ada/libgnat/s-trasym.ads @@ -71,10 +71,6 @@ -- executable. You should consider using gdb to obtain symbolic traceback in -- such cases. -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on. - with Ada.Exceptions; package System.Traceback.Symbolic is diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb index d8e3956..78cbcc2 100644 --- a/gcc/ada/libgnat/s-trasym__dwarf.adb +++ b/gcc/ada/libgnat/s-trasym__dwarf.adb @@ -31,10 +31,6 @@ -- Run-time symbolic traceback support for targets using DWARF debug data -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on. - with Ada.Unchecked_Deallocation; with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; diff --git a/gcc/ada/libgnat/s-unstyp.ads b/gcc/ada/libgnat/s-unstyp.ads index 0f6c73c..86c5d7f 100644 --- a/gcc/ada/libgnat/s-unstyp.ads +++ b/gcc/ada/libgnat/s-unstyp.ads @@ -41,13 +41,14 @@ package System.Unsigned_Types is pragma Pure; pragma No_Elaboration_Code_All; - type Short_Short_Unsigned is mod 2 ** Short_Short_Integer'Size; - type Short_Unsigned is mod 2 ** Short_Integer'Size; - type Unsigned is mod 2 ** Integer'Size; - type Long_Unsigned is mod 2 ** Long_Integer'Size; - type Long_Long_Unsigned is mod 2 ** Long_Long_Integer'Size; - - type Float_Unsigned is mod 2 ** Float'Size; + type Short_Short_Unsigned is mod 2 ** Short_Short_Integer'Size; + type Short_Unsigned is mod 2 ** Short_Integer'Size; + type Unsigned is mod 2 ** Integer'Size; + type Long_Unsigned is mod 2 ** Long_Integer'Size; + type Long_Long_Unsigned is mod 2 ** Long_Long_Integer'Size; + type Long_Long_Long_Unsigned is mod Max_Binary_Modulus; + + type Float_Unsigned is mod 2 ** Float'Size; -- Used in the implementation of Is_Negative intrinsic (see Exp_Intr) type Packed_Byte is mod 2 ** 8; @@ -215,6 +216,26 @@ package System.Unsigned_Types is (Value : Long_Long_Unsigned; Amount : Natural) return Long_Long_Unsigned; + function Shift_Left + (Value : Long_Long_Long_Unsigned; + Amount : Natural) return Long_Long_Long_Unsigned; + + function Shift_Right + (Value : Long_Long_Long_Unsigned; + Amount : Natural) return Long_Long_Long_Unsigned; + + function Shift_Right_Arithmetic + (Value : Long_Long_Long_Unsigned; + Amount : Natural) return Long_Long_Long_Unsigned; + + function Rotate_Left + (Value : Long_Long_Long_Unsigned; + Amount : Natural) return Long_Long_Long_Unsigned; + + function Rotate_Right + (Value : Long_Long_Long_Unsigned; + Amount : Natural) return Long_Long_Long_Unsigned; + pragma Import (Intrinsic, Shift_Left); pragma Import (Intrinsic, Shift_Right); pragma Import (Intrinsic, Shift_Right_Arithmetic); diff --git a/gcc/ada/libgnat/s-valint.adb b/gcc/ada/libgnat/s-valint.adb index c40d558..983d2d1 100644 --- a/gcc/ada/libgnat/s-valint.adb +++ b/gcc/ada/libgnat/s-valint.adb @@ -29,90 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_Uns; use System.Val_Uns; -with System.Val_Util; use System.Val_Util; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Val_Int is - - ------------------ - -- Scan_Integer -- - ------------------ - - function Scan_Integer - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Integer - is - Uval : Unsigned; - -- Unsigned result - - Minus : Boolean := False; - -- Set to True if minus sign is present, otherwise to False - - Start : Positive; - -- Saves location of first non-blank (not used in this case) - - begin - Scan_Sign (Str, Ptr, Max, Minus, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - Bad_Value (Str); - end if; - - Uval := Scan_Raw_Unsigned (Str, Ptr, Max); - - -- Deal with overflow cases, and also with maximum negative number - - if Uval > Unsigned (Integer'Last) then - if Minus and then Uval = Unsigned (-(Integer'First)) then - return Integer'First; - else - Bad_Value (Str); - end if; - - -- Negative values - - elsif Minus then - return -(Integer (Uval)); - - -- Positive values - - else - return Integer (Uval); - end if; - end Scan_Integer; - - ------------------- - -- Value_Integer -- - ------------------- - - function Value_Integer (Str : String) return Integer is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Integer (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Integer; - P : aliased Integer := Str'First; - begin - V := Scan_Integer (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Integer; - -end System.Val_Int; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads index 79571da..8a3c55e 100644 --- a/gcc/ada/libgnat/s-valint.ads +++ b/gcc/ada/libgnat/s-valint.ads @@ -32,42 +32,24 @@ -- This package contains routines for scanning signed Integer values for use -- in Text_IO.Integer_IO, and the Value attribute. +with System.Unsigned_Types; +with System.Val_Uns; +with System.Value_I; + package System.Val_Int is pragma Preelaborate; + subtype Unsigned is Unsigned_Types.Unsigned; + + package Impl is new Value_I (Integer, Unsigned, Val_Uns.Scan_Raw_Unsigned); + function Scan_Integer (Str : String; Ptr : not null access Integer; - Max : Integer) return Integer; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). There are three cases for the - -- return: - -- - -- If a valid integer is found after scanning past any initial spaces, then - -- Ptr.all is updated past the last character of the integer (but trailing - -- spaces are not scanned out). - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_Io.Get - -- - -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. + Max : Integer) return Integer + renames Impl.Scan_Integer; - function Value_Integer (Str : String) return Integer; - -- Used in computing X'Value (Str) where X is a signed integer type whose - -- base range does not exceed the base range of Integer. Str is the string - -- argument of the attribute. Constraint_Error is raised if the string is - -- malformed, or if the value is out of range. + function Value_Integer (Str : String) return Integer + renames Impl.Value_Integer; end System.Val_Int; diff --git a/gcc/ada/libgnat/s-vallli.adb b/gcc/ada/libgnat/s-vallli.adb index 43bb0a7..eadab12 100644 --- a/gcc/ada/libgnat/s-vallli.adb +++ b/gcc/ada/libgnat/s-vallli.adb @@ -29,92 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_LLU; use System.Val_LLU; -with System.Val_Util; use System.Val_Util; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Val_LLI is - - ---------------------------- - -- Scan_Long_Long_Integer -- - ---------------------------- - - function Scan_Long_Long_Integer - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Integer - is - Uval : Long_Long_Unsigned; - -- Unsigned result - - Minus : Boolean := False; - -- Set to True if minus sign is present, otherwise to False - - Start : Positive; - -- Saves location of first non-blank - - begin - Scan_Sign (Str, Ptr, Max, Minus, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - Bad_Value (Str); - end if; - - Uval := Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max); - - -- Deal with overflow cases, and also with maximum negative number - - if Uval > Long_Long_Unsigned (Long_Long_Integer'Last) then - if Minus - and then Uval = Long_Long_Unsigned (-(Long_Long_Integer'First)) - then - return Long_Long_Integer'First; - else - Bad_Value (Str); - end if; - - -- Negative values - - elsif Minus then - return -(Long_Long_Integer (Uval)); - - -- Positive values - - else - return Long_Long_Integer (Uval); - end if; - end Scan_Long_Long_Integer; - - ----------------------------- - -- Value_Long_Long_Integer -- - ----------------------------- - - function Value_Long_Long_Integer (Str : String) return Long_Long_Integer is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Long_Long_Integer (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Long_Long_Integer; - P : aliased Integer := Str'First; - begin - V := Scan_Long_Long_Integer (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Long_Long_Integer; - -end System.Val_LLI; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads index 0a51bbe..e53873e 100644 --- a/gcc/ada/libgnat/s-vallli.ads +++ b/gcc/ada/libgnat/s-vallli.ads @@ -32,42 +32,27 @@ -- This package contains routines for scanning signed Long_Long_Integer -- values for use in Text_IO.Integer_IO, and the Value attribute. +with System.Unsigned_Types; +with System.Val_LLU; +with System.Value_I; + package System.Val_LLI is pragma Preelaborate; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + package Impl is new + Value_I (Long_Long_Integer, + Long_Long_Unsigned, + Val_LLU.Scan_Raw_Long_Long_Unsigned); + function Scan_Long_Long_Integer (Str : String; Ptr : not null access Integer; - Max : Integer) return Long_Long_Integer; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). There are three cases for the - -- return: - -- - -- If a valid integer is found after scanning past any initial spaces, then - -- Ptr.all is updated past the last character of the integer (but trailing - -- spaces are not scanned out). - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_Io.Get - -- - -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. + Max : Integer) return Long_Long_Integer + renames Impl.Scan_Integer; - function Value_Long_Long_Integer (Str : String) return Long_Long_Integer; - -- Used in computing X'Value (Str) where X is a signed integer type whose - -- base range exceeds the base range of Integer. Str is the string argument - -- of the attribute. Constraint_Error is raised if the string is malformed, - -- or if the value is out of range. + function Value_Long_Long_Integer (Str : String) return Long_Long_Integer + renames Impl.Value_Integer; end System.Val_LLI; diff --git a/gcc/ada/libgnat/s-valllli.ads b/gcc/ada/libgnat/s-valllli.ads new file mode 100644 index 0000000..9ab7161 --- /dev/null +++ b/gcc/ada/libgnat/s-valllli.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning signed Long_Long_Long_Integer +-- values for use in Text_IO.Integer_IO, and the Value attribute. + +with System.Unsigned_Types; +with System.Val_LLLU; +with System.Value_I; + +package System.Val_LLLI is + pragma Preelaborate; + + subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; + + package Impl is new + Value_I (Long_Long_Long_Integer, + Long_Long_Long_Unsigned, + Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned); + + function Scan_Long_Long_Long_Integer + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Long_Long_Integer + renames Impl.Scan_Integer; + + function Value_Long_Long_Long_Integer + (Str : String) return Long_Long_Long_Integer + renames Impl.Value_Integer; + +end System.Val_LLLI; diff --git a/gcc/ada/libgnat/s-vallllu.ads b/gcc/ada/libgnat/s-vallllu.ads new file mode 100644 index 0000000..34ce282 --- /dev/null +++ b/gcc/ada/libgnat/s-vallllu.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning modular Long_Long_Unsigned +-- values for use in Text_IO.Modular_IO, and the Value attribute. + +with System.Unsigned_Types; +with System.Value_U; + +package System.Val_LLLU is + pragma Preelaborate; + + subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; + + package Impl is new Value_U (Long_Long_Long_Unsigned); + + function Scan_Raw_Long_Long_Long_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Long_Long_Unsigned + renames Impl.Scan_Raw_Unsigned; + + function Scan_Long_Long_Long_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Long_Long_Unsigned + renames Impl.Scan_Unsigned; + + function Value_Long_Long_Long_Unsigned + (Str : String) return Long_Long_Long_Unsigned + renames Impl.Value_Unsigned; + +end System.Val_LLLU; diff --git a/gcc/ada/libgnat/s-valllu.adb b/gcc/ada/libgnat/s-valllu.adb index dca0aac..1afb632 100644 --- a/gcc/ada/libgnat/s-valllu.adb +++ b/gcc/ada/libgnat/s-valllu.adb @@ -29,302 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_Util; use System.Val_Util; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Val_LLU is - - --------------------------------- - -- Scan_Raw_Long_Long_Unsigned -- - --------------------------------- - - function Scan_Raw_Long_Long_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Unsigned - is - P : Integer; - -- Local copy of the pointer - - Uval : Long_Long_Unsigned; - -- Accumulated unsigned integer result - - Expon : Integer; - -- Exponent value - - Overflow : Boolean := False; - -- Set True if overflow is detected at any point - - Base_Char : Character; - -- Base character (# or :) in based case - - Base : Long_Long_Unsigned := 10; - -- Base value (reset in based case) - - Digit : Long_Long_Unsigned; - -- Digit value - - begin - -- We do not tolerate strings with Str'Last = Positive'Last - - if Str'Last = Positive'Last then - raise Program_Error with - "string upper bound is Positive'Last, not supported"; - end if; - - P := Ptr.all; - Uval := Character'Pos (Str (P)) - Character'Pos ('0'); - P := P + 1; - - -- Scan out digits of what is either the number or the base. - -- In either case, we are definitely scanning out in base 10. - - declare - Umax : constant := (Long_Long_Unsigned'Last - 9) / 10; - -- Max value which cannot overflow on accumulating next digit - - Umax10 : constant := Long_Long_Unsigned'Last / 10; - -- Numbers bigger than Umax10 overflow if multiplied by 10 - - begin - -- Loop through decimal digits - loop - exit when P > Max; - - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - -- Non-digit encountered - - if Digit > 9 then - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - exit; - end if; - - -- Accumulate result, checking for overflow - - else - if Uval <= Umax then - Uval := 10 * Uval + Digit; - - elsif Uval > Umax10 then - Overflow := True; - - else - Uval := 10 * Uval + Digit; - - if Uval < Umax10 then - Overflow := True; - end if; - end if; - - P := P + 1; - end if; - end loop; - end; - - Ptr.all := P; - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - if P < Max and then (Str (P) = '#' or else Str (P) = ':') then - Base_Char := Str (P); - P := P + 1; - Base := Uval; - Uval := 0; - - -- Check base value. Overflow is set True if we find a bad base, or - -- a digit that is out of range of the base. That way, we scan out - -- the numeral that is still syntactically correct, though illegal. - -- We use a safe base of 16 for this scan, to avoid zero divide. - - if Base not in 2 .. 16 then - Overflow := True; - Base := 16; - end if; - - -- Scan out based integer - - declare - Umax : constant Long_Long_Unsigned := - (Long_Long_Unsigned'Last - Base + 1) / Base; - -- Max value which cannot overflow on accumulating next digit - - UmaxB : constant Long_Long_Unsigned := - Long_Long_Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - -- Loop to scan out based integer value - - loop - -- We require a digit at this stage - - if Str (P) in '0' .. '9' then - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - elsif Str (P) in 'A' .. 'F' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('A') - 10); - - elsif Str (P) in 'a' .. 'f' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('a') - 10); - - -- If we don't have a digit, then this is not a based number - -- after all, so we use the value we scanned out as the base - -- (now in Base), and the pointer to the base character was - -- already stored in Ptr.all. - - else - Uval := Base; - exit; - end if; - - -- If digit is too large, just signal overflow and continue. - -- The idea here is to keep scanning as long as the input is - -- syntactically valid, even if we have detected overflow - - if Digit >= Base then - Overflow := True; - - -- Here we accumulate the value, checking overflow - - elsif Uval <= Umax then - Uval := Base * Uval + Digit; - - elsif Uval > UmaxB then - Overflow := True; - - else - Uval := Base * Uval + Digit; - - if Uval < UmaxB then - Overflow := True; - end if; - end if; - - -- If at end of string with no base char, not a based number - -- but we signal Constraint_Error and set the pointer past - -- the end of the field, since this is what the ACVC tests - -- seem to require, see CE3704N, line 204. - - P := P + 1; - - if P > Max then - Ptr.all := P; - Bad_Value (Str); - end if; - - -- If terminating base character, we are done with loop - - if Str (P) = Base_Char then - Ptr.all := P + 1; - exit; - - -- Deal with underscore - - elsif Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, True); - end if; - - end loop; - end; - end if; - - -- Come here with scanned unsigned value in Uval. The only remaining - -- required step is to deal with exponent if one is present. - - Expon := Scan_Exponent (Str, Ptr, Max); - - if Expon /= 0 and then Uval /= 0 then - - -- For non-zero value, scale by exponent value. No need to do this - -- efficiently, since use of exponent in integer literals is rare, - -- and in any case the exponent cannot be very large. - - declare - UmaxB : constant Long_Long_Unsigned := - Long_Long_Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - for J in 1 .. Expon loop - if Uval > UmaxB then - Overflow := True; - exit; - end if; - - Uval := Uval * Base; - end loop; - end; - end if; - - -- Return result, dealing with sign and overflow - - if Overflow then - Bad_Value (Str); - else - return Uval; - end if; - end Scan_Raw_Long_Long_Unsigned; - - ----------------------------- - -- Scan_Long_Long_Unsigned -- - ----------------------------- - - function Scan_Long_Long_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Unsigned - is - Start : Positive; - -- Save location of first non-blank character - - begin - Scan_Plus_Sign (Str, Ptr, Max, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - raise Constraint_Error; - end if; - - return Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max); - end Scan_Long_Long_Unsigned; - - ------------------------------ - -- Value_Long_Long_Unsigned -- - ------------------------------ - - function Value_Long_Long_Unsigned - (Str : String) return Long_Long_Unsigned - is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Long_Long_Unsigned (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Long_Long_Unsigned; - P : aliased Integer := Str'First; - begin - V := Scan_Long_Long_Unsigned (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Long_Long_Unsigned; - -end System.Val_LLU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-valllu.ads b/gcc/ada/libgnat/s-valllu.ads index 51a31dd..5c0300c 100644 --- a/gcc/ada/libgnat/s-valllu.ads +++ b/gcc/ada/libgnat/s-valllu.ads @@ -33,97 +33,29 @@ -- values for use in Text_IO.Modular_IO, and the Value attribute. with System.Unsigned_Types; +with System.Value_U; package System.Val_LLU is pragma Preelaborate; + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + package Impl is new Value_U (Long_Long_Unsigned); + function Scan_Raw_Long_Long_Unsigned (Str : String; Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). Note: this does not scan - -- leading or trailing blanks, nor leading sign. - -- - -- There are three cases for the return: - -- - -- If a valid integer is found, then Ptr.all is updated past the last - -- character of the integer. - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_IO.Get. Note that the rules as stated in the RM would - -- seem to imply that for a case like: - -- - -- 8#12345670009# - -- - -- the pointer should be left at the first # having scanned out the longest - -- valid integer literal (8), but in fact in this case the pointer points - -- past the final # and Constraint_Error is raised. This is the behavior - -- expected for Text_IO and enforced by the ACATS tests. - -- - -- If a based literal is malformed in that a character other than a valid - -- hexadecimal digit is encountered during scanning out the digits after - -- the # (this includes the case of using the wrong terminator, : instead - -- of # or vice versa) there are two cases. If all the digits before the - -- non-digit are in range of the base, as in - -- - -- 8#100x00# - -- 8#100: - -- - -- then in this case, the "base" value before the initial # is returned as - -- the result, and the pointer points to the initial # character on return. - -- - -- If an out of range digit has been detected before the invalid character, - -- as in: - -- - -- 8#900x00# - -- 8#900: - -- - -- then the pointer is also left at the initial # character, but constraint - -- error is raised reflecting the encounter of an out of range digit. - -- - -- Finally if we have an unterminated fixed-point constant where the final - -- # or : character is missing, Constraint_Error is raised and the pointer - -- is left pointing past the last digit, as in: - -- - -- 8#22 - -- - -- This string results in a Constraint_Error with the pointer pointing - -- past the second 2. - -- - -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - -- - -- Note: this routine should not be called with Str'Last = Positive'Last. - -- If this occurs Program_Error is raised with a message noting that this - -- case is not supported. Most such cases are eliminated by the caller. + Max : Integer) return Long_Long_Unsigned + renames Impl.Scan_Raw_Unsigned; function Scan_Long_Long_Unsigned (Str : String; Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned; - -- Same as Scan_Raw_Long_Long_Unsigned, except scans optional leading - -- blanks, and an optional leading plus sign. - -- - -- Note: if a minus sign is present, Constraint_Error will be raised. - -- Note: trailing blanks are not scanned. + Max : Integer) return Long_Long_Unsigned + renames Impl.Scan_Unsigned; function Value_Long_Long_Unsigned - (Str : String) return System.Unsigned_Types.Long_Long_Unsigned; - -- Used in computing X'Value (Str) where X is a modular integer type whose - -- modulus exceeds the range of System.Unsigned_Types.Unsigned. Str is the - -- string argument of the attribute. Constraint_Error is raised if the - -- string is malformed, or if the value is out of range. + (Str : String) return Long_Long_Unsigned + renames Impl.Value_Unsigned; end System.Val_LLU; diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb new file mode 100644 index 0000000..1bc8b32 --- /dev/null +++ b/gcc/ada/libgnat/s-valuei.adb @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Val_Util; use System.Val_Util; + +package body System.Value_I is + + ------------------ + -- Scan_Integer -- + ------------------ + + function Scan_Integer + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Int + is + Uval : Uns; + -- Unsigned result + + Minus : Boolean := False; + -- Set to True if minus sign is present, otherwise to False + + Start : Positive; + -- Saves location of first non-blank (not used in this case) + + begin + Scan_Sign (Str, Ptr, Max, Minus, Start); + + if Str (Ptr.all) not in '0' .. '9' then + Ptr.all := Start; + Bad_Value (Str); + end if; + + Uval := Scan_Raw_Unsigned (Str, Ptr, Max); + + -- Deal with overflow cases, and also with maximum negative number + + if Uval > Uns (Int'Last) then + if Minus and then Uval = Uns (-(Int'First)) then + return Int'First; + else + Bad_Value (Str); + end if; + + -- Negative values + + elsif Minus then + return -(Int (Uval)); + + -- Positive values + + else + return Int (Uval); + end if; + end Scan_Integer; + + ------------------- + -- Value_Integer -- + ------------------- + + function Value_Integer (Str : String) return Int is + begin + -- We have to special case Str'Last = Positive'Last because the normal + -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We + -- deal with this by converting to a subtype which fixes the bounds. + + if Str'Last = Positive'Last then + declare + subtype NT is String (1 .. Str'Length); + begin + return Value_Integer (NT (Str)); + end; + + -- Normal case where Str'Last < Positive'Last + + else + declare + V : Int; + P : aliased Integer := Str'First; + begin + V := Scan_Integer (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end; + end if; + end Value_Integer; + +end System.Value_I; diff --git a/gcc/ada/libgnat/s-valuei.ads b/gcc/ada/libgnat/s-valuei.ads new file mode 100644 index 0000000..13f4f8c --- /dev/null +++ b/gcc/ada/libgnat/s-valuei.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning signed integer values for use +-- in Text_IO.Integer_IO, and the Value attribute. + +generic + + type Int is range <>; + + type Uns is mod <>; + + with function Scan_Raw_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Uns; + +package System.Value_I is + pragma Preelaborate; + + function Scan_Integer + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Int; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- integer according to the syntax described in (RM 3.5(43)). The substring + -- scanned extends no further than Str (Max). There are three cases for the + -- return: + -- + -- If a valid integer is found after scanning past any initial spaces, then + -- Ptr.all is updated past the last character of the integer (but trailing + -- spaces are not scanned out). + -- + -- If no valid integer is found, then Ptr.all points either to an initial + -- non-digit character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the pointer + -- positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Integer (Str : String) return Int; + -- Used in computing X'Value (Str) where X is a signed integer type whose + -- base range does not exceed the base range of Integer. Str is the string + -- argument of the attribute. Constraint_Error is raised if the string is + -- malformed, or if the value is out of range. + +end System.Value_I; diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb new file mode 100644 index 0000000..75bef07 --- /dev/null +++ b/gcc/ada/libgnat/s-valueu.adb @@ -0,0 +1,324 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Val_Util; use System.Val_Util; + +package body System.Value_U is + + ----------------------- + -- Scan_Raw_Unsigned -- + ----------------------- + + function Scan_Raw_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Uns + is + P : Integer; + -- Local copy of the pointer + + Uval : Uns; + -- Accumulated unsigned integer result + + Expon : Integer; + -- Exponent value + + Overflow : Boolean := False; + -- Set True if overflow is detected at any point + + Base_Char : Character; + -- Base character (# or :) in based case + + Base : Uns := 10; + -- Base value (reset in based case) + + Digit : Uns; + -- Digit value + + begin + -- We do not tolerate strings with Str'Last = Positive'Last + + if Str'Last = Positive'Last then + raise Program_Error with + "string upper bound is Positive'Last, not supported"; + end if; + + P := Ptr.all; + Uval := Character'Pos (Str (P)) - Character'Pos ('0'); + P := P + 1; + + -- Scan out digits of what is either the number or the base. + -- In either case, we are definitely scanning out in base 10. + + declare + Umax : constant Uns := (Uns'Last - 9) / 10; + -- Max value which cannot overflow on accumulating next digit + + Umax10 : constant Uns := Uns'Last / 10; + -- Numbers bigger than Umax10 overflow if multiplied by 10 + + begin + -- Loop through decimal digits + loop + exit when P > Max; + + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + -- Non-digit encountered + + if Digit > 9 then + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + exit; + end if; + + -- Accumulate result, checking for overflow + + else + if Uval <= Umax then + Uval := 10 * Uval + Digit; + + elsif Uval > Umax10 then + Overflow := True; + + else + Uval := 10 * Uval + Digit; + + if Uval < Umax10 then + Overflow := True; + end if; + end if; + + P := P + 1; + end if; + end loop; + end; + + Ptr.all := P; + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + if P < Max and then (Str (P) = '#' or else Str (P) = ':') then + Base_Char := Str (P); + P := P + 1; + Base := Uval; + Uval := 0; + + -- Check base value. Overflow is set True if we find a bad base, or + -- a digit that is out of range of the base. That way, we scan out + -- the numeral that is still syntactically correct, though illegal. + -- We use a safe base of 16 for this scan, to avoid zero divide. + + if Base not in 2 .. 16 then + Overflow := True; + Base := 16; + end if; + + -- Scan out based integer + + declare + Umax : constant Uns := (Uns'Last - Base + 1) / Base; + -- Max value which cannot overflow on accumulating next digit + + UmaxB : constant Uns := Uns'Last / Base; + -- Numbers bigger than UmaxB overflow if multiplied by base + + begin + -- Loop to scan out based integer value + + loop + -- We require a digit at this stage + + if Str (P) in '0' .. '9' then + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + elsif Str (P) in 'A' .. 'F' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('A') - 10); + + elsif Str (P) in 'a' .. 'f' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('a') - 10); + + -- If we don't have a digit, then this is not a based number + -- after all, so we use the value we scanned out as the base + -- (now in Base), and the pointer to the base character was + -- already stored in Ptr.all. + + else + Uval := Base; + exit; + end if; + + -- If digit is too large, just signal overflow and continue. + -- The idea here is to keep scanning as long as the input is + -- syntactically valid, even if we have detected overflow + + if Digit >= Base then + Overflow := True; + + -- Here we accumulate the value, checking overflow + + elsif Uval <= Umax then + Uval := Base * Uval + Digit; + + elsif Uval > UmaxB then + Overflow := True; + + else + Uval := Base * Uval + Digit; + + if Uval < UmaxB then + Overflow := True; + end if; + end if; + + -- If at end of string with no base char, not a based number + -- but we signal Constraint_Error and set the pointer past + -- the end of the field, since this is what the ACVC tests + -- seem to require, see CE3704N, line 204. + + P := P + 1; + + if P > Max then + Ptr.all := P; + Bad_Value (Str); + end if; + + -- If terminating base character, we are done with loop + + if Str (P) = Base_Char then + Ptr.all := P + 1; + exit; + + -- Deal with underscore + + elsif Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, True); + end if; + + end loop; + end; + end if; + + -- Come here with scanned unsigned value in Uval. The only remaining + -- required step is to deal with exponent if one is present. + + Expon := Scan_Exponent (Str, Ptr, Max); + + if Expon /= 0 and then Uval /= 0 then + + -- For non-zero value, scale by exponent value. No need to do this + -- efficiently, since use of exponent in integer literals is rare, + -- and in any case the exponent cannot be very large. + + declare + UmaxB : constant Uns := Uns'Last / Base; + -- Numbers bigger than UmaxB overflow if multiplied by base + + begin + for J in 1 .. Expon loop + if Uval > UmaxB then + Overflow := True; + exit; + end if; + + Uval := Uval * Base; + end loop; + end; + end if; + + -- Return result, dealing with sign and overflow + + if Overflow then + Bad_Value (Str); + else + return Uval; + end if; + end Scan_Raw_Unsigned; + + ------------------- + -- Scan_Unsigned -- + ------------------- + + function Scan_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Uns + is + Start : Positive; + -- Save location of first non-blank character + + begin + Scan_Plus_Sign (Str, Ptr, Max, Start); + + if Str (Ptr.all) not in '0' .. '9' then + Ptr.all := Start; + Bad_Value (Str); + end if; + + return Scan_Raw_Unsigned (Str, Ptr, Max); + end Scan_Unsigned; + + -------------------- + -- Value_Unsigned -- + -------------------- + + function Value_Unsigned (Str : String) return Uns is + begin + -- We have to special case Str'Last = Positive'Last because the normal + -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We + -- deal with this by converting to a subtype which fixes the bounds. + + if Str'Last = Positive'Last then + declare + subtype NT is String (1 .. Str'Length); + begin + return Value_Unsigned (NT (Str)); + end; + + -- Normal case where Str'Last < Positive'Last + + else + declare + V : Uns; + P : aliased Integer := Str'First; + begin + V := Scan_Unsigned (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end; + end if; + end Value_Unsigned; + +end System.Value_U; diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads new file mode 100644 index 0000000..ad8256c --- /dev/null +++ b/gcc/ada/libgnat/s-valueu.ads @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning modular Unsigned +-- values for use in Text_IO.Modular_IO, and the Value attribute. + +generic + + type Uns is mod <>; + +package System.Value_U is + pragma Preelaborate; + + function Scan_Raw_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Uns; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- integer according to the syntax described in (RM 3.5(43)). The substring + -- scanned extends no further than Str (Max). Note: this does not scan + -- leading or trailing blanks, nor leading sign. + -- + -- There are three cases for the return: + -- + -- If a valid integer is found, then Ptr.all is updated past the last + -- character of the integer. + -- + -- If no valid integer is found, then Ptr.all points either to an initial + -- non-digit character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the pointer + -- positioned in Text_IO.Get. Note that the rules as stated in the RM would + -- seem to imply that for a case like: + -- + -- 8#12345670009# + -- + -- the pointer should be left at the first # having scanned out the longest + -- valid integer literal (8), but in fact in this case the pointer points + -- past the final # and Constraint_Error is raised. This is the behavior + -- expected for Text_IO and enforced by the ACATS tests. + -- + -- If a based literal is malformed in that a character other than a valid + -- hexadecimal digit is encountered during scanning out the digits after + -- the # (this includes the case of using the wrong terminator, : instead + -- of # or vice versa) there are two cases. If all the digits before the + -- non-digit are in range of the base, as in + -- + -- 8#100x00# + -- 8#100: + -- + -- then in this case, the "base" value before the initial # is returned as + -- the result, and the pointer points to the initial # character on return. + -- + -- If an out of range digit has been detected before the invalid character, + -- as in: + -- + -- 8#900x00# + -- 8#900: + -- + -- then the pointer is also left at the initial # character, but constraint + -- error is raised reflecting the encounter of an out of range digit. + -- + -- Finally if we have an unterminated fixed-point constant where the final + -- # or : character is missing, Constraint_Error is raised and the pointer + -- is left pointing past the last digit, as in: + -- + -- 8#22 + -- + -- This string results in a Constraint_Error with the pointer pointing + -- past the second 2. + -- + -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + -- + -- Note: this routine should not be called with Str'Last = Positive'Last. + -- If this occurs Program_Error is raised with a message noting that this + -- case is not supported. Most such cases are eliminated by the caller. + + function Scan_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Uns; + -- Same as Scan_Raw_Unsigned, except scans optional leading + -- blanks, and an optional leading plus sign. + -- + -- Note: if a minus sign is present, Constraint_Error will be raised. + -- Note: trailing blanks are not scanned. + + function Value_Unsigned + (Str : String) return Uns; + -- Used in computing X'Value (Str) where X is a modular integer type whose + -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str + -- is the string argument of the attribute. Constraint_Error is raised if + -- the string is malformed, or if the value is out of range. + +end System.Value_U; diff --git a/gcc/ada/libgnat/s-valuns.adb b/gcc/ada/libgnat/s-valuns.adb index 9f9e81e..b710a9b 100644 --- a/gcc/ada/libgnat/s-valuns.adb +++ b/gcc/ada/libgnat/s-valuns.adb @@ -29,297 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_Util; use System.Val_Util; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Val_Uns is - - ----------------------- - -- Scan_Raw_Unsigned -- - ----------------------- - - function Scan_Raw_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Unsigned - is - P : Integer; - -- Local copy of the pointer - - Uval : Unsigned; - -- Accumulated unsigned integer result - - Expon : Integer; - -- Exponent value - - Overflow : Boolean := False; - -- Set True if overflow is detected at any point - - Base_Char : Character; - -- Base character (# or :) in based case - - Base : Unsigned := 10; - -- Base value (reset in based case) - - Digit : Unsigned; - -- Digit value - - begin - -- We do not tolerate strings with Str'Last = Positive'Last - - if Str'Last = Positive'Last then - raise Program_Error with - "string upper bound is Positive'Last, not supported"; - end if; - - P := Ptr.all; - Uval := Character'Pos (Str (P)) - Character'Pos ('0'); - P := P + 1; - - -- Scan out digits of what is either the number or the base. - -- In either case, we are definitely scanning out in base 10. - - declare - Umax : constant := (Unsigned'Last - 9) / 10; - -- Max value which cannot overflow on accumulating next digit - - Umax10 : constant := Unsigned'Last / 10; - -- Numbers bigger than Umax10 overflow if multiplied by 10 - - begin - -- Loop through decimal digits - loop - exit when P > Max; - - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - -- Non-digit encountered - - if Digit > 9 then - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - exit; - end if; - - -- Accumulate result, checking for overflow - - else - if Uval <= Umax then - Uval := 10 * Uval + Digit; - - elsif Uval > Umax10 then - Overflow := True; - - else - Uval := 10 * Uval + Digit; - - if Uval < Umax10 then - Overflow := True; - end if; - end if; - - P := P + 1; - end if; - end loop; - end; - - Ptr.all := P; - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - if P < Max and then (Str (P) = '#' or else Str (P) = ':') then - Base_Char := Str (P); - P := P + 1; - Base := Uval; - Uval := 0; - - -- Check base value. Overflow is set True if we find a bad base, or - -- a digit that is out of range of the base. That way, we scan out - -- the numeral that is still syntactically correct, though illegal. - -- We use a safe base of 16 for this scan, to avoid zero divide. - - if Base not in 2 .. 16 then - Overflow := True; - Base := 16; - end if; - - -- Scan out based integer - - declare - Umax : constant Unsigned := (Unsigned'Last - Base + 1) / Base; - -- Max value which cannot overflow on accumulating next digit - - UmaxB : constant Unsigned := Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - -- Loop to scan out based integer value - - loop - -- We require a digit at this stage - - if Str (P) in '0' .. '9' then - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - elsif Str (P) in 'A' .. 'F' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('A') - 10); - - elsif Str (P) in 'a' .. 'f' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('a') - 10); - - -- If we don't have a digit, then this is not a based number - -- after all, so we use the value we scanned out as the base - -- (now in Base), and the pointer to the base character was - -- already stored in Ptr.all. - - else - Uval := Base; - exit; - end if; - - -- If digit is too large, just signal overflow and continue. - -- The idea here is to keep scanning as long as the input is - -- syntactically valid, even if we have detected overflow - - if Digit >= Base then - Overflow := True; - - -- Here we accumulate the value, checking overflow - - elsif Uval <= Umax then - Uval := Base * Uval + Digit; - - elsif Uval > UmaxB then - Overflow := True; - - else - Uval := Base * Uval + Digit; - - if Uval < UmaxB then - Overflow := True; - end if; - end if; - - -- If at end of string with no base char, not a based number - -- but we signal Constraint_Error and set the pointer past - -- the end of the field, since this is what the ACVC tests - -- seem to require, see CE3704N, line 204. - - P := P + 1; - - if P > Max then - Ptr.all := P; - Bad_Value (Str); - end if; - - -- If terminating base character, we are done with loop - - if Str (P) = Base_Char then - Ptr.all := P + 1; - exit; - - -- Deal with underscore - - elsif Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, True); - end if; - - end loop; - end; - end if; - - -- Come here with scanned unsigned value in Uval. The only remaining - -- required step is to deal with exponent if one is present. - - Expon := Scan_Exponent (Str, Ptr, Max); - - if Expon /= 0 and then Uval /= 0 then - - -- For non-zero value, scale by exponent value. No need to do this - -- efficiently, since use of exponent in integer literals is rare, - -- and in any case the exponent cannot be very large. - - declare - UmaxB : constant Unsigned := Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - for J in 1 .. Expon loop - if Uval > UmaxB then - Overflow := True; - exit; - end if; - - Uval := Uval * Base; - end loop; - end; - end if; - - -- Return result, dealing with sign and overflow - - if Overflow then - Bad_Value (Str); - else - return Uval; - end if; - end Scan_Raw_Unsigned; - - ------------------- - -- Scan_Unsigned -- - ------------------- - - function Scan_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Unsigned - is - Start : Positive; - -- Save location of first non-blank character - - begin - Scan_Plus_Sign (Str, Ptr, Max, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - Bad_Value (Str); - end if; - - return Scan_Raw_Unsigned (Str, Ptr, Max); - end Scan_Unsigned; - - -------------------- - -- Value_Unsigned -- - -------------------- - - function Value_Unsigned (Str : String) return Unsigned is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Unsigned (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Unsigned; - P : aliased Integer := Str'First; - begin - V := Scan_Unsigned (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Unsigned; - -end System.Val_Uns; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-valuns.ads b/gcc/ada/libgnat/s-valuns.ads index b965ba5..84b7a7d 100644 --- a/gcc/ada/libgnat/s-valuns.ads +++ b/gcc/ada/libgnat/s-valuns.ads @@ -33,97 +33,29 @@ -- values for use in Text_IO.Modular_IO, and the Value attribute. with System.Unsigned_Types; +with System.Value_U; package System.Val_Uns is pragma Preelaborate; + subtype Unsigned is Unsigned_Types.Unsigned; + + package Impl is new Value_U (Unsigned); + function Scan_Raw_Unsigned (Str : String; Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Unsigned; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). Note: this does not scan - -- leading or trailing blanks, nor leading sign. - -- - -- There are three cases for the return: - -- - -- If a valid integer is found, then Ptr.all is updated past the last - -- character of the integer. - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_IO.Get. Note that the rules as stated in the RM would - -- seem to imply that for a case like: - -- - -- 8#12345670009# - -- - -- the pointer should be left at the first # having scanned out the longest - -- valid integer literal (8), but in fact in this case the pointer points - -- past the final # and Constraint_Error is raised. This is the behavior - -- expected for Text_IO and enforced by the ACATS tests. - -- - -- If a based literal is malformed in that a character other than a valid - -- hexadecimal digit is encountered during scanning out the digits after - -- the # (this includes the case of using the wrong terminator, : instead - -- of # or vice versa) there are two cases. If all the digits before the - -- non-digit are in range of the base, as in - -- - -- 8#100x00# - -- 8#100: - -- - -- then in this case, the "base" value before the initial # is returned as - -- the result, and the pointer points to the initial # character on return. - -- - -- If an out of range digit has been detected before the invalid character, - -- as in: - -- - -- 8#900x00# - -- 8#900: - -- - -- then the pointer is also left at the initial # character, but constraint - -- error is raised reflecting the encounter of an out of range digit. - -- - -- Finally if we have an unterminated fixed-point constant where the final - -- # or : character is missing, Constraint_Error is raised and the pointer - -- is left pointing past the last digit, as in: - -- - -- 8#22 - -- - -- This string results in a Constraint_Error with the pointer pointing - -- past the second 2. - -- - -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - -- - -- Note: this routine should not be called with Str'Last = Positive'Last. - -- If this occurs Program_Error is raised with a message noting that this - -- case is not supported. Most such cases are eliminated by the caller. + Max : Integer) return Unsigned + renames Impl.Scan_Raw_Unsigned; function Scan_Unsigned (Str : String; Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Unsigned; - -- Same as Scan_Raw_Unsigned, except scans optional leading - -- blanks, and an optional leading plus sign. - -- - -- Note: if a minus sign is present, Constraint_Error will be raised. - -- Note: trailing blanks are not scanned. + Max : Integer) return Unsigned + renames Impl.Scan_Unsigned; function Value_Unsigned - (Str : String) return System.Unsigned_Types.Unsigned; - -- Used in computing X'Value (Str) where X is a modular integer type whose - -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str - -- is the string argument of the attribute. Constraint_Error is raised if - -- the string is malformed, or if the value is out of range. + (Str : String) return Unsigned + renames Impl.Value_Unsigned; end System.Val_Uns; diff --git a/gcc/ada/libgnat/s-widint.ads b/gcc/ada/libgnat/s-widint.ads new file mode 100644 index 0000000..6306277 --- /dev/null +++ b/gcc/ada/libgnat/s-widint.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ I N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Width attribute for signed integers up to Integer + +with System.Width_I; + +package System.Wid_Int is + + function Width_Integer is new Width_I (Integer); + pragma Pure_Function (Width_Integer); + +end System.Wid_Int; diff --git a/gcc/ada/libgnat/s-widlli.adb b/gcc/ada/libgnat/s-widlli.adb index ff62186e..65b1ab4 100644 --- a/gcc/ada/libgnat/s-widlli.adb +++ b/gcc/ada/libgnat/s-widlli.adb @@ -29,45 +29,8 @@ -- -- ------------------------------------------------------------------------------ -package body System.Wid_LLI is +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. - ----------------------------- - -- Width_Long_Long_Integer -- - ----------------------------- - - function Width_Long_Long_Integer - (Lo, Hi : Long_Long_Integer) - return Natural - is - W : Natural; - T : Long_Long_Integer; - - begin - if Lo > Hi then - return 0; - - else - -- Minimum value is 2, one for sign, one for digit - - W := 2; - - -- Get max of absolute values, but avoid bomb if we have the maximum - -- negative number (note that First + 1 has same digits as First) - - T := Long_Long_Integer'Max ( - abs (Long_Long_Integer'Max (Lo, Long_Long_Integer'First + 1)), - abs (Long_Long_Integer'Max (Hi, Long_Long_Integer'First + 1))); - - -- Increase value if more digits required - - while T >= 10 loop - T := T / 10; - W := W + 1; - end loop; - - return W; - end if; - - end Width_Long_Long_Integer; - -end System.Wid_LLI; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-widlli.ads b/gcc/ada/libgnat/s-widlli.ads index 73e95bc..a67050e 100644 --- a/gcc/ada/libgnat/s-widlli.ads +++ b/gcc/ada/libgnat/s-widlli.ads @@ -29,17 +29,13 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routine used for Width attribute for all --- non-static signed integer subtypes. Note we only have one routine, --- since this seems a fairly marginal function. +-- Width attribute for signed integers larger than Integer + +with System.Width_I; package System.Wid_LLI is - pragma Pure; - function Width_Long_Long_Integer - (Lo, Hi : Long_Long_Integer) - return Natural; - -- Compute Width attribute for non-static type derived from a signed - -- Integer type. The arguments Lo, Hi are the bounds of the type. + function Width_Long_Long_Integer is new Width_I (Long_Long_Integer); + pragma Pure_Function (Width_Long_Long_Integer); end System.Wid_LLI; diff --git a/gcc/ada/libgnat/s-widllli.ads b/gcc/ada/libgnat/s-widllli.ads new file mode 100644 index 0000000..80ab9d1 --- /dev/null +++ b/gcc/ada/libgnat/s-widllli.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Width attribute for signed integers larger than Long_Long_Integer + +with System.Width_I; + +package System.Wid_LLLI is + + function Width_Long_Long_Long_Integer is + new Width_I (Long_Long_Long_Integer); + pragma Pure_Function (Width_Long_Long_Long_Integer); + +end System.Wid_LLLI; diff --git a/gcc/ada/libgnat/s-widlllu.ads b/gcc/ada/libgnat/s-widlllu.ads new file mode 100644 index 0000000..6f84837 --- /dev/null +++ b/gcc/ada/libgnat/s-widlllu.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Width attribute for modular integers larger than Long_Long_Integer + +with System.Width_U; +with System.Unsigned_Types; + +package System.Wid_LLLU is + + subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; + + function Width_Long_Long_Long_Unsigned is + new Width_U (Long_Long_Long_Unsigned); + pragma Pure_Function (Width_Long_Long_Long_Unsigned); + +end System.Wid_LLLU; diff --git a/gcc/ada/libgnat/s-widllu.adb b/gcc/ada/libgnat/s-widllu.adb index 49ac43f..840f0a0 100644 --- a/gcc/ada/libgnat/s-widllu.adb +++ b/gcc/ada/libgnat/s-widllu.adb @@ -29,45 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Unsigned_Types; use System.Unsigned_Types; +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body System.Wid_LLU is - - ------------------------------ - -- Width_Long_Long_Unsigned -- - ------------------------------ - - function Width_Long_Long_Unsigned - (Lo, Hi : Long_Long_Unsigned) - return Natural - is - W : Natural; - T : Long_Long_Unsigned; - - begin - if Lo > Hi then - return 0; - - else - -- Minimum value is 2, one for sign, one for digit - - W := 2; - - -- Get max of absolute values, but avoid bomb if we have the maximum - -- negative number (note that First + 1 has same digits as First) - - T := Long_Long_Unsigned'Max (Lo, Hi); - - -- Increase value if more digits required - - while T >= 10 loop - T := T / 10; - W := W + 1; - end loop; - - return W; - end if; - - end Width_Long_Long_Unsigned; - -end System.Wid_LLU; +pragma No_Body; diff --git a/gcc/ada/libgnat/s-widllu.ads b/gcc/ada/libgnat/s-widllu.ads index fad814c..e77eb55 100644 --- a/gcc/ada/libgnat/s-widllu.ads +++ b/gcc/ada/libgnat/s-widllu.ads @@ -29,19 +29,16 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routine used for Width attribute for all --- non-static unsigned integer (modular integer) subtypes. Note we only --- have one routine, since this seems a fairly marginal function. +-- Width attribute for modular integers larger than Integer +with System.Width_U; with System.Unsigned_Types; package System.Wid_LLU is - pragma Pure; - function Width_Long_Long_Unsigned - (Lo, Hi : System.Unsigned_Types.Long_Long_Unsigned) - return Natural; - -- Compute Width attribute for non-static type derived from a modular - -- integer type. The arguments Lo, Hi are the bounds of the type. + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; + + function Width_Long_Long_Unsigned is new Width_U (Long_Long_Unsigned); + pragma Pure_Function (Width_Long_Long_Unsigned); end System.Wid_LLU; diff --git a/gcc/ada/libgnat/a-excpol__abort.adb b/gcc/ada/libgnat/s-widthi.adb index 511f58c..dee6068 100644 --- a/gcc/ada/libgnat/a-excpol__abort.adb +++ b/gcc/ada/libgnat/s-widthi.adb @@ -1,15 +1,14 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . E X C E P T I O N S . P O L L -- --- (version supporting asynchronous abort test) -- +-- S Y S T E M . W I D T H _ I -- -- -- --- B o d y -- +-- B o d y -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- --- GNARL is free software; you can redistribute it and/or modify it under -- +-- 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- -- @@ -25,38 +24,39 @@ -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- This version is for targets that do not support per-thread asynchronous --- signals. On such targets, we require compilation with the -gnatP switch --- that activates periodic polling. Then in the body of the polling routine --- we test for asynchronous abort. +function System.Width_I (Lo, Hi : Int) return Natural is + W : Natural; + T : Int; --- Windows and HPUX 10 currently use this file +begin + if Lo > Hi then + return 0; -pragma Warnings (Off); --- Allow withing of non-Preelaborated units in Ada 2005 mode where this --- package will be categorized as Preelaborate. See AI-362 for details. --- It is safe in the context of the run-time to violate the rules. + else + -- Minimum value is 2, one for sign, one for digit -with System.Soft_Links; + W := 2; -pragma Warnings (On); + -- Get max of absolute values, but avoid bomb if we have the maximum + -- negative number (note that First + 1 has same digits as First) -separate (Ada.Exceptions) + T := Int'Max ( + abs (Int'Max (Lo, Int'First + 1)), + abs (Int'Max (Hi, Int'First + 1))); ----------- --- Poll -- ----------- + -- Increase value if more digits required -procedure Poll is -begin - -- Test for asynchronous abort on each poll + while T >= 10 loop + T := T / 10; + W := W + 1; + end loop; - if System.Soft_Links.Check_Abort_Status.all /= 0 then - raise Standard'Abort_Signal; + return W; end if; -end Poll; + +end System.Width_I; diff --git a/gcc/ada/libgnat/s-widthi.ads b/gcc/ada/libgnat/s-widthi.ads new file mode 100644 index 0000000..570ac20 --- /dev/null +++ b/gcc/ada/libgnat/s-widthi.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D T H _ I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Compute Width attribute for non-static type derived from a signed integer +-- type. The arguments Lo, Hi are the bounds of the type. + +generic + + type Int is range <>; + +function System.Width_I (Lo, Hi : Int) return Natural; diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb new file mode 100644 index 0000000..2469e30 --- /dev/null +++ b/gcc/ada/libgnat/s-widthu.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D T H _ U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +function System.Width_U (Lo, Hi : Uns) return Natural is + W : Natural; + T : Uns; + +begin + if Lo > Hi then + return 0; + + else + -- Minimum value is 2, one for sign, one for digit + + W := 2; + + -- Get max of absolute values, but avoid bomb if we have the maximum + -- negative number (note that First + 1 has same digits as First) + + T := Uns'Max (Lo, Hi); + + -- Increase value if more digits required + + while T >= 10 loop + T := T / 10; + W := W + 1; + end loop; + + return W; + end if; + +end System.Width_U; diff --git a/gcc/ada/libgnat/s-widthu.ads b/gcc/ada/libgnat/s-widthu.ads new file mode 100644 index 0000000..2861738 --- /dev/null +++ b/gcc/ada/libgnat/s-widthu.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D T H _ U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Compute Width attribute for non-static type derived from a modular integer +-- type. The arguments Lo, Hi are the bounds of the type. + +generic + + type Uns is mod <>; + +function System.Width_U (Lo, Hi : Uns) return Natural; diff --git a/gcc/ada/libgnat/s-widuns.ads b/gcc/ada/libgnat/s-widuns.ads new file mode 100644 index 0000000..d93d3e2 --- /dev/null +++ b/gcc/ada/libgnat/s-widuns.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ U N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Width attribute for modular integers up to Integer + +with System.Width_U; +with System.Unsigned_Types; + +package System.Wid_Uns is + + subtype Unsigned is Unsigned_Types.Unsigned; + + function Width_Unsigned is new Width_U (Unsigned); + pragma Pure_Function (Width_Unsigned); + +end System.Wid_Uns; diff --git a/gcc/ada/libgnat/system-aix.ads b/gcc/ada/libgnat/system-aix.ads index 6ffa0f5..5bf603d 100644 --- a/gcc/ada/libgnat/system-aix.ads +++ b/gcc/ada/libgnat/system-aix.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-darwin-arm.ads b/gcc/ada/libgnat/system-darwin-arm.ads index 4206b04..70e02a1 100644 --- a/gcc/ada/libgnat/system-darwin-arm.ads +++ b/gcc/ada/libgnat/system-darwin-arm.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-darwin-ppc.ads b/gcc/ada/libgnat/system-darwin-ppc.ads index b543f63..4947c6c 100644 --- a/gcc/ada/libgnat/system-darwin-ppc.ads +++ b/gcc/ada/libgnat/system-darwin-ppc.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-darwin-x86.ads b/gcc/ada/libgnat/system-darwin-x86.ads index 3ceacff..828b310 100644 --- a/gcc/ada/libgnat/system-darwin-x86.ads +++ b/gcc/ada/libgnat/system-darwin-x86.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-djgpp.ads b/gcc/ada/libgnat/system-djgpp.ads index 82b496e..68fdb49 100644 --- a/gcc/ada/libgnat/system-djgpp.ads +++ b/gcc/ada/libgnat/system-djgpp.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-dragonfly-x86_64.ads b/gcc/ada/libgnat/system-dragonfly-x86_64.ads index a77ebd6..6bfb5c4 100644 --- a/gcc/ada/libgnat/system-dragonfly-x86_64.ads +++ b/gcc/ada/libgnat/system-dragonfly-x86_64.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-freebsd.ads b/gcc/ada/libgnat/system-freebsd.ads index c2afb79..d4fe60e 100644 --- a/gcc/ada/libgnat/system-freebsd.ads +++ b/gcc/ada/libgnat/system-freebsd.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-hpux-ia64.ads b/gcc/ada/libgnat/system-hpux-ia64.ads index c0d5515..f11edc6 100644 --- a/gcc/ada/libgnat/system-hpux-ia64.ads +++ b/gcc/ada/libgnat/system-hpux-ia64.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-hpux.ads b/gcc/ada/libgnat/system-hpux.ads index 7acd350..ddf6a82 100644 --- a/gcc/ada/libgnat/system-hpux.ads +++ b/gcc/ada/libgnat/system-hpux.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-alpha.ads b/gcc/ada/libgnat/system-linux-alpha.ads index 1d1411e..eebe93a 100644 --- a/gcc/ada/libgnat/system-linux-alpha.ads +++ b/gcc/ada/libgnat/system-linux-alpha.ads @@ -48,11 +48,11 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := Integer'Last; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-arm.ads b/gcc/ada/libgnat/system-linux-arm.ads index e3ee506..4d09d9e 100644 --- a/gcc/ada/libgnat/system-linux-arm.ads +++ b/gcc/ada/libgnat/system-linux-arm.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-hppa.ads b/gcc/ada/libgnat/system-linux-hppa.ads index 59aab83..6bc9541 100644 --- a/gcc/ada/libgnat/system-linux-hppa.ads +++ b/gcc/ada/libgnat/system-linux-hppa.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-ia64.ads b/gcc/ada/libgnat/system-linux-ia64.ads index bf36c77..ae9b49a 100644 --- a/gcc/ada/libgnat/system-linux-ia64.ads +++ b/gcc/ada/libgnat/system-linux-ia64.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-m68k.ads b/gcc/ada/libgnat/system-linux-m68k.ads index 571c629..3fbd781 100644 --- a/gcc/ada/libgnat/system-linux-m68k.ads +++ b/gcc/ada/libgnat/system-linux-m68k.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-mips.ads b/gcc/ada/libgnat/system-linux-mips.ads index c381496..d760db8 100644 --- a/gcc/ada/libgnat/system-linux-mips.ads +++ b/gcc/ada/libgnat/system-linux-mips.ads @@ -48,11 +48,11 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := Integer'Last; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-ppc.ads b/gcc/ada/libgnat/system-linux-ppc.ads index f3d3712..0f39370 100644 --- a/gcc/ada/libgnat/system-linux-ppc.ads +++ b/gcc/ada/libgnat/system-linux-ppc.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-riscv.ads b/gcc/ada/libgnat/system-linux-riscv.ads index 676394a..91eddf2 100644 --- a/gcc/ada/libgnat/system-linux-riscv.ads +++ b/gcc/ada/libgnat/system-linux-riscv.ads @@ -48,11 +48,11 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := Integer'Last; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-s390.ads b/gcc/ada/libgnat/system-linux-s390.ads index 916f68d..374b938 100644 --- a/gcc/ada/libgnat/system-linux-s390.ads +++ b/gcc/ada/libgnat/system-linux-s390.ads @@ -48,11 +48,11 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := Integer'Last; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-sh4.ads b/gcc/ada/libgnat/system-linux-sh4.ads index 8940ab0..cd811de 100644 --- a/gcc/ada/libgnat/system-linux-sh4.ads +++ b/gcc/ada/libgnat/system-linux-sh4.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-sparc.ads b/gcc/ada/libgnat/system-linux-sparc.ads index 5d93b76..e74214b 100644 --- a/gcc/ada/libgnat/system-linux-sparc.ads +++ b/gcc/ada/libgnat/system-linux-sparc.ads @@ -48,11 +48,11 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := Integer'Last; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-linux-x86.ads b/gcc/ada/libgnat/system-linux-x86.ads index 7e30fee..eb8b5dd 100644 --- a/gcc/ada/libgnat/system-linux-x86.ads +++ b/gcc/ada/libgnat/system-linux-x86.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-lynxos178-ppc.ads b/gcc/ada/libgnat/system-lynxos178-ppc.ads index 8882034..cf516e1 100644 --- a/gcc/ada/libgnat/system-lynxos178-ppc.ads +++ b/gcc/ada/libgnat/system-lynxos178-ppc.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-lynxos178-x86.ads b/gcc/ada/libgnat/system-lynxos178-x86.ads index 3a5f297..c151472 100644 --- a/gcc/ada/libgnat/system-lynxos178-x86.ads +++ b/gcc/ada/libgnat/system-lynxos178-x86.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-mingw.ads b/gcc/ada/libgnat/system-mingw.ads index 990c5f5..cf960da 100644 --- a/gcc/ada/libgnat/system-mingw.ads +++ b/gcc/ada/libgnat/system-mingw.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-qnx-aarch64.ads b/gcc/ada/libgnat/system-qnx-aarch64.ads index a04f7b2..37b8fd1 100644 --- a/gcc/ada/libgnat/system-qnx-aarch64.ads +++ b/gcc/ada/libgnat/system-qnx-aarch64.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-rtems.ads b/gcc/ada/libgnat/system-rtems.ads index 50a96a3..099c234 100644 --- a/gcc/ada/libgnat/system-rtems.ads +++ b/gcc/ada/libgnat/system-rtems.ads @@ -52,11 +52,11 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := Integer'Last; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; + Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; Max_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-solaris-sparc.ads b/gcc/ada/libgnat/system-solaris-sparc.ads index 244042c..0e1ce01 100644 --- a/gcc/ada/libgnat/system-solaris-sparc.ads +++ b/gcc/ada/libgnat/system-solaris-sparc.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-solaris-x86.ads b/gcc/ada/libgnat/system-solaris-x86.ads index c77c916..010ce5b 100644 --- a/gcc/ada/libgnat/system-solaris-x86.ads +++ b/gcc/ada/libgnat/system-solaris-x86.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads index 1186d8b..91806e5 100644 --- a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads index ce52c07..de13974 100644 --- a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-arm.ads b/gcc/ada/libgnat/system-vxworks-arm.ads index 4dc6be8..fac4e72 100644 --- a/gcc/ada/libgnat/system-vxworks-arm.ads +++ b/gcc/ada/libgnat/system-vxworks-arm.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads index 44b713a..cf89c2d 100644 --- a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads index a3e8f41..862f3f6 100644 --- a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads index 5a26eed..a3baecb 100644 --- a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads index df96432..fc92958 100644 --- a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads +++ b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads index 76ec6eb..383c820 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads index 8485e74..53a1f9e 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads @@ -73,10 +73,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads index 17b7f2c..aa99413 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads index a57563d..acb20c4 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads index 9d2c379..aca420e 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-ppc.ads b/gcc/ada/libgnat/system-vxworks-ppc.ads index 20b8674..99644ee 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads index 42d8769..3781020 100644 --- a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads index 8bed920..374041c 100644 --- a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads index fd20986..cff7291 100644 --- a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads index 418e52b..1867196 100644 --- a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads +++ b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks-x86.ads b/gcc/ada/libgnat/system-vxworks-x86.ads index 6059202..c82a61f 100644 --- a/gcc/ada/libgnat/system-vxworks-x86.ads +++ b/gcc/ada/libgnat/system-vxworks-x86.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads index 524f967..37bf607 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64.ads b/gcc/ada/libgnat/system-vxworks7-aarch64.ads index f1e11ba..c386500 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads index 032620d..7e2db7a 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-arm.ads b/gcc/ada/libgnat/system-vxworks7-arm.ads index 4dc6be8..fac4e72 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads index 495cfed..e03264e 100644 --- a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads index 2633156..a9b3317 100644 --- a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads index a521d25..3e963d0 100644 --- a/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads index a054aa2..93b3271 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads index 7e3e16db..e5d984b 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads index 87ac8f0..e96d303 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads index c631a85..90499f6 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads index 9f27913..49b22b6 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads @@ -50,10 +50,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads index 5bfe0b3..d7b35dd 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads index 5e66142..293ede8 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads index 47ca3e8..caf458f 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads index ac90238..a5f00ff 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads index c3e4a9c..05e69e5 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads @@ -48,10 +48,10 @@ package System is -- System-Dependent Named Numbers - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; + Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); + Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; + Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; Max_Base_Digits : constant := Long_Long_Float'Digits; diff --git a/gcc/ada/namet-sp.adb b/gcc/ada/namet-sp.adb index d3106bc..b64a1f1 100644 --- a/gcc/ada/namet-sp.adb +++ b/gcc/ada/namet-sp.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/namet-sp.ads b/gcc/ada/namet-sp.ads index f4a6fed..3d75460 100644 --- a/gcc/ada/namet-sp.ads +++ b/gcc/ada/namet-sp.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index e39e0b9..557232d 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -1094,6 +1088,15 @@ package body Namet is return Id in Name_Entries.First .. Name_Entries.Last; end Is_Valid_Name; + ------------------ + -- Last_Name_Id -- + ------------------ + + function Last_Name_Id return Name_Id is + begin + return Name_Id (Int (First_Name_Id) + Name_Entries_Count - 1); + end Last_Name_Id; + -------------------- -- Length_Of_Name -- -------------------- diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index ce7cac1..f3c7c5b4 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -437,6 +431,10 @@ package Namet is function Name_Entries_Count return Nat; -- Return current number of entries in the names table + function Last_Name_Id return Name_Id; + -- Return the last Name_Id in the table. This information is valid until + -- new names have been added. + -------------------------- -- Obsolete Subprograms -- -------------------------- diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 29eec04..02859c7 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -338,8 +332,6 @@ package body Nlists is ---------------- procedure Initialize is - E : constant List_Id := Error_List; - begin Lists.Init; Next_Node.Init; @@ -348,9 +340,9 @@ package body Nlists is -- Allocate Error_List list header Lists.Increment_Last; - Set_Parent (E, Empty); - Set_First (E, Empty); - Set_Last (E, Empty); + Set_Parent (Error_List, Empty); + Set_First (Error_List, Empty); + Set_Last (Error_List, Empty); end Initialize; ------------------ diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 67fc661..169c8e5 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -377,6 +371,7 @@ package Nlists is -- "if Present (Statements)" as opposed to "if Statements /= No_List". procedure Allocate_List_Tables (N : Node_Or_Entity_Id); + pragma Inline (Allocate_List_Tables); -- Called when nodes table is expanded to include node N. This call -- makes sure that list structures internal to Nlists are adjusted -- appropriately to reflect this increase in the size of the nodes table. diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 2d21b56..8ad6d3a 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -98,7 +92,6 @@ package body Opt is No_Component_Reordering_Config := No_Component_Reordering; Optimize_Alignment_Config := Optimize_Alignment; Persistent_BSS_Mode_Config := Persistent_BSS_Mode; - Polling_Required_Config := Polling_Required; Prefix_Exception_Messages_Config := Prefix_Exception_Messages; SPARK_Mode_Config := SPARK_Mode; SPARK_Mode_Pragma_Config := SPARK_Mode_Pragma; @@ -139,7 +132,6 @@ package body Opt is Optimize_Alignment := Save.Optimize_Alignment; Optimize_Alignment_Local := Save.Optimize_Alignment_Local; Persistent_BSS_Mode := Save.Persistent_BSS_Mode; - Polling_Required := Save.Polling_Required; Prefix_Exception_Messages := Save.Prefix_Exception_Messages; SPARK_Mode := Save.SPARK_Mode; SPARK_Mode_Pragma := Save.SPARK_Mode_Pragma; @@ -183,7 +175,6 @@ package body Opt is Optimize_Alignment => Optimize_Alignment, Optimize_Alignment_Local => Optimize_Alignment_Local, Persistent_BSS_Mode => Persistent_BSS_Mode, - Polling_Required => Polling_Required, Prefix_Exception_Messages => Prefix_Exception_Messages, SPARK_Mode => SPARK_Mode, SPARK_Mode_Pragma => SPARK_Mode_Pragma, @@ -302,7 +293,6 @@ package body Opt is Default_Pool := Default_Pool_Config; Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config; Fast_Math := Fast_Math_Config; - Polling_Required := Polling_Required_Config; end Set_Config_Switches; end Opt; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 885a6fb..7ec44dc 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -1199,6 +1193,12 @@ package Opt is -- If a pragma No_Tagged_Streams is active for the current scope, this -- points to the corresponding pragma. + Nodes_Size_In_Meg : Nat := 0; + -- GNAT + -- Amount of memory to allocate for all nodes, in units of 2**20 bytes. + -- Set by the -gnaten switch; 0 means -gnaten was not given, and a default + -- value should be used. + Normalize_Scalars : Boolean := False; -- GNAT, GNATBIND -- Set True if a pragma Normalize_Scalars applies to the current unit. @@ -1306,11 +1306,6 @@ package Opt is -- GNATBIND -- True if pessimistic elaboration order is to be chosen (-p switch set) - Polling_Required : Boolean := False; - -- GNAT - -- Set to True if polling for asynchronous abort is enabled by using - -- the -gnatP option for GNAT. - Prefix_Exception_Messages : Boolean := False; -- GNAT -- Set True to prefix exception messages with entity-name: @@ -2103,14 +2098,6 @@ package Opt is -- at the start of each compilation unit, except that it is always -- set False for predefined units. - Polling_Required_Config : Boolean; - -- GNAT - -- This is the value of the configuration switch that controls polling - -- mode. It can be set True by the command line switch -gnatP, and then - -- further modified by the use of pragma Polling in the gnat.adc file. This - -- flag is used to set the initial value for Polling_Required at the start - -- of analyzing each unit. - Prefix_Exception_Messages_Config : Boolean; -- The setting of Prefix_Exception_Messages from configuration pragmas @@ -2338,7 +2325,6 @@ private Optimize_Alignment : Character; Optimize_Alignment_Local : Boolean; Persistent_BSS_Mode : Boolean; - Polling_Required : Boolean; Prefix_Exception_Messages : Boolean; SPARK_Mode : SPARK_Mode_Type; SPARK_Mode_Pragma : Node_Id; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 3ae76cf..e935c2b 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -1072,7 +1072,7 @@ package body Osint is function File_Hash (F : File_Name_Type) return File_Hash_Num is begin - return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length); + return File_Hash_Num (Int (F) mod File_Hash_Num'Range_Length); end File_Hash; ----------------- diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index 971819b..432247f 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index 55d308a..d501602 100644 --- a/gcc/ada/output.ads +++ b/gcc/ada/output.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 0b0319d..95223a1 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -153,9 +153,8 @@ package body Ch13 is Result := True; else Scan; -- past identifier - Result := Token = Tok_Arrow or else - Token = Tok_Comma or else - Token = Tok_Semicolon; + Result := Token in + Tok_Arrow | Tok_Comma | Tok_Is | Tok_Semicolon | Tok_Right_Paren; end if; -- If earlier than Ada 2012, check for valid aspect identifier (possibly @@ -178,7 +177,7 @@ package body Ch13 is -- defaulted True value. Further checks when analyzing aspect -- specification, which may include further aspects. - elsif Token = Tok_Comma or else Token = Tok_Semicolon then + elsif Token in Tok_Comma | Tok_Semicolon then Result := True; elsif Token = Tok_Apostrophe then @@ -265,7 +264,8 @@ package body Ch13 is -- The aspect mark is not recognized if A_Id = No_Aspect then - Error_Msg_N ("& is not a valid aspect identifier", Token_Node); + Error_Msg_Warn := not Debug_Flag_2; + Error_Msg_N ("<<& is not a valid aspect identifier", Token_Node); OK := False; -- Check bad spelling @@ -274,7 +274,7 @@ package body Ch13 is if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then Error_Msg_Name_1 := Aspect_Names (J); Error_Msg_N -- CODEFIX - ("\possible misspelling of%", Token_Node); + ("\<<possible misspelling of%", Token_Node); exit; end if; end loop; @@ -957,7 +957,7 @@ package body Ch13 is -- If Decl is Error, we ignore the aspects, and issue a message elsif Decl = Error - or else not Permits_Aspect_Specifications (Decl) + or else not Permits_Aspect_Specifications (Decl) then Error_Msg ("aspect specifications not allowed here", Ptr); diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index adaa3e2..017a0a1 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -2810,7 +2810,7 @@ package body Ch3 is -- end if; Set_Subtype_Indication (CompDef_Node, Empty); - Set_Aliased_Present (CompDef_Node, False); + Set_Aliased_Present (CompDef_Node, Aliased_Present); Set_Access_Definition (CompDef_Node, P_Access_Definition (Not_Null_Present)); else diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 9815ca1..925da76 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -281,9 +281,10 @@ package body Ch4 is goto Scan_Name_Extension; end if; - -- We have scanned out a qualified simple name, check for name extension - -- Note that we know there is no dot here at this stage, so the only - -- possible cases of name extension are apostrophe and left paren. + -- We have scanned out a qualified simple name, check for name + -- extension. Note that we know there is no dot here at this stage, + -- so the only possible cases of name extension are apostrophe followed + -- by '(' or '['. if Token = Tok_Apostrophe then Save_Scan_State (Scan_State); -- at apostrophe @@ -291,7 +292,9 @@ package body Ch4 is -- Qualified expression in Ada 2012 mode (treated as a name) - if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then + if Ada_Version >= Ada_2012 + and then Token in Tok_Left_Paren | Tok_Left_Bracket + then goto Scan_Name_Extension_Apostrophe; -- If left paren not in Ada 2012, then it is not part of the name, @@ -445,7 +448,9 @@ package body Ch4 is begin -- Check for qualified expression case in Ada 2012 mode - if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then + if Ada_Version >= Ada_2012 + and then Token in Tok_Left_Paren | Tok_Left_Bracket + then Name_Node := P_Qualified_Expression (Name_Node); goto Scan_Name_Extension; @@ -1386,11 +1391,14 @@ package body Ch4 is return Maybe; end Is_Quantified_Expression; + Start_Token : constant Token_Type := Token; + -- Used to prevent mismatches (...] and [...) + -- Start of processing for P_Aggregate_Or_Paren_Expr begin Lparen_Sloc := Token_Ptr; - if Token = Tok_Left_Bracket and then Ada_Version >= Ada_2020 then + if Token = Tok_Left_Bracket then Scan; -- Special case for null aggregate in Ada 2020 @@ -1599,8 +1607,11 @@ package body Ch4 is -- identifier or OTHERS follows (the latter cases are missing -- comma cases). Also assume positional if a semicolon follows, -- which can happen if there are missing parens. + -- In Ada_2012 and Ada_2020 an iterated association can appear. - elsif Nkind (Expr_Node) = N_Iterated_Component_Association then + elsif Nkind (Expr_Node) in + N_Iterated_Component_Association | N_Iterated_Element_Association + then if No (Assoc_List) then Assoc_List := New_List (Expr_Node); else @@ -1692,23 +1703,26 @@ package body Ch4 is end if; end loop; - -- All component associations (positional and named) have been scanned + -- All component associations (positional and named) have been scanned. + -- Scan ] or ) based on Start_Token. - if Token = Tok_Right_Bracket and then Ada_Version >= Ada_2020 then - Set_Component_Associations (Aggregate_Node, Assoc_List); - Set_Is_Homogeneous_Aggregate (Aggregate_Node); - Scan; -- past right bracket + case Start_Token is + when Tok_Left_Bracket => + Set_Component_Associations (Aggregate_Node, Assoc_List); + Set_Is_Homogeneous_Aggregate (Aggregate_Node); + T_Right_Bracket; - if Token = Tok_Apostrophe then - Scan; + if Token = Tok_Apostrophe then + Scan; - if Token = Tok_Identifier then - return P_Reduction_Attribute_Reference (Aggregate_Node); + if Token = Tok_Identifier then + return P_Reduction_Attribute_Reference (Aggregate_Node); + end if; end if; - end if; - else - T_Right_Paren; - end if; + when Tok_Left_Paren => + T_Right_Paren; + when others => raise Program_Error; + end case; if Nkind (Aggregate_Node) /= N_Delta_Aggregate then Set_Expressions (Aggregate_Node, Expr_List); @@ -3406,11 +3420,38 @@ package body Ch4 is function P_Iterated_Component_Association return Node_Id is Assoc_Node : Node_Id; + Choice : Node_Id; + Filter : Node_Id := Empty; Id : Node_Id; Iter_Spec : Node_Id; Loop_Spec : Node_Id; State : Saved_Scan_State; + procedure Build_Iterated_Element_Association; + -- If the iterator includes a key expression or a filter, it is + -- an Ada_2020 Iterator_Element_Association within a container + -- aggregate. + + ---------------------------------------- + -- Build_Iterated_Element_Association -- + ---------------------------------------- + + procedure Build_Iterated_Element_Association is + begin + Choice := First (Discrete_Choices (Assoc_Node)); + Assoc_Node := + New_Node (N_Iterated_Element_Association, Prev_Token_Ptr); + Set_Loop_Parameter_Specification (Assoc_Node, Loop_Spec); + + if Present (Next (Choice)) then + Error_Msg_N ("expect loop parameter specification", Choice); + end if; + + Remove (Choice); + Set_Discrete_Subtype_Definition (Loop_Spec, Choice); + Set_Iterator_Filter (Loop_Spec, Filter); + end Build_Iterated_Element_Association; + -- Start of processing for P_Iterated_Component_Association begin @@ -3428,6 +3469,8 @@ package body Ch4 is -- In addition, if "use" is present after the specification, -- this is an Iterated_Element_Association that carries a -- key_expression, and we generate the appropriate node. + -- Finally, the Iterated_Element form is reserved for contwiner + -- aggregates, and is illegal in array aggregates. Id := P_Defining_Identifier; Assoc_Node := @@ -3438,19 +3481,34 @@ package body Ch4 is T_In; Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List); + -- The iterator may include a filter. + + if Token = Tok_When then + Scan; -- past WHEN + Filter := P_Condition; + end if; + + -- Build loop_parameter specification. + + Loop_Spec := + New_Node (N_Loop_Parameter_Specification, Prev_Token_Ptr); + Set_Defining_Identifier (Loop_Spec, Id); + if Token = Tok_Use then - -- Key-expression is present, rewrite node as an + -- Ada_2020 Key-expression is present, rewrite node as an -- iterated_Element_Awwoiation. Scan; -- past USE - Loop_Spec := - New_Node (N_Loop_Parameter_Specification, Prev_Token_Ptr); - Set_Defining_Identifier (Loop_Spec, Id); - Set_Discrete_Subtype_Definition (Loop_Spec, - First (Discrete_Choices (Assoc_Node))); - Set_Loop_Parameter_Specification (Assoc_Node, Loop_Spec); + Build_Iterated_Element_Association; Set_Key_Expression (Assoc_Node, P_Expression); + + elsif Present (Filter) then + -- A loop_Parameter_Specification also indicates an Ada_2020 + -- conwtruct, in contrast with a subtype indication used in + -- array aggregates. + + Build_Iterated_Element_Association; end if; TF_Arrow; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 1ff7950..622a508 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -1627,6 +1627,25 @@ package body Ch6 is Scan; -- past right paren exit Specification_Loop; + -- Support for aspects on formal parameters is a GNAT extension for + -- the time being. + + elsif Token = Tok_With then + if not Extensions_Allowed then + Error_Msg_SP ("aspect on formal parameter requires -gnatX"); + end if; + + P_Aspect_Specifications (Specification_Node, False); + + if Token = Tok_Right_Paren then + Scan; -- past right paren + exit Specification_Loop; + + elsif Token = Tok_Semicolon then + Save_Scan_State (Scan_State); + Scan; -- past semicolon + end if; + -- Special check for common error of using comma instead of semicolon elsif Token = Tok_Comma then diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 265f187..5783c33 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1449,7 +1449,6 @@ begin | Pragma_Partition_Elaboration_Policy | Pragma_Passive | Pragma_Persistent_BSS - | Pragma_Polling | Pragma_Post | Pragma_Post_Class | Pragma_Postcondition @@ -1497,6 +1496,7 @@ begin | Pragma_Storage_Unit | Pragma_Stream_Convert | Pragma_Subtitle + | Pragma_Subprogram_Variant | Pragma_Suppress | Pragma_Suppress_Debug_Info | Pragma_Suppress_Exception_Locations diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb index 8eb705e..65ff45a 100644 --- a/gcc/ada/par-tchk.adb +++ b/gcc/ada/par-tchk.adb @@ -402,6 +402,20 @@ package body Tchk is Check_Token (Tok_Record, AP); end T_Record; + --------------------- + -- T_Right_Bracket -- + --------------------- + + procedure T_Right_Bracket is + begin + if Token = Tok_Right_Bracket then + Scan; + else + Error_Msg_AP -- CODEFIX + ("|missing ""']'"""); + end if; + end T_Right_Bracket; + ------------------- -- T_Right_Paren -- ------------------- diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 1dee1e7..4c3a154 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -995,10 +995,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is procedure P_Aspect_Specifications (Decl : Node_Id; Semicolon : Boolean := True); - -- This procedure scans out a series of aspect spefications. If argument - -- Semicolon is True, a terminating semicolon is also scanned. If this - -- argument is False, the scan pointer is left pointing past the aspects - -- and the caller must check for a proper terminator. + -- This procedure scans out a series of aspect specifications. If + -- argument Semicolon is True, a terminating semicolon is also scanned. + -- If this argument is False, the scan pointer is left pointing past the + -- aspects and the caller must check for a proper terminator. -- -- P_Aspect_Specifications is called with the current token pointing -- to either a WITH keyword starting an aspect specification, or an @@ -1212,6 +1212,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is procedure T_Private; procedure T_Range; procedure T_Record; + procedure T_Right_Bracket; procedure T_Right_Paren; procedure T_Semicolon; procedure T_Then; diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads index 36ffb68..e9f538c 100644 --- a/gcc/ada/rident.ads +++ b/gcc/ada/rident.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 7689375..872ce01 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -589,7 +589,10 @@ package body Rtsfind is range CUDA_Driver_Types .. CUDA_Vector_Types; subtype Interfaces_Descendant is RTU_Id - range Interfaces_Packed_Decimal .. Interfaces_Packed_Decimal; + range Interfaces_C .. Interfaces_C_Strings; + + subtype Interfaces_C_Descendant is Interfaces_Descendant + range Interfaces_C_Strings .. Interfaces_C_Strings; subtype System_Descendant is RTU_Id range System_Address_Image .. System_Tasking_Stages; @@ -674,6 +677,10 @@ package body Rtsfind is elsif U_Id in Interfaces_Descendant then Name_Buffer (11) := '.'; + if U_Id in Interfaces_C_Descendant then + Name_Buffer (13) := '.'; + end if; + elsif U_Id in System_Descendant then Name_Buffer (7) := '.'; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index ff9eb0a..42578db 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -159,13 +159,15 @@ package Rtsfind is Ada_Wide_Wide_Text_IO_Integer_IO, Ada_Wide_Wide_Text_IO_Modular_IO, - -- CUDA + -- Package CUDA CUDA, -- Children of CUDA CUDA_Driver_Types, + CUDA_Internal, + CUDA_Runtime_Api, CUDA_Vector_Types, -- Interfaces @@ -174,8 +176,13 @@ package Rtsfind is -- Children of Interfaces + Interfaces_C, Interfaces_Packed_Decimal, + -- Children of Interfaces.C + + Interfaces_C_Strings, + -- Package System System, @@ -185,6 +192,7 @@ package Rtsfind is System_Address_Image, System_Address_To_Access_Conversions, System_Arith_64, + System_Arith_128, System_AST_Handling, System_Assertions, System_Atomic_Primitives, @@ -195,14 +203,16 @@ package Rtsfind is System_Boolean_Array_Operations, System_Byte_Swapping, System_Checked_Pools, + System_Compare_Array_Signed_8, System_Compare_Array_Signed_16, System_Compare_Array_Signed_32, System_Compare_Array_Signed_64, - System_Compare_Array_Signed_8, + System_Compare_Array_Signed_128, + System_Compare_Array_Unsigned_8, System_Compare_Array_Unsigned_16, System_Compare_Array_Unsigned_32, System_Compare_Array_Unsigned_64, - System_Compare_Array_Unsigned_8, + System_Compare_Array_Unsigned_128, System_Concat_2, System_Concat_3, System_Concat_4, @@ -220,10 +230,12 @@ package Rtsfind is System_Exn_Int, System_Exn_LLF, System_Exn_LLI, + System_Exn_LLLI, System_Exp_Int, - System_Exp_LInt, System_Exp_LLI, + System_Exp_LLLI, System_Exp_LLU, + System_Exp_LLLU, System_Exp_Mod, System_Exp_Uns, System_Fat_Flt, @@ -246,7 +258,9 @@ package Rtsfind is System_Img_Int, System_Img_LLD, System_Img_LLI, + System_Img_LLLI, System_Img_LLU, + System_Img_LLLU, System_Img_Name, System_Img_Real, System_Img_Uns, @@ -315,6 +329,69 @@ package Rtsfind is System_Pack_61, System_Pack_62, System_Pack_63, + System_Pack_65, + System_Pack_66, + System_Pack_67, + System_Pack_68, + System_Pack_69, + System_Pack_70, + System_Pack_71, + System_Pack_72, + System_Pack_73, + System_Pack_74, + System_Pack_75, + System_Pack_76, + System_Pack_77, + System_Pack_78, + System_Pack_79, + System_Pack_80, + System_Pack_81, + System_Pack_82, + System_Pack_83, + System_Pack_84, + System_Pack_85, + System_Pack_86, + System_Pack_87, + System_Pack_88, + System_Pack_89, + System_Pack_90, + System_Pack_91, + System_Pack_92, + System_Pack_93, + System_Pack_94, + System_Pack_95, + System_Pack_96, + System_Pack_97, + System_Pack_98, + System_Pack_99, + System_Pack_100, + System_Pack_101, + System_Pack_102, + System_Pack_103, + System_Pack_104, + System_Pack_105, + System_Pack_106, + System_Pack_107, + System_Pack_108, + System_Pack_109, + System_Pack_110, + System_Pack_111, + System_Pack_112, + System_Pack_113, + System_Pack_114, + System_Pack_115, + System_Pack_116, + System_Pack_117, + System_Pack_118, + System_Pack_119, + System_Pack_120, + System_Pack_121, + System_Pack_122, + System_Pack_123, + System_Pack_124, + System_Pack_125, + System_Pack_126, + System_Pack_127, System_Parameters, System_Partition_Interface, System_Pool_32_Global, @@ -345,7 +422,9 @@ package Rtsfind is System_Val_Int, System_Val_LLD, System_Val_LLI, + System_Val_LLLI, System_Val_LLU, + System_Val_LLLU, System_Val_Name, System_Val_Real, System_Val_Uns, @@ -356,9 +435,13 @@ package Rtsfind is System_Wid_Bool, System_Wid_Char, System_Wid_Enum, + System_Wid_Int, System_Wid_LLI, + System_Wid_LLLI, System_Wid_LLU, + System_Wid_LLLU, System_Wid_Name, + System_Wid_Uns, System_Wid_WChar, System_WWd_Char, System_WWd_Enum, @@ -625,16 +708,31 @@ package Rtsfind is RE_Stream_T, -- CUDA.Driver_Types + RE_Fatbin_Wrapper, -- CUDA.Internal + RE_Launch_Kernel, -- CUDA.Internal + RE_Pop_Call_Configuration, -- CUDA.Internal + RE_Push_Call_Configuration, -- CUDA.Internal + RE_Register_Fat_Binary, -- CUDA.Internal + RE_Register_Fat_Binary_End, -- CUDA.Internal + RE_Register_Function, -- CUDA.Internal + RE_Dim3, -- CUDA.Vector_Types RE_Integer_8, -- Interfaces RE_Integer_16, -- Interfaces RE_Integer_32, -- Interfaces RE_Integer_64, -- Interfaces + RE_Integer_128, -- Interfaces RE_Unsigned_8, -- Interfaces RE_Unsigned_16, -- Interfaces RE_Unsigned_32, -- Interfaces RE_Unsigned_64, -- Interfaces + RE_Unsigned_128, -- Interfaces + + RO_IC_Unsigned, -- Interfaces.C + + RE_Chars_Ptr, -- Interfaces.C.Strings + RE_New_Char_Array, -- Interfaces.C.Strings RE_Address, -- System RE_Any_Priority, -- System @@ -651,11 +749,15 @@ package Rtsfind is RE_Address_Image, -- System.Address_Image - RE_Add_With_Ovflo_Check, -- System.Arith_64 - RE_Double_Divide, -- System.Arith_64 - RE_Multiply_With_Ovflo_Check, -- System.Arith_64 - RE_Scaled_Divide, -- System.Arith_64 - RE_Subtract_With_Ovflo_Check, -- System.Arith_64 + RE_Add_With_Ovflo_Check64, -- System.Arith_64 + RE_Double_Divide64, -- System.Arith_64 + RE_Multiply_With_Ovflo_Check64, -- System.Arith_64 + RE_Scaled_Divide64, -- System.Arith_64 + RE_Subtract_With_Ovflo_Check64, -- System.Arith_64 + + RE_Add_With_Ovflo_Check128, -- System.Arith_128 + RE_Multiply_With_Ovflo_Check128, -- System.Arith_128 + RE_Subtract_With_Ovflo_Check128, -- System.Arith_128 RE_Create_AST_Handler, -- System.AST_Handling @@ -731,6 +833,7 @@ package Rtsfind is RE_Bswap_16, -- System.Byte_Swapping RE_Bswap_32, -- System.Byte_Swapping RE_Bswap_64, -- System.Byte_Swapping + RE_Bswap_128, -- System.Byte_Swapping RE_Checked_Pool, -- System.Checked_Pools @@ -738,15 +841,17 @@ package Rtsfind is RE_Compare_Array_S8_Unaligned, -- System.Compare_Array_Signed_8 RE_Compare_Array_S16, -- System.Compare_Array_Signed_16 - RE_Compare_Array_S32, -- System.Compare_Array_Signed_16 - RE_Compare_Array_S64, -- System.Compare_Array_Signed_16 + RE_Compare_Array_S32, -- System.Compare_Array_Signed_32 + RE_Compare_Array_S64, -- System.Compare_Array_Signed_64 + RE_Compare_Array_S128, -- System.Compare_Array_Signed_128 RE_Compare_Array_U8, -- System.Compare_Array_Unsigned_8 RE_Compare_Array_U8_Unaligned, -- System.Compare_Array_Unsigned_8 RE_Compare_Array_U16, -- System.Compare_Array_Unsigned_16 - RE_Compare_Array_U32, -- System.Compare_Array_Unsigned_16 - RE_Compare_Array_U64, -- System.Compare_Array_Unsigned_16 + RE_Compare_Array_U32, -- System.Compare_Array_Unsigned_32 + RE_Compare_Array_U64, -- System.Compare_Array_Unsigned_64 + RE_Compare_Array_U128, -- System.Compare_Array_Unsigned_128 RE_Str_Concat_2, -- System.Concat_2 RE_Str_Concat_3, -- System.Concat_3 @@ -786,12 +891,18 @@ package Rtsfind is RE_Exn_Long_Long_Integer, -- System.Exn_LLI + RE_Exn_Long_Long_Long_Integer, -- System.Exn_LLLI + RE_Exp_Integer, -- System.Exp_Int RE_Exp_Long_Long_Integer, -- System.Exp_LLI + RE_Exp_Long_Long_Long_Integer, -- System.Exp_LLLI + RE_Exp_Long_Long_Unsigned, -- System.Exp_LLU + RE_Exp_Long_Long_Long_Unsigned, -- System.Exp_LLLU + RE_Exp_Modular, -- System.Exp_Mod RE_Exp_Unsigned, -- System.Exp_Uns @@ -851,8 +962,12 @@ package Rtsfind is RE_Image_Long_Long_Integer, -- System.Img_LLI + RE_Image_Long_Long_Long_Integer, -- System.Img_LLLI + RE_Image_Long_Long_Unsigned, -- System.Img_LLU + RE_Image_Long_Long_Long_Unsigned, -- System.Img_LLLU + RE_Image_Ordinary_Fixed_Point, -- System.Img_Real RE_Image_Floating_Point, -- System.Img_Real @@ -1162,6 +1277,320 @@ package Rtsfind is RE_Get_63, -- System.Pack_63 RE_Set_63, -- System.Pack_63 + RE_Bits_65, -- System.Pack_65 + RE_Get_65, -- System.Pack_65 + RE_Set_65, -- System.Pack_65 + + RE_Bits_66, -- System.Pack_66 + RE_Get_66, -- System.Pack_66 + RE_GetU_66, -- System.Pack_66 + RE_Set_66, -- System.Pack_66 + RE_SetU_66, -- System.Pack_66 + + RE_Bits_67, -- System.Pack_67 + RE_Get_67, -- System.Pack_67 + RE_Set_67, -- System.Pack_67 + + RE_Bits_68, -- System.Pack_68 + RE_Get_68, -- System.Pack_68 + RE_GetU_68, -- System.Pack_68 + RE_Set_68, -- System.Pack_68 + RE_SetU_68, -- System.Pack_68 + + RE_Bits_69, -- System.Pack_69 + RE_Get_69, -- System.Pack_69 + RE_Set_69, -- System.Pack_69 + + RE_Bits_70, -- System.Pack_70 + RE_Get_70, -- System.Pack_70 + RE_GetU_70, -- System.Pack_70 + RE_Set_70, -- System.Pack_70 + RE_SetU_70, -- System.Pack_70 + + RE_Bits_71, -- System.Pack_71 + RE_Get_71, -- System.Pack_71 + RE_Set_71, -- System.Pack_71 + + RE_Bits_72, -- System.Pack_72 + RE_Get_72, -- System.Pack_72 + RE_GetU_72, -- System.Pack_72 + RE_Set_72, -- System.Pack_72 + RE_SetU_72, -- System.Pack_72 + + RE_Bits_73, -- System.Pack_73 + RE_Get_73, -- System.Pack_73 + RE_Set_73, -- System.Pack_73 + + RE_Bits_74, -- System.Pack_74 + RE_Get_74, -- System.Pack_74 + RE_GetU_74, -- System.Pack_74 + RE_Set_74, -- System.Pack_74 + RE_SetU_74, -- System.Pack_74 + + RE_Bits_75, -- System.Pack_75 + RE_Get_75, -- System.Pack_75 + RE_Set_75, -- System.Pack_75 + + RE_Bits_76, -- System.Pack_76 + RE_Get_76, -- System.Pack_76 + RE_GetU_76, -- System.Pack_76 + RE_Set_76, -- System.Pack_76 + RE_SetU_76, -- System.Pack_76 + + RE_Bits_77, -- System.Pack_77 + RE_Get_77, -- System.Pack_77 + RE_Set_77, -- System.Pack_77 + + RE_Bits_78, -- System.Pack_78 + RE_Get_78, -- System.Pack_78 + RE_GetU_78, -- System.Pack_78 + RE_Set_78, -- System.Pack_78 + RE_SetU_78, -- System.Pack_78 + + RE_Bits_79, -- System.Pack_79 + RE_Get_79, -- System.Pack_79 + RE_Set_79, -- System.Pack_79 + + RE_Bits_80, -- System.Pack_80 + RE_Get_80, -- System.Pack_80 + RE_GetU_80, -- System.Pack_80 + RE_Set_80, -- System.Pack_80 + RE_SetU_80, -- System.Pack_80 + + RE_Bits_81, -- System.Pack_81 + RE_Get_81, -- System.Pack_81 + RE_Set_81, -- System.Pack_81 + + RE_Bits_82, -- System.Pack_82 + RE_Get_82, -- System.Pack_82 + RE_GetU_82, -- System.Pack_82 + RE_Set_82, -- System.Pack_82 + RE_SetU_82, -- System.Pack_82 + + RE_Bits_83, -- System.Pack_83 + RE_Get_83, -- System.Pack_83 + RE_Set_83, -- System.Pack_83 + + RE_Bits_84, -- System.Pack_84 + RE_Get_84, -- System.Pack_84 + RE_GetU_84, -- System.Pack_84 + RE_Set_84, -- System.Pack_84 + RE_SetU_84, -- System.Pack_84 + + RE_Bits_85, -- System.Pack_85 + RE_Get_85, -- System.Pack_85 + RE_Set_85, -- System.Pack_85 + + RE_Bits_86, -- System.Pack_86 + RE_Get_86, -- System.Pack_86 + RE_GetU_86, -- System.Pack_86 + RE_Set_86, -- System.Pack_86 + RE_SetU_86, -- System.Pack_86 + + RE_Bits_87, -- System.Pack_87 + RE_Get_87, -- System.Pack_87 + RE_Set_87, -- System.Pack_87 + + RE_Bits_88, -- System.Pack_88 + RE_Get_88, -- System.Pack_88 + RE_GetU_88, -- System.Pack_88 + RE_Set_88, -- System.Pack_88 + RE_SetU_88, -- System.Pack_88 + + RE_Bits_89, -- System.Pack_89 + RE_Get_89, -- System.Pack_89 + RE_Set_89, -- System.Pack_89 + + RE_Bits_90, -- System.Pack_90 + RE_Get_90, -- System.Pack_90 + RE_GetU_90, -- System.Pack_90 + RE_Set_90, -- System.Pack_90 + RE_SetU_90, -- System.Pack_90 + + RE_Bits_91, -- System.Pack_91 + RE_Get_91, -- System.Pack_91 + RE_Set_91, -- System.Pack_91 + + RE_Bits_92, -- System.Pack_92 + RE_Get_92, -- System.Pack_92 + RE_GetU_92, -- System.Pack_92 + RE_Set_92, -- System.Pack_92 + RE_SetU_92, -- System.Pack_92 + + RE_Bits_93, -- System.Pack_93 + RE_Get_93, -- System.Pack_93 + RE_Set_93, -- System.Pack_93 + + RE_Bits_94, -- System.Pack_94 + RE_Get_94, -- System.Pack_94 + RE_GetU_94, -- System.Pack_94 + RE_Set_94, -- System.Pack_94 + RE_SetU_94, -- System.Pack_94 + + RE_Bits_95, -- System.Pack_95 + RE_Get_95, -- System.Pack_95 + RE_Set_95, -- System.Pack_95 + + RE_Bits_96, -- System.Pack_96 + RE_Get_96, -- System.Pack_96 + RE_GetU_96, -- System.Pack_96 + RE_Set_96, -- System.Pack_96 + RE_SetU_96, -- System.Pack_96 + + RE_Bits_97, -- System.Pack_97 + RE_Get_97, -- System.Pack_97 + RE_Set_97, -- System.Pack_97 + + RE_Bits_98, -- System.Pack_98 + RE_Get_98, -- System.Pack_98 + RE_GetU_98, -- System.Pack_98 + RE_Set_98, -- System.Pack_98 + RE_SetU_98, -- System.Pack_98 + + RE_Bits_99, -- System.Pack_99 + RE_Get_99, -- System.Pack_99 + RE_Set_99, -- System.Pack_99 + + RE_Bits_100, -- System.Pack_100 + RE_Get_100, -- System.Pack_100 + RE_GetU_100, -- System.Pack_100 + RE_Set_100, -- System.Pack_100 + RE_SetU_100, -- System.Pack_100 + + RE_Bits_101, -- System.Pack_101 + RE_Get_101, -- System.Pack_101 + RE_Set_101, -- System.Pack_101 + + RE_Bits_102, -- System.Pack_102 + RE_Get_102, -- System.Pack_102 + RE_GetU_102, -- System.Pack_102 + RE_Set_102, -- System.Pack_102 + RE_SetU_102, -- System.Pack_102 + + RE_Bits_103, -- System.Pack_103 + RE_Get_103, -- System.Pack_103 + RE_Set_103, -- System.Pack_103 + + RE_Bits_104, -- System.Pack_104 + RE_Get_104, -- System.Pack_104 + RE_GetU_104, -- System.Pack_104 + RE_Set_104, -- System.Pack_104 + RE_SetU_104, -- System.Pack_104 + + RE_Bits_105, -- System.Pack_105 + RE_Get_105, -- System.Pack_105 + RE_Set_105, -- System.Pack_105 + + RE_Bits_106, -- System.Pack_106 + RE_Get_106, -- System.Pack_106 + RE_GetU_106, -- System.Pack_106 + RE_Set_106, -- System.Pack_106 + RE_SetU_106, -- System.Pack_106 + + RE_Bits_107, -- System.Pack_107 + RE_Get_107, -- System.Pack_107 + RE_Set_107, -- System.Pack_107 + + RE_Bits_108, -- System.Pack_108 + RE_Get_108, -- System.Pack_108 + RE_GetU_108, -- System.Pack_108 + RE_Set_108, -- System.Pack_108 + RE_SetU_108, -- System.Pack_108 + + RE_Bits_109, -- System.Pack_109 + RE_Get_109, -- System.Pack_109 + RE_Set_109, -- System.Pack_109 + + RE_Bits_110, -- System.Pack_110 + RE_Get_110, -- System.Pack_110 + RE_GetU_110, -- System.Pack_110 + RE_Set_110, -- System.Pack_110 + RE_SetU_110, -- System.Pack_110 + + RE_Bits_111, -- System.Pack_111 + RE_Get_111, -- System.Pack_111 + RE_Set_111, -- System.Pack_111 + + RE_Bits_112, -- System.Pack_112 + RE_Get_112, -- System.Pack_112 + RE_GetU_112, -- System.Pack_112 + RE_Set_112, -- System.Pack_112 + RE_SetU_112, -- System.Pack_112 + + RE_Bits_113, -- System.Pack_113 + RE_Get_113, -- System.Pack_113 + RE_Set_113, -- System.Pack_113 + + RE_Bits_114, -- System.Pack_114 + RE_Get_114, -- System.Pack_114 + RE_GetU_114, -- System.Pack_114 + RE_Set_114, -- System.Pack_114 + RE_SetU_114, -- System.Pack_114 + + RE_Bits_115, -- System.Pack_115 + RE_Get_115, -- System.Pack_115 + RE_Set_115, -- System.Pack_115 + + RE_Bits_116, -- System.Pack_116 + RE_Get_116, -- System.Pack_116 + RE_GetU_116, -- System.Pack_116 + RE_Set_116, -- System.Pack_116 + RE_SetU_116, -- System.Pack_116 + + RE_Bits_117, -- System.Pack_117 + RE_Get_117, -- System.Pack_117 + RE_Set_117, -- System.Pack_117 + + RE_Bits_118, -- System.Pack_118 + RE_Get_118, -- System.Pack_118 + RE_GetU_118, -- System.Pack_118 + RE_Set_118, -- System.Pack_118 + RE_SetU_118, -- System.Pack_118 + + RE_Bits_119, -- System.Pack_119 + RE_Get_119, -- System.Pack_119 + RE_Set_119, -- System.Pack_119 + + RE_Bits_120, -- System.Pack_120 + RE_Get_120, -- System.Pack_120 + RE_GetU_120, -- System.Pack_120 + RE_Set_120, -- System.Pack_120 + RE_SetU_120, -- System.Pack_120 + + RE_Bits_121, -- System.Pack_121 + RE_Get_121, -- System.Pack_121 + RE_Set_121, -- System.Pack_121 + + RE_Bits_122, -- System.Pack_122 + RE_Get_122, -- System.Pack_122 + RE_GetU_122, -- System.Pack_122 + RE_Set_122, -- System.Pack_122 + RE_SetU_122, -- System.Pack_122 + + RE_Bits_123, -- System.Pack_123 + RE_Get_123, -- System.Pack_123 + RE_Set_123, -- System.Pack_123 + + RE_Bits_124, -- System.Pack_124 + RE_Get_124, -- System.Pack_124 + RE_GetU_124, -- System.Pack_124 + RE_Set_124, -- System.Pack_124 + RE_SetU_124, -- System.Pack_124 + + RE_Bits_125, -- System.Pack_125 + RE_Get_125, -- System.Pack_125 + RE_Set_125, -- System.Pack_125 + + RE_Bits_126, -- System.Pack_126 + RE_Get_126, -- System.Pack_126 + RE_GetU_126, -- System.Pack_126 + RE_Set_126, -- System.Pack_126 + RE_SetU_126, -- System.Pack_126 + + RE_Bits_127, -- System.Pack_127 + RE_Get_127, -- System.Pack_127 + RE_Set_127, -- System.Pack_127 + RE_Adjust_Storage_Size, -- System.Parameters RE_Default_Secondary_Stack_Size, -- System.Parameters RE_Default_Stack_Size, -- System.Parameters @@ -1197,8 +1626,10 @@ package Rtsfind is RE_Put_Image_Integer, -- System.Put_Images RE_Put_Image_Long_Long_Integer, -- System.Put_Images + RE_Put_Image_Long_Long_Long_Integer, -- System.Put_Images RE_Put_Image_Unsigned, -- System.Put_Images RE_Put_Image_Long_Long_Unsigned, -- System.Put_Images + RE_Put_Image_Long_Long_Long_Unsigned, -- System.Put_Images RE_Put_Image_Thin_Pointer, -- System.Put_Images RE_Put_Image_Fat_Pointer, -- System.Put_Images RE_Put_Image_Access_Subp, -- System.Put_Images @@ -1349,14 +1780,12 @@ package Rtsfind is RE_IS_Is2, -- System.Scalar_Values RE_IS_Is4, -- System.Scalar_Values RE_IS_Is8, -- System.Scalar_Values + RE_IS_Is16, -- System.Scalar_Values RE_IS_Iu1, -- System.Scalar_Values RE_IS_Iu2, -- System.Scalar_Values RE_IS_Iu4, -- System.Scalar_Values RE_IS_Iu8, -- System.Scalar_Values - RE_IS_Iz1, -- System.Scalar_Values - RE_IS_Iz2, -- System.Scalar_Values - RE_IS_Iz4, -- System.Scalar_Values - RE_IS_Iz8, -- System.Scalar_Values + RE_IS_Iu16, -- System.Scalar_Values RE_IS_Isf, -- System.Scalar_Values RE_IS_Ifl, -- System.Scalar_Values RE_IS_Ilf, -- System.Scalar_Values @@ -1547,8 +1976,8 @@ package Rtsfind is RE_Bits_2, -- System.Unsigned_Types RE_Bits_4, -- System.Unsigned_Types RE_Float_Unsigned, -- System.Unsigned_Types - RE_Long_Unsigned, -- System.Unsigned_Types RE_Long_Long_Unsigned, -- System.Unsigned_Types + RE_Long_Long_Long_Unsigned, -- System.Unsigned_Types RE_Packed_Byte, -- System.Unsigned_Types RE_Packed_Bytes1, -- System.Unsigned_Types RE_Packed_Bytes2, -- System.Unsigned_Types @@ -1556,8 +1985,6 @@ package Rtsfind is RE_Rev_Packed_Bytes1, -- System.Unsigned_Types RE_Rev_Packed_Bytes2, -- System.Unsigned_Types RE_Rev_Packed_Bytes4, -- System.Unsigned_Types - RE_Short_Unsigned, -- System.Unsigned_Types - RE_Short_Short_Unsigned, -- System.Unsigned_Types RE_Unsigned, -- System.Unsigned_Types RE_Value_Boolean, -- System.Val_Bool @@ -1576,8 +2003,12 @@ package Rtsfind is RE_Value_Long_Long_Integer, -- System.Val_LLI + RE_Value_Long_Long_Long_Integer, -- System.Val_LLLI + RE_Value_Long_Long_Unsigned, -- System.Val_LLU + RE_Value_Long_Long_Long_Unsigned, -- System.Val_LLLU + RE_Value_Real, -- System.Val_Real RE_Value_Unsigned, -- System.Val_Uns @@ -1618,10 +2049,18 @@ package Rtsfind is RE_Width_Enumeration_16, -- System.Wid_Enum RE_Width_Enumeration_32, -- System.Wid_Enum + RE_Width_Integer, -- System.Wid_Int + RE_Width_Long_Long_Integer, -- System.Wid_LLI + RE_Width_Long_Long_Long_Integer, -- System.Wid_LLLI + RE_Width_Long_Long_Unsigned, -- System.Wid_LLU + RE_Width_Long_Long_Long_Unsigned, -- System.Wid_LLLU + + RE_Width_Unsigned, -- System.Wid_Uns + RE_Width_Wide_Character, -- System.Wid_WChar RE_Width_Wide_Wide_Character, -- System.Wid_WChar @@ -1916,16 +2355,31 @@ package Rtsfind is RE_Stream_T => CUDA_Driver_Types, + RE_Fatbin_Wrapper => CUDA_Internal, + RE_Launch_Kernel => CUDA_Internal, + RE_Pop_Call_Configuration => CUDA_Internal, + RE_Push_Call_Configuration => CUDA_Internal, + RE_Register_Fat_Binary => CUDA_Internal, + RE_Register_Fat_Binary_End => CUDA_Internal, + RE_Register_Function => CUDA_Internal, + RE_Dim3 => CUDA_Vector_Types, RE_Integer_8 => Interfaces, RE_Integer_16 => Interfaces, RE_Integer_32 => Interfaces, RE_Integer_64 => Interfaces, + RE_Integer_128 => Interfaces, RE_Unsigned_8 => Interfaces, RE_Unsigned_16 => Interfaces, RE_Unsigned_32 => Interfaces, RE_Unsigned_64 => Interfaces, + RE_Unsigned_128 => Interfaces, + + RO_IC_Unsigned => Interfaces_C, + + RE_Chars_Ptr => Interfaces_C_Strings, + RE_New_Char_Array => Interfaces_C_Strings, RE_Address => System, RE_Any_Priority => System, @@ -1942,11 +2396,15 @@ package Rtsfind is RE_Address_Image => System_Address_Image, - RE_Add_With_Ovflo_Check => System_Arith_64, - RE_Double_Divide => System_Arith_64, - RE_Multiply_With_Ovflo_Check => System_Arith_64, - RE_Scaled_Divide => System_Arith_64, - RE_Subtract_With_Ovflo_Check => System_Arith_64, + RE_Add_With_Ovflo_Check64 => System_Arith_64, + RE_Double_Divide64 => System_Arith_64, + RE_Multiply_With_Ovflo_Check64 => System_Arith_64, + RE_Scaled_Divide64 => System_Arith_64, + RE_Subtract_With_Ovflo_Check64 => System_Arith_64, + + RE_Add_With_Ovflo_Check128 => System_Arith_128, + RE_Multiply_With_Ovflo_Check128 => System_Arith_128, + RE_Subtract_With_Ovflo_Check128 => System_Arith_128, RE_Create_AST_Handler => System_AST_Handling, @@ -2024,6 +2482,7 @@ package Rtsfind is RE_Bswap_16 => System_Byte_Swapping, RE_Bswap_32 => System_Byte_Swapping, RE_Bswap_64 => System_Byte_Swapping, + RE_Bswap_128 => System_Byte_Swapping, RE_Compare_Array_S8 => System_Compare_Array_Signed_8, RE_Compare_Array_S8_Unaligned => System_Compare_Array_Signed_8, @@ -2034,6 +2493,8 @@ package Rtsfind is RE_Compare_Array_S64 => System_Compare_Array_Signed_64, + RE_Compare_Array_S128 => System_Compare_Array_Signed_128, + RE_Compare_Array_U8 => System_Compare_Array_Unsigned_8, RE_Compare_Array_U8_Unaligned => System_Compare_Array_Unsigned_8, @@ -2043,6 +2504,8 @@ package Rtsfind is RE_Compare_Array_U64 => System_Compare_Array_Unsigned_64, + RE_Compare_Array_U128 => System_Compare_Array_Unsigned_128, + RE_Str_Concat_2 => System_Concat_2, RE_Str_Concat_3 => System_Concat_3, RE_Str_Concat_4 => System_Concat_4, @@ -2081,12 +2544,18 @@ package Rtsfind is RE_Exn_Long_Long_Integer => System_Exn_LLI, + RE_Exn_Long_Long_Long_Integer => System_Exn_LLLI, + RE_Exp_Integer => System_Exp_Int, RE_Exp_Long_Long_Integer => System_Exp_LLI, + RE_Exp_Long_Long_Long_Integer => System_Exp_LLLI, + RE_Exp_Long_Long_Unsigned => System_Exp_LLU, + RE_Exp_Long_Long_Long_Unsigned => System_Exp_LLLU, + RE_Exp_Modular => System_Exp_Mod, RE_Exp_Unsigned => System_Exp_Uns, @@ -2146,8 +2615,12 @@ package Rtsfind is RE_Image_Long_Long_Integer => System_Img_LLI, + RE_Image_Long_Long_Long_Integer => System_Img_LLLI, + RE_Image_Long_Long_Unsigned => System_Img_LLU, + RE_Image_Long_Long_Long_Unsigned => System_Img_LLLU, + RE_Image_Ordinary_Fixed_Point => System_Img_Real, RE_Image_Floating_Point => System_Img_Real, @@ -2457,6 +2930,320 @@ package Rtsfind is RE_Get_63 => System_Pack_63, RE_Set_63 => System_Pack_63, + RE_Bits_65 => System_Pack_65, + RE_Get_65 => System_Pack_65, + RE_Set_65 => System_Pack_65, + + RE_Bits_66 => System_Pack_66, + RE_Get_66 => System_Pack_66, + RE_GetU_66 => System_Pack_66, + RE_Set_66 => System_Pack_66, + RE_SetU_66 => System_Pack_66, + + RE_Bits_67 => System_Pack_67, + RE_Get_67 => System_Pack_67, + RE_Set_67 => System_Pack_67, + + RE_Bits_68 => System_Pack_68, + RE_Get_68 => System_Pack_68, + RE_GetU_68 => System_Pack_68, + RE_Set_68 => System_Pack_68, + RE_SetU_68 => System_Pack_68, + + RE_Bits_69 => System_Pack_69, + RE_Get_69 => System_Pack_69, + RE_Set_69 => System_Pack_69, + + RE_Bits_70 => System_Pack_70, + RE_Get_70 => System_Pack_70, + RE_GetU_70 => System_Pack_70, + RE_Set_70 => System_Pack_70, + RE_SetU_70 => System_Pack_70, + + RE_Bits_71 => System_Pack_71, + RE_Get_71 => System_Pack_71, + RE_Set_71 => System_Pack_71, + + RE_Bits_72 => System_Pack_72, + RE_Get_72 => System_Pack_72, + RE_GetU_72 => System_Pack_72, + RE_Set_72 => System_Pack_72, + RE_SetU_72 => System_Pack_72, + + RE_Bits_73 => System_Pack_73, + RE_Get_73 => System_Pack_73, + RE_Set_73 => System_Pack_73, + + RE_Bits_74 => System_Pack_74, + RE_Get_74 => System_Pack_74, + RE_GetU_74 => System_Pack_74, + RE_Set_74 => System_Pack_74, + RE_SetU_74 => System_Pack_74, + + RE_Bits_75 => System_Pack_75, + RE_Get_75 => System_Pack_75, + RE_Set_75 => System_Pack_75, + + RE_Bits_76 => System_Pack_76, + RE_Get_76 => System_Pack_76, + RE_GetU_76 => System_Pack_76, + RE_Set_76 => System_Pack_76, + RE_SetU_76 => System_Pack_76, + + RE_Bits_77 => System_Pack_77, + RE_Get_77 => System_Pack_77, + RE_Set_77 => System_Pack_77, + + RE_Bits_78 => System_Pack_78, + RE_Get_78 => System_Pack_78, + RE_GetU_78 => System_Pack_78, + RE_Set_78 => System_Pack_78, + RE_SetU_78 => System_Pack_78, + + RE_Bits_79 => System_Pack_79, + RE_Get_79 => System_Pack_79, + RE_Set_79 => System_Pack_79, + + RE_Bits_80 => System_Pack_80, + RE_Get_80 => System_Pack_80, + RE_GetU_80 => System_Pack_80, + RE_Set_80 => System_Pack_80, + RE_SetU_80 => System_Pack_80, + + RE_Bits_81 => System_Pack_81, + RE_Get_81 => System_Pack_81, + RE_Set_81 => System_Pack_81, + + RE_Bits_82 => System_Pack_82, + RE_Get_82 => System_Pack_82, + RE_GetU_82 => System_Pack_82, + RE_Set_82 => System_Pack_82, + RE_SetU_82 => System_Pack_82, + + RE_Bits_83 => System_Pack_83, + RE_Get_83 => System_Pack_83, + RE_Set_83 => System_Pack_83, + + RE_Bits_84 => System_Pack_84, + RE_Get_84 => System_Pack_84, + RE_GetU_84 => System_Pack_84, + RE_Set_84 => System_Pack_84, + RE_SetU_84 => System_Pack_84, + + RE_Bits_85 => System_Pack_85, + RE_Get_85 => System_Pack_85, + RE_Set_85 => System_Pack_85, + + RE_Bits_86 => System_Pack_86, + RE_Get_86 => System_Pack_86, + RE_GetU_86 => System_Pack_86, + RE_Set_86 => System_Pack_86, + RE_SetU_86 => System_Pack_86, + + RE_Bits_87 => System_Pack_87, + RE_Get_87 => System_Pack_87, + RE_Set_87 => System_Pack_87, + + RE_Bits_88 => System_Pack_88, + RE_Get_88 => System_Pack_88, + RE_GetU_88 => System_Pack_88, + RE_Set_88 => System_Pack_88, + RE_SetU_88 => System_Pack_88, + + RE_Bits_89 => System_Pack_89, + RE_Get_89 => System_Pack_89, + RE_Set_89 => System_Pack_89, + + RE_Bits_90 => System_Pack_90, + RE_Get_90 => System_Pack_90, + RE_GetU_90 => System_Pack_90, + RE_Set_90 => System_Pack_90, + RE_SetU_90 => System_Pack_90, + + RE_Bits_91 => System_Pack_91, + RE_Get_91 => System_Pack_91, + RE_Set_91 => System_Pack_91, + + RE_Bits_92 => System_Pack_92, + RE_Get_92 => System_Pack_92, + RE_GetU_92 => System_Pack_92, + RE_Set_92 => System_Pack_92, + RE_SetU_92 => System_Pack_92, + + RE_Bits_93 => System_Pack_93, + RE_Get_93 => System_Pack_93, + RE_Set_93 => System_Pack_93, + + RE_Bits_94 => System_Pack_94, + RE_Get_94 => System_Pack_94, + RE_GetU_94 => System_Pack_94, + RE_Set_94 => System_Pack_94, + RE_SetU_94 => System_Pack_94, + + RE_Bits_95 => System_Pack_95, + RE_Get_95 => System_Pack_95, + RE_Set_95 => System_Pack_95, + + RE_Bits_96 => System_Pack_96, + RE_Get_96 => System_Pack_96, + RE_GetU_96 => System_Pack_96, + RE_Set_96 => System_Pack_96, + RE_SetU_96 => System_Pack_96, + + RE_Bits_97 => System_Pack_97, + RE_Get_97 => System_Pack_97, + RE_Set_97 => System_Pack_97, + + RE_Bits_98 => System_Pack_98, + RE_Get_98 => System_Pack_98, + RE_GetU_98 => System_Pack_98, + RE_Set_98 => System_Pack_98, + RE_SetU_98 => System_Pack_98, + + RE_Bits_99 => System_Pack_99, + RE_Get_99 => System_Pack_99, + RE_Set_99 => System_Pack_99, + + RE_Bits_100 => System_Pack_100, + RE_Get_100 => System_Pack_100, + RE_GetU_100 => System_Pack_100, + RE_Set_100 => System_Pack_100, + RE_SetU_100 => System_Pack_100, + + RE_Bits_101 => System_Pack_101, + RE_Get_101 => System_Pack_101, + RE_Set_101 => System_Pack_101, + + RE_Bits_102 => System_Pack_102, + RE_Get_102 => System_Pack_102, + RE_GetU_102 => System_Pack_102, + RE_Set_102 => System_Pack_102, + RE_SetU_102 => System_Pack_102, + + RE_Bits_103 => System_Pack_103, + RE_Get_103 => System_Pack_103, + RE_Set_103 => System_Pack_103, + + RE_Bits_104 => System_Pack_104, + RE_Get_104 => System_Pack_104, + RE_GetU_104 => System_Pack_104, + RE_Set_104 => System_Pack_104, + RE_SetU_104 => System_Pack_104, + + RE_Bits_105 => System_Pack_105, + RE_Get_105 => System_Pack_105, + RE_Set_105 => System_Pack_105, + + RE_Bits_106 => System_Pack_106, + RE_Get_106 => System_Pack_106, + RE_GetU_106 => System_Pack_106, + RE_Set_106 => System_Pack_106, + RE_SetU_106 => System_Pack_106, + + RE_Bits_107 => System_Pack_107, + RE_Get_107 => System_Pack_107, + RE_Set_107 => System_Pack_107, + + RE_Bits_108 => System_Pack_108, + RE_Get_108 => System_Pack_108, + RE_GetU_108 => System_Pack_108, + RE_Set_108 => System_Pack_108, + RE_SetU_108 => System_Pack_108, + + RE_Bits_109 => System_Pack_109, + RE_Get_109 => System_Pack_109, + RE_Set_109 => System_Pack_109, + + RE_Bits_110 => System_Pack_110, + RE_Get_110 => System_Pack_110, + RE_GetU_110 => System_Pack_110, + RE_Set_110 => System_Pack_110, + RE_SetU_110 => System_Pack_110, + + RE_Bits_111 => System_Pack_111, + RE_Get_111 => System_Pack_111, + RE_Set_111 => System_Pack_111, + + RE_Bits_112 => System_Pack_112, + RE_Get_112 => System_Pack_112, + RE_GetU_112 => System_Pack_112, + RE_Set_112 => System_Pack_112, + RE_SetU_112 => System_Pack_112, + + RE_Bits_113 => System_Pack_113, + RE_Get_113 => System_Pack_113, + RE_Set_113 => System_Pack_113, + + RE_Bits_114 => System_Pack_114, + RE_Get_114 => System_Pack_114, + RE_GetU_114 => System_Pack_114, + RE_Set_114 => System_Pack_114, + RE_SetU_114 => System_Pack_114, + + RE_Bits_115 => System_Pack_115, + RE_Get_115 => System_Pack_115, + RE_Set_115 => System_Pack_115, + + RE_Bits_116 => System_Pack_116, + RE_Get_116 => System_Pack_116, + RE_GetU_116 => System_Pack_116, + RE_Set_116 => System_Pack_116, + RE_SetU_116 => System_Pack_116, + + RE_Bits_117 => System_Pack_117, + RE_Get_117 => System_Pack_117, + RE_Set_117 => System_Pack_117, + + RE_Bits_118 => System_Pack_118, + RE_Get_118 => System_Pack_118, + RE_GetU_118 => System_Pack_118, + RE_Set_118 => System_Pack_118, + RE_SetU_118 => System_Pack_118, + + RE_Bits_119 => System_Pack_119, + RE_Get_119 => System_Pack_119, + RE_Set_119 => System_Pack_119, + + RE_Bits_120 => System_Pack_120, + RE_Get_120 => System_Pack_120, + RE_GetU_120 => System_Pack_120, + RE_Set_120 => System_Pack_120, + RE_SetU_120 => System_Pack_120, + + RE_Bits_121 => System_Pack_121, + RE_Get_121 => System_Pack_121, + RE_Set_121 => System_Pack_121, + + RE_Bits_122 => System_Pack_122, + RE_Get_122 => System_Pack_122, + RE_GetU_122 => System_Pack_122, + RE_Set_122 => System_Pack_122, + RE_SetU_122 => System_Pack_122, + + RE_Bits_123 => System_Pack_123, + RE_Get_123 => System_Pack_123, + RE_Set_123 => System_Pack_123, + + RE_Bits_124 => System_Pack_124, + RE_Get_124 => System_Pack_124, + RE_GetU_124 => System_Pack_124, + RE_Set_124 => System_Pack_124, + RE_SetU_124 => System_Pack_124, + + RE_Bits_125 => System_Pack_125, + RE_Get_125 => System_Pack_125, + RE_Set_125 => System_Pack_125, + + RE_Bits_126 => System_Pack_126, + RE_Get_126 => System_Pack_126, + RE_GetU_126 => System_Pack_126, + RE_Set_126 => System_Pack_126, + RE_SetU_126 => System_Pack_126, + + RE_Bits_127 => System_Pack_127, + RE_Get_127 => System_Pack_127, + RE_Set_127 => System_Pack_127, + RE_Adjust_Storage_Size => System_Parameters, RE_Default_Secondary_Stack_Size => System_Parameters, RE_Default_Stack_Size => System_Parameters, @@ -2612,8 +3399,10 @@ package Rtsfind is RE_Put_Image_Integer => System_Put_Images, RE_Put_Image_Long_Long_Integer => System_Put_Images, + RE_Put_Image_Long_Long_Long_Integer => System_Put_Images, RE_Put_Image_Unsigned => System_Put_Images, RE_Put_Image_Long_Long_Unsigned => System_Put_Images, + RE_Put_Image_Long_Long_Long_Unsigned => System_Put_Images, RE_Put_Image_Thin_Pointer => System_Put_Images, RE_Put_Image_Fat_Pointer => System_Put_Images, RE_Put_Image_Access_Subp => System_Put_Images, @@ -2644,14 +3433,12 @@ package Rtsfind is RE_IS_Is2 => System_Scalar_Values, RE_IS_Is4 => System_Scalar_Values, RE_IS_Is8 => System_Scalar_Values, + RE_IS_Is16 => System_Scalar_Values, RE_IS_Iu1 => System_Scalar_Values, RE_IS_Iu2 => System_Scalar_Values, RE_IS_Iu4 => System_Scalar_Values, RE_IS_Iu8 => System_Scalar_Values, - RE_IS_Iz1 => System_Scalar_Values, - RE_IS_Iz2 => System_Scalar_Values, - RE_IS_Iz4 => System_Scalar_Values, - RE_IS_Iz8 => System_Scalar_Values, + RE_IS_Iu16 => System_Scalar_Values, RE_IS_Isf => System_Scalar_Values, RE_IS_Ifl => System_Scalar_Values, RE_IS_Ilf => System_Scalar_Values, @@ -2842,8 +3629,8 @@ package Rtsfind is RE_Bits_2 => System_Unsigned_Types, RE_Bits_4 => System_Unsigned_Types, RE_Float_Unsigned => System_Unsigned_Types, - RE_Long_Unsigned => System_Unsigned_Types, RE_Long_Long_Unsigned => System_Unsigned_Types, + RE_Long_Long_Long_Unsigned => System_Unsigned_Types, RE_Packed_Byte => System_Unsigned_Types, RE_Packed_Bytes1 => System_Unsigned_Types, RE_Packed_Bytes2 => System_Unsigned_Types, @@ -2851,8 +3638,6 @@ package Rtsfind is RE_Rev_Packed_Bytes1 => System_Unsigned_Types, RE_Rev_Packed_Bytes2 => System_Unsigned_Types, RE_Rev_Packed_Bytes4 => System_Unsigned_Types, - RE_Short_Unsigned => System_Unsigned_Types, - RE_Short_Short_Unsigned => System_Unsigned_Types, RE_Unsigned => System_Unsigned_Types, RE_Value_Boolean => System_Val_Bool, @@ -2871,8 +3656,12 @@ package Rtsfind is RE_Value_Long_Long_Integer => System_Val_LLI, + RE_Value_Long_Long_Long_Integer => System_Val_LLLI, + RE_Value_Long_Long_Unsigned => System_Val_LLU, + RE_Value_Long_Long_Long_Unsigned => System_Val_LLLU, + RE_Value_Real => System_Val_Real, RE_Value_Unsigned => System_Val_Uns, @@ -2914,10 +3703,18 @@ package Rtsfind is RE_Width_Enumeration_16 => System_Wid_Enum, RE_Width_Enumeration_32 => System_Wid_Enum, + RE_Width_Integer => System_Wid_Int, + RE_Width_Long_Long_Integer => System_Wid_LLI, + RE_Width_Long_Long_Long_Integer => System_Wid_LLLI, + RE_Width_Long_Long_Unsigned => System_Wid_LLU, + RE_Width_Long_Long_Long_Unsigned => System_Wid_LLLU, + + RE_Width_Unsigned => System_Wid_Uns, + RE_Width_Wide_Character => System_Wid_WChar, RE_Width_Wide_Wide_Character => System_Wid_WChar, diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 14a58aa..e3e5bc2 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -96,7 +96,7 @@ pragma Style_Checks ("M32766"); /* Define _BSD_SOURCE to get CRTSCTS */ # define _BSD_SOURCE -#endif /* defined (__linux__) */ +#endif /* defined (__linux__) || defined (__ANDROID__) */ /* Include gsocket.h before any system header so it can redefine FD_SETSIZE */ @@ -121,6 +121,8 @@ pragma Style_Checks ("M32766"); **/ # include <vxWorks.h> +#elif !defined(__MINGW32__) +#include <poll.h> #endif #include "adaint.h" @@ -1735,12 +1737,28 @@ CND(SIZEOF_sigset, "sigset") #endif #if defined(_WIN32) || defined(__vxworks) +#define SIZEOF_nfds_t sizeof (int) * 8 #define SIZEOF_socklen_t sizeof (size_t) #else +#define SIZEOF_nfds_t sizeof (nfds_t) * 8 #define SIZEOF_socklen_t sizeof (socklen_t) #endif +CND(SIZEOF_nfds_t, "Size of nfds_t"); CND(SIZEOF_socklen_t, "Size of socklen_t"); +{ +#if defined(__vxworks) +#define SIZEOF_fd_type sizeof (int) * 8 +#define SIZEOF_pollfd_events sizeof (short) * 8 +#else +const struct pollfd v_pollfd; +#define SIZEOF_fd_type sizeof (v_pollfd.fd) * 8 +#define SIZEOF_pollfd_events sizeof (v_pollfd.events) * 8 +#endif +CND(SIZEOF_fd_type, "Size of socket fd"); +CND(SIZEOF_pollfd_events, "Size of pollfd.events"); +} + #ifndef IF_NAMESIZE #ifdef IF_MAX_STRING_SIZE #define IF_NAMESIZE IF_MAX_STRING_SIZE @@ -1752,6 +1770,50 @@ CND(IF_NAMESIZE, "Max size of interface name with 0 terminator"); /* + -- Poll values + +*/ + +#if defined(__vxworks) +#ifndef POLLIN +#define POLLIN 1 +#endif + +#ifndef POLLPRI +#define POLLPRI 2 +#endif + +#ifndef POLLOUT +#define POLLOUT 4 +#endif + +#ifndef POLLERR +#define POLLERR 8 +#endif + +#ifndef POLLHUP +#define POLLHUP 16 +#endif + +#ifndef POLLNVAL +#define POLLNVAL 32 +#endif + +#elif defined(_WIN32) +#define POLLPRI 0 +/* If the POLLPRI flag is set on a socket for the Microsoft Winsock provider, + * the WSAPoll function will fail. */ +#endif + +CND(POLLIN, "There is data to read"); +CND(POLLPRI, "Urgent data to read"); +CND(POLLOUT, "Writing will not block"); +CND(POLLERR, "Error (output only)"); +CND(POLLHUP, "Hang up (output only)"); +CND(POLLNVAL, "Invalid request"); + +/* + -- Fields of struct msghdr */ @@ -1799,6 +1861,13 @@ CST(Inet_Pton_Linkname, "") #endif CST(Inet_Ntop_Linkname, "") +#if defined(_WIN32) +# define Poll_Linkname "WSAPoll" +#else +# define Poll_Linkname "poll" +#endif +CST(Poll_Linkname, "") + #endif /* HAVE_SOCKETS */ /* diff --git a/gcc/ada/scans.adb b/gcc/ada/scans.adb index 12cf27a..9ea407e 100644 --- a/gcc/ada/scans.adb +++ b/gcc/ada/scans.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index 746d337..6db276b 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb index 98ca30d..53c9013 100644 --- a/gcc/ada/scil_ll.adb +++ b/gcc/ada/scil_ll.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -122,7 +116,7 @@ package body SCIL_LL is when N_SCIL_Membership_Test => pragma Assert (Nkind (N) in N_Identifier | N_And_Then | N_Or_Else | - N_Expression_With_Actions); + N_Expression_With_Actions | N_Function_Call); null; when others => diff --git a/gcc/ada/scil_ll.ads b/gcc/ada/scil_ll.ads index 8942cc8..5770b37 100644 --- a/gcc/ada/scil_ll.ads +++ b/gcc/ada/scil_ll.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 2bac3a8..0d5cff8 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -1180,6 +1180,8 @@ package body Scng is end if; end Start_Of_Wide_Character; + Token_Contains_Uppercase : Boolean; + -- Start of processing for Scan begin @@ -1241,6 +1243,8 @@ package body Scng is Token_Ptr := Scan_Ptr; + Token_Contains_Uppercase := False; + -- Here begins the main case statement which transfers control on the -- basis of the non-blank character we have encountered. @@ -1378,14 +1382,19 @@ package body Scng is -- Left bracket when '[' => - if Source (Scan_Ptr + 1) = '"' then - goto Scan_Wide_Character; - elsif Ada_Version >= Ada_2020 then + -- [] under -gnatX is an aggregate notation and the special + -- wide character notation becomes unsupported since the two + -- are ambiguous. + + if Extensions_Allowed then Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Bracket; return; + elsif Source (Scan_Ptr + 1) = '"' then + goto Scan_Wide_Character; + else Error_Msg_S ("illegal character, replaced by ""("""); Scan_Ptr := Scan_Ptr + 1; @@ -1994,6 +2003,7 @@ package body Scng is -- Upper case letters when 'A' .. 'Z' => + Token_Contains_Uppercase := True; Name_Len := 1; Underline_Found := False; Name_Buffer (1) := @@ -2342,6 +2352,8 @@ package body Scng is Accumulate_Checksum (Source (Scan_Ptr)); elsif Source (Scan_Ptr) in 'A' .. 'Z' then + Token_Contains_Uppercase := True; + Name_Buffer (Name_Len + 1) := Character'Val (Character'Pos (Source (Scan_Ptr)) + 32); Accumulate_Checksum (Name_Buffer (Name_Len + 1)); @@ -2569,7 +2581,7 @@ package body Scng is Token := Tok_Identifier; - -- Here is where we check if it was a keyword + -- Check if it is a keyword if Is_Keyword_Name (Token_Name) then Accumulate_Token_Checksum; @@ -2596,7 +2608,7 @@ package body Scng is -- Ada 2005 (AI-340): Do not apply the style check in case of -- MOD attribute. - if Source (Token_Ptr) <= 'Z' + if Token_Contains_Uppercase and then (Prev_Token /= Tok_Apostrophe or else (Token /= Tok_Access and then diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 4429b6b..7a67a43 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1193,6 +1193,38 @@ package body Sem is end if; end Insert_Before_And_Analyze; + -------------------------------------------- + -- Insert_Before_First_Source_Declaration -- + -------------------------------------------- + + procedure Insert_Before_First_Source_Declaration + (Stmt : Node_Id; + Decls : List_Id) + is + Decl : Node_Id; + begin + -- Inspect the declarations of the related subprogram body looking for + -- the first source declaration. + + pragma Assert (Present (Decls)); + + Decl := First (Decls); + while Present (Decl) loop + if Comes_From_Source (Decl) then + Insert_Before (Decl, Stmt); + return; + end if; + + Next (Decl); + end loop; + + -- If we get there, then the subprogram body lacks any source + -- declarations. The body of _Postconditions now acts as the + -- last declaration. + + Append (Stmt, Decls); + end Insert_Before_First_Source_Declaration; + ----------------------------------- -- Insert_List_After_And_Analyze -- ----------------------------------- diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index f320b32..6003997 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -671,6 +671,13 @@ package Sem is -- Suppress argument is present, then the analysis is done with the -- specified check suppressed (can be All_Checks to suppress all checks). + procedure Insert_Before_First_Source_Declaration + (Stmt : Node_Id; + Decls : List_Id); + -- Insert node Stmt before the first source declaration of the related + -- subprogram's body. If no such declaration exists, Stmt becomes the last + -- declaration. + function External_Ref_In_Generic (E : Entity_Id) return Boolean; -- Return True if we are in the context of a generic and E is -- external (more global) to it. diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index f77230c..fdc27b3 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -48,6 +48,7 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; +with Sem_Ch5; use Sem_Ch5; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Dim; use Sem_Dim; @@ -63,6 +64,7 @@ with Stand; use Stand; with Style; use Style; with Targparm; use Targparm; with Tbuild; use Tbuild; +with Ttypes; use Ttypes; with Uintp; use Uintp; package body Sem_Aggr is @@ -789,6 +791,31 @@ package body Sem_Aggr is -- The actual aggregate subtype. This is not necessarily the same as Typ -- which is the subtype of the context in which the aggregate was found. + Others_Box : Boolean := False; + -- Set to True if N represents a simple aggregate with only + -- (others => <>), not nested as part of another aggregate. + + function Within_Aggregate (N : Node_Id) return Boolean; + -- Return True if N is part of an N_Aggregate + + ---------------------- + -- Within_Aggregate -- + ---------------------- + + function Within_Aggregate (N : Node_Id) return Boolean is + P : Node_Id := Parent (N); + begin + while Present (P) loop + if Nkind (P) = N_Aggregate then + return True; + end if; + + P := Parent (P); + end loop; + + return False; + end Within_Aggregate; + begin -- Ignore junk empty aggregate resulting from parser error @@ -809,16 +836,26 @@ package body Sem_Aggr is and then Present (Component_Associations (N)) then declare - Comp : Node_Id; + Comp : Node_Id; + First_Comp : Boolean := True; begin Comp := First (Component_Associations (N)); while Present (Comp) loop if Box_Present (Comp) then + if First_Comp + and then No (Expressions (N)) + and then Nkind (First (Choices (Comp))) = N_Others_Choice + and then not Within_Aggregate (N) + then + Others_Box := True; + end if; + Insert_Actions (N, Freeze_Entity (Typ, N)); exit; end if; + First_Comp := False; Next (Comp); end loop; end; @@ -831,7 +868,8 @@ package body Sem_Aggr is if not Support_Aggregates_On_Target and then Comes_From_Source (N) - and then (not Known_Static_Esize (Typ) or else Esize (Typ) > 64) + and then (not Known_Static_Esize (Typ) + or else Esize (Typ) > System_Max_Integer_Size) then Error_Msg_CRT ("aggregate", N); end if; @@ -861,6 +899,12 @@ package body Sem_Aggr is elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then Error_Msg_N ("null record forbidden in array aggregate", N); + elsif Present (Find_Aspect (Typ, Aspect_Aggregate)) + and then Ekind (Typ) /= E_Record_Type + and then Ada_Version >= Ada_2020 + then + Resolve_Container_Aggregate (N, Typ); + elsif Is_Record_Type (Typ) then Resolve_Record_Aggregate (N, Typ); @@ -1042,6 +1086,13 @@ package body Sem_Aggr is Set_Analyzed (N); end if; + if Warn_On_No_Value_Assigned + and then Others_Box + and then not Is_Fully_Initialized_Type (Etype (N)) + then + Error_Msg_N ("?v?aggregate not fully initialized", N); + end if; + Check_Function_Writable_Actuals (N); end Resolve_Aggregate; @@ -1590,21 +1641,16 @@ package body Sem_Aggr is Set_Etype (Ent, Standard_Void_Type); Set_Parent (Ent, Parent (N)); Push_Scope (Ent); - Id := - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (N))); -- Insert and decorate the index variable in the current scope. -- The expression has to be analyzed once the index variable is - -- directly visible. Mark the variable as referenced to prevent - -- spurious warnings, given that subsequent uses of its name in the - -- expression will reference the internal (synonym) loop variable. + -- directly visible. + Id := Defining_Identifier (N); Enter_Name (Id); Set_Etype (Id, Index_Typ); Set_Ekind (Id, E_Variable); Set_Scope (Id, Ent); - Set_Referenced (Id); -- Analyze a copy of the expression, to verify legality. We use -- a copy because the expression will be analyzed anew when the @@ -1612,6 +1658,7 @@ package body Sem_Aggr is -- as a loop with a new index variable. Expr := New_Copy_Tree (Expression (N)); + Set_Parent (Expr, N); Dummy := Resolve_Aggr_Expr (Expr, False); -- An iterated_component_association may appear in a nested @@ -1791,7 +1838,7 @@ package body Sem_Aggr is if Others_Present and then not Others_Allowed then Error_Msg_N ("OTHERS choice not allowed here", - First (Choices (First (Component_Associations (N))))); + First (Choice_List (First (Component_Associations (N))))); return Failure; end if; @@ -2007,8 +2054,13 @@ package body Sem_Aggr is return Failure; end if; + -- ??? Checks for dynamically tagged expressions below will + -- be only applied to iterated_component_association after + -- expansion; in particular, errors might not be reported when + -- -gnatc switch is used. + elsif Nkind (Assoc) = N_Iterated_Component_Association then - null; -- handled above, in a loop context. + null; -- handled above, in a loop context elsif not Resolve_Aggr_Expr (Expression (Assoc), Single_Elmt => Single_Choice) @@ -2644,11 +2696,12 @@ package body Sem_Aggr is --------------------------------- procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is - procedure Resolve_Iterated_Component_Association + procedure Resolve_Iterated_Association (Comp : Node_Id; Key_Type : Entity_Id; Elmt_Type : Entity_Id); - -- Resolve choices and expression in an iterated component association. + -- Resolve choices and expression in an iterated component association + -- or an iterated element association, which has a key_expression. -- This is similar but not identical to the handling of this construct -- in an array aggregate. -- For a named container, the type of each choice must be compatible @@ -2664,25 +2717,54 @@ package body Sem_Aggr is New_Indexed_Subp : Node_Id := Empty; Assign_Indexed_Subp : Node_Id := Empty; - -------------------------------------------- - -- Resolve_Iterated_Component_Association -- - -------------------------------------------- + ---------------------------------- + -- Resolve_Iterated_Association -- + ---------------------------------- - procedure Resolve_Iterated_Component_Association + procedure Resolve_Iterated_Association (Comp : Node_Id; Key_Type : Entity_Id; Elmt_Type : Entity_Id) is - Choice : Node_Id; - Ent : Entity_Id; - Expr : Node_Id; - Id : Entity_Id; - Iter : Node_Id; - Typ : Entity_Id := Empty; + Choice : Node_Id; + Ent : Entity_Id; + Expr : Node_Id; + Key_Expr : Node_Id; + Id : Entity_Id; + Id_Name : Name_Id; + Iter : Node_Id; + Typ : Entity_Id := Empty; begin - if Present (Iterator_Specification (Comp)) then - Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); + -- If this is an Iterated_Element_Association then either a + -- an Iterator_Specification or a Loop_Parameter specification + -- is present. In both cases a Key_Expression is present. + + if Nkind (Comp) = N_Iterated_Element_Association then + if Present (Loop_Parameter_Specification (Comp)) then + Analyze_Loop_Parameter_Specification + (Loop_Parameter_Specification (Comp)); + Id_Name := Chars (Defining_Identifier + (Loop_Parameter_Specification (Comp))); + else + Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); + Analyze (Iter); + Typ := Etype (Defining_Identifier (Iter)); + Id_Name := Chars (Defining_Identifier + (Iterator_Specification (Comp))); + end if; + + -- Key expression must have the type of the key. We analyze + -- a copy of the original expression, because it will be + -- reanalyzed and copied as needed during expansion of the + -- corresponding loop. + + Key_Expr := Key_Expression (Comp); + Analyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type); + + elsif Present (Iterator_Specification (Comp)) then + Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); + Id_Name := Chars (Defining_Identifier (Comp)); Analyze (Iter); Typ := Etype (Defining_Identifier (Iter)); @@ -2709,19 +2791,19 @@ package body Sem_Aggr is Next (Choice); end loop; + + Id_Name := Chars (Defining_Identifier (Comp)); end if; -- Create a scope in which to introduce an index, which is usually -- visible in the expression for the component, and needed for its -- analysis. + Id := Make_Defining_Identifier (Sloc (Comp), Id_Name); Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (Comp), 'L'); Set_Etype (Ent, Standard_Void_Type); Set_Parent (Ent, Parent (Comp)); Push_Scope (Ent); - Id := - Make_Defining_Identifier (Sloc (Comp), - Chars => Chars (Defining_Identifier (Comp))); -- Insert and decorate the loop variable in the current scope. -- The expression has to be analyzed once the loop variable is @@ -2750,7 +2832,8 @@ package body Sem_Aggr is Expr := New_Copy_Tree (Expression (Comp)); Preanalyze_And_Resolve (Expr, Elmt_Type); End_Scope; - end Resolve_Iterated_Component_Association; + + end Resolve_Iterated_Association; begin pragma Assert (Nkind (Asp) = N_Aggregate); @@ -2795,7 +2878,7 @@ package body Sem_Aggr is & "for unnamed container aggregate", Comp); return; else - Resolve_Iterated_Component_Association + Resolve_Iterated_Association (Comp, Empty, Elmt_Type); end if; @@ -2835,8 +2918,11 @@ package body Sem_Aggr is Analyze_And_Resolve (Expression (Comp), Elmt_Type); - elsif Nkind (Comp) = N_Iterated_Component_Association then - Resolve_Iterated_Component_Association + elsif Nkind (Comp) in + N_Iterated_Component_Association | + N_Iterated_Element_Association + then + Resolve_Iterated_Association (Comp, Key_Type, Elmt_Type); end if; @@ -2845,9 +2931,9 @@ package body Sem_Aggr is end; else - -- Indexed Aggregate. Both positional and indexed component - -- can be present. Choices must be static values or ranges - -- with static bounds. + -- Indexed Aggregate. Positional or indexed component + -- can be present, but not both. Choices must be static + -- values or ranges with static bounds. declare Container : constant Entity_Id := @@ -2868,6 +2954,12 @@ package body Sem_Aggr is end if; if Present (Component_Associations (N)) then + if Present (Expressions (N)) then + Error_Msg_N ("Container aggregate cannot be " + & "both positional and named", N); + return; + end if; + Comp := First (Expressions (N)); while Present (Comp) loop @@ -2881,8 +2973,11 @@ package body Sem_Aggr is Analyze_And_Resolve (Expression (Comp), Comp_Type); - elsif Nkind (Comp) = N_Iterated_Component_Association then - Resolve_Iterated_Component_Association + elsif Nkind (Comp) in + N_Iterated_Component_Association | + N_Iterated_Element_Association + then + Resolve_Iterated_Association (Comp, Index_Type, Comp_Type); end if; @@ -2958,15 +3053,15 @@ package body Sem_Aggr is begin Set_Etype (Ent, Standard_Void_Type); Set_Parent (Ent, Assoc); + Push_Scope (Ent); if No (Scope (Id)) then - Enter_Name (Id); Set_Etype (Id, Index_Type); Set_Ekind (Id, E_Variable); Set_Scope (Id, Ent); end if; + Enter_Name (Id); - Push_Scope (Ent); Analyze_And_Resolve (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ)); End_Scope; @@ -3965,7 +4060,7 @@ package body Sem_Aggr is -- Copy the expression so that it is resolved -- independently for each component, This is needed - -- for accessibility checks on compoents of anonymous + -- for accessibility checks on components of anonymous -- access types, even in compile_only mode. if not Inside_A_Generic then @@ -5031,16 +5126,28 @@ package body Sem_Aggr is end if; -- Ada 2012: If component is scalar with default value, use it + -- by converting it to Ctyp, so that subtype constraints are + -- checked. elsif Is_Scalar_Type (Ctyp) and then Has_Default_Aspect (Ctyp) then - Add_Association - (Component => Component, - Expr => - Default_Aspect_Value - (First_Subtype (Underlying_Type (Ctyp))), - Assoc_List => New_Assoc_List); + declare + Conv : constant Node_Id := + Convert_To + (Typ => Ctyp, + Expr => + New_Copy_Tree + (Default_Aspect_Value + (First_Subtype (Underlying_Type (Ctyp))))); + + begin + Analyze_And_Resolve (Conv, Ctyp); + Add_Association + (Component => Component, + Expr => Conv, + Assoc_List => New_Assoc_List); + end; elsif Has_Non_Null_Base_Init_Proc (Ctyp) or else not Expander_Active diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads index b0b4e14..cbbc71d 100644 --- a/gcc/ada/sem_aggr.ads +++ b/gcc/ada/sem_aggr.ads @@ -39,7 +39,7 @@ package Sem_Aggr is -- Returns True is aggregate Aggr consists of a single OTHERS choice function Is_Single_Aggregate (Aggr : Node_Id) return Boolean; - -- Returns True is aggregate Aggr consists of a single choice + -- Returns True if aggregate Aggr consists of a single choice -- WARNING: There is a matching C declaration of this subprogram in fe.h diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e3c027d..e361601 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -2748,6 +2748,16 @@ package body Sem_Attr is procedure Min_Max is begin + -- Attribute can appear as function name in a reduction. + -- Semantic checks are performed later. + + if Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) = Name_Reduce + then + Set_Etype (N, P_Base_Type); + return; + end if; + Check_E2; Check_Scalar_Type; Resolve (E1, P_Base_Type); @@ -2818,9 +2828,21 @@ package body Sem_Attr is case Uneval_Old_Setting is when 'E' => + -- ??? In the case where Ada_Version is < Ada_2020 and + -- an illegal 'Old prefix would be legal in Ada_2020, + -- we'd like to call Error_Msg_Ada_2020_Feature. + -- Identifying that case involves some work. + Error_Attr_P ("prefix of attribute % that is potentially " - & "unevaluated must statically name an entity"); + & "unevaluated must statically name an entity" + + -- further text needed for accuracy if Ada_2020 + & (if Ada_Version >= Ada_2020 + and then Attr_Id = Attribute_Old + then " or be eligible for conditional evaluation" + & " (RM 6.1.1 (27))" + else "")); when 'W' => Error_Msg_Name_1 := Aname; @@ -4755,6 +4777,13 @@ package body Sem_Attr is when Attribute_Max_Size_In_Storage_Elements => Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements; + ---------------------- + -- Max_Integer_Size -- + ---------------------- + + when Attribute_Max_Integer_Size => + Standard_Attribute (System_Max_Integer_Size); + ---------------------------------- -- Max_Size_In_Storage_Elements -- ---------------------------------- @@ -5119,10 +5148,15 @@ package body Sem_Attr is else -- Ensure that the prefix of attribute 'Old is an entity when it - -- is potentially unevaluated (6.1.1 (27/3)). + -- is potentially unevaluated (6.1.1 (27/3)). This rule is + -- relaxed in Ada2020 - this relaxation is reflected in the + -- call (below) to Eligible_For_Conditional_Evaluation. if Is_Potentially_Unevaluated (N) and then not Statically_Names_Object (P) + and then not + Old_Attr_Util.Conditional_Evaluation + .Eligible_For_Conditional_Evaluation (N) then Uneval_Old_Msg; @@ -6254,6 +6288,15 @@ package body Sem_Attr is if Comes_From_Source (N) then Check_Not_Incomplete_Type; + + -- 'Tag requires visibility on the corresponding package holding + -- the tag, so record a reference here, to avoid spurious unused + -- with_clause reported when compiling the main unit. + + if In_Extended_Main_Source_Unit (Current_Scope) then + Set_Referenced (P_Type, True); + Set_Referenced (Scope (P_Type), True); + end if; end if; -- Set appropriate type @@ -6854,7 +6897,7 @@ package body Sem_Attr is end if; -- Verify the consistency of types when the current component is - -- part of a miltiple component update. + -- part of a multiple component update. -- Comp_1 | ... | Comp_N => <value> @@ -6882,6 +6925,11 @@ package body Sem_Attr is -- Start of processing for Update begin + if Warn_On_Obsolescent_Feature then + Error_Msg_N ("?j?attribute Update is an obsolescent feature", N); + Error_Msg_N ("\?j?use a delta aggregate instead", N); + end if; + Check_E1; if not Is_Object_Reference (P) then @@ -7298,7 +7346,7 @@ package body Sem_Attr is -------------------- procedure Eval_Attribute (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); C_Type : constant Entity_Id := Etype (N); -- The type imposed by the context @@ -7875,7 +7923,7 @@ package body Sem_Attr is if Known_Static_Component_Bit_Offset (CE) then Compile_Time_Known_Attribute - (N, Component_Bit_Offset (Entity (P))); + (N, Component_Bit_Offset (CE)); else Check_Expressions; end if; @@ -10431,6 +10479,7 @@ package body Sem_Attr is | Attribute_Initialized | Attribute_Last_Bit | Attribute_Library_Level + | Attribute_Max_Integer_Size | Attribute_Maximum_Alignment | Attribute_Old | Attribute_Output @@ -11237,10 +11286,10 @@ package body Sem_Attr is -- Otherwise a check will be generated later when the return -- statement gets expanded. - and then not Is_Special_Aliased_Formal_Access - (N, Current_Scope) + and then not Is_Special_Aliased_Formal_Access (N) and then - Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) + Static_Accessibility_Level (N, Zero_On_Dynamic_Level) > + Deepest_Type_Access_Level (Btyp) then -- In an instance, this is a runtime check, but one we know -- will fail, so generate an appropriate warning. As usual, @@ -11383,8 +11432,20 @@ package body Sem_Attr is if Attr_Id /= Attribute_Unchecked_Access and then Ekind (Btyp) = E_General_Access_Type + + -- Call Accessibility_Level directly to avoid returning zero + -- on cases where the prefix is an explicitly aliased + -- parameter in a return statement, instead of using the + -- normal Static_Accessibility_Level function. + + -- Shouldn't this be handled somehow in + -- Static_Accessibility_Level ??? + + and then Nkind (Accessibility_Level (P, Dynamic_Level)) + = N_Integer_Literal and then - Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) + Intval (Accessibility_Level (P, Dynamic_Level)) + > Deepest_Type_Access_Level (Btyp) then Accessibility_Message; return; @@ -11405,7 +11466,8 @@ package body Sem_Attr is -- anonymous_access_to_protected, there are no accessibility -- checks either. Omit check entirely for Unrestricted_Access. - elsif Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) + elsif Static_Accessibility_Level (P, Zero_On_Dynamic_Level) + > Deepest_Type_Access_Level (Btyp) and then Comes_From_Source (N) and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type and then Attr_Id /= Attribute_Unrestricted_Access @@ -11453,7 +11515,7 @@ package body Sem_Attr is Set_Etype (N, Btyp); - -- Check for incorrect atomic/volatile reference (RM C.6(12)) + -- Check for incorrect atomic/volatile/VFA reference (RM C.6(12)) if Attr_Id /= Attribute_Unrestricted_Access then if Is_Atomic_Object (P) @@ -11469,6 +11531,27 @@ package body Sem_Attr is Error_Msg_F ("access to volatile object cannot yield access-to-" & "non-volatile type", P); + + elsif Is_Volatile_Full_Access_Object (P) + and then not Is_Volatile_Full_Access (Designated_Type (Typ)) + then + Error_Msg_F + ("access to full access object cannot yield access-to-" & + "non-full-access type", P); + end if; + + -- Check for nonatomic subcomponent of a full access object + -- in Ada 2020 (RM C.6 (12)). + + if Ada_Version >= Ada_2020 + and then Is_Subcomponent_Of_Full_Access_Object (P) + and then not Is_Atomic_Object (P) + then + Error_Msg_NE + ("cannot have access attribute with prefix &", N, P); + Error_Msg_N + ("\nonatomic subcomponent of full access object " + & "(RM C.6(12))", N); end if; end if; @@ -12011,6 +12094,11 @@ package body Sem_Attr is or else Present (Next_Formal (F2)) then return False; + + elsif Ekind (Op) = E_Procedure then + return Ekind (F1) = E_In_Out_Parameter + and then Covers (Typ, Etype (F1)); + else return (Ekind (Op) = E_Operator @@ -12034,13 +12122,19 @@ package body Sem_Attr is Get_Next_Interp (Index, It); end loop; + elsif Nkind (E1) = N_Attribute_Reference + and then (Attribute_Name (E1) = Name_Max + or else Attribute_Name (E1) = Name_Min) + then + Op := E1; + elsif Proper_Op (Entity (E1)) then Op := Entity (E1); Set_Etype (N, Typ); end if; if No (Op) then - Error_Msg_N ("No visible function for reduction", E1); + Error_Msg_N ("No visible subprogram for reduction", E1); end if; end; @@ -12355,11 +12449,17 @@ package body Sem_Attr is -- applies to an ancestor type. while Etype (Etyp) /= Etyp loop - Etyp := Etype (Etyp); + declare + Derived_Type : constant Entity_Id := Etyp; + begin + Etyp := Etype (Etyp); - if Has_Stream_Attribute_Definition (Etyp, Nam) then - return True; - end if; + if Has_Stream_Attribute_Definition (Etyp, Nam) then + if not Derivation_Too_Early_To_Inherit (Derived_Type, Nam) then + return True; + end if; + end if; + end; end loop; if Ada_Version < Ada_2005 then diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index b118a97..5ccb1c1 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -311,6 +311,16 @@ package Sem_Attr is -- This attribute is identical to the Object_Size attribute. It is -- provided for compatibility with the DEC attribute of this name. + ---------------------- + -- Max_Integer_Size -- + ---------------------- + + Attribute_Max_Integer_Size => True, + -- Standard'Max_Integer_Size (Standard is the only permissible prefix) + -- provides values System.Min_Int and System.Max_Int, and is intended + -- primarily for constructing these definitions in package System. This + -- is a static attribute. + ----------------------- -- Maximum_Alignment -- ----------------------- diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 4a16c12..36fd6ad 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -18,13 +18,6 @@ -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- @@ -163,6 +156,8 @@ package body Sem_Aux is return Standard_Long_Unsigned; elsif Siz = Esize (Standard_Long_Long_Integer) then return Standard_Long_Long_Unsigned; + elsif Siz = Esize (Standard_Long_Long_Long_Integer) then + return Standard_Long_Long_Long_Unsigned; else raise Program_Error; end if; @@ -364,6 +359,9 @@ package body Sem_Aux is elsif B = Base_Type (Standard_Long_Long_Integer) then return Standard_Long_Long_Integer; + elsif B = Base_Type (Standard_Long_Long_Long_Integer) then + return Standard_Long_Long_Long_Integer; + elsif Is_Generic_Type (Typ) then if Present (Parent (B)) then return Defining_Identifier (Parent (B)); @@ -706,29 +704,6 @@ package body Sem_Aux is return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents)); end Has_Rep_Item; - function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is - Item : Node_Id; - - begin - pragma Assert - (Nkind (N) in N_Aspect_Specification - | N_Attribute_Definition_Clause - | N_Enumeration_Representation_Clause - | N_Pragma - | N_Record_Representation_Clause); - - Item := First_Rep_Item (E); - while Present (Item) loop - if Item = N then - return True; - end if; - - Next_Rep_Item (Item); - end loop; - - return False; - end Has_Rep_Item; - -------------------- -- Has_Rep_Pragma -- -------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index c15c271..1d82045 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -18,13 +18,6 @@ -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- @@ -247,10 +240,6 @@ package Sem_Aux is -- 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_Item (E : Entity_Id; N : Node_Id) return Boolean; - -- Determine whether the Rep_Item chain of arbitrary entity E contains item - -- N. N must denote a valid rep item. - function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id; diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index be1e67e..7872c68 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -2121,6 +2121,7 @@ package body Sem_Cat is | N_Index_Or_Discriminant_Constraint | N_Membership_Test | N_Op + | N_Range => return True; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 76b68a1..0bad136 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -4480,10 +4480,6 @@ package body Sem_Ch10 is -- Determine whether any package in the ancestor chain starting with -- C_Unit has a limited with clause for package Pack. - function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean; - -- Check if some package installed though normal with-clauses has a - -- renaming declaration of package P. AARM 10.1.2(21/2). - ------------------------- -- Check_Body_Required -- ------------------------- @@ -4813,108 +4809,6 @@ package body Sem_Ch10 is return False; end Has_Limited_With_Clause; - ---------------------------------- - -- Is_Visible_Through_Renamings -- - ---------------------------------- - - function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is - Kind : constant Node_Kind := - Nkind (Unit (Cunit (Current_Sem_Unit))); - Aux_Unit : Node_Id; - Item : Node_Id; - Decl : Entity_Id; - - begin - -- Example of the error detected by this subprogram: - - -- package P is - -- type T is ... - -- end P; - - -- with P; - -- package Q is - -- package Ren_P renames P; - -- end Q; - - -- with Q; - -- package R is ... - - -- limited with P; -- ERROR - -- package R.C is ... - - Aux_Unit := Cunit (Current_Sem_Unit); - - loop - Item := First (Context_Items (Aux_Unit)); - while Present (Item) loop - if Nkind (Item) = N_With_Clause - and then not Limited_Present (Item) - and then Nkind (Unit (Library_Unit (Item))) = - N_Package_Declaration - then - Decl := - First (Visible_Declarations - (Specification (Unit (Library_Unit (Item))))); - while Present (Decl) loop - if Nkind (Decl) = N_Package_Renaming_Declaration - and then Entity (Name (Decl)) = P - then - -- Generate the error message only if the current unit - -- is a package declaration; in case of subprogram - -- bodies and package bodies we just return True to - -- indicate that the limited view must not be - -- installed. - - if Kind = N_Package_Declaration then - Error_Msg_N - ("simultaneous visibility of the limited and " & - "unlimited views not allowed", N); - Error_Msg_Sloc := Sloc (Item); - Error_Msg_NE - ("\\ unlimited view of & visible through the " & - "context clause #", N, P); - Error_Msg_Sloc := Sloc (Decl); - Error_Msg_NE ("\\ and the renaming #", N, P); - end if; - - return True; - end if; - - Next (Decl); - end loop; - end if; - - Next (Item); - end loop; - - -- If it is a body not acting as spec, follow pointer to the - -- corresponding spec, otherwise follow pointer to parent spec. - - if Present (Library_Unit (Aux_Unit)) - and then Nkind (Unit (Aux_Unit)) in - N_Package_Body | N_Subprogram_Body - then - if Aux_Unit = Library_Unit (Aux_Unit) then - - -- Aux_Unit is a body that acts as a spec. Clause has - -- already been flagged as illegal. - - return False; - - else - Aux_Unit := Library_Unit (Aux_Unit); - end if; - - else - Aux_Unit := Parent_Spec (Unit (Aux_Unit)); - end if; - - exit when No (Aux_Unit); - end loop; - - return False; - end Is_Visible_Through_Renamings; - -- Start of processing for Install_Limited_With_Clause begin @@ -4952,7 +4846,7 @@ package body Sem_Ch10 is -- Do not install the limited-view if the full-view is already visible -- through renaming declarations. - if Is_Visible_Through_Renamings (P) then + if Is_Visible_Through_Renamings (P, N) then return; end if; @@ -5303,8 +5197,9 @@ package body Sem_Ch10 is -- analyzing the private part of the package). if Private_Present (With_Clause) - and then Nkind (Unit (Parent (With_Clause))) = N_Package_Declaration - and then not (Private_With_OK) + and then Nkind (Unit (Parent (With_Clause))) + in N_Package_Declaration | N_Generic_Package_Declaration + and then not Private_With_OK then return; end if; @@ -5371,7 +5266,7 @@ package body Sem_Ch10 is Set_Is_Visible_Lib_Unit (Uname); -- If the unit is a wrapper package for a compilation unit that is - -- a subprogrm instance, indicate that the instance itself is a + -- a subprogram instance, indicate that the instance itself is a -- visible unit. This is necessary if the instance is inlined. if Is_Wrapper_Package (Uname) then @@ -5551,6 +5446,148 @@ package body Sem_Ch10 is end if; end Is_Ancestor_Unit; + ---------------------------------- + -- Is_Visible_Through_Renamings -- + ---------------------------------- + + function Is_Visible_Through_Renamings + (P : Entity_Id; + Error_Node : Node_Id := Empty) return Boolean + is + function Is_Limited_Withed_Unit + (Lib_Unit : Node_Id; + Pkg_Ent : Entity_Id) return Boolean; + -- Return True if Pkg_Ent is a limited-withed package of the given + -- library unit. + + ---------------------------- + -- Is_Limited_Withed_Unit -- + ---------------------------- + + function Is_Limited_Withed_Unit + (Lib_Unit : Node_Id; + Pkg_Ent : Entity_Id) return Boolean + is + Item : Node_Id := First (Context_Items (Lib_Unit)); + + begin + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then Entity (Name (Item)) = Pkg_Ent + then + return True; + end if; + + Next (Item); + end loop; + + return False; + end Is_Limited_Withed_Unit; + + -- Local variables + + Kind : constant Node_Kind := Nkind (Unit (Cunit (Current_Sem_Unit))); + Aux_Unit : Node_Id; + Item : Node_Id; + Decl : Entity_Id; + + begin + -- Example of the error detected by this subprogram: + + -- package P is + -- type T is ... + -- end P; + + -- with P; + -- package Q is + -- package Ren_P renames P; + -- end Q; + + -- with Q; + -- package R is ... + + -- limited with P; -- ERROR + -- package R.C is ... + + Aux_Unit := Cunit (Current_Sem_Unit); + + loop + Item := First (Context_Items (Aux_Unit)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then not Limited_Present (Item) + and then Nkind (Unit (Library_Unit (Item))) = + N_Package_Declaration + then + Decl := + First (Visible_Declarations + (Specification (Unit (Library_Unit (Item))))); + while Present (Decl) loop + if Nkind (Decl) = N_Package_Renaming_Declaration + and then Entity (Name (Decl)) = P + and then not Is_Limited_Withed_Unit + (Lib_Unit => Library_Unit (Item), + Pkg_Ent => Entity (Name (Decl))) + then + -- Generate the error message only if the current unit + -- is a package declaration; in case of subprogram + -- bodies and package bodies we just return True to + -- indicate that the limited view must not be + -- installed. + + if Kind = N_Package_Declaration + and then Present (Error_Node) + then + Error_Msg_N + ("simultaneous visibility of the limited and " & + "unlimited views not allowed", Error_Node); + Error_Msg_Sloc := Sloc (Item); + Error_Msg_NE + ("\\ unlimited view of & visible through the " & + "context clause #", Error_Node, P); + Error_Msg_Sloc := Sloc (Decl); + Error_Msg_NE ("\\ and the renaming #", Error_Node, P); + end if; + + return True; + end if; + + Next (Decl); + end loop; + end if; + + Next (Item); + end loop; + + -- If it is a body not acting as spec, follow pointer to the + -- corresponding spec, otherwise follow pointer to parent spec. + + if Present (Library_Unit (Aux_Unit)) + and then Nkind (Unit (Aux_Unit)) in + N_Package_Body | N_Subprogram_Body + then + if Aux_Unit = Library_Unit (Aux_Unit) then + + -- Aux_Unit is a body that acts as a spec. Clause has + -- already been flagged as illegal. + + return False; + + else + Aux_Unit := Library_Unit (Aux_Unit); + end if; + + else + Aux_Unit := Parent_Spec (Unit (Aux_Unit)); + end if; + + exit when No (Aux_Unit); + end loop; + + return False; + end Is_Visible_Through_Renamings; + ----------------------- -- Load_Needed_Body -- ----------------------- @@ -6464,7 +6501,7 @@ package body Sem_Ch10 is null; elsif Nkind (Item) = N_With_Clause - and then Context_Installed (Item) + and then Context_Installed (Item) then -- Remove items from one with'ed unit @@ -6818,12 +6855,12 @@ package body Sem_Ch10 is -- In_Regular_With_Clause -- ---------------------------- - function In_Regular_With_Clause (E : Entity_Id) return Boolean - is + function In_Regular_With_Clause (E : Entity_Id) return Boolean is Item : Node_Id; begin Item := First (Context_Items (Comp_Unit)); + while Present (Item) loop if Nkind (Item) = N_With_Clause @@ -6836,6 +6873,7 @@ package body Sem_Ch10 is then return True; end if; + Next (Item); end loop; diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads index 11f1586..b0946a4 100644 --- a/gcc/ada/sem_ch10.ads +++ b/gcc/ada/sem_ch10.ads @@ -51,6 +51,25 @@ package Sem_Ch10 is -- view, determine whether the package where T resides is imported through -- a regular with clause in the current package body. + function Is_Visible_Through_Renamings + (P : Entity_Id; + Error_Node : Node_Id := Empty) return Boolean; + -- Check if some package installed though normal with-clauses has a + -- renaming declaration of package P. AARM 10.1.2(21/2). Errors are + -- reported on Error_Node (if present); otherwise no error is reported. + + procedure Load_Needed_Body + (N : Node_Id; + OK : out Boolean; + Do_Analyze : Boolean := True); + -- Load and analyze the body of a context unit that is generic, or that + -- contains generic units or inlined units. The body becomes part of the + -- semantic dependency set of the unit that needs it. The returned result + -- in OK is True if the load is successful, and False if the requested file + -- cannot be found. If the flag Do_Analyze is false, the unit is loaded and + -- parsed only. This allows a selective analysis in some inlining cases + -- where a full analysis would lead so circularities in the back-end. + procedure Remove_Context (N : Node_Id); -- Removes the entities from the context clause of the given compilation -- unit from the visibility chains. This is done on exit from a unit as @@ -66,16 +85,4 @@ package Sem_Ch10 is -- rule imposes extra steps in order to install/remove the private_with -- clauses of an enclosing unit. - procedure Load_Needed_Body - (N : Node_Id; - OK : out Boolean; - Do_Analyze : Boolean := True); - -- Load and analyze the body of a context unit that is generic, or that - -- contains generic units or inlined units. The body becomes part of the - -- semantic dependency set of the unit that needs it. The returned result - -- in OK is True if the load is successful, and False if the requested file - -- cannot be found. If the flag Do_Analyze is false, the unit is loaded and - -- parsed only. This allows a selective analysis in some inlining cases - -- where a full analysis would lead so circularities in the back-end. - end Sem_Ch10; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index cbf27e2..06b3bec 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -270,6 +270,7 @@ package body Sem_Ch12 is -- Refined_Depends -- Refined_Global -- Refined_Post + -- Subprogram_Variant -- Test_Case -- Most package contract annotations utilize forward references to classify @@ -7512,11 +7513,60 @@ package body Sem_Ch12 is null; elsif Present (Entity (Gen_Id)) + and then No (Renamed_Entity (Entity (Gen_Id))) and then Is_Child_Unit (Entity (Gen_Id)) and then not In_Open_Scopes (Inst_Par) then Install_Parent (Inst_Par); Parent_Installed := True; + + -- Handle renaming of generic child unit + + elsif Present (Entity (Gen_Id)) + and then Present (Renamed_Entity (Entity (Gen_Id))) + and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id))) + then + declare + E : Entity_Id; + Ren_Decl : Node_Id; + + begin + -- The entity of the renamed generic child unit does not + -- have any reference to the instantiated parent. In order to + -- locate it we traverse the scope containing the renaming + -- declaration; the instance of the parent is available in + -- the prefix of the renaming declaration. For example: + + -- package A is + -- package Inst_Par is new ... + -- generic package Ren_Child renames Ins_Par.Child; + -- end; + + -- with A; + -- package B is + -- package Inst_Child is new A.Ren_Child; + -- end; + + E := First_Entity (Entity (Prefix (Gen_Id))); + while Present (E) loop + if Present (Renamed_Entity (E)) + and then + Renamed_Entity (E) = Renamed_Entity (Entity (Gen_Id)) + then + Ren_Decl := Parent (E); + Inst_Par := Entity (Prefix (Name (Ren_Decl))); + + if not In_Open_Scopes (Inst_Par) then + Install_Parent (Inst_Par); + Parent_Installed := True; + end if; + + exit; + end if; + + E := Next_Entity (E); + end loop; + end; end if; elsif In_Enclosing_Instance then @@ -8005,9 +8055,7 @@ package body Sem_Ch12 is end if; elsif No (Ent) - or else Nkind (Ent) not in N_Defining_Identifier - | N_Defining_Character_Literal - | N_Defining_Operator_Symbol + or else Nkind (Ent) not in N_Entity or else No (Scope (Ent)) or else (Scope (Ent) = Current_Instantiated_Parent.Gen_Id @@ -8174,9 +8222,7 @@ package body Sem_Ch12 is then Set_Entity (New_N, Entity (Name (Assoc))); - elsif Nkind (Assoc) in N_Defining_Identifier - | N_Defining_Character_Literal - | N_Defining_Operator_Symbol + elsif Nkind (Assoc) in N_Entity and then Expander_Active then -- Inlining case: we are copying a tree that contains @@ -8934,8 +8980,8 @@ package body Sem_Ch12 is is Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); Par : constant Entity_Id := Scope (Gen_Unit); - E_G_Id : Entity_Id; Enc_G : Entity_Id; + Enc_G_F : Node_Id; Enc_I : Node_Id; F_Node : Node_Id; @@ -9060,12 +9106,7 @@ package body Sem_Ch12 is and then Present (Freeze_Node (Par)) and then Present (Enc_I) then - if In_Same_Declarative_Part (Parent (Freeze_Node (Par)), Enc_I) - or else - (Nkind (Enc_I) = N_Package_Body - and then In_Same_Declarative_Part - (Parent (Freeze_Node (Par)), Parent (Enc_I))) - then + if In_Same_Declarative_Part (Parent (Freeze_Node (Par)), Enc_I) then -- The enclosing package may contain several instances. Rather -- than computing the earliest point at which to insert its freeze -- node, we place it at the end of the declarative part of the @@ -9082,14 +9123,6 @@ package body Sem_Ch12 is and then Enc_G /= Enc_I and then Earlier (Inst_Node, Gen_Body) then - if Nkind (Enc_G) = N_Package_Body then - E_G_Id := - Corresponding_Spec (Enc_G); - else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub); - E_G_Id := - Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G)))); - end if; - -- Freeze package that encloses instance, and place node after the -- package that encloses generic. If enclosing package is already -- frozen we have to assume it is at the proper place. This may be a @@ -9117,10 +9150,10 @@ package body Sem_Ch12 is -- Freeze enclosing subunit before instance - Ensure_Freeze_Node (E_G_Id); + Enc_G_F := Package_Freeze_Node (Enc_G); - if not Is_List_Member (Freeze_Node (E_G_Id)) then - Insert_After (Enc_G, Freeze_Node (E_G_Id)); + if not Is_List_Member (Enc_G_F) then + Insert_After (Enc_G, Enc_G_F); end if; Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); @@ -11346,8 +11379,8 @@ package body Sem_Ch12 is Note_Possible_Modification (Actual, Sure => True); - -- Check for instantiation with atomic/volatile object actual for - -- nonatomic/nonvolatile formal (RM C.6 (12)). + -- Check for instantiation with atomic/volatile/VFA object actual for + -- nonatomic/nonvolatile/nonVFA formal (RM C.6 (12)). if Is_Atomic_Object (Actual) and then not Is_Atomic (Orig_Ftyp) then Error_Msg_NE @@ -11361,20 +11394,29 @@ package body Sem_Ch12 is ("cannot instantiate nonvolatile formal & of mode in out", Actual, Gen_Obj); Error_Msg_N ("\with volatile object actual (RM C.6(12))", Actual); + + elsif Is_Volatile_Full_Access_Object (Actual) + and then not Is_Volatile_Full_Access (Orig_Ftyp) + then + Error_Msg_NE + ("cannot instantiate nonfull access formal & of mode in out", + Actual, Gen_Obj); + Error_Msg_N + ("\with full access object actual (RM C.6(12))", Actual); end if; - -- Check for instantiation on nonatomic subcomponent of an atomic - -- object in Ada 2020 (RM C.6 (13)). + -- Check for instantiation on nonatomic subcomponent of a full access + -- object in Ada 2020 (RM C.6 (12)). if Ada_Version >= Ada_2020 - and then Is_Subcomponent_Of_Atomic_Object (Actual) + and then Is_Subcomponent_Of_Full_Access_Object (Actual) and then not Is_Atomic_Object (Actual) then Error_Msg_NE ("cannot instantiate formal & of mode in out with actual", Actual, Gen_Obj); Error_Msg_N - ("\nonatomic subcomponent of atomic object (RM C.6(13))", + ("\nonatomic subcomponent of full access object (RM C.6(12))", Actual); end if; @@ -11637,6 +11679,8 @@ package body Sem_Ch12 is Act_Decl : constant Node_Id := Body_Info.Act_Decl; Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl); Act_Spec : constant Node_Id := Specification (Act_Decl); + Ctx_Parents : Elist_Id := No_Elist; + Ctx_Top : Int := 0; Inst_Node : constant Node_Id := Body_Info.Inst_Node; Gen_Id : constant Node_Id := Name (Inst_Node); Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); @@ -11648,6 +11692,17 @@ package body Sem_Ch12 is -- appear uninitialized. This is suspicious, unless the actual is a -- fully initialized type. + procedure Install_Parents_Of_Generic_Context + (Inst_Scope : Entity_Id; + Ctx_Parents : out Elist_Id); + -- Inst_Scope is the scope where the instance appears within; when it + -- appears within a generic child package G, this routine collects and + -- installs the enclosing packages of G in the scopes stack; installed + -- packages are returned in Ctx_Parents. + + procedure Remove_Parents_Of_Generic_Context (Ctx_Parents : Elist_Id); + -- Reverse effect after instantiation is complete + ----------------------------- -- Check_Initialized_Types -- ----------------------------- @@ -11711,6 +11766,60 @@ package body Sem_Ch12 is end loop; end Check_Initialized_Types; + ---------------------------------------- + -- Install_Parents_Of_Generic_Context -- + ---------------------------------------- + + procedure Install_Parents_Of_Generic_Context + (Inst_Scope : Entity_Id; + Ctx_Parents : out Elist_Id) + is + Elmt : Elmt_Id; + S : Entity_Id; + + begin + Ctx_Parents := New_Elmt_List; + + -- Collect context parents (ie. parents where the instantiation + -- appears within). + + S := Inst_Scope; + while S /= Standard_Standard loop + Prepend_Elmt (S, Ctx_Parents); + S := Scope (S); + end loop; + + -- Install enclosing parents + + Elmt := First_Elmt (Ctx_Parents); + while Present (Elmt) loop + Push_Scope (Node (Elmt)); + Set_Is_Immediately_Visible (Node (Elmt)); + Next_Elmt (Elmt); + end loop; + end Install_Parents_Of_Generic_Context; + + --------------------------------------- + -- Remove_Parents_Of_Generic_Context -- + --------------------------------------- + + procedure Remove_Parents_Of_Generic_Context (Ctx_Parents : Elist_Id) is + Elmt : Elmt_Id; + + begin + -- Traverse Ctx_Parents in LIFO order to check the removed scopes + + Elmt := Last_Elmt (Ctx_Parents); + while Present (Elmt) loop + pragma Assert (Current_Scope = Node (Elmt)); + Set_Is_Immediately_Visible (Current_Scope, False); + Pop_Scope; + + Remove_Last_Elmt (Ctx_Parents); + Elmt := Last_Elmt (Ctx_Parents); + end loop; + end Remove_Parents_Of_Generic_Context; + -- Local variables -- The following constants capture the context prior to instantiating @@ -11738,6 +11847,11 @@ package body Sem_Ch12 is Par_Installed : Boolean := False; Par_Vis : Boolean := False; + Scope_Check_Id : Entity_Id; + Scope_Check_Last : Nat; + -- Value of Current_Scope before calls to Install_Parents; used to check + -- that scopes are correctly removed after instantiation. + Vis_Prims_List : Elist_Id := No_Elist; -- List of primitives made temporarily visible in the instantiation -- to match the visibility of the formal type. @@ -11951,6 +12065,34 @@ package body Sem_Ch12 is end loop; end; + Scope_Check_Id := Current_Scope; + Scope_Check_Last := Scope_Stack.Last; + + -- If the instantiation appears within a generic child some actual + -- parameter may be the current instance of the enclosing generic + -- parent. + + declare + Inst_Scope : constant Entity_Id := Scope (Act_Decl_Id); + + begin + if Is_Child_Unit (Inst_Scope) + and then Ekind (Inst_Scope) = E_Generic_Package + and then Present (Generic_Associations (Inst_Node)) + then + Install_Parents_Of_Generic_Context (Inst_Scope, Ctx_Parents); + + -- Hide them from visibility; required to avoid conflicts + -- installing the parent instance. + + if Present (Ctx_Parents) then + Push_Scope (Standard_Standard); + Ctx_Top := Scope_Stack.Last; + Scope_Stack.Table (Ctx_Top).Is_Active_Stack_Base := True; + end if; + end if; + end; + -- If it is a child unit, make the parent instance (which is an -- instance of the parent of the generic) visible. The parent -- instance is the prefix of the name of the generic unit. @@ -11986,7 +12128,18 @@ package body Sem_Ch12 is Build_Instance_Compilation_Unit_Nodes (Inst_Node, Act_Body, Act_Decl); - Analyze (Inst_Node); + + -- If the instantiation appears within a generic child package + -- enable visibility of current instance of enclosing generic + -- parents. + + if Present (Ctx_Parents) then + Scope_Stack.Table (Ctx_Top).Is_Active_Stack_Base := False; + Analyze (Inst_Node); + Scope_Stack.Table (Ctx_Top).Is_Active_Stack_Base := True; + else + Analyze (Inst_Node); + end if; if Parent (Inst_Node) = Cunit (Main_Unit) then @@ -12010,14 +12163,22 @@ package body Sem_Ch12 is -- indicate that the body instance is to be delayed. Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl); - Analyze (Act_Body); + + -- If the instantiation appears within a generic child package + -- enable visibility of current instance of enclosing generic + -- parents. + + if Present (Ctx_Parents) then + Scope_Stack.Table (Ctx_Top).Is_Active_Stack_Base := False; + Analyze (Act_Body); + Scope_Stack.Table (Ctx_Top).Is_Active_Stack_Base := True; + else + Analyze (Act_Body); + end if; end if; Inherit_Context (Gen_Body, Inst_Node); - -- Remove the parent instances if they have been placed on the scope - -- stack to compile the body. - if Par_Installed then Remove_Parent (In_Body => True); @@ -12026,6 +12187,20 @@ package body Sem_Ch12 is Set_Is_Immediately_Visible (Par_Ent, Par_Vis); end if; + -- Remove the parent instances if they have been placed on the scope + -- stack to compile the body. + + if Present (Ctx_Parents) then + pragma Assert (Scope_Stack.Last = Ctx_Top + and then Current_Scope = Standard_Standard); + Pop_Scope; + + Remove_Parents_Of_Generic_Context (Ctx_Parents); + end if; + + pragma Assert (Current_Scope = Scope_Check_Id); + pragma Assert (Scope_Stack.Last = Scope_Check_Last); + Restore_Hidden_Primitives (Vis_Prims_List); -- Restore the private views that were made visible when the body of @@ -12533,15 +12708,15 @@ package body Sem_Ch12 is if Is_Volatile (A_Gen_T) and then not Is_Volatile (Act_T) then Error_Msg_NE - ("actual for& has different Volatile aspect", - Actual, A_Gen_T); + ("actual for& must have Volatile aspect", + Actual, A_Gen_T); elsif Is_Derived_Type (A_Gen_T) and then Is_Volatile (A_Gen_T) /= Is_Volatile (Act_T) then Error_Msg_NE ("actual for& has different Volatile aspect", - Actual, A_Gen_T); + Actual, A_Gen_T); end if; -- We assume that an array type whose atomic component type @@ -15656,10 +15831,7 @@ package body Sem_Ch12 is -- preserve in this case, since the expansion will be redone in -- the instance. - if Nkind (E) not in N_Defining_Character_Literal - | N_Defining_Identifier - | N_Defining_Operator_Symbol - then + if Nkind (E) not in N_Entity then Set_Associated_Node (N, Empty); Set_Etype (N, Empty); return; @@ -15708,7 +15880,12 @@ package body Sem_Ch12 is elsif Nkind (Parent (N)) = N_Selected_Component and then Nkind (Parent (N2)) = N_Expanded_Name then - if Is_Global (Entity (Parent (N2))) then + -- In case of previous errors, the tree might be malformed + + if No (Entity (Parent (N2))) then + null; + + elsif Is_Global (Entity (Parent (N2))) then Change_Selected_Component_To_Expanded_Name (Parent (N)); Set_Associated_Node (Parent (N), Parent (N2)); Set_Global_Type (Parent (N), Parent (N2)); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 30cade8..7013094 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -390,8 +390,7 @@ package body Sem_Ch13 is procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is Max_Machine_Scalar_Size : constant Uint := - UI_From_Int - (Standard_Long_Long_Integer_Size); + UI_From_Int (System_Max_Integer_Size); -- We use this as the maximum machine scalar size SSU : constant Uint := UI_From_Int (System_Storage_Unit); @@ -1211,9 +1210,11 @@ package body Sem_Ch13 is Set_Is_Volatile (E); end if; - -- Volatile_Full_Access + -- Volatile_Full_Access (also Full_Access_Only) - when Aspect_Volatile_Full_Access => + when Aspect_Volatile_Full_Access + | Aspect_Full_Access_Only + => if Is_Volatile_Full_Access (P) then Set_Is_Volatile_Full_Access (E); end if; @@ -1309,7 +1310,9 @@ package body Sem_Ch13 is return; end if; - when Aspect_Volatile_Full_Access => + when Aspect_Volatile_Full_Access + | Aspect_Full_Access_Only + => if not Is_Volatile_Full_Access (Par) then return; end if; @@ -1327,23 +1330,28 @@ package body Sem_Ch13 is -- Local variables - Prag : Node_Id; + Prag : Node_Id; + P_Name : Name_Id; -- Start of processing for Make_Pragma_From_Boolean_Aspect begin - -- Note that we know Expr is present, because for a missing Expr - -- argument, we knew it was True and did not need to delay the - -- evaluation to the freeze point. - - if Is_False (Static_Boolean (Expr)) then + if Present (Expr) and then Is_False (Static_Boolean (Expr)) then Check_False_Aspect_For_Derived_Type; else + -- There is no Full_Access_Only pragma so use VFA instead + + if A_Name = Name_Full_Access_Only then + P_Name := Name_Volatile_Full_Access; + else + P_Name := A_Name; + end if; + Prag := Make_Pragma (Loc, Pragma_Identifier => - Make_Identifier (Sloc (Ident), Chars (Ident)), + Make_Identifier (Sloc (Ident), P_Name), Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ident), Expression => New_Occurrence_Of (Ent, Sloc (Ident))))); @@ -1428,12 +1436,13 @@ package body Sem_Ch13 is -- Analyze_Aspect_Export_Import, but is not analyzed as -- the complete analysis must happen now. - if A_Id = Aspect_Export or else A_Id = Aspect_Import then - null; - - -- Otherwise create a corresponding pragma + -- Aspect Full_Access_Only must be analyzed last so that + -- aspects Volatile and Atomic, if any, are analyzed. - else + if A_Id /= Aspect_Export + and then A_Id /= Aspect_Import + and then A_Id /= Aspect_Full_Access_Only + then Make_Pragma_From_Boolean_Aspect (ASN); end if; @@ -1500,6 +1509,25 @@ package body Sem_Ch13 is Next_Rep_Item (ASN); end loop; + -- Make a second pass for a Full_Access_Only entry + + ASN := First_Rep_Item (E); + while Present (ASN) loop + if Nkind (ASN) = N_Aspect_Specification then + exit when Entity (ASN) /= E; + + if Get_Aspect_Id (ASN) = Aspect_Full_Access_Only then + Make_Pragma_From_Boolean_Aspect (ASN); + Ritem := Aspect_Rep_Item (ASN); + if Present (Ritem) then + Analyze (Ritem); + end if; + end if; + end if; + + Next_Rep_Item (ASN); + end loop; + -- This is where we inherit delayed rep aspects from our parent. Note -- that if we fell out of the above loop with ASN non-empty, it means -- we hit an aspect for an entity other than E, and it must be the @@ -1545,6 +1573,7 @@ package body Sem_Ch13 is -- Refined_Global -- Refined_State -- SPARK_Mode + -- Subprogram_Variant -- Warnings -- Insert pragma Prag such that it mimics the placement of a source -- pragma of the same kind. Flag Is_Generic should be set when the @@ -1765,10 +1794,10 @@ package body Sem_Ch13 is -- analyzed right now. -- Note that there is a special handling for Pre, Post, Test_Case, - -- Contract_Cases aspects. In these cases, we do not have to worry - -- about delay issues, since the pragmas themselves deal with delay - -- of visibility for the expression analysis. Thus, we just insert - -- the pragma after the node N. + -- Contract_Cases and Subprogram_Variant aspects. In these cases, we do + -- not have to worry about delay issues, since the pragmas themselves + -- deal with delay of visibility for the expression analysis. Thus, we + -- just insert the pragma after the node N. -- Loop through aspects @@ -1813,9 +1842,9 @@ package body Sem_Ch13 is procedure Analyze_Aspect_Static; -- Ada 202x (AI12-0075): Perform analysis of aspect Static - procedure Make_Aitem_Pragma + function Make_Aitem_Pragma (Pragma_Argument_Associations : List_Id; - Pragma_Name : Name_Id); + Pragma_Name : Name_Id) return Node_Id; -- This is a wrapper for Make_Pragma used for converting aspects -- to pragmas. It takes care of Sloc (set from Loc) and building -- the pragma identifier from the given name. In addition the @@ -1874,7 +1903,7 @@ package body Sem_Ch13 is -- Generate: -- pragma Convention (<Conv>, <E>); - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Name => Name_Convention, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, @@ -2166,6 +2195,9 @@ package body Sem_Ch13 is Seen : in out Elist_Id) is begin + -- Set name of the aspect for error messages + Error_Msg_Name_1 := Nam; + -- The relaxed parameter is a formal parameter if Nkind (Param) in N_Identifier | N_Expanded_Name then @@ -2180,6 +2212,14 @@ package body Sem_Ch13 is pragma Assert (Is_Formal (Item)); + -- It must not have scalar or access type + + if Is_Elementary_Type (Etype (Item)) then + Error_Msg_N ("illegal aspect % item", Param); + Error_Msg_N + ("\item must not have elementary type", Param); + end if; + -- Detect duplicated items if Contains (Seen, Item) then @@ -2206,6 +2246,16 @@ package body Sem_Ch13 is and then Entity (Pref) = Subp_Id then + -- Function result must not have scalar or access + -- type. + + if Is_Elementary_Type (Etype (Pref)) then + Error_Msg_N ("illegal aspect % item", Param); + Error_Msg_N + ("\function result must not have elementary" + & " type", Param); + end if; + -- Detect duplicated items if Contains (Seen, Subp_Id) then @@ -2346,12 +2396,14 @@ package body Sem_Ch13 is if not Is_OK_Static_Expression (Expression (Assoc)) then + Error_Msg_Name_1 := Nam; Error_Msg_N ("expression of aspect %" & "must be static", Aspect); end if; else + Error_Msg_Name_1 := Nam; Error_Msg_N ("illegal aspect % expression", Expr); end if; @@ -2654,11 +2706,12 @@ package body Sem_Ch13 is -- Make_Aitem_Pragma -- ----------------------- - procedure Make_Aitem_Pragma + function Make_Aitem_Pragma (Pragma_Argument_Associations : List_Id; - Pragma_Name : Name_Id) + Pragma_Name : Name_Id) return Node_Id is - Args : List_Id := Pragma_Argument_Associations; + Args : List_Id := Pragma_Argument_Associations; + Aitem : Node_Id; begin -- We should never get here if aspect was disabled @@ -2692,6 +2745,8 @@ package body Sem_Ch13 is Set_Corresponding_Aspect (Aitem, Aspect); Set_From_Aspect_Specification (Aitem); + + return Aitem; end Make_Aitem_Pragma; -- Start of processing for Analyze_One_Aspect @@ -2845,23 +2900,33 @@ package body Sem_Ch13 is case Aspect_Delay (A_Id) is when Always_Delay => - Delay_Required := True; + -- For Boolean aspects, do not delay if no expression + + if A_Id in Boolean_Aspects | Library_Unit_Aspects then + Delay_Required := Present (Expr); + else + Delay_Required := True; + end if; when Never_Delay => Delay_Required := False; when Rep_Aspect => - -- If expression has the form of an integer literal, then - -- do not delay, since we know the value cannot change. - -- This optimization catches most rep clause cases. - - -- For Boolean aspects, don't delay if no expression + -- For Boolean aspects, do not delay if no expression except + -- for Full_Access_Only because we need to process it after + -- Volatile and Atomic, which can be independently delayed. - if A_Id in Boolean_Aspects and then No (Expr) then + if A_Id in Boolean_Aspects + and then A_Id /= Aspect_Full_Access_Only + and then No (Expr) + then Delay_Required := False; - -- For non-Boolean aspects, don't delay if integer literal + -- For non-Boolean aspects, if the expression has the form + -- of an integer literal, then do not delay, since we know + -- the value cannot change. This optimization catches most + -- rep clause cases. elsif A_Id not in Boolean_Aspects and then Present (Expr) @@ -2869,7 +2934,7 @@ package body Sem_Ch13 is then Delay_Required := False; - -- For Alignment and various Size aspects, don't delay for + -- For Alignment and various Size aspects, do not delay for -- an attribute reference whose prefix is Standard, for -- example Standard'Maximum_Alignment or Standard'Word_Size. @@ -3025,13 +3090,10 @@ package body Sem_Ch13 is -- referring to the entity, and the second argument is the -- aspect definition expression. - -- Linker_Section/Suppress/Unsuppress + -- Linker_Section - when Aspect_Linker_Section - | Aspect_Suppress - | Aspect_Unsuppress - => - Make_Aitem_Pragma + when Aspect_Linker_Section => + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => New_Occurrence_Of (E, Loc)), @@ -3046,8 +3108,7 @@ package body Sem_Ch13 is -- code. (This is already done for types with implicit -- initialization, such as protected types.) - if A_Id = Aspect_Linker_Section - and then Nkind (N) = N_Object_Declaration + if Nkind (N) = N_Object_Declaration and then Has_Init_Expression (N) then Delay_Required := False; @@ -3058,7 +3119,7 @@ package body Sem_Ch13 is -- Corresponds to pragma Implemented, construct the pragma when Aspect_Synchronization => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => New_Occurrence_Of (E, Loc)), @@ -3069,7 +3130,7 @@ package body Sem_Ch13 is -- Attach_Handler when Aspect_Attach_Handler => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent), @@ -3111,7 +3172,7 @@ package body Sem_Ch13 is -- flags recording whether it is static/dynamic). We also -- set flags recording this in the type itself. - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent), @@ -3196,7 +3257,7 @@ package body Sem_Ch13 is -- Construct the pragma - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent), @@ -3352,10 +3413,25 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr)); end if; + -- Suppress/Unsuppress + + when Aspect_Suppress + | Aspect_Unsuppress + => + Aitem := Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr)), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => New_Occurrence_Of (E, Loc))), + Pragma_Name => Chars (Id)); + + Delay_Required := False; + -- Warnings when Aspect_Warnings => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Expr), Expression => Relocate_Node (Expr)), @@ -3383,7 +3459,7 @@ package body Sem_Ch13 is -- an invariant must apply to a private type, or appear in -- the private part of a spec and apply to a completion. - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent), @@ -3435,7 +3511,7 @@ package body Sem_Ch13 is if Nkind (Context) in N_Generic_Package_Declaration | N_Package_Declaration then - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3461,7 +3537,7 @@ package body Sem_Ch13 is -- related object declaration. when Aspect_Async_Readers => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3476,7 +3552,7 @@ package body Sem_Ch13 is -- related object declaration. when Aspect_Async_Writers => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3491,7 +3567,7 @@ package body Sem_Ch13 is -- related object declaration. when Aspect_Constant_After_Elaboration => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3511,7 +3587,7 @@ package body Sem_Ch13 is -- private type's full view. when Aspect_Default_Initial_Condition => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3525,7 +3601,7 @@ package body Sem_Ch13 is -- Default_Storage_Pool when Aspect_Default_Storage_Pool => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3546,7 +3622,7 @@ package body Sem_Ch13 is -- Analyze_Depends_In_Decl_Part for details. when Aspect_Depends => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3561,7 +3637,7 @@ package body Sem_Ch13 is -- related object declaration. when Aspect_Effective_Reads => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3576,7 +3652,7 @@ package body Sem_Ch13 is -- related object declaration. when Aspect_Effective_Writes => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3591,7 +3667,7 @@ package body Sem_Ch13 is -- related subprogram. when Aspect_Extensions_Visible => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3607,7 +3683,7 @@ package body Sem_Ch13 is -- a type declaration. when Aspect_Ghost => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3627,7 +3703,7 @@ package body Sem_Ch13 is -- Analyze_Global_In_Decl_Part for details. when Aspect_Global => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3662,7 +3738,7 @@ package body Sem_Ch13 is if Nkind (Context) in N_Generic_Package_Declaration | N_Package_Declaration then - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3710,7 +3786,7 @@ package body Sem_Ch13 is if Nkind (Context) in N_Generic_Package_Declaration | N_Package_Declaration then - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3736,7 +3812,7 @@ package body Sem_Ch13 is -- Max_Entry_Queue_Depth when Aspect_Max_Entry_Queue_Depth => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3749,7 +3825,7 @@ package body Sem_Ch13 is -- Max_Entry_Queue_Length when Aspect_Max_Entry_Queue_Length => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3762,7 +3838,7 @@ package body Sem_Ch13 is -- Max_Queue_Length when Aspect_Max_Queue_Length => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3777,7 +3853,7 @@ package body Sem_Ch13 is -- declaration. when Aspect_No_Caching => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3801,7 +3877,7 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))); end if; - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => Args, Pragma_Name => Chars (Id)); end; @@ -3813,7 +3889,7 @@ package body Sem_Ch13 is | N_Package_Instantiation or else Is_Single_Concurrent_Type_Declaration (N) then - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3834,7 +3910,7 @@ package body Sem_Ch13 is -- SPARK_Mode when Aspect_SPARK_Mode => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3855,7 +3931,7 @@ package body Sem_Ch13 is -- routine Analyze_Refined_Depends_In_Decl_Part. when Aspect_Refined_Depends => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3876,7 +3952,7 @@ package body Sem_Ch13 is -- routine Analyze_Refined_Global_In_Decl_Part. when Aspect_Refined_Global => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3889,7 +3965,7 @@ package body Sem_Ch13 is -- Refined_Post when Aspect_Refined_Post => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3909,7 +3985,7 @@ package body Sem_Ch13 is -- the pragma. if Nkind (N) = N_Package_Body then - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3930,7 +4006,7 @@ package body Sem_Ch13 is -- Relative_Deadline when Aspect_Relative_Deadline => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3979,7 +4055,7 @@ package body Sem_Ch13 is -- attribute does not have visibility on the discriminant. when Aspect_Secondary_Stack_Size => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -3997,7 +4073,7 @@ package body Sem_Ch13 is -- related subprogram. when Aspect_Volatile_Function => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -4077,7 +4153,7 @@ package body Sem_Ch13 is Chars => Name_Entity, Expression => Ent)); - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => Pargs, Pragma_Name => Name_Annotate); end; @@ -4123,7 +4199,7 @@ package body Sem_Ch13 is when Aspect_Aggregate => Validate_Aspect_Aggregate (Expr); Record_Rep_Item (E, Aspect); - return; + goto Continue; when Aspect_Integer_Literal | Aspect_Real_Literal @@ -4170,8 +4246,8 @@ package body Sem_Ch13 is -- Case 4: Aspects requiring special handling - -- Pre/Post/Test_Case/Contract_Cases whose corresponding - -- pragmas take care of the delay. + -- Pre/Post/Test_Case/Contract_Cases/Subprogram_Variant whose + -- corresponding pragmas take care of the delay. -- Pre/Post @@ -4271,7 +4347,7 @@ package body Sem_Ch13 is New_Expr := Relocate_Node (Expr); end if; - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Eloc, Chars => Name_Check, @@ -4362,7 +4438,7 @@ package body Sem_Ch13 is -- Build the test-case pragma - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => Args, Pragma_Name => Nam); end Test_Case; @@ -4370,7 +4446,20 @@ package body Sem_Ch13 is -- Contract_Cases when Aspect_Contract_Cases => - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Nam); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + + -- Subprogram_Variant + + when Aspect_Subprogram_Variant => + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -4398,14 +4487,16 @@ package body Sem_Ch13 is if Ekind (E) /= E_Protected_Type then Error_Msg_Name_1 := Nam; Error_Msg_N - ("aspect % only applies to a protected object", + ("aspect % only applies to a protected type " & + "or object", Aspect); else -- Set the Uses_Lock_Free flag to True if there is no -- expression or if the expression is True. The -- evaluation of this aspect should be delayed to the - -- freeze point (why???) + -- freeze point if we wanted to handle the corner case + -- of "true" or "false" being redefined. if No (Expr) or else Is_True (Static_Boolean (Expr)) @@ -4427,6 +4518,28 @@ package body Sem_Ch13 is Analyze_Aspect_Disable_Controlled; goto Continue; + -- Ada 202x (AI12-0129): Exclusive_Functions + + elsif A_Id = Aspect_Exclusive_Functions then + if Ekind (E) /= E_Protected_Type then + Error_Msg_Name_1 := Nam; + Error_Msg_N + ("aspect % only applies to a protected type " & + "or object", + Aspect); + end if; + + goto Continue; + + -- Ada 202x (AI12-0363): Full_Access_Only + + elsif A_Id = Aspect_Full_Access_Only then + if Ada_Version < Ada_2020 then + Error_Msg_N + ("aspect % is an Ada 202x feature", Aspect); + Error_Msg_N ("\compile with -gnat2020", Aspect); + end if; + -- Ada 202x (AI12-0075): static expression functions elsif A_Id = Aspect_Static then @@ -4461,10 +4574,9 @@ package body Sem_Ch13 is goto Continue; end if; - -- Cases where we do not delay, includes all cases where the - -- expression is missing other than the above cases. + -- Cases where we do not delay - if not Delay_Required or else No (Expr) then + if not Delay_Required then -- Exclude aspects Export and Import because their pragma -- syntax does not map directly to a Boolean aspect. @@ -4472,15 +4584,13 @@ package body Sem_Ch13 is if A_Id /= Aspect_Export and then A_Id /= Aspect_Import then - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent)), Pragma_Name => Chars (Id)); end if; - Delay_Required := False; - -- In general cases, the corresponding pragma/attribute -- definition clause will be inserted later at the freezing -- point, and we do not need to build it now. @@ -4523,7 +4633,7 @@ package body Sem_Ch13 is -- Create a pragma and put it at the start of the task -- definition for the task type declaration. - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), @@ -4584,7 +4694,7 @@ package body Sem_Ch13 is if Is_Boolean_Aspect (Aspect) and then No (Aitem) then if Is_True (Static_Boolean (Expr)) then - Make_Aitem_Pragma + Aitem := Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent), Expression => Ent)), @@ -4687,9 +4797,39 @@ package body Sem_Ch13 is Insert_After (Ins_Node, Aitem); Ins_Node := Aitem; end if; + + <<Continue>> + + -- If a nonoverridable aspect is explicitly specified for a + -- derived type, then check consistency with the parent type. + + if A_Id in Nonoverridable_Aspect_Id + and then Nkind (N) = N_Full_Type_Declaration + and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then not In_Instance_Body + then + declare + Parent_Type : constant Entity_Id := Etype (E); + Inherited_Aspect : constant Node_Id := + Find_Aspect (Parent_Type, A_Id); + begin + if Present (Inherited_Aspect) + and then not Is_Confirming + (A_Id, Inherited_Aspect, Aspect) + then + Error_Msg_Name_1 := Aspect_Names (A_Id); + Error_Msg_Sloc := Sloc (Inherited_Aspect); + + Error_Msg + ("overriding aspect specification for " + & "nonoverridable aspect % does not confirm " + & "aspect specification inherited from #", + Sloc (Aspect)); + end if; + end; + end if; end Analyze_One_Aspect; - <<Continue>> Next (Aspect); end loop Aspect_Loop; @@ -6977,12 +7117,13 @@ package body Sem_Ch13 is else if Is_Elementary_Type (Etyp) and then Size /= System_Storage_Unit - and then Size /= System_Storage_Unit * 2 - and then Size /= System_Storage_Unit * 4 - and then Size /= System_Storage_Unit * 8 + and then Size /= 16 + and then Size /= 32 + and then Size /= 64 + and then Size /= System_Max_Integer_Size then Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); - Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8; + Error_Msg_Uint_2 := UI_From_Int (System_Max_Integer_Size); Error_Msg_N ("size for primitive object must be a power of 2 in " & "the range ^-^", N); @@ -7143,7 +7284,10 @@ package body Sem_Ch13 is -- check (B) - if Type_Access_Level (Ent) > Object_Access_Level (Pool) then + if Type_Access_Level (Ent) + > Static_Accessibility_Level + (Pool, Object_Decl_Level) + then Error_Msg_N ("subpool access type has deeper accessibility " & "level than pool", Ent); @@ -7154,7 +7298,7 @@ package body Sem_Ch13 is -- check (C) - if Present (Obj) and then Ekind (Obj) in Formal_Kind then + if Present (Obj) and then Is_Formal (Obj) then Error_Msg_N ("subpool cannot be part of a parameter", Ent); return; @@ -9546,8 +9690,8 @@ package body Sem_Ch13 is -- Predicate_Function of the parent type, using Add_Call above. procedure Add_Call (T : Entity_Id); - -- Includes a call to the predicate function for type T in Expr if T - -- has predicates and Predicate_Function (T) is non-empty. + -- Includes a call to the predicate function for type T in Expr if + -- Predicate_Function (T) is non-empty. function Process_RE (N : Node_Id) return Traverse_Result; -- Used in Process REs, tests if node N is a raise expression, and if @@ -9571,8 +9715,8 @@ package body Sem_Ch13 is Exp : Node_Id; begin - if Present (T) and then Present (Predicate_Function (T)) then - Set_Has_Predicates (Typ); + if Present (Predicate_Function (T)) then + pragma Assert (Has_Predicates (Typ)); -- Build the call to the predicate function of T. The type may be -- derived, so use an unchecked conversion for the actual. @@ -9746,7 +9890,7 @@ package body Sem_Ch13 is elsif Nkind (Ritem) = N_Aspect_Specification and then Present (Aspect_Rep_Item (Ritem)) - and then Scope (Typ) /= Current_Scope + and then Scope_Depth (Scope (Typ)) > Scope_Depth (Current_Scope) then declare Prag : constant Node_Id := Aspect_Rep_Item (Ritem); @@ -10016,7 +10160,7 @@ package body Sem_Ch13 is end if; end; - -- within a generic unit, prevent a double analysis of the body + -- Within a generic unit, prevent a double analysis of the body -- which will not be marked analyzed yet. This will happen when -- the freeze node is created during the preanalysis of an -- expression function. @@ -10350,7 +10494,10 @@ package body Sem_Ch13 is Freeze_Expr : constant Node_Id := Expression (ASN); -- Expression from call to Check_Aspect_At_Freeze_Point. - T : constant Entity_Id := Etype (Original_Node (Freeze_Expr)); + T : constant Entity_Id := + (if Present (Freeze_Expr) + then Etype (Original_Node (Freeze_Expr)) + else Empty); -- Type required for preanalyze call. We use the original expression to -- get the proper type, to prevent cascaded errors when the expression -- is constant-folded. @@ -10494,12 +10641,12 @@ package body Sem_Ch13 is Set_Parent (End_Decl_Expr, ASN); - -- In a generic context the original aspect expressions have not + -- In a generic context the original aspect expressions have not -- been preanalyzed, so do it now. There are no conformance checks -- to perform in this case. As before, we have to make components -- visible for aspects that may reference them. - if No (T) then + if Present (Freeze_Expr) and then No (T) then if A_Id = Aspect_Dynamic_Predicate or else A_Id = Aspect_Predicate or else A_Id = Aspect_Priority @@ -10539,7 +10686,7 @@ package body Sem_Ch13 is elsif A_Id = Aspect_Predicate_Failure then Preanalyze_Spec_Expression (End_Decl_Expr, Standard_String); - else + elsif Present (End_Decl_Expr) then Preanalyze_Spec_Expression (End_Decl_Expr, T); end if; @@ -10701,8 +10848,6 @@ package body Sem_Ch13 is | Aspect_Output | Aspect_Put_Image | Aspect_Read - | Aspect_Suppress - | Aspect_Unsuppress | Aspect_Warnings | Aspect_Write => @@ -10818,8 +10963,11 @@ package body Sem_Ch13 is | Aspect_Refined_State | Aspect_Relaxed_Initialization | Aspect_SPARK_Mode + | Aspect_Subprogram_Variant + | Aspect_Suppress | Aspect_Test_Case | Aspect_Unimplemented + | Aspect_Unsuppress | Aspect_Volatile_Function => raise Program_Error; @@ -10828,7 +10976,9 @@ package body Sem_Ch13 is -- Do the preanalyze call - Preanalyze_Spec_Expression (Expression (ASN), T); + if Present (Expression (ASN)) then + Preanalyze_Spec_Expression (Expression (ASN), T); + end if; end Check_Aspect_At_Freeze_Point; ----------------------------------- @@ -13031,9 +13181,6 @@ package body Sem_Ch13 is -- specification node whose correponding pragma (if any) is present in -- the Rep Item chain of the entity it has been specified to. - function Rep_Item_Entity (Rep_Item : Node_Id) return Entity_Id; - -- Return the entity for which Rep_Item is specified - -------------------------------------------------- -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item -- -------------------------------------------------- @@ -13044,26 +13191,10 @@ package body Sem_Ch13 is begin return Nkind (Rep_Item) = N_Pragma - or else Present_In_Rep_Item - (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item)); + or else + Present_In_Rep_Item (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item)); end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item; - --------------------- - -- Rep_Item_Entity -- - --------------------- - - function Rep_Item_Entity (Rep_Item : Node_Id) return Entity_Id is - begin - if Nkind (Rep_Item) = N_Aspect_Specification then - return Entity (Rep_Item); - - else - pragma Assert - (Nkind (Rep_Item) in N_Attribute_Definition_Clause | N_Pragma); - return Entity (Name (Rep_Item)); - end if; - end Rep_Item_Entity; - -- Start of processing for Inherit_Aspects_At_Freeze_Point begin @@ -13189,10 +13320,12 @@ package body Sem_Ch13 is Set_Treat_As_Volatile (Typ); end if; - -- Volatile_Full_Access + -- Volatile_Full_Access and Full_Access_Only if not Has_Rep_Item (Typ, Name_Volatile_Full_Access, False) - and then Has_Rep_Pragma (Typ, Name_Volatile_Full_Access) + and then not Has_Rep_Item (Typ, Name_Full_Access_Only, False) + and then (Has_Rep_Item (Typ, Name_Volatile_Full_Access) + or else Has_Rep_Item (Typ, Name_Full_Access_Only)) and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Get_Rep_Item (Typ, Name_Volatile_Full_Access)) then @@ -13249,23 +13382,20 @@ package body Sem_Ch13 is -- Bit_Order - if Is_Record_Type (Typ) then + if Is_Record_Type (Typ) and then Typ = Bas_Typ then 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 (Rep_Item_Entity - (Get_Rep_Item (Typ, Name_Bit_Order)))); + Reverse_Bit_Order + (Implementation_Base_Type (Etype (Bas_Typ)))); end if; end if; -- Scalar_Storage_Order - -- Note: the aspect is specified on a first subtype, but recorded - -- in a flag of the base type! - if (Is_Record_Type (Typ) or else Is_Array_Type (Typ)) - and then Typ = Bas_Typ + and then Typ = Bas_Typ then -- For a type extension, always inherit from parent; otherwise -- inherit if no default applies. Note: we do not check for @@ -14498,11 +14628,9 @@ package body Sem_Ch13 is function Visible_Component (Comp : Name_Id) return Entity_Id; -- Given an identifier in the expression, check whether there is a - -- discriminant or component of the type that is directy visible, and - -- rewrite it as the corresponding selected component of the formal of - -- the subprogram. The entity is located by a sequential search, which - -- seems acceptable given the typical size of component lists and check - -- expressions. Possible optimization ??? + -- discriminant, component, protected procedure, or entry of the type + -- that is directy visible, and rewrite it as the corresponding selected + -- component of the formal of the subprogram. ---------------------- -- Replace_Type_Ref -- @@ -14677,14 +14805,20 @@ package body Sem_Ch13 is function Visible_Component (Comp : Name_Id) return Entity_Id is E : Entity_Id; - begin - -- Types with nameable components are records and discriminated - -- private types. + -- Types with nameable components are record, task, and protected + -- types, and discriminated private types. - if Ekind (T) = E_Record_Type + if Ekind (T) in E_Record_Type + | E_Task_Type + | E_Protected_Type or else (Is_Private_Type (T) and then Has_Discriminants (T)) then + -- This is a sequential search, which seems acceptable + -- efficiency-wise, given the typical size of component + -- lists, protected operation lists, task item lists, and + -- check expressions. + E := First_Entity (T); while Present (E) loop if Comes_From_Source (E) and then Chars (E) = Comp then @@ -14695,7 +14829,7 @@ package body Sem_Ch13 is end loop; end if; - -- Nothing by that name, or the type has no components + -- Nothing by that name return Empty; end Visible_Component; @@ -15142,19 +15276,33 @@ package body Sem_Ch13 is -- Predicates that establish the legality of each possible operation in -- an Aggregate aspect. - function Valid_Empty (E : Entity_Id) return Boolean; - function Valid_Add_Named (E : Entity_Id) return Boolean; - function Valid_Add_Unnamed (E : Entity_Id) return Boolean; - function Valid_New_Indexed (E : Entity_Id) return Boolean; - - -- Note: The legality rules for Assign_Indexed are the same as for - -- Add_Named. + function Valid_Empty (E : Entity_Id) return Boolean; + function Valid_Add_Named (E : Entity_Id) return Boolean; + function Valid_Add_Unnamed (E : Entity_Id) return Boolean; + function Valid_New_Indexed (E : Entity_Id) return Boolean; + function Valid_Assign_Indexed (E : Entity_Id) return Boolean; generic with function Pred (Id : Node_Id) return Boolean; procedure Resolve_Operation (Subp_Id : Node_Id); -- Common processing to resolve each aggregate operation. + ------------------------ + -- Valid_Assign_Index -- + ------------------------ + + function Valid_Assign_Indexed (E : Entity_Id) return Boolean is + begin + -- The profile must be the same as for Add_Named, with the added + -- requirement that the key_type be a discrete type. + + if Valid_Add_Named (E) then + return Is_Discrete_Type (Etype (Next_Formal (First_Formal (E)))); + else + return False; + end if; + end Valid_Assign_Indexed; + ----------------- -- Valid_Emoty -- ----------------- @@ -15278,7 +15426,8 @@ package body Sem_Ch13 is procedure Resolve_Named is new Resolve_Operation (Valid_Add_Named); procedure Resolve_Indexed is new Resolve_Operation (Valid_New_Indexed); procedure Resolve_Assign_Indexed - is new Resolve_Operation (Valid_Add_Named); + is new Resolve_Operation + (Valid_Assign_Indexed); begin Assoc := First (Component_Associations (Expr)); @@ -15347,7 +15496,7 @@ package body Sem_Ch13 is begin Init_Alignment (T); - -- Find the minimum standard size (8,16,32,64) that fits + -- Find the minimum standard size (8,16,32,64,128) that fits Lo := Enumeration_Rep (Entity (Type_Low_Bound (T))); Hi := Enumeration_Rep (Entity (Type_High_Bound (T))); @@ -15362,8 +15511,11 @@ package body Sem_Ch13 is elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then Sz := 32; - else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63); + elsif Lo >= -Uint_2**63 and then Hi < Uint_2**63 then Sz := 64; + + else pragma Assert (Lo >= -Uint_2**127 and then Hi < Uint_2**127); + Sz := 128; end if; else @@ -15376,8 +15528,11 @@ package body Sem_Ch13 is elsif Hi < Uint_2**32 then Sz := 32; - else pragma Assert (Hi < Uint_2**63); + elsif Hi < Uint_2**64 then Sz := 64; + + else pragma Assert (Hi < Uint_2**128); + Sz := 128; end if; end if; @@ -15674,12 +15829,12 @@ package body Sem_Ch13 is return; end if; - -- Case of component size is greater than or equal to 64 and the - -- alignment of the array is at least as large as the alignment - -- of the component. We are definitely OK in this situation. + -- Case where component size is greater than or equal to the maximum + -- integer size and the alignment of the array is at least as large + -- as the alignment of the component. We are OK in this situation. if Known_Component_Size (Atyp) - and then Component_Size (Atyp) >= 64 + and then Component_Size (Atyp) >= System_Max_Integer_Size and then Known_Alignment (Atyp) and then Known_Alignment (Ctyp) and then Alignment (Atyp) >= Alignment (Ctyp) @@ -15690,8 +15845,7 @@ package body Sem_Ch13 is -- Check actual component size if not Known_Component_Size (Atyp) - or else not (Addressable (Component_Size (Atyp)) - and then Component_Size (Atyp) < 64) + or else not Addressable (Component_Size (Atyp)) or else Component_Size (Atyp) mod Esize (Ctyp) /= 0 then No_Independence; @@ -15777,10 +15931,12 @@ package body Sem_Ch13 is return False; end if; - -- Size of component must be addressable or greater than 64 bits - -- and a multiple of bytes. + -- Size of component must be addressable or greater than the maximum + -- integer size and a multiple of bytes. - if not Addressable (Esize (C)) and then Esize (C) < Uint_64 then + if not Addressable (Esize (C)) + and then Esize (C) < System_Max_Integer_Size + then return False; end if; diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 3d24c04..7d9f38d 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -164,6 +164,11 @@ package Sem_Ch13 is -- parameter does the actual replacement of node N, which is either a -- simple direct reference to T, or a selected component that represents -- an appropriately qualified occurrence of T. + -- + -- This also replaces each reference to a component, entry, or protected + -- procedure with a selected component whose prefix is the parameter. + -- For example, Component_Name becomes Parameter.Component_Name, where + -- Parameter is the parameter, which is of type T. function Rep_Item_Too_Late (T : Entity_Id; @@ -176,7 +181,7 @@ package Sem_Ch13 is -- is the pragma or representation clause itself, used for placing error -- messages if the item is too late. -- - -- Fonly is a flag that causes only the freezing rule (para 9) to be + -- FOnly is a flag that causes only the freezing rule (para 9) to be -- applied, and the tests of para 10 are skipped. This is appropriate for -- both subtype related attributes (Alignment and Size) and for stream -- attributes, which, although certainly not subtype related attributes, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a5690d6..269818a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -410,7 +410,7 @@ package body Sem_Ch3 is -- When constraining a protected type or task type with discriminants, -- constrain the corresponding record with the same discriminant values. - procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id); + procedure Constrain_Decimal (Def_Id : Entity_Id; S : Node_Id); -- Constrain a decimal fixed point type with a digits constraint and/or a -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity. @@ -426,11 +426,11 @@ package body Sem_Ch3 is -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation -- of For_Access. - procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id); + procedure Constrain_Enumeration (Def_Id : Entity_Id; S : Node_Id); -- Constrain an enumeration type with a range constraint. This is identical -- to Constrain_Integer, but for the Ekind of the resulting subtype. - procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id); + procedure Constrain_Float (Def_Id : Entity_Id; S : Node_Id); -- Constrain a floating point type with either a digits constraint -- and/or a range constraint, building a E_Floating_Point_Subtype. @@ -440,17 +440,17 @@ package body Sem_Ch3 is Related_Nod : Node_Id; Related_Id : Entity_Id; Suffix : Character; - Suffix_Index : Nat); + Suffix_Index : Pos); -- Process an index constraint S in a constrained array declaration. The -- constraint can be a subtype name, or a range with or without an explicit -- subtype mark. The index is the corresponding index of the unconstrained -- array. The Related_Id and Suffix parameters are used to build the -- associated Implicit type name. - procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id); + procedure Constrain_Integer (Def_Id : Entity_Id; S : Node_Id); -- Build subtype of a signed or modular integer type - procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id); + procedure Constrain_Ordinary_Fixed (Def_Id : Entity_Id; S : Node_Id); -- Constrain an ordinary fixed point type with a range constraint, and -- build an E_Ordinary_Fixed_Point_Subtype entity. @@ -1185,7 +1185,7 @@ package body Sem_Ch3 is end; end if; - if not (Is_Type (Etype (Desig_Type))) then + if not Is_Type (Etype (Desig_Type)) then Error_Msg_N ("expect type in function specification", Result_Definition (T_Def)); @@ -1329,7 +1329,8 @@ package body Sem_Ch3 is if Nkind (S) /= N_Subtype_Indication then Analyze (S); - if Present (Entity (S)) + if Nkind (S) in N_Has_Entity + and then Present (Entity (S)) and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then Set_Directly_Designated_Type (T, Entity (S)); @@ -3644,8 +3645,6 @@ package body Sem_Ch3 is -- E is set to Expression (N) throughout this routine. When Expression -- (N) is modified, E is changed accordingly. - Prev_Entity : Entity_Id := Empty; - procedure Check_Dynamic_Object (Typ : Entity_Id); -- A library-level object with nonstatic discriminant constraints may -- require dynamic allocation. The declaration is illegal if the @@ -3921,7 +3920,8 @@ package body Sem_Ch3 is Saved_IGR : constant Node_Id := Ignored_Ghost_Region; -- Save the Ghost-related attributes to restore on exit - Related_Id : Entity_Id; + Prev_Entity : Entity_Id := Empty; + Related_Id : Entity_Id; Full_View_Present : Boolean := False; -- Start of processing for Analyze_Object_Declaration @@ -4423,7 +4423,7 @@ package body Sem_Ch3 is -- the predicate still applies. if not Suppress_Assignment_Checks (N) - and then Predicate_Enabled (T) + and then (Predicate_Enabled (T) or else Has_Static_Predicate (T)) and then (not No_Initialization (N) or else (Present (E) and then Nkind (E) = N_Aggregate)) @@ -4434,15 +4434,23 @@ package body Sem_Ch3 is then -- If the type has a static predicate and the expression is known at -- compile time, see if the expression satisfies the predicate. + -- In the case of a static expression, this must be done even if + -- the predicate is not enabled (as per static expression rules). if Present (E) then Check_Expression_Against_Static_Predicate (E, T); end if; + -- Do not perform further predicate-related checks unless + -- predicates are enabled for the subtype. + + if not Predicate_Enabled (T) then + null; + -- If the type is a null record and there is no explicit initial -- expression, no predicate check applies. - if No (E) and then Is_Null_Record_Type (T) then + elsif No (E) and then Is_Null_Record_Type (T) then null; -- Do not generate a predicate check if the initialization expression @@ -4512,7 +4520,7 @@ package body Sem_Ch3 is end if; -- Case of initialization present but in error. Set initial - -- expression as absent (but do not make above complaints) + -- expression as absent (but do not make above complaints). elsif E = Error then Set_Expression (N, Empty); @@ -4521,19 +4529,15 @@ package body Sem_Ch3 is -- Case of initialization present else - -- Check restrictions in Ada 83 - - if not Constant_Present (N) then - - -- Unconstrained variables not allowed in Ada 83 mode + -- Unconstrained variables not allowed in Ada 83 - if Ada_Version = Ada_83 - and then Comes_From_Source (Object_Definition (N)) - then - Error_Msg_N - ("(Ada 83) unconstrained variable not allowed", - Object_Definition (N)); - end if; + if Ada_Version = Ada_83 + and then not Constant_Present (N) + and then Comes_From_Source (Object_Definition (N)) + then + Error_Msg_N + ("(Ada 83) unconstrained variable not allowed", + Object_Definition (N)); end if; -- Now we constrain the variable from the initializing expression @@ -4612,7 +4616,7 @@ package body Sem_Ch3 is Act_T := Find_Type_Of_Object (Object_Definition (N), N); end if; - -- Propagate attributes to full view when needed. + -- Propagate attributes to full view when needed Set_Is_Constr_Subt_For_U_Nominal (Act_T); @@ -5279,8 +5283,8 @@ package body Sem_Ch3 is (N : Node_Id; Skip : Boolean := False) is - Id : constant Entity_Id := Defining_Identifier (N); - T : Entity_Id; + Id : constant Entity_Id := Defining_Identifier (N); + T : Entity_Id; begin Generate_Definition (Id); @@ -5710,6 +5714,16 @@ package body Sem_Ch3 is then Set_Subprograms_For_Type (Id, Subprograms_For_Type (T)); + -- If the current declaration created both a private and a full view, + -- then propagate Predicate_Function to the latter as well. + + if Present (Full_View (Id)) + and then No (Predicate_Function (Full_View (Id))) + then + Set_Subprograms_For_Type + (Full_View (Id), Subprograms_For_Type (Id)); + end if; + if Has_Static_Predicate (T) then Set_Has_Static_Predicate (Id); Set_Static_Discrete_Predicate (Id, Static_Discrete_Predicate (T)); @@ -5829,8 +5843,8 @@ package body Sem_Ch3 is Target_Index := First_Index (Indic_Typ); while Present (Subt_Index) loop - if ((Nkind (Subt_Index) = N_Identifier - and then Ekind (Entity (Subt_Index)) in Scalar_Kind) + if ((Nkind (Subt_Index) in N_Expanded_Name | N_Identifier + and then Is_Scalar_Type (Entity (Subt_Index))) or else Nkind (Subt_Index) = N_Subtype_Indication) and then Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range @@ -5987,9 +6001,9 @@ package body Sem_Ch3 is Element_Type : Entity_Id; Implicit_Base : Entity_Id; Index : Node_Id; - Nb_Index : Nat; + Nb_Index : Pos; Priv : Entity_Id; - Related_Id : Entity_Id := Empty; + Related_Id : Entity_Id; begin if Nkind (Def) = N_Constrained_Array_Definition then @@ -6042,7 +6056,7 @@ package body Sem_Ch3 is then declare Loc : constant Source_Ptr := Sloc (Def); - Decl : Entity_Id; + Decl : Node_Id; New_E : Entity_Id; begin @@ -6138,7 +6152,12 @@ package body Sem_Ch3 is -- Constrained array case if No (T) then - T := Create_Itype (E_Void, P, Related_Id, 'T'); + -- We might be creating more than one itype with the same Related_Id, + -- e.g. for an array object definition and its initial value. Give + -- them unique suffixes, because GNATprove require distinct types to + -- have different names. + + T := Create_Itype (E_Void, P, Related_Id, 'T', Suffix_Index => -1); end if; if Nkind (Def) = N_Constrained_Array_Definition then @@ -6182,7 +6201,8 @@ package body Sem_Ch3 is -- Unconstrained array case - else + else pragma Assert (Nkind (Def) = N_Unconstrained_Array_Definition); + Set_Ekind (T, E_Array_Type); Init_Size_Align (T); Set_Etype (T, T); @@ -7222,7 +7242,7 @@ package body Sem_Ch3 is -- Introduce an implicit base type for the derived type even if there -- is no constraint attached to it, since this seems closer to the -- Ada semantics. Build a full type declaration tree for the derived - -- type using the implicit base type as the defining identifier. The + -- type using the implicit base type as the defining identifier. Then -- build a subtype declaration tree which applies the constraint (if -- any) have it replace the derived type declaration. @@ -9732,6 +9752,13 @@ package body Sem_Ch3 is Set_Convention (Derived_Type, Convention (Parent_Base)); + if Is_Tagged_Type (Derived_Type) + and then Present (Class_Wide_Type (Derived_Type)) + then + Set_Convention (Class_Wide_Type (Derived_Type), + Convention (Class_Wide_Type (Parent_Base))); + end if; + -- Set SSO default for record or array type if (Is_Array_Type (Derived_Type) or else Is_Record_Type (Derived_Type)) @@ -10849,6 +10876,13 @@ package body Sem_Ch3 is then null; + -- Subprogram renamings cannot be overridden + + elsif Comes_From_Source (Subp) + and then Present (Alias (Subp)) + then + null; + else Error_Msg_NE ("type must be declared abstract or & overridden", @@ -13781,7 +13815,7 @@ package body Sem_Ch3 is -- Constrain_Decimal -- ----------------------- - procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is + procedure Constrain_Decimal (Def_Id : Entity_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : constant Node_Id := Constraint (S); Loc : constant Source_Ptr := Sloc (C); @@ -13998,7 +14032,7 @@ package body Sem_Ch3 is -- Constrain_Enumeration -- --------------------------- - procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is + procedure Constrain_Enumeration (Def_Id : Entity_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : constant Node_Id := Constraint (S); @@ -14021,7 +14055,7 @@ package body Sem_Ch3 is -- Constrain_Float -- ---------------------- - procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is + procedure Constrain_Float (Def_Id : Entity_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : Node_Id; D : Node_Id; @@ -14100,7 +14134,7 @@ package body Sem_Ch3 is Related_Nod : Node_Id; Related_Id : Entity_Id; Suffix : Character; - Suffix_Index : Nat) + Suffix_Index : Pos) is Def_Id : Entity_Id; R : Node_Id := Empty; @@ -14230,7 +14264,7 @@ package body Sem_Ch3 is -- Constrain_Integer -- ----------------------- - procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is + procedure Constrain_Integer (Def_Id : Entity_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : constant Node_Id := Constraint (S); @@ -14253,7 +14287,7 @@ package body Sem_Ch3 is -- Constrain_Ordinary_Fixed -- ------------------------------ - procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is + procedure Constrain_Ordinary_Fixed (Def_Id : Entity_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : Node_Id; D : Node_Id; @@ -15699,7 +15733,9 @@ package body Sem_Ch3 is null; -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" - -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). + -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). Note + -- that functions with controlling access results of record extensions + -- with a null extension part require overriding (AI95-00391/06). -- Ada 202x (AI12-0042): Similarly, set those properties for -- implementing the rule of RM 7.3.2(6.1/4). @@ -15717,8 +15753,7 @@ package body Sem_Ch3 is and then Ekind (Etype (New_Subp)) = E_Anonymous_Access_Type and then Designated_Type (Etype (New_Subp)) = - Derived_Type - and then not Is_Null_Extension (Derived_Type)) + Derived_Type) or else (Comes_From_Source (Alias (New_Subp)) and then Is_EVF_Procedure (Alias (New_Subp))) @@ -16728,6 +16763,14 @@ package body Sem_Ch3 is Next (Intf); end loop; end; + + -- Check consistency of any nonoverridable aspects that are + -- inherited from multiple sources. + + Check_Inherited_Nonoverridable_Aspects + (Inheritor => T, + Interface_List => Interface_List (Def), + Parent_Type => Parent_Type); end if; if Parent_Type = Any_Type @@ -17727,9 +17770,7 @@ package body Sem_Ch3 is -- Case of an anonymous array subtype - if Def_Kind in - N_Constrained_Array_Definition | N_Unconstrained_Array_Definition - then + if Def_Kind in N_Array_Type_Definition then T := Empty; Array_Type_Declaration (T, Obj_Def); @@ -19120,7 +19161,7 @@ package body Sem_Ch3 is (N : Node_Id; Related_Nod : Node_Id; Related_Id : Entity_Id := Empty; - Suffix_Index : Nat := 1) + Suffix_Index : Pos := 1) is R : Node_Id; T : Entity_Id; @@ -19211,24 +19252,20 @@ package body Sem_Ch3 is return; end if; + -- If the range bounds are "T'Low .. T'High" where T is a name of + -- a discrete type, then use T as the type of the index. + if Nkind (Low_Bound (N)) = N_Attribute_Reference and then Attribute_Name (Low_Bound (N)) = Name_First and then Is_Entity_Name (Prefix (Low_Bound (N))) - and then Is_Type (Entity (Prefix (Low_Bound (N)))) and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N)))) - then - -- The type of the index will be the type of the prefix, as long - -- as the upper bound is 'Last of the same type. + and then Nkind (High_Bound (N)) = N_Attribute_Reference + and then Attribute_Name (High_Bound (N)) = Name_Last + and then Is_Entity_Name (Prefix (High_Bound (N))) + and then Entity (Prefix (High_Bound (N))) = Def_Id + then Def_Id := Entity (Prefix (Low_Bound (N))); - - if Nkind (High_Bound (N)) /= N_Attribute_Reference - or else Attribute_Name (High_Bound (N)) /= Name_Last - or else not Is_Entity_Name (Prefix (High_Bound (N))) - or else Entity (Prefix (High_Bound (N))) /= Def_Id - then - Def_Id := Empty; - end if; end if; R := N; @@ -19266,7 +19303,6 @@ package body Sem_Ch3 is if Is_Entity_Name (Prefix (N)) and then Comes_From_Source (N) - and then Is_Type (Entity (Prefix (N))) and then Is_Discrete_Type (Entity (Prefix (N))) then Def_Id := Entity (Prefix (N)); @@ -19372,25 +19408,30 @@ package body Sem_Ch3 is Set_First_Literal (Def_Id, First_Literal (T)); end if; - Set_Size_Info (Def_Id, (T)); - Set_RM_Size (Def_Id, RM_Size (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); + Set_Size_Info (Def_Id, (T)); + Set_RM_Size (Def_Id, RM_Size (T)); + Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); Set_Scalar_Range (Def_Id, R); Conditional_Delay (Def_Id, T); + -- In the subtype indication case inherit properties of the parent + if Nkind (N) = N_Subtype_Indication then + + -- It is enough to inherit predicate flags and not the predicate + -- functions, because predicates on an index type are illegal + -- anyway and the flags are enough to detect them. + Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N))); - end if; - -- In the subtype indication case, if the immediate parent of the - -- new subtype is nonstatic, then the subtype we create is nonstatic, - -- even if its bounds are static. + -- If the immediate parent of the new subtype is nonstatic, then + -- the subtype we create is nonstatic as well, even if its bounds + -- are static. - if Nkind (N) = N_Subtype_Indication - and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) - then - Set_Is_Non_Static_Subtype (Def_Id); + if not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) then + Set_Is_Non_Static_Subtype (Def_Id); + end if; end if; end if; @@ -19415,17 +19456,20 @@ package body Sem_Ch3 is ---------------------- procedure Set_Modular_Size (Bits : Int) is + Siz : Int; + begin Set_RM_Size (T, UI_From_Int (Bits)); - if Bits <= 8 then - Init_Esize (T, 8); + if Bits < System_Max_Binary_Modulus_Power then + Siz := 8; - elsif Bits <= 16 then - Init_Esize (T, 16); + while Siz < 128 loop + exit when Bits <= Siz; + Siz := Siz * 2; + end loop; - elsif Bits <= 32 then - Init_Esize (T, 32); + Init_Esize (T, Siz); else Init_Esize (T, System_Max_Binary_Modulus_Power); @@ -19440,14 +19484,14 @@ package body Sem_Ch3 is begin -- If the mod expression is (exactly) 2 * literal, where literal is - -- 64 or less,then almost certainly the * was meant to be **. Warn. + -- 128 or less,then almost certainly the * was meant to be **. Warn. if Warn_On_Suspicious_Modulus_Value and then Nkind (Mod_Expr) = N_Op_Multiply and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal and then Intval (Left_Opnd (Mod_Expr)) = Uint_2 and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal - and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64 + and then Intval (Right_Opnd (Mod_Expr)) <= Uint_128 then Error_Msg_N ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr); @@ -21487,14 +21531,6 @@ package body Sem_Ch3 is Related_Id : Entity_Id := Empty; Suffix : Character := ' ') return Entity_Id is - P : Node_Id; - Def_Id : Entity_Id; - Error_Node : Node_Id; - Full_View_Id : Entity_Id; - Subtype_Mark_Id : Entity_Id; - - May_Have_Null_Exclusion : Boolean; - procedure Check_Incomplete (T : Node_Id); -- Called to verify that an incomplete type is not used prematurely @@ -21519,6 +21555,16 @@ package body Sem_Ch3 is end if; end Check_Incomplete; + -- Local variables + + P : Node_Id; + Def_Id : Entity_Id; + Error_Node : Node_Id; + Full_View_Id : Entity_Id; + Subtype_Mark_Id : Entity_Id; + + May_Have_Null_Exclusion : Boolean; + -- Start of processing for Process_Subtype begin @@ -21539,20 +21585,12 @@ package body Sem_Ch3 is Check_Incomplete (S); P := Parent (S); - -- Ada 2005 (AI-231): Static check - - if Ada_Version >= Ada_2005 - and then Present (P) - and then Null_Exclusion_Present (P) - and then Nkind (P) /= N_Access_To_Object_Definition - and then not Is_Access_Type (Entity (S)) - then - Error_Msg_N ("`NOT NULL` only allowed for an access type", S); - end if; - - -- The following is ugly, can't we have a range or even a flag??? + -- The following mirroring of assertion in Null_Exclusion_Present is + -- ugly, can't we have a range, a static predicate or even a flag??? May_Have_Null_Exclusion := + Present (P) + and then Nkind (P) in N_Access_Definition | N_Access_Function_Definition | N_Access_Procedure_Definition @@ -21562,11 +21600,23 @@ package body Sem_Ch3 is | N_Derived_Type_Definition | N_Discriminant_Specification | N_Formal_Object_Declaration + | N_Function_Specification | N_Object_Declaration | N_Object_Renaming_Declaration | N_Parameter_Specification | N_Subtype_Declaration; + -- Ada 2005 (AI-231): Static check + + if Ada_Version >= Ada_2005 + and then May_Have_Null_Exclusion + and then Null_Exclusion_Present (P) + and then Nkind (P) /= N_Access_To_Object_Definition + and then not Is_Access_Type (Entity (S)) + then + Error_Msg_N ("`NOT NULL` only allowed for an access type", S); + end if; + -- Create an Itype that is a duplicate of Entity (S) but with the -- null-exclusion attribute. @@ -22440,8 +22490,8 @@ package body Sem_Ch3 is Check_Bound (Hi); if Errs then - Hi := Type_High_Bound (Standard_Long_Long_Integer); - Lo := Type_Low_Bound (Standard_Long_Long_Integer); + Hi := Type_High_Bound (Standard_Long_Long_Long_Integer); + Lo := Type_Low_Bound (Standard_Long_Long_Long_Integer); end if; -- Find type to derive from @@ -22465,11 +22515,15 @@ package body Sem_Ch3 is Check_Restriction (No_Long_Long_Integers, Def); Base_Typ := Base_Type (Standard_Long_Long_Integer); + elsif Can_Derive_From (Standard_Long_Long_Long_Integer) then + Check_Restriction (No_Long_Long_Integers, Def); + Base_Typ := Base_Type (Standard_Long_Long_Long_Integer); + else - Base_Typ := Base_Type (Standard_Long_Long_Integer); + Base_Typ := Base_Type (Standard_Long_Long_Long_Integer); Error_Msg_N ("integer type definition bounds out of range", Def); - Hi := Type_High_Bound (Standard_Long_Long_Integer); - Lo := Type_Low_Bound (Standard_Long_Long_Integer); + Hi := Type_High_Bound (Standard_Long_Long_Long_Integer); + Lo := Type_Low_Bound (Standard_Long_Long_Long_Integer); end if; end if; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index bb29904..e94ce15 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -195,7 +195,7 @@ package Sem_Ch3 is (N : Node_Id; Related_Nod : Node_Id; Related_Id : Entity_Id := Empty; - Suffix_Index : Nat := 1); + Suffix_Index : Pos := 1); -- Process an index that is given in an array declaration, an entry -- family declaration or a loop iteration. The index is given by an index -- declaration (a 'box'), or by a discrete range. The later can be the name diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c92fb06..d06a4a8 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -976,7 +976,7 @@ package body Sem_Ch4 is Nam : Node_Id; X : Interp_Index; It : Interp; - Nam_Ent : Entity_Id; + Nam_Ent : Entity_Id := Empty; Success : Boolean := False; Deref : Boolean := False; @@ -1254,6 +1254,25 @@ package body Sem_Ch4 is Analyze_One_Call (N, Nam_Ent, True, Success); + -- If the nonoverloaded interpretation is a call to an abstract + -- nondispatching operation, then flag an error and return. + + -- Should this be incorporated in Remove_Abstract_Operations (which + -- currently only deals with cases where the name is overloaded)? ??? + + if Is_Overloadable (Nam_Ent) + and then Is_Abstract_Subprogram (Nam_Ent) + and then not Is_Dispatching_Operation (Nam_Ent) + then + Set_Etype (N, Any_Type); + + Error_Msg_Sloc := Sloc (Nam_Ent); + Error_Msg_NE + ("cannot call abstract operation& declared#", N, Nam_Ent); + + return; + end if; + -- If this is an indirect call, the return type of the access_to -- subprogram may be an incomplete type. At the point of the call, -- use the full type if available, and at the same time update the @@ -1452,6 +1471,46 @@ package body Sem_Ch4 is End_Interp_List; end if; + -- Check the accessibility level for actuals for explicitly aliased + -- formals. + + if Nkind (N) = N_Function_Call + and then Comes_From_Source (N) + and then Present (Nam_Ent) + and then In_Return_Value (N) + then + declare + Form : Node_Id; + Act : Node_Id; + begin + Act := First_Actual (N); + Form := First_Formal (Nam_Ent); + + while Present (Form) and then Present (Act) loop + -- Check whether the formal is aliased and if the accessibility + -- level of the actual is deeper than the accessibility level + -- of the enclosing subprogam to which the current return + -- statement applies. + + -- Should we be checking Is_Entity_Name on Act? Won't this miss + -- other cases ??? + + if Is_Explicitly_Aliased (Form) + and then Is_Entity_Name (Act) + and then Static_Accessibility_Level + (Act, Zero_On_Dynamic_Level) + > Subprogram_Access_Level (Current_Subprogram) + then + Error_Msg_N ("actual for explicitly aliased formal is too" + & " short lived", Act); + end if; + + Next_Formal (Form); + Next_Actual (Act); + end loop; + end; + end if; + if Ada_Version >= Ada_2012 then -- Check if the call contains a function with writable actuals @@ -3136,7 +3195,7 @@ package body Sem_Ch4 is begin -- A special warning check, if we have an expression of the form: -- expr mod 2 * literal - -- where literal is 64 or less, then probably what was meant was + -- where literal is 128 or less, then probably what was meant was -- expr mod 2 ** literal -- so issue an appropriate warning. @@ -3145,7 +3204,7 @@ package body Sem_Ch4 is and then Intval (Right_Opnd (N)) = Uint_2 and then Nkind (Parent (N)) = N_Op_Multiply and then Nkind (Right_Opnd (Parent (N))) = N_Integer_Literal - and then Intval (Right_Opnd (Parent (N))) <= Uint_64 + and then Intval (Right_Opnd (Parent (N))) <= Uint_128 then Error_Msg_N ("suspicious MOD value, was '*'* intended'??M?", Parent (N)); @@ -4220,6 +4279,7 @@ package body Sem_Ch4 is if Warn_On_Suspicious_Contract and then not Referenced (Loop_Id, Cond) + and then not Is_Internal_Name (Chars (Loop_Id)) then -- Generating C, this check causes spurious warnings on inlined -- postconditions; we can safely disable it because this check @@ -8990,16 +9050,20 @@ package body Sem_Ch4 is Rewrite (First_Actual, Obj); end if; - -- The operation is obtained from the dispatch table and not by - -- visibility, and may be declared in a unit that is not explicitly - -- referenced in the source, but is nevertheless required in the - -- context of the current unit. Indicate that operation and its scope - -- are referenced, to prevent spurious and misleading warnings. If - -- the operation is overloaded, all primitives are in the same scope - -- and we can use any of them. + if In_Extended_Main_Source_Unit (Current_Scope) then + -- The operation is obtained from the dispatch table and not by + -- visibility, and may be declared in a unit that is not + -- explicitly referenced in the source, but is nevertheless + -- required in the context of the current unit. Indicate that + -- operation and its scope are referenced, to prevent spurious and + -- misleading warnings. If the operation is overloaded, all + -- primitives are in the same scope and we can use any of them. + -- Don't do that outside the main unit since otherwise this will + -- e.g. prevent the detection of some unused with clauses. - Set_Referenced (Entity (Subprog), True); - Set_Referenced (Scope (Entity (Subprog)), True); + Set_Referenced (Entity (Subprog), True); + Set_Referenced (Scope (Entity (Subprog)), True); + end if; Rewrite (Node_To_Replace, Call_Node); @@ -9338,6 +9402,7 @@ package body Sem_Ch4 is Error_Msg_NE ("ambiguous call to&", N, Hom); Report_Ambiguity (Matching_Op); Report_Ambiguity (Hom); + Check_Ambiguous_Aggregate (New_Call_Node); Error := True; return; end if; @@ -9960,6 +10025,7 @@ package body Sem_Ch4 is Error_Msg_NE ("ambiguous call to&", N, Prim_Op); Report_Ambiguity (Matching_Op); Report_Ambiguity (Prim_Op); + Check_Ambiguous_Aggregate (Call_Node); return True; end if; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 336507a..2afe18b 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -59,6 +59,7 @@ with Stand; use Stand; with Sinfo; use Sinfo; with Targparm; use Targparm; with Tbuild; use Tbuild; +with Ttypes; use Ttypes; with Uintp; use Uintp; package body Sem_Ch5 is @@ -1049,7 +1050,8 @@ package body Sem_Ch5 is if not Support_Composite_Assign_On_Target and then (Is_Array_Type (T1) or else Is_Record_Type (T1)) - and then (not Has_Size_Clause (T1) or else Esize (T1) > 64) + and then (not Has_Size_Clause (T1) + or else Esize (T1) > Ttypes.System_Max_Integer_Size) then Error_Msg_CRT ("composite assignment", N); end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index ed1c326..88bbdf7 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -306,8 +306,6 @@ package body Sem_Ch6 is -- If the expression is a completion, Prev is the entity whose -- declaration is completed. Def_Id is needed to analyze the spec. - -- Start of processing for Analyze_Expression_Function - begin -- This is one of the occasions on which we transform the tree during -- semantic analysis. If this is a completion, transform the expression @@ -611,6 +609,12 @@ package body Sem_Ch6 is Set_Expression (Original_Node (Subprogram_Spec (Def_Id)), New_Copy_Tree (Expr)); + + -- Mark static expression functions as inlined, to ensure + -- that even calls with nonstatic actuals will be inlined. + + Set_Has_Pragma_Inline (Def_Id); + Set_Is_Inlined (Def_Id); end if; end if; end; @@ -668,9 +672,9 @@ package body Sem_Ch6 is end if; end Analyze_Expression_Function; - ---------------------------------------- - -- Analyze_Extended_Return_Statement -- - ---------------------------------------- + --------------------------------------- + -- Analyze_Extended_Return_Statement -- + --------------------------------------- procedure Analyze_Extended_Return_Statement (N : Node_Id) is begin @@ -780,20 +784,19 @@ package body Sem_Ch6 is ------------------------------------------ procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is - Assoc : Node_Id; - Agg : Node_Id := Empty; - Discr : Entity_Id; - Expr : Node_Id; - Obj : Node_Id; - Process_Exprs : Boolean := False; - Return_Con : Node_Id; + Return_Con : Node_Id; + Assoc : Node_Id := Empty; + Assoc_Expr : Node_Id; + Disc : Entity_Id; + Obj_Decl : Node_Id; + Unqual : Node_Id; begin -- Only perform checks on record types with access discriminants and -- non-internally generated functions. if not Is_Record_Type (R_Type) - or else not Has_Discriminants (R_Type) + or else not Has_Anonymous_Access_Discriminant (R_Type) or else not Comes_From_Source (Return_Stmt) then return; @@ -833,166 +836,219 @@ package body Sem_Ch6 is Return_Con := Original_Node (Return_Con); else - Return_Con := Return_Stmt; + Return_Con := Expression (Return_Stmt); end if; - -- We may need to check an aggregate or a subtype indication - -- depending on how the discriminants were specified and whether - -- we are looking at an extended return statement. + -- Obtain the accessibility levels of the expressions associated + -- with all anonymous access discriminants, then generate a + -- dynamic check or static error when relevant. - if Nkind (Return_Con) = N_Object_Declaration - and then Nkind (Object_Definition (Return_Con)) - = N_Subtype_Indication + Unqual := Unqualify (Original_Node (Return_Con)); + + -- Obtain the corresponding declaration based on the return object's + -- identifier. + + if Nkind (Unqual) = N_Identifier + and then Nkind (Parent (Entity (Unqual))) + in N_Object_Declaration + | N_Object_Renaming_Declaration then - Assoc := Original_Node - (First - (Constraints - (Constraint (Object_Definition (Return_Con))))); + Obj_Decl := Original_Node (Parent (Entity (Unqual))); + + -- We were passed the object declaration directly, so use it + + elsif Nkind (Unqual) in N_Object_Declaration + | N_Object_Renaming_Declaration + then + Obj_Decl := Unqual; + + -- Otherwise, we are looking at something else + else - -- Qualified expressions may be nested + Obj_Decl := Empty; - Agg := Original_Node (Expression (Return_Con)); - while Nkind (Agg) = N_Qualified_Expression loop - Agg := Original_Node (Expression (Agg)); - end loop; + end if; + + -- Hop up object renamings when present + + if Present (Obj_Decl) + and then Nkind (Obj_Decl) = N_Object_Renaming_Declaration + then + while Nkind (Obj_Decl) = N_Object_Renaming_Declaration loop - -- If we are looking at an aggregate instead of a function call we - -- can continue checking accessibility for the supplied - -- discriminant associations. + if Nkind (Name (Obj_Decl)) not in N_Entity then + -- We may be looking at the expansion of iterators or + -- some other internally generated construct, so it is safe + -- to ignore checks ??? + + if not Comes_From_Source (Obj_Decl) then + return; + end if; + + Obj_Decl := Original_Node + (Declaration_Node + (Ultimate_Prefix (Name (Obj_Decl)))); + + -- Move up to the next declaration based on the object's name - if Nkind (Agg) = N_Aggregate then - if Present (Expressions (Agg)) then - Assoc := First (Expressions (Agg)); - Process_Exprs := True; else - Assoc := First (Component_Associations (Agg)); + Obj_Decl := Original_Node + (Declaration_Node (Name (Obj_Decl))); end if; + end loop; + end if; - -- Otherwise the expression is not of interest ??? + -- Obtain the discriminant values from the return aggregate + -- Do we cover extension aggregates correctly ??? + + if Nkind (Unqual) = N_Aggregate then + if Present (Expressions (Unqual)) then + Assoc := First (Expressions (Unqual)); else - return; + Assoc := First (Component_Associations (Unqual)); end if; - end if; - -- Move through the discriminants checking the accessibility level - -- of each co-extension's associated expression. + -- There is an object declaration for the return object - Discr := First_Discriminant (R_Type); - while Present (Discr) loop - if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + elsif Present (Obj_Decl) then + -- When a subtype indication is present in an object declaration + -- it must contain the object's discriminants. + + if Nkind (Object_Definition (Obj_Decl)) = N_Subtype_Indication then + Assoc := First + (Constraints + (Constraint + (Object_Definition (Obj_Decl)))); + + -- The object declaration contains an aggregate + + elsif Present (Expression (Obj_Decl)) then + + if Nkind (Unqualify (Expression (Obj_Decl))) = N_Aggregate then + -- Grab the first associated discriminant expresion + + if Present + (Expressions (Unqualify (Expression (Obj_Decl)))) + then + Assoc := First + (Expressions + (Unqualify (Expression (Obj_Decl)))); + else + Assoc := First + (Component_Associations + (Unqualify (Expression (Obj_Decl)))); + end if; + + -- Otherwise, this is something else - if Nkind (Assoc) = N_Attribute_Reference then - Expr := Assoc; - elsif Nkind (Assoc) in - N_Component_Association | N_Discriminant_Association - then - Expr := Expression (Assoc); else - Expr := Empty; + return; end if; - -- This anonymous access discriminant has an associated - -- expression which needs checking. + -- There are no supplied discriminants in the object declaration, + -- so get them from the type definition since they must be default + -- initialized. - if Present (Expr) - and then Nkind (Expr) = N_Attribute_Reference - and then Attribute_Name (Expr) /= Name_Unrestricted_Access - then - -- Obtain the object to perform static checks on by moving - -- up the prefixes in the expression taking into account - -- named access types and renamed objects within the - -- expression. + -- Do we handle constrained subtypes correctly ??? - -- Note, this loop duplicates some of the logic in - -- Object_Access_Level since we have to check special rules - -- based on the context we are in (a return aggregate) - -- relating to formals of the current function. + elsif Nkind (Unqual) = N_Object_Declaration then + Assoc := First_Discriminant + (Etype (Object_Definition (Obj_Decl))); - Obj := Original_Node (Prefix (Expr)); - loop - while Nkind (Obj) in N_Explicit_Dereference - | N_Indexed_Component - | N_Selected_Component - loop - -- When we encounter a named access type then we can - -- ignore accessibility checks on the dereference. - - if Ekind (Etype (Original_Node (Prefix (Obj)))) - in E_Access_Type .. - E_Access_Protected_Subprogram_Type - then - if Nkind (Obj) = N_Selected_Component then - Obj := Selector_Name (Obj); - else - Obj := Original_Node (Prefix (Obj)); - end if; - exit; - end if; + else + Assoc := First_Discriminant (Etype (Unqual)); + end if; - Obj := Original_Node (Prefix (Obj)); - end loop; + -- When we are not looking at an aggregate or an identifier, return + -- since any other construct (like a function call) is not + -- applicable since checks will be performed on the side of the + -- callee. - if Nkind (Obj) = N_Selected_Component then - Obj := Selector_Name (Obj); - end if; + else + return; + end if; - -- Check for renamings + -- Obtain the discriminants so we know the actual type in case the + -- value of their associated expression gets implicitly converted. - pragma Assert (Is_Entity_Name (Obj)); + if No (Obj_Decl) then + pragma Assert (Nkind (Unqual) = N_Aggregate); - if Present (Renamed_Object (Entity (Obj))) then - Obj := Renamed_Object (Entity (Obj)); - else - exit; - end if; - end loop; + Disc := First_Discriminant (Etype (Unqual)); - -- Do not check aliased formals statically + else + Disc := First_Discriminant + (Etype (Defining_Identifier (Obj_Decl))); + end if; - if Is_Formal (Entity (Obj)) - and then (Is_Aliased (Entity (Obj)) - or else Ekind (Etype (Entity (Obj))) = - E_Anonymous_Access_Type) - then - null; + -- Loop through each of the discriminants and check each expression + -- associated with an anonymous access discriminant. - -- Otherwise, handle the expression normally, avoiding the - -- special logic above, and call Object_Access_Level with - -- the original expression. + while Present (Assoc) and then Present (Disc) loop + -- Unwrap the associated expression - elsif Object_Access_Level (Expr) > - Scope_Depth (Scope (Scope_Id)) - then - Error_Msg_N - ("access discriminant in return aggregate would " - & "be a dangling reference", Obj); - end if; - end if; - end if; + if Nkind (Assoc) + in N_Component_Association | N_Discriminant_Association + then + Assoc_Expr := Expression (Assoc); - Next_Discriminant (Discr); + elsif Nkind (Assoc) in N_Entity + and then Ekind (Assoc) = E_Discriminant + then + Assoc_Expr := Discriminant_Default_Value (Assoc); - if not Is_List_Member (Assoc) then - Assoc := Empty; else - Nlists.Next (Assoc); + Assoc_Expr := Assoc; end if; - -- After aggregate expressions, examine component associations if - -- present. + -- Check the accessibility level of the expression when the + -- discriminant is of an anonymous access type. + + if Present (Assoc_Expr) + and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type + then + -- Perform a static check first, if possible - if No (Assoc) then - if Present (Agg) - and then Process_Exprs - and then Present (Component_Associations (Agg)) + if Static_Accessibility_Level + (Expr => Assoc_Expr, + Level => Zero_On_Dynamic_Level, + In_Return_Context => True) + > Scope_Depth (Scope (Scope_Id)) then - Assoc := First (Component_Associations (Agg)); - Process_Exprs := False; - else + Error_Msg_N + ("access discriminant in return object would be a dangling" + & " reference", Return_Stmt); exit; + + end if; + + -- Otherwise, generate a dynamic check based on the extra + -- accessibility of the result. + + if Present (Extra_Accessibility_Of_Result (Scope_Id)) then + Insert_Before_And_Analyze (Return_Stmt, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Accessibility_Level + (Expr => Assoc_Expr, + Level => Dynamic_Level, + In_Return_Context => True), + Right_Opnd => Extra_Accessibility_Of_Result + (Scope_Id)), + Reason => PE_Accessibility_Check_Failed)); end if; end if; + + -- Iterate over the discriminants + + Disc := Next_Discriminant (Disc); + if not Is_List_Member (Assoc) then + exit; + else + Nlists.Next (Assoc); + end if; end loop; end Check_Return_Construct_Accessibility; @@ -1432,8 +1488,8 @@ package body Sem_Ch6 is if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) and then Is_Limited_View (Etype (Scope_Id)) - and then Object_Access_Level (Expr) > - Subprogram_Access_Level (Scope_Id) + and then Static_Accessibility_Level (Expr, Zero_On_Dynamic_Level) + > Subprogram_Access_Level (Scope_Id) then -- Suppress the message in a generic, where the rewriting -- is irrelevant. @@ -2574,6 +2630,9 @@ package body Sem_Ch6 is Loc : constant Source_Ptr := Sloc (N); Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); + Body_Nod : Node_Id := Empty; + Minimum_Acc_Objs : List_Id := No_List; + Conformant : Boolean; Desig_View : Entity_Id := Empty; Exch_Views : Elist_Id := No_Elist; @@ -2658,6 +2717,13 @@ package body Sem_Ch6 is -- limited views with the non-limited ones. Return the list of changes -- to be used to undo the transformation. + procedure Generate_Minimum_Accessibility + (Extra_Access : Entity_Id; + Related_Form : Entity_Id := Empty); + -- Generate a minimum accessibility object for a given extra + -- accessibility formal (Extra_Access) and its related formal if it + -- exists. + function Is_Private_Concurrent_Primitive (Subp_Id : Entity_Id) return Boolean; -- Determine whether subprogram Subp_Id is a primitive of a concurrent @@ -3435,6 +3501,66 @@ package body Sem_Ch6 is return Result; end Exchange_Limited_Views; + ------------------------------------ + -- Generate_Minimum_Accessibility -- + ------------------------------------ + + procedure Generate_Minimum_Accessibility + (Extra_Access : Entity_Id; + Related_Form : Entity_Id := Empty) + is + Loc : constant Source_Ptr := Sloc (Body_Nod); + Form : Entity_Id; + Obj_Node : Node_Id; + begin + -- When no related formal exists then we are dealing with an + -- extra accessibility formal for a function result. + + if No (Related_Form) then + Form := Extra_Access; + else + Form := Related_Form; + end if; + + -- Create the minimum accessibility object + + Obj_Node := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Temporary + (Loc, 'A', Extra_Access), + Object_Definition => New_Occurrence_Of + (Standard_Natural, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of + (Standard_Natural, Loc), + Attribute_Name => Name_Min, + Expressions => New_List ( + Make_Integer_Literal (Loc, + Scope_Depth (Body_Id)), + New_Occurrence_Of + (Extra_Access, Loc)))); + + -- Add the new local object to the Minimum_Acc_Obj to + -- be later prepended to the subprogram's list of + -- declarations after we are sure all expansion is + -- done. + + if Present (Minimum_Acc_Objs) then + Prepend (Obj_Node, Minimum_Acc_Objs); + else + Minimum_Acc_Objs := New_List (Obj_Node); + end if; + + -- Register the object and analyze it + + Set_Minimum_Accessibility + (Form, Defining_Identifier (Obj_Node)); + + Analyze (Obj_Node); + end Generate_Minimum_Accessibility; + ------------------------------------- -- Is_Private_Concurrent_Primitive -- ------------------------------------- @@ -3766,9 +3892,6 @@ package body Sem_Ch6 is -- Local variables - Body_Nod : Node_Id := Empty; - Minimum_Acc_Objs : List_Id := No_List; - Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; Saved_IGR : constant Node_Id := Ignored_Ghost_Region; Saved_EA : constant Boolean := Expander_Active; @@ -4646,7 +4769,7 @@ package body Sem_Ch6 is -- This method is used to supplement our "small integer model" for -- accessibility-check generation (for more information see - -- Dynamic_Accessibility_Level). + -- Accessibility_Level). -- Because we allow accessibility values greater than our expected value -- passing along the same extra accessibility formal as an actual @@ -4695,50 +4818,33 @@ package body Sem_Ch6 is then -- Generate the minimum accessibility level object - -- A60b : natural := natural'min(1, paramL); + -- A60b : constant natural := natural'min(1, paramL); - declare - Loc : constant Source_Ptr := Sloc (Body_Nod); - Obj_Node : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Temporary - (Loc, 'A', Extra_Accessibility (Form)), - Object_Definition => New_Occurrence_Of - (Standard_Natural, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of - (Standard_Natural, Loc), - Attribute_Name => Name_Min, - Expressions => New_List ( - Make_Integer_Literal (Loc, - Object_Access_Level (Form)), - New_Occurrence_Of - (Extra_Accessibility (Form), Loc)))); - begin - -- Add the new local object to the Minimum_Acc_Obj to - -- be later prepended to the subprogram's list of - -- declarations after we are sure all expansion is - -- done. + Generate_Minimum_Accessibility + (Extra_Accessibility (Form), Form); + end if; - if Present (Minimum_Acc_Objs) then - Prepend (Obj_Node, Minimum_Acc_Objs); - else - Minimum_Acc_Objs := New_List (Obj_Node); - end if; + Next_Formal (Form); + end loop; - -- Register the object and analyze it + -- Generate the minimum accessibility level object for the + -- function's Extra_Accessibility_Of_Result. - Set_Minimum_Accessibility - (Form, Defining_Identifier (Obj_Node)); + -- A31b : constant natural := natural'min (2, funcL); - Analyze (Obj_Node); - end; - end if; + if Ekind (Body_Id) = E_Function + and then Present (Extra_Accessibility_Of_Result (Body_Id)) + then + Generate_Minimum_Accessibility + (Extra_Accessibility_Of_Result (Body_Id)); - Next_Formal (Form); - end loop; + -- Replace the Extra_Accessibility_Of_Result with the new + -- minimum accessibility object. + + Set_Extra_Accessibility_Of_Result + (Body_Id, Minimum_Accessibility + (Extra_Accessibility_Of_Result (Body_Id))); + end if; end if; end; end if; @@ -9120,10 +9226,27 @@ package body Sem_Ch6 is ("equality operator appears too late (Ada 2012)?y?", Eq_Op); end if; - -- No error detected + -- Finally check for AI12-0352: declaration of a user-defined primitive + -- equality operation for a record type T is illegal if it occurs after + -- a type has been derived from T. else - return; + Obj_Decl := Next (Parent (Typ)); + + while Present (Obj_Decl) and then Obj_Decl /= Decl loop + if Nkind (Obj_Decl) = N_Full_Type_Declaration + and then Etype (Defining_Identifier (Obj_Decl)) = Typ + then + Error_Msg_N + ("equality operator cannot appear after derivation", Eq_Op); + Error_Msg_NE + ("an equality operator for& cannot be declared after " + & "this point??", + Obj_Decl, Typ); + end if; + + Next (Obj_Decl); + end loop; end if; end Check_Untagged_Equality; @@ -12261,6 +12384,27 @@ package body Sem_Ch6 is end if; end if; + -- Deal with aspects on formal parameters. Only Unreferenced is + -- supported for the time being. + + if Has_Aspects (Param_Spec) then + declare + Aspect : Node_Id := First (Aspect_Specifications (Param_Spec)); + begin + while Present (Aspect) loop + if Chars (Identifier (Aspect)) = Name_Unreferenced then + Set_Has_Pragma_Unreferenced (Formal); + else + Error_Msg_NE + ("unsupported aspect& on parameter", + Aspect, Identifier (Aspect)); + end if; + + Next (Aspect); + end loop; + end; + end if; + <<Continue>> Next (Param_Spec); end loop; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 3ff2001..762f0c1 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -40,6 +40,7 @@ with Exp_Dist; use Exp_Dist; with Exp_Dbug; use Exp_Dbug; with Freeze; use Freeze; with Ghost; use Ghost; +with GNAT_CUDA; use GNAT_CUDA; with Lib; use Lib; with Lib.Xref; use Lib.Xref; with Namet; use Namet; @@ -999,6 +1000,13 @@ package body Sem_Ch7 is Analyze_List (Declarations (N)); end if; + -- If procedures marked with CUDA_Global have been defined within N, we + -- need to register them with the CUDA runtime at program startup. This + -- requires multiple declarations and function calls which need to be + -- appended to N's declarations. + + Build_And_Insert_CUDA_Initialization (N); + HSS := Handled_Statement_Sequence (N); if Present (HSS) then @@ -2725,6 +2733,7 @@ package body Sem_Ch7 is Set_Has_Pragma_Unreferenced_Objects (Priv, Has_Pragma_Unreferenced_Objects (Full)); + Set_Predicates_Ignored (Priv, Predicates_Ignored (Full)); if Is_Unchecked_Union (Full) then Set_Is_Unchecked_Union (Base_Type (Priv)); end if; @@ -3184,6 +3193,25 @@ package body Sem_Ch7 is end loop; end; + -- For subtypes of private types the frontend generates two entities: + -- one associated with the partial view and the other associated with + -- the full view. When the subtype declaration is public the frontend + -- places the former entity in the list of public entities of the + -- package and the latter entity in the private part of the package. + -- When the subtype declaration is private it generates these two + -- entities but both are placed in the private part of the package + -- (and the full view has the same source location as the partial + -- view and no parent; see Prepare_Private_Subtype_Completion). + + elsif Ekind (Id) in E_Private_Subtype + | E_Limited_Private_Subtype + and then Present (Full_View (Id)) + and then Sloc (Id) = Sloc (Full_View (Id)) + and then No (Parent (Full_View (Id))) + then + Set_Is_Hidden (Id); + Set_Is_Potentially_Use_Visible (Id, False); + elsif not Is_Child_Unit (Id) and then (not Is_Private_Type (Id) or else No (Full_View (Id))) then diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 3c10a96..35c6f60 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -52,6 +52,7 @@ with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch6; use Sem_Ch6; +with Sem_Ch10; use Sem_Ch10; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Dim; use Sem_Dim; @@ -776,8 +777,9 @@ package body Sem_Ch8 is ------------------------------ procedure Check_Constrained_Object is - Typ : constant Entity_Id := Etype (Nam); - Subt : Entity_Id; + Typ : constant Entity_Id := Etype (Nam); + Subt : Entity_Id; + Loop_Scheme : Node_Id; begin if Nkind (Nam) in N_Function_Call | N_Explicit_Dereference @@ -821,6 +823,29 @@ package body Sem_Ch8 is Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc)); Set_Etype (Nam, Subt); + -- Suppress discriminant checks on this subtype if the original + -- type has defaulted discriminants and Id is a "for of" loop + -- iterator. + + if Has_Defaulted_Discriminants (Typ) + and then Nkind (Original_Node (Parent (N))) = N_Loop_Statement + then + Loop_Scheme := Iteration_Scheme (Original_Node (Parent (N))); + + if Present (Loop_Scheme) + and then Present (Iterator_Specification (Loop_Scheme)) + and then + Defining_Identifier + (Iterator_Specification (Loop_Scheme)) = Id + then + Set_Checks_May_Be_Suppressed (Subt); + Push_Local_Suppress_Stack_Entry + (Entity => Subt, + Check => Discriminant_Check, + Suppress => True); + end if; + end if; + -- Freeze subtype at once, to prevent order of elaboration -- issues in the backend. The renamed object exists, so its -- type is already frozen in any case. @@ -1520,6 +1545,21 @@ package body Sem_Ch8 is Set_Ekind (New_P, E_Package); Set_Etype (New_P, Standard_Void_Type); + elsif Present (Renamed_Entity (Old_P)) + and then (From_Limited_With (Renamed_Entity (Old_P)) + or else Has_Limited_View (Renamed_Entity (Old_P))) + and then not + Unit_Is_Visible (Cunit (Get_Source_Unit (Renamed_Entity (Old_P)))) + then + Error_Msg_NE + ("renaming of limited view of package & not usable in this context" + & " (RM 8.5.3(3.1/2))", Name (N), Renamed_Entity (Old_P)); + + -- Set basic attributes to minimize cascaded errors + + Set_Ekind (New_P, E_Package); + Set_Etype (New_P, Standard_Void_Type); + -- Here for OK package renaming else @@ -2965,16 +3005,7 @@ package body Sem_Ch8 is -- Check whether the renaming is for a defaulted actual subprogram -- with a class-wide actual. - -- The class-wide wrapper is not needed in GNATprove_Mode and there - -- is an external axiomatization on the package. - - if CW_Actual - and then Box_Present (Inst_Node) - and then not - (GNATprove_Mode - and then - Present (Containing_Package_With_Ext_Axioms (Formal_Spec))) - then + if CW_Actual and then Box_Present (Inst_Node) then Build_Class_Wide_Wrapper (New_S, Old_S); elsif Is_Entity_Name (Nam) @@ -3834,29 +3865,6 @@ package body Sem_Ch8 is Ada_Version_Pragma := Save_AVP; Ada_Version_Explicit := Save_AV_Exp; - -- In GNATprove mode, the renamings of actual subprograms are replaced - -- with wrapper functions that make it easier to propagate axioms to the - -- points of call within an instance. Wrappers are generated if formal - -- subprogram is subject to axiomatization. - - -- The types in the wrapper profiles are obtained from (instances of) - -- the types of the formal subprogram. - - if Is_Actual - and then GNATprove_Mode - and then Present (Containing_Package_With_Ext_Axioms (Formal_Spec)) - and then not Inside_A_Generic - then - if Ekind (Old_S) = E_Function then - Rewrite (N, Build_Function_Wrapper (Formal_Spec, Old_S)); - Analyze (N); - - elsif Ekind (Old_S) = E_Operator then - Rewrite (N, Build_Operator_Wrapper (Formal_Spec, Old_S)); - Analyze (N); - end if; - end if; - -- Check if we are looking at an Ada 2012 defaulted formal subprogram -- and mark any use_package_clauses that affect the visibility of the -- implicit generic actual. @@ -5013,12 +5021,7 @@ package body Sem_Ch8 is -- Find_Direct_Name -- ---------------------- - procedure Find_Direct_Name - (N : Node_Id; - Errors_OK : Boolean := True; - Marker_OK : Boolean := True; - Reference_OK : Boolean := True) - is + procedure Find_Direct_Name (N : Node_Id) is E : Entity_Id; E2 : Entity_Id; Msg : Boolean; @@ -5285,10 +5288,6 @@ package body Sem_Ch8 is Item : Node_Id; begin - if not Errors_OK then - return; - end if; - -- Ada 2005 (AI-262): Generate a precise error concerning the -- Beaujolais effect that was previously detected @@ -5456,8 +5455,7 @@ package body Sem_Ch8 is -- Named aggregate should also be handled similarly ??? - if Errors_OK - and then Nkind (N) = N_Identifier + if Nkind (N) = N_Identifier and then Nkind (Parent (N)) = N_Case_Statement_Alternative then declare @@ -5493,122 +5491,114 @@ package body Sem_Ch8 is Set_Entity (N, Any_Id); Set_Etype (N, Any_Type); - if Errors_OK then - - -- We use the table Urefs to keep track of entities for which we - -- have issued errors for undefined references. Multiple errors - -- for a single name are normally suppressed, however we modify - -- the error message to alert the programmer to this effect. + -- We use the table Urefs to keep track of entities for which we + -- have issued errors for undefined references. Multiple errors + -- for a single name are normally suppressed, however we modify + -- the error message to alert the programmer to this effect. - for J in Urefs.First .. Urefs.Last loop - if Chars (N) = Chars (Urefs.Table (J).Node) then - if Urefs.Table (J).Err /= No_Error_Msg - and then Sloc (N) /= Urefs.Table (J).Loc - then - Error_Msg_Node_1 := Urefs.Table (J).Node; - - if Urefs.Table (J).Nvis then - Change_Error_Text (Urefs.Table (J).Err, - "& is not visible (more references follow)"); - else - Change_Error_Text (Urefs.Table (J).Err, - "& is undefined (more references follow)"); - end if; + for J in Urefs.First .. Urefs.Last loop + if Chars (N) = Chars (Urefs.Table (J).Node) then + if Urefs.Table (J).Err /= No_Error_Msg + and then Sloc (N) /= Urefs.Table (J).Loc + then + Error_Msg_Node_1 := Urefs.Table (J).Node; - Urefs.Table (J).Err := No_Error_Msg; + if Urefs.Table (J).Nvis then + Change_Error_Text (Urefs.Table (J).Err, + "& is not visible (more references follow)"); + else + Change_Error_Text (Urefs.Table (J).Err, + "& is undefined (more references follow)"); end if; - -- Although we will set Msg False, and thus suppress the - -- message, we also set Error_Posted True, to avoid any - -- cascaded messages resulting from the undefined reference. - - Msg := False; - Set_Error_Posted (N); - return; + Urefs.Table (J).Err := No_Error_Msg; end if; - end loop; - -- If entry not found, this is first undefined occurrence + -- Although we will set Msg False, and thus suppress the + -- message, we also set Error_Posted True, to avoid any + -- cascaded messages resulting from the undefined reference. - if Nvis then - Error_Msg_N ("& is not visible!", N); - Emsg := Get_Msg_Id; + Msg := False; + Set_Error_Posted (N); + return; + end if; + end loop; - else - Error_Msg_N ("& is undefined!", N); - Emsg := Get_Msg_Id; + -- If entry not found, this is first undefined occurrence - -- A very bizarre special check, if the undefined identifier - -- is Put or Put_Line, then add a special error message (since - -- this is a very common error for beginners to make). + if Nvis then + Error_Msg_N ("& is not visible!", N); + Emsg := Get_Msg_Id; - if Chars (N) in Name_Put | Name_Put_Line then - Error_Msg_N -- CODEFIX - ("\\possible missing `WITH Ada.Text_'I'O; " & - "USE Ada.Text_'I'O`!", N); + else + Error_Msg_N ("& is undefined!", N); + Emsg := Get_Msg_Id; - -- Another special check if N is the prefix of a selected - -- component which is a known unit: add message complaining - -- about missing with for this unit. + -- A very bizarre special check, if the undefined identifier + -- is Put or Put_Line, then add a special error message (since + -- this is a very common error for beginners to make). - elsif Nkind (Parent (N)) = N_Selected_Component - and then N = Prefix (Parent (N)) - and then Is_Known_Unit (Parent (N)) - then - Error_Msg_Node_2 := Selector_Name (Parent (N)); - Error_Msg_N -- CODEFIX - ("\\missing `WITH &.&;`", Prefix (Parent (N))); - end if; + if Chars (N) in Name_Put | Name_Put_Line then + Error_Msg_N -- CODEFIX + ("\\possible missing `WITH Ada.Text_'I'O; " & + "USE Ada.Text_'I'O`!", N); - -- Now check for possible misspellings + -- Another special check if N is the prefix of a selected + -- component which is a known unit: add message complaining + -- about missing with for this unit. - declare - E : Entity_Id; - Ematch : Entity_Id := Empty; + elsif Nkind (Parent (N)) = N_Selected_Component + and then N = Prefix (Parent (N)) + and then Is_Known_Unit (Parent (N)) + then + Error_Msg_Node_2 := Selector_Name (Parent (N)); + Error_Msg_N -- CODEFIX + ("\\missing `WITH &.&;`", Prefix (Parent (N))); + end if; - Last_Name_Id : constant Name_Id := - Name_Id (Nat (First_Name_Id) + - Name_Entries_Count - 1); + -- Now check for possible misspellings - begin - for Nam in First_Name_Id .. Last_Name_Id loop - E := Get_Name_Entity_Id (Nam); + declare + E : Entity_Id; + Ematch : Entity_Id := Empty; + begin + for Nam in First_Name_Id .. Last_Name_Id loop + E := Get_Name_Entity_Id (Nam); - if Present (E) - and then (Is_Immediately_Visible (E) - or else - Is_Potentially_Use_Visible (E)) - then - if Is_Bad_Spelling_Of (Chars (N), Nam) then - Ematch := E; - exit; - end if; + if Present (E) + and then (Is_Immediately_Visible (E) + or else + Is_Potentially_Use_Visible (E)) + then + if Is_Bad_Spelling_Of (Chars (N), Nam) then + Ematch := E; + exit; end if; - end loop; - - if Present (Ematch) then - Error_Msg_NE -- CODEFIX - ("\possible misspelling of&", N, Ematch); end if; - end; - end if; + end loop; - -- Make entry in undefined references table unless the full errors - -- switch is set, in which case by refraining from generating the - -- table entry we guarantee that we get an error message for every - -- undefined reference. The entry is not added if we are ignoring - -- errors. + if Present (Ematch) then + Error_Msg_NE -- CODEFIX + ("\possible misspelling of&", N, Ematch); + end if; + end; + end if; - if not All_Errors_Mode and then Ignore_Errors_Enable = 0 then - Urefs.Append ( - (Node => N, - Err => Emsg, - Nvis => Nvis, - Loc => Sloc (N))); - end if; + -- Make entry in undefined references table unless the full errors + -- switch is set, in which case by refraining from generating the + -- table entry we guarantee that we get an error message for every + -- undefined reference. The entry is not added if we are ignoring + -- errors. - Msg := True; + if not All_Errors_Mode and then Ignore_Errors_Enable = 0 then + Urefs.Append ( + (Node => N, + Err => Emsg, + Nvis => Nvis, + Loc => Sloc (N))); end if; + + Msg := True; end Undefined; -- Local variables @@ -5627,6 +5617,21 @@ package body Sem_Ch8 is if Is_Type (Entity (N)) then Set_Etype (N, Entity (N)); + -- The exception to this general rule are constants associated with + -- discriminals of protected types because for each protected op + -- a new set of discriminals is internally created by the frontend + -- (see Exp_Ch9.Set_Discriminals), and the current decoration of the + -- entity pointer may have been set as part of a preanalysis, where + -- discriminals still reference the first subprogram or entry to be + -- expanded (see Expand_Protected_Body_Declarations). + + elsif Full_Analysis + and then Ekind (Entity (N)) = E_Constant + and then Present (Discriminal_Link (Entity (N))) + and then Is_Protected_Type (Scope (Discriminal_Link (Entity (N)))) + then + goto Find_Name; + else declare Entyp : constant Entity_Id := Etype (Entity (N)); @@ -5667,6 +5672,8 @@ package body Sem_Ch8 is return; end if; + <<Find_Name>> + -- Preserve relevant elaboration-related attributes of the context which -- are no longer available or very expensive to recompute once analysis, -- resolution, and expansion are over. @@ -5714,6 +5721,12 @@ package body Sem_Ch8 is E := Homonym (E); end loop; + -- If we are ignoring errors, skip the error processing + + if Get_Ignore_Errors then + return; + end if; + -- If no entries on homonym chain that were potentially visible, -- and no entities reasonably considered as non-visible, then -- we have a plain undefined reference, with no additional @@ -5752,7 +5765,7 @@ package body Sem_Ch8 is -- outside the instance. if From_Actual_Package (E) - and then Scope_Depth (E2) < Scope_Depth (Inst) + and then Scope_Depth (Scope (E2)) < Scope_Depth (Inst) then goto Found; else @@ -6033,7 +6046,7 @@ package body Sem_Ch8 is -- If no homonyms were visible, the entity is unambiguous if not Is_Overloaded (N) then - if Reference_OK and then not Is_Actual_Parameter then + if not Is_Actual_Parameter then Generate_Reference (E, N); end if; end if; @@ -6052,8 +6065,7 @@ package body Sem_Ch8 is -- in SPARK mode where renamings are traversed for generating -- local effects of subprograms. - if Reference_OK - and then Is_Object (E) + if Is_Object (E) and then Present (Renamed_Object (E)) and then not GNATprove_Mode then @@ -6083,7 +6095,7 @@ package body Sem_Ch8 is -- Generate reference unless this is an actual parameter -- (see comment below). - if Reference_OK and then not Is_Actual_Parameter then + if not Is_Actual_Parameter then Generate_Reference (E, N); Set_Referenced (E, R); end if; @@ -6092,7 +6104,7 @@ package body Sem_Ch8 is -- Normal case, not a label: generate reference else - if Reference_OK and then not Is_Actual_Parameter then + if not Is_Actual_Parameter then -- Package or generic package is always a simple reference @@ -6112,7 +6124,7 @@ package body Sem_Ch8 is -- If we don't know now, generate reference later when Unknown => - Deferred_References.Append ((E, N)); + Defer_Reference ((E, N)); end case; end if; end if; @@ -6161,11 +6173,7 @@ package body Sem_Ch8 is -- reference is a write when it appears on the left hand side of an -- assignment. - if Marker_OK - and then Needs_Variable_Reference_Marker - (N => N, - Calls_OK => False) - then + if Needs_Variable_Reference_Marker (N => N, Calls_OK => False) then declare Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes; @@ -6266,6 +6274,22 @@ package body Sem_Ch8 is then P_Name := Renamed_Object (P_Name); + if From_Limited_With (P_Name) + and then not Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name))) + then + Error_Msg_NE + ("renaming of limited view of package & not usable in this" + & " context (RM 8.5.3(3.1/2))", Prefix (N), P_Name); + + elsif Has_Limited_View (P_Name) + and then not Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name))) + and then not Is_Visible_Through_Renamings (P_Name) + then + Error_Msg_NE + ("renaming of limited view of package & not usable in this" + & " context (RM 8.5.3(3.1/2))", Prefix (N), P_Name); + end if; + -- Rewrite node with entity field pointing to renamed object Rewrite (Prefix (N), New_Copy (Prefix (N))); @@ -6331,6 +6355,19 @@ package body Sem_Ch8 is Candidate := Get_Full_View (Non_Limited_View (Id)); Is_New_Candidate := True; + -- Handle special case where the prefix is a renaming of a shadow + -- package which is visible. Required to avoid reporting spurious + -- errors. + + elsif Ekind (P_Name) = E_Package + and then From_Limited_With (P_Name) + and then not From_Limited_With (Id) + and then Sloc (Scope (Id)) = Sloc (P_Name) + and then Unit_Is_Visible (Cunit (Get_Source_Unit (P_Name))) + then + Candidate := Get_Full_View (Id); + Is_New_Candidate := True; + -- An unusual case arises with a fully qualified name for an -- entity local to a generic child unit package, within an -- instantiation of that package. The name of the unit now @@ -6729,7 +6766,7 @@ package body Sem_Ch8 is Generate_Reference (Id, N, 'r'); when Unknown => - Deferred_References.Append ((Id, N)); + Defer_Reference ((Id, N)); end case; end if; diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads index b1a2b9e..fe5d5ee 100644 --- a/gcc/ada/sem_ch8.ads +++ b/gcc/ada/sem_ch8.ads @@ -82,11 +82,7 @@ package Sem_Ch8 is -- Subsidiaries of End_Use_Clauses. Also called directly for use clauses -- appearing in context clauses. - procedure Find_Direct_Name - (N : Node_Id; - Errors_OK : Boolean := True; - Marker_OK : Boolean := True; - Reference_OK : Boolean := True); + procedure Find_Direct_Name (N : Node_Id); -- Given a direct name (Identifier or Operator_Symbol), this routine scans -- the homonym chain for the name, searching for corresponding visible -- entities to find the referenced entity (or in the case of overloading, diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index effc858..a9d720b 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1252,7 +1252,7 @@ package body Sem_Ch9 is E := First_Entity (P_Type); while Present (E) loop if Chars (E) = Chars (Id) - and then (Ekind (E) = Ekind (Id)) + and then Ekind (E) = Ekind (Id) and then Type_Conformant (Id, E) then Entry_Name := E; @@ -2360,7 +2360,8 @@ package body Sem_Ch9 is -- entry body) unless it is a parameter of the innermost enclosing -- accept statement (or entry body). - if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) + if Static_Accessibility_Level (Target_Obj, Zero_On_Dynamic_Level) + >= Scope_Depth (Outer_Ent) and then (not Is_Entity_Name (Target_Obj) or else not Is_Formal (Entity (Target_Obj)) @@ -3532,6 +3533,14 @@ package body Sem_Ch9 is Next (Iface); end loop; + + -- Check consistency of any nonoverridable aspects that are + -- inherited from multiple sources. + + Check_Inherited_Nonoverridable_Aspects + (Inheritor => N, + Interface_List => Interface_List (N), + Parent_Type => Empty); end if; if not Has_Private_Declaration (T) then diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 67a8cdf..cf54337 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -575,12 +575,16 @@ package body Sem_Disp is -- Similarly, if this is a pre/postcondition for an abstract -- subprogram, it may call another abstract function which is -- a primitive of an abstract type. The call is non-dispatching - -- but will be legal in overridings of the operation. + -- but will be legal in overridings of the operation. However, + -- if the call is tag-indeterminate we want to continue with + -- with the error checking below, as this case is illegal even + -- for abstract subprograms (see AI12-0170). elsif (Is_Subprogram (Scop) or else Chars (Scop) = Name_Postcondition) and then - (Is_Abstract_Subprogram (Scop) + ((Is_Abstract_Subprogram (Scop) + and then not Is_Tag_Indeterminate (N)) or else (Nkind (Parent (Scop)) = N_Procedure_Specification and then Null_Present (Parent (Scop)))) diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 78108e9..d7a8bb0 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -18633,16 +18633,17 @@ package body Sem_Elab is elsif Nkind (N) = N_Attribute_Reference then Error_Msg_NE ("Access attribute of & before body seen<<", N, Orig_Ent); - Error_Msg_N ("\possible Program_Error on later references<", N); + Error_Msg_N + ("\possible Program_Error on later references<<", N); Insert_Check := False; elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= N_Subprogram_Renaming_Declaration + or else Is_Generic_Actual_Subprogram (Orig_Ent) then Error_Msg_NE ("cannot call& before body seen<<", N, Orig_Ent); - - elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then + else Insert_Check := False; end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 8c13abc..12f2822 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -445,9 +445,11 @@ package body Sem_Eval is -- is folded, and since this is definitely a failure, extra checks -- are OK. - Insert_Action (Expr, - Make_Predicate_Check - (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks); + if Predicate_Enabled (Typ) then + Insert_Action (Expr, + Make_Predicate_Check + (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks); + end if; end if; end Check_Expression_Against_Static_Predicate; @@ -2941,9 +2943,14 @@ package body Sem_Eval is end if; case Nam is - when Name_Shift_Left => Eval_Shift (N, E, N_Op_Shift_Left); - when Name_Shift_Right => Eval_Shift (N, E, N_Op_Shift_Right); - when others => null; + when Name_Shift_Left => + Eval_Shift (N, E, N_Op_Shift_Left); + when Name_Shift_Right => + Eval_Shift (N, E, N_Op_Shift_Right); + when Name_Shift_Right_Arithmetic => + Eval_Shift (N, E, N_Op_Shift_Right_Arithmetic); + when others => + null; end case; end Eval_Intrinsic_Call; @@ -3224,7 +3231,7 @@ package body Sem_Eval is -- Eval_Op_Not -- ----------------- - -- The not operation is a static functions, so the result is potentially + -- The not operation is a static function, so the result is potentially -- static if the operand is potentially static (RM 4.9(7), 4.9(20)). procedure Eval_Op_Not (N : Node_Id) is @@ -4800,13 +4807,11 @@ package body Sem_Eval is end Check_Elab_Call; begin - -- Evaluate logical shift operators on binary modular types - - if Is_Modular_Integer_Type (Typ) - and then not Non_Binary_Modulus (Typ) - and then Compile_Time_Known_Value (Left) + if Compile_Time_Known_Value (Left) and then Compile_Time_Known_Value (Right) then + pragma Assert (not Non_Binary_Modulus (Typ)); + if Op = N_Op_Shift_Left then Check_Elab_Call; @@ -4821,12 +4826,73 @@ package body Sem_Eval is elsif Op = N_Op_Shift_Right then Check_Elab_Call; - -- Fold Shift_Right (X, Y) by computing X / 2**Y + -- Fold Shift_Right (X, Y) by computing abs X / 2**Y Fold_Uint (N, - Expr_Value (Left) / (Uint_2 ** Expr_Value (Right)), + abs Expr_Value (Left) / (Uint_2 ** Expr_Value (Right)), Static => Static); + + elsif Op = N_Op_Shift_Right_Arithmetic then + Check_Elab_Call; + + declare + Two_Y : constant Uint := Uint_2 ** Expr_Value (Right); + Modulus : Uint; + begin + if Is_Modular_Integer_Type (Typ) then + Modulus := Einfo.Modulus (Typ); + else + Modulus := Uint_2 ** RM_Size (Typ); + end if; + + -- X / 2**Y if X if positive or a small enough modular integer + + if (Is_Modular_Integer_Type (Typ) + and then Expr_Value (Left) < Modulus / Uint_2) + or else + (not Is_Modular_Integer_Type (Typ) + and then Expr_Value (Left) >= 0) + then + Fold_Uint (N, Expr_Value (Left) / Two_Y, Static => Static); + + -- -1 (aka all 1's) if Y is larger than the number of bits + -- available or if X = -1. + + elsif Two_Y > Modulus + or else Expr_Value (Left) = Uint_Minus_1 + then + if Is_Modular_Integer_Type (Typ) then + Fold_Uint (N, Modulus - Uint_1, Static => Static); + else + Fold_Uint (N, Uint_Minus_1, Static => Static); + end if; + + -- Large modular integer, compute via multiply/divide the + -- following: X >> Y + (1 << Y - 1) << (RM_Size - Y) + + elsif Is_Modular_Integer_Type (Typ) then + Fold_Uint + (N, + (Expr_Value (Left)) / Two_Y + + (Two_Y - Uint_1) + * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)), + Static => Static); + + -- Negative signed integer, compute via multiple/divide the + -- following: + -- (Modulus + X) >> Y + (1 << Y - 1) << (RM_Size - Y) - Modulus + + else + Fold_Uint + (N, + (Modulus + Expr_Value (Left)) / Two_Y + + (Two_Y - Uint_1) + * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)) + - Modulus, + Static => Static); + end if; + end; end if; end if; end Fold_Shift; @@ -6488,8 +6554,65 @@ package body Sem_Eval is end if; declare - DL1 : constant Elist_Id := Discriminant_Constraint (T1); - DL2 : constant Elist_Id := Discriminant_Constraint (T2); + + function Original_Discriminant_Constraint + (Typ : Entity_Id) return Elist_Id; + -- Returns Typ's discriminant constraint, or if the constraint + -- is inherited from an ancestor type, then climbs the parent + -- types to locate and return the constraint farthest up the + -- parent chain that Typ's constraint is ultimately inherited + -- from (stopping before a parent that doesn't impose a constraint + -- or a parent that has new discriminants). This ensures a proper + -- result from the equality comparison of Elist_Ids below (as + -- otherwise, derived types that inherit constraints may appear + -- to be unequal, because each level of derivation can have its + -- own copy of the constraint). + + function Original_Discriminant_Constraint + (Typ : Entity_Id) return Elist_Id + is + begin + if not Has_Discriminants (Typ) then + return No_Elist; + + -- If Typ is not a derived type, then directly return the + -- its constraint. + + elsif not Is_Derived_Type (Typ) then + return Discriminant_Constraint (Typ); + + -- If the parent type doesn't have discriminants, doesn't + -- have a constraint, or has new discriminants, then stop + -- and return Typ's constraint. + + elsif not Has_Discriminants (Etype (Typ)) + + -- No constraint on the parent type + + or else not Present (Discriminant_Constraint (Etype (Typ))) + or else Is_Empty_Elmt_List + (Discriminant_Constraint (Etype (Typ))) + + -- The parent type defines new discriminants + + or else + (Is_Base_Type (Etype (Typ)) + and then Present (Discriminant_Specifications + (Parent (Etype (Typ))))) + then + return Discriminant_Constraint (Typ); + + -- Otherwise, make a recursive call on the parent type + + else + return Original_Discriminant_Constraint (Etype (Typ)); + end if; + end Original_Discriminant_Constraint; + + -- Local variables + + DL1 : constant Elist_Id := Original_Discriminant_Constraint (T1); + DL2 : constant Elist_Id := Original_Discriminant_Constraint (T2); DA1 : Elmt_Id; DA2 : Elmt_Id; diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 15bb146..f3d9f44 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -38,6 +38,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with Ttypes; use Ttypes; with Uintp; use Uintp; package body Sem_Intr is @@ -430,11 +431,18 @@ package body Sem_Intr is if Size /= 8 and then Size /= 16 and then Size /= 32 and then - Size /= 64 + Size /= 64 and then + Size /= System_Max_Integer_Size then - Errint - ("first argument for shift must have size 8, 16, 32 or 64", - Ptyp1, N, Relaxed => True); + if System_Max_Integer_Size > 64 then + Errint + ("first argument for shift must have size 8, 16, 32, 64 or 128", + Ptyp1, N, Relaxed => True); + else + Errint + ("first argument for shift must have size 8, 16, 32 or 64", + Ptyp1, N, Relaxed => True); + end if; return; elsif Non_Binary_Modulus (Typ1) then @@ -449,10 +457,19 @@ package body Sem_Intr is and then Modulus (Typ1) /= Uint_2 ** 16 and then Modulus (Typ1) /= Uint_2 ** 32 and then Modulus (Typ1) /= Uint_2 ** 64 + and then Modulus (Typ1) /= Uint_2 ** System_Max_Binary_Modulus_Power then - Errint - ("modular type for shift must have modulus of 2'*'*8, " - & "2'*'*16, 2'*'*32, or 2'*'*64", Ptyp1, N, Relaxed => True); + if System_Max_Binary_Modulus_Power > 64 then + Errint + ("modular type for shift must have modulus of 2'*'*8, " + & "2'*'*16, 2'*'*32, 2'*'*64 or 2'*'*128", Ptyp1, N, + Relaxed => True); + else + Errint + ("modular type for shift must have modulus of 2'*'*8, " + & "2'*'*16, 2'*'*32, or 2'*'*64", Ptyp1, N, + Relaxed => True); + end if; elsif Etype (Arg1) /= Etype (E) then Errint diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index b7148d80..1e1a279 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -44,6 +44,7 @@ with Exp_Util; use Exp_Util; with Expander; use Expander; with Freeze; use Freeze; with Ghost; use Ghost; +with GNAT_CUDA; use GNAT_CUDA; with Gnatvsn; use Gnatvsn; with Lib; use Lib; with Lib.Writ; use Lib.Writ; @@ -543,12 +544,16 @@ package body Sem_Prag is Set_Ghost_Mode (N); -- Single and multiple contract cases must appear in aggregate form. If - -- this is not the case, then either the parser of the analysis of the + -- this is not the case, then either the parser or the analysis of the -- pragma failed to produce an aggregate. pragma Assert (Nkind (CCases) = N_Aggregate); - if Present (Component_Associations (CCases)) then + -- Only CASE_GUARD => CONSEQUENCE clauses are allowed + + if Present (Component_Associations (CCases)) + and then No (Expressions (CCases)) + then -- Ensure that the formal parameters are visible when analyzing all -- clauses. This falls out of the general rule of aspects pertaining @@ -583,7 +588,7 @@ package body Sem_Prag is -- Otherwise the pragma is illegal else - Error_Msg_N ("wrong syntax for constract cases", N); + Error_Msg_N ("wrong syntax for contract cases", N); end if; Set_Is_Analyzed_Pragma (N); @@ -2100,12 +2105,11 @@ package body Sem_Prag is Expr : Node_Id; begin - Expr_Val := False; - - -- Do not analyze the pragma multiple times + -- Do not analyze the pragma multiple times, but set the output + -- parameter to the argument specified by the pragma. if Is_Analyzed_Pragma (N) then - return; + goto Leave; end if; Error_Msg_Name_1 := Pragma_Name (N); @@ -2146,6 +2150,10 @@ package body Sem_Prag is end if; end if; + Set_Is_Analyzed_Pragma (N); + + <<Leave>> + -- Ensure that the Boolean expression (if present) is static. A missing -- argument defaults the value to True (SPARK RM 7.1.2(5)). @@ -2159,7 +2167,6 @@ package body Sem_Prag is end if; end if; - Set_Is_Analyzed_Pragma (N); end Analyze_External_Property_In_Decl_Part; --------------------------------- @@ -2467,10 +2474,11 @@ package body Sem_Prag is elsif SPARK_Mode = On and then Ekind (Item_Id) = E_Variable - and then Is_Effectively_Volatile (Item_Id) + and then Is_Effectively_Volatile_For_Reading (Item_Id) then - -- An effectively volatile object cannot appear as a global - -- item of a nonvolatile function (SPARK RM 7.1.3(8)). + -- An effectively volatile object for reading cannot appear + -- as a global item of a nonvolatile function (SPARK RM + -- 7.1.3(8)). if Ekind (Spec_Id) in E_Function | E_Generic_Function and then not Is_Volatile_Function (Spec_Id) @@ -3940,10 +3948,6 @@ package body Sem_Prag is procedure Check_At_Most_N_Arguments (N : Nat); -- Check there are no more than N arguments present - procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean); - -- Apply legality checks to type or object E subject to an Atomic aspect - -- in Ada 2020 (RM C.6(13)) or to a Volatile_Full_Access aspect. - procedure Check_Component (Comp : Node_Id; UU_Typ : Entity_Id; @@ -4068,10 +4072,10 @@ package body Sem_Prag is procedure Ensure_Aggregate_Form (Arg : Node_Id); -- Subsidiary routine to the processing of pragmas Abstract_State, -- Contract_Cases, Depends, Global, Initializes, Refined_Depends, - -- Refined_Global and Refined_State. Transform argument Arg into - -- an aggregate if not one already. N_Null is never transformed. - -- Arg may denote an aspect specification or a pragma argument - -- association. + -- Refined_Global, Refined_State and Subprogram_Variant. Transform + -- argument Arg into an aggregate if not one already. N_Null is never + -- transformed. Arg may denote an aspect specification or a pragma + -- argument association. procedure Error_Pragma (Msg : String); pragma No_Return (Error_Pragma); @@ -4796,7 +4800,7 @@ package body Sem_Prag is -- Chain the pragma on the contract for further processing by -- Analyze_Pre_Post_Condition_In_Decl_Part. - Add_Contract_Item (N, Defining_Entity (Subp_Decl)); + Add_Contract_Item (N, Subp_Id); -- Fully analyze the pragma when it appears inside an entry or -- subprogram body because it cannot benefit from forward references. @@ -5623,165 +5627,6 @@ package body Sem_Prag is end if; end Check_At_Most_N_Arguments; - ------------------------ - -- Check_Atomic_VFA -- - ------------------------ - - procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean) is - - Aliased_Subcomponent : exception; - -- Exception raised if an aliased subcomponent is found in E - - Independent_Subcomponent : exception; - -- Exception raised if an independent subcomponent is found in E - - procedure Check_Subcomponents (Typ : Entity_Id); - -- Apply checks to subcomponents for Atomic and Volatile_Full_Access - - ------------------------- - -- Check_Subcomponents -- - ------------------------- - - procedure Check_Subcomponents (Typ : Entity_Id) is - Comp : Entity_Id; - - begin - if Is_Array_Type (Typ) then - Comp := Component_Type (Typ); - - -- For Atomic we accept any atomic subcomponents - - if not VFA - and then (Has_Atomic_Components (Typ) - or else Is_Atomic (Comp)) - then - null; - - -- Give an error if the components are aliased - - elsif Has_Aliased_Components (Typ) - or else Is_Aliased (Comp) - then - raise Aliased_Subcomponent; - - -- For VFA we accept non-aliased VFA subcomponents - - elsif VFA - and then Is_Volatile_Full_Access (Comp) - then - null; - - -- Give an error if the components are independent - - elsif Has_Independent_Components (Typ) - or else Is_Independent (Comp) - then - raise Independent_Subcomponent; - end if; - - -- Recurse on the component type - - Check_Subcomponents (Comp); - - -- Note: Has_Aliased_Components, like Has_Atomic_Components, - -- and Has_Independent_Components, applies only to arrays. - -- However, this flag does not have a corresponding pragma, so - -- perhaps it should be possible to apply it to record types as - -- well. Should this be done ??? - - elsif Is_Record_Type (Typ) then - -- It is possible to have an aliased discriminant, so they - -- must be checked along with normal components. - - Comp := First_Component_Or_Discriminant (Typ); - while Present (Comp) loop - - -- For Atomic we accept any atomic subcomponents - - if not VFA - and then (Is_Atomic (Comp) - or else Is_Atomic (Etype (Comp))) - then - null; - - -- Give an error if the component is aliased - - elsif Is_Aliased (Comp) - or else Is_Aliased (Etype (Comp)) - then - raise Aliased_Subcomponent; - - -- For VFA we accept non-aliased VFA subcomponents - - elsif VFA - and then (Is_Volatile_Full_Access (Comp) - or else Is_Volatile_Full_Access (Etype (Comp))) - then - null; - - -- Give an error if the component is independent - - elsif Is_Independent (Comp) - or else Is_Independent (Etype (Comp)) - then - raise Independent_Subcomponent; - end if; - - -- Recurse on the component type - - Check_Subcomponents (Etype (Comp)); - - Next_Component_Or_Discriminant (Comp); - end loop; - end if; - end Check_Subcomponents; - - Typ : Entity_Id; - - begin - -- Fetch the type in case we are dealing with an object or component - - if Is_Type (E) then - Typ := E; - else - pragma Assert (Is_Object (E) - or else - Nkind (Declaration_Node (E)) = N_Component_Declaration); - - Typ := Etype (E); - end if; - - -- Check all the subcomponents of the type recursively, if any - - Check_Subcomponents (Typ); - - exception - when Aliased_Subcomponent => - if VFA then - Error_Pragma - ("cannot apply Volatile_Full_Access with aliased " - & "subcomponent "); - else - Error_Pragma - ("cannot apply Atomic with aliased subcomponent " - & "(RM C.6(13))"); - end if; - - when Independent_Subcomponent => - if VFA then - Error_Pragma - ("cannot apply Volatile_Full_Access with independent " - & "subcomponent "); - else - Error_Pragma - ("cannot apply Atomic with independent subcomponent " - & "(RM C.6(13))"); - end if; - - when others => - raise Program_Error; - end Check_Atomic_VFA; - --------------------- -- Check_Component -- --------------------- @@ -7367,8 +7212,9 @@ package body Sem_Prag is ------------------------------------------------ procedure Process_Atomic_Independent_Shared_Volatile is - procedure Check_VFA_Conflicts (Ent : Entity_Id); - -- Check that Volatile_Full_Access and VFA do not conflict + procedure Check_Full_Access_Only (Ent : Entity_Id); + -- Apply legality checks to type or object Ent subject to the + -- Full_Access_Only aspect in Ada 2020 (RM C.6(8.2)). procedure Mark_Component_Or_Object (Ent : Entity_Id); -- Appropriately set flags on the given entity, either an array or @@ -7385,15 +7231,68 @@ package body Sem_Prag is -- full access arrays. Note: this is necessary for derived types. ------------------------- - -- Check_VFA_Conflicts -- + -- Check_Full_Access_Only -- ------------------------- - procedure Check_VFA_Conflicts (Ent : Entity_Id) is - Comp : Entity_Id; + procedure Check_Full_Access_Only (Ent : Entity_Id) is Typ : Entity_Id; - VFA_And_Atomic : Boolean := False; - -- Set True if both VFA and Atomic present + Full_Access_Subcomponent : exception; + -- Exception raised if a full access subcomponent is found + + Generic_Type_Subcomponent : exception; + -- Exception raised if a subcomponent with generic type is found + + procedure Check_Subcomponents (Typ : Entity_Id); + -- Apply checks to subcomponents recursively + + ------------------------- + -- Check_Subcomponents -- + ------------------------- + + procedure Check_Subcomponents (Typ : Entity_Id) is + Comp : Entity_Id; + + begin + if Is_Array_Type (Typ) then + Comp := Component_Type (Typ); + + if Has_Atomic_Components (Typ) + or else Is_Full_Access (Comp) + then + raise Full_Access_Subcomponent; + + elsif Is_Generic_Type (Comp) then + raise Generic_Type_Subcomponent; + end if; + + -- Recurse on the component type + + Check_Subcomponents (Comp); + + elsif Is_Record_Type (Typ) then + Comp := First_Component_Or_Discriminant (Typ); + while Present (Comp) loop + + if Is_Full_Access (Comp) + or else Is_Full_Access (Etype (Comp)) + then + raise Full_Access_Subcomponent; + + elsif Is_Generic_Type (Etype (Comp)) then + raise Generic_Type_Subcomponent; + end if; + + -- Recurse on the component type + + Check_Subcomponents (Etype (Comp)); + + Next_Component_Or_Discriminant (Comp); + end loop; + end if; + end Check_Subcomponents; + + -- Start of processing for Check_Full_Access_Only begin -- Fetch the type in case we are dealing with an object or @@ -7409,49 +7308,29 @@ package body Sem_Prag is Typ := Etype (Ent); end if; - -- Check Atomic and VFA used together - - if Prag_Id = Pragma_Volatile_Full_Access - or else Is_Volatile_Full_Access (Ent) - then - if Prag_Id = Pragma_Atomic - or else Prag_Id = Pragma_Shared - or else Is_Atomic (Ent) - then - VFA_And_Atomic := True; - - elsif Is_Array_Type (Typ) then - VFA_And_Atomic := Has_Atomic_Components (Typ); + if not Is_Volatile (Ent) and then not Is_Volatile (Typ) then + Error_Pragma + ("cannot have Full_Access_Only without Volatile/Atomic " + & "(RM C.6(8.2))"); + return; + end if; - -- Note: Has_Atomic_Components is not used below, as this flag - -- represents the pragma of the same name, Atomic_Components, - -- which only applies to arrays. + -- Check all the subcomponents of the type recursively, if any - elsif Is_Record_Type (Typ) then - -- Attributes cannot be applied to discriminants, only - -- regular record components. - - Comp := First_Component (Typ); - while Present (Comp) loop - if Is_Atomic (Comp) - or else Is_Atomic (Typ) - then - VFA_And_Atomic := True; + Check_Subcomponents (Typ); - exit; - end if; + exception + when Full_Access_Subcomponent => + Error_Pragma + ("cannot have Full_Access_Only with full access subcomponent " + & "(RM C.6(8.2))"); - Next_Component (Comp); - end loop; - end if; + when Generic_Type_Subcomponent => + Error_Pragma + ("cannot have Full_Access_Only with subcomponent of generic " + & "type (RM C.6(8.2))"); - if VFA_And_Atomic then - Error_Pragma - ("cannot have Volatile_Full_Access and Atomic for same " - & "entity"); - end if; - end if; - end Check_VFA_Conflicts; + end Check_Full_Access_Only; ------------------------------ -- Mark_Component_Or_Object -- @@ -7607,6 +7486,7 @@ package body Sem_Prag is end if; E := Entity (E_Arg); + Decl := Declaration_Node (E); -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code. @@ -7617,9 +7497,43 @@ package body Sem_Prag is Check_Duplicate_Pragma (E); - -- Check appropriateness of the entity + -- Check the constraints of Full_Access_Only in Ada 2020. Note that + -- they do not apply to GNAT's Volatile_Full_Access because 1) this + -- aspect subsumes the Volatile aspect and 2) nesting is supported + -- for this aspect and the outermost enclosing VFA object prevails. - Decl := Declaration_Node (E); + -- Note also that we used to forbid specifying both Atomic and VFA on + -- the same type or object, but the restriction has been lifted in + -- light of the semantics of Full_Access_Only and Atomic in Ada 2020. + + if Prag_Id = Pragma_Volatile_Full_Access + and then From_Aspect_Specification (N) + and then + Get_Aspect_Id (Corresponding_Aspect (N)) = Aspect_Full_Access_Only + then + Check_Full_Access_Only (E); + end if; + + -- The following check is only relevant when SPARK_Mode is on as + -- this is not a standard Ada legality rule. Pragma Volatile can + -- only apply to a full type declaration or an object declaration + -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for + -- untagged derived types that are rewritten as subtypes of their + -- respective root types. + + if SPARK_Mode = On + and then Prag_Id = Pragma_Volatile + and then Nkind (Original_Node (Decl)) not in + N_Full_Type_Declaration | + N_Formal_Type_Declaration | + N_Object_Declaration | + N_Single_Protected_Declaration | + N_Single_Task_Declaration + then + Error_Pragma_Arg + ("argument of pragma % must denote a full type or object " + & "declaration", Arg1); + end if; -- Deal with the case where the pragma/attribute is applied to a type @@ -7652,41 +7566,6 @@ package body Sem_Prag is else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; - - -- Check that Volatile_Full_Access and Atomic do not conflict - - Check_VFA_Conflicts (E); - - -- Check for the application of Atomic or Volatile_Full_Access to - -- an entity that has [nonatomic] aliased, or else specified to be - -- independently addressable, subcomponents. - - if (Prag_Id = Pragma_Atomic and then Ada_Version >= Ada_2020) - or else Prag_Id = Pragma_Volatile_Full_Access - then - Check_Atomic_VFA (E, VFA => Prag_Id = Pragma_Volatile_Full_Access); - end if; - - -- The following check is only relevant when SPARK_Mode is on as - -- this is not a standard Ada legality rule. Pragma Volatile can - -- only apply to a full type declaration or an object declaration - -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for - -- untagged derived types that are rewritten as subtypes of their - -- respective root types. - - if SPARK_Mode = On - and then Prag_Id = Pragma_Volatile - and then Nkind (Original_Node (Decl)) not in - N_Full_Type_Declaration | - N_Formal_Type_Declaration | - N_Object_Declaration | - N_Single_Protected_Declaration | - N_Single_Task_Declaration - then - Error_Pragma_Arg - ("argument of pragma % must denote a full type or object " - & "declaration", Arg1); - end if; end Process_Atomic_Independent_Shared_Volatile; ------------------------------------------- @@ -8268,8 +8147,13 @@ package body Sem_Prag is -- Accept Intrinsic Export on types if Relaxed_RM_Semantics if not (Is_Type (E) and then Relaxed_RM_Semantics) then - Error_Pragma_Arg - ("second argument of pragma% must be a subprogram", Arg2); + if From_Aspect_Specification (N) then + Error_Pragma_Arg + ("entity for aspect% must be a subprogram", Arg2); + else + Error_Pragma_Arg + ("second argument of pragma% must be a subprogram", Arg2); + end if; end if; -- Special checks for C_Variadic_n @@ -9541,10 +9425,17 @@ package body Sem_Prag is Process_Import_Predefined_Type; else - Error_Pragma_Arg - ("second argument of pragma% must be object, subprogram " - & "or incomplete type", - Arg2); + if From_Aspect_Specification (N) then + Error_Pragma_Arg + ("entity for aspect% must be object, subprogram " + & "or incomplete type", + Arg2); + else + Error_Pragma_Arg + ("second argument of pragma% must be object, subprogram " + & "or incomplete type", + Arg2); + end if; end if; -- If this pragma applies to a compilation unit, then the unit, which @@ -13575,11 +13466,6 @@ package body Sem_Prag is -- Atomic implies both Independent and Volatile if Prag_Id = Pragma_Atomic_Components then - if Ada_Version >= Ada_2020 then - Check_Atomic_VFA - (Component_Type (Etype (E)), VFA => False); - end if; - Set_Has_Atomic_Components (E); Set_Has_Independent_Components (E); end if; @@ -14774,16 +14660,17 @@ package body Sem_Prag is function Is_Acceptable_Dim3 (N : Node_Id) return Boolean; -- Returns True if N is an acceptable argument for CUDA_Execute, - -- false otherwise. + -- False otherwise. ------------------------ -- Is_Acceptable_Dim3 -- ------------------------ function Is_Acceptable_Dim3 (N : Node_Id) return Boolean is - Tmp : Node_Id; + Expr : Node_Id; begin - if Etype (N) = RTE (RE_Dim3) or else Is_Integer_Type (Etype (N)) + if Is_RTE (Etype (N), RE_Dim3) + or else Is_Integer_Type (Etype (N)) then return True; end if; @@ -14791,10 +14678,10 @@ package body Sem_Prag is if Nkind (N) = N_Aggregate and then List_Length (Expressions (N)) = 3 then - Tmp := First (Expressions (N)); - while Present (Tmp) loop - Analyze_And_Resolve (Tmp, Any_Integer); - Tmp := Next (Tmp); + Expr := First (Expressions (N)); + while Present (Expr) loop + Analyze_And_Resolve (Expr, Any_Integer); + Next (Expr); end loop; return True; end if; @@ -14813,7 +14700,6 @@ package body Sem_Prag is -- Start of processing for CUDA_Execute begin - GNAT_Pragma; Check_At_Least_N_Arguments (3); Check_At_Most_N_Arguments (5); @@ -14891,6 +14777,7 @@ package body Sem_Prag is else Set_Is_CUDA_Kernel (Kernel_Proc); + Add_CUDA_Kernel (Pack_Id, Kernel_Proc); end if; end CUDA_Global; @@ -15314,7 +15201,7 @@ package body Sem_Prag is -- Default_Storage_Pool -- -------------------------- - -- pragma Default_Storage_Pool (storage_pool_NAME | null); + -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard); when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare Pool : Node_Id; @@ -15355,6 +15242,18 @@ package body Sem_Prag is Set_Etype (Pool, Empty); + -- Case of Default_Storage_Pool (Standard); + + elsif Nkind (Pool) = N_Identifier + and then Chars (Pool) = Name_Standard + then + Analyze (Pool); + + if Entity (Pool) /= Standard_Standard then + Error_Pragma_Arg + ("package Standard is not directly visible", Arg1); + end if; + -- Case of Default_Storage_Pool (storage_pool_NAME); else @@ -15362,7 +15261,7 @@ package body Sem_Prag is -- argument is "null". if Is_Configuration_Pragma then - Error_Pragma_Arg ("NULL expected", Arg1); + Error_Pragma_Arg ("NULL or Standard expected", Arg1); end if; -- The expected type for a non-"null" argument is @@ -17008,7 +16907,7 @@ package body Sem_Prag is return; end if; - -- Otherwie the expression is not static + -- Otherwise the expression is not static else Error_Pragma_Arg @@ -17792,15 +17691,17 @@ package body Sem_Prag is -- Short_Float -- | Float -- | Long_Float - -- | Long_Long_Flat + -- | Long_Long_Float -- | Signed_8 -- | Signed_16 -- | Signed_32 -- | Signed_64 + -- | Signed_128 -- | Unsigned_8 -- | Unsigned_16 -- | Unsigned_32 -- | Unsigned_64 + -- | Unsigned_128 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare Seen : array (Scalar_Id) of Node_Id := (others => Empty); @@ -17853,7 +17754,14 @@ package body Sem_Prag is begin Analyze_And_Resolve (Val_Expr, Any_Integer); - if Is_OK_Static_Expression (Val_Expr) then + if (Scal_Typ = Name_Signed_128 + or else Scal_Typ = Name_Unsigned_128) + and then Ttypes.System_Max_Integer_Size < 128 + then + Error_Msg_Name_1 := Scal_Typ; + Error_Msg_N ("value cannot be set for type %", Val_Expr); + + elsif Is_OK_Static_Expression (Val_Expr) then Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr)); else @@ -21041,19 +20949,6 @@ package body Sem_Prag is Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name)); end Rename_Pragma; - ------------- - -- Polling -- - ------------- - - -- pragma Polling (ON | OFF); - - when Pragma_Polling => - GNAT_Pragma; - Check_Arg_Count (1); - Check_No_Identifiers; - Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); - Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On); - ----------------------------------- -- Post/Post_Class/Postcondition -- ----------------------------------- @@ -21201,9 +21096,7 @@ package body Sem_Prag is Set_Has_Delayed_Freeze (Typ); Set_Predicates_Ignored (Typ, - Present (Check_Policy_List) - and then - Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore); + Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore); Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); end Predicate; @@ -23709,6 +23602,9 @@ package body Sem_Prag is Error_Pragma_Arg ("argument for pragma% must be function of one argument", Arg); + elsif Is_Abstract_Subprogram (Ent) then + Error_Pragma_Arg + ("argument for pragma% cannot be abstract", Arg); end if; end Check_OK_Stream_Convert_Function; @@ -23895,6 +23791,139 @@ package body Sem_Prag is end if; end Style_Checks; + ------------------------ + -- Subprogram_Variant -- + ------------------------ + + -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_ITEM + -- {, SUBPROGRAM_VARIANT_ITEM } ); + + -- SUBPROGRAM_VARIANT_ITEM ::= + -- CHANGE_DIRECTION => discrete_EXPRESSION + + -- CHANGE_DIRECTION ::= Increases | Decreases + + -- Characteristics: + + -- * Analysis - The annotation undergoes initial checks to verify + -- the legal placement and context. Secondary checks preanalyze the + -- expressions in: + + -- Analyze_Subprogram_Variant_In_Decl_Part + + -- * Expansion - The annotation is expanded during the expansion of + -- the related subprogram [body] contract as performed in: + + -- Expand_Subprogram_Contract + + -- * Template - The annotation utilizes the generic template of the + -- related subprogram [body] when it is: + + -- aspect on subprogram declaration + -- aspect on stand-alone subprogram body + -- pragma on stand-alone subprogram body + + -- The annotation must prepare its own template when it is: + + -- pragma on subprogram declaration + + -- * Globals - Capture of global references must occur after full + -- analysis. + + -- * Instance - The annotation is instantiated automatically when + -- the related generic subprogram [body] is instantiated except for + -- the "pragma on subprogram declaration" case. In that scenario + -- the annotation must instantiate itself. + + when Pragma_Subprogram_Variant => Subprogram_Variant : declare + Spec_Id : Entity_Id; + Subp_Decl : Node_Id; + Subp_Spec : Node_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + + -- Ensure the proper placement of the pragma. Subprogram_Variant + -- must be associated with a subprogram declaration or a body that + -- acts as a spec. + + Subp_Decl := + Find_Related_Declaration_Or_Body (N, Do_Checks => True); + + -- Generic subprogram + + if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then + null; + + -- Body acts as spec + + elsif Nkind (Subp_Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Subp_Decl)) + then + null; + + -- Body stub acts as spec + + elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub + and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) + then + null; + + -- Subprogram + + elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then + Subp_Spec := Specification (Subp_Decl); + + -- Pragma Subprogram_Variant is forbidden on null procedures, + -- as this may lead to potential ambiguities in behavior when + -- interface null procedures are involved. Also, it just + -- wouldn't make sense, because null procedure is not + -- recursive. + + if Nkind (Subp_Spec) = N_Procedure_Specification + and then Null_Present (Subp_Spec) + then + Error_Msg_N (Fix_Error + ("pragma % cannot apply to null procedure"), N); + return; + end if; + + else + Pragma_Misplaced; + return; + end if; + + Spec_Id := Unique_Defining_Entity (Subp_Decl); + + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. + + Mark_Ghost_Pragma (N, Spec_Id); + Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); + + -- Chain the pragma on the contract for further processing by + -- Analyze_Subprogram_Variant_In_Decl_Part. + + Add_Contract_Item (N, Defining_Entity (Subp_Decl)); + + -- Fully analyze the pragma when it appears inside a subprogram + -- body because it cannot benefit from forward references. + + if Nkind (Subp_Decl) in N_Subprogram_Body + | N_Subprogram_Body_Stub + then + -- The legality checks of pragma Subprogram_Variant are + -- affected by the SPARK mode in effect and the volatility + -- of the context. Analyze all pragmas in a specific order. + + Analyze_If_Present (Pragma_SPARK_Mode); + Analyze_If_Present (Pragma_Volatile_Function); + Analyze_Subprogram_Variant_In_Decl_Part (N); + end if; + end Subprogram_Variant; + -------------- -- Subtitle -- -------------- @@ -28915,6 +28944,156 @@ package body Sem_Prag is Set_Is_Analyzed_Pragma (N); end Analyze_Refined_State_In_Decl_Part; + --------------------------------------------- + -- Analyze_Subprogram_Variant_In_Decl_Part -- + --------------------------------------------- + + -- WARNING: This routine manages Ghost regions. Return statements must be + -- replaced by gotos which jump to the end of the routine and restore the + -- Ghost mode. + + procedure Analyze_Subprogram_Variant_In_Decl_Part + (N : Node_Id; + Freeze_Id : Entity_Id := Empty) + is + Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); + + procedure Analyze_Variant (Variant : Node_Id); + -- Verify the legality of a single contract case + + --------------------- + -- Analyze_Variant -- + --------------------- + + procedure Analyze_Variant (Variant : Node_Id) is + Direction : Node_Id; + Expr : Node_Id; + Errors : Nat; + Extra_Direction : Node_Id; + + begin + if Nkind (Variant) /= N_Component_Association then + Error_Msg_N ("wrong syntax in subprogram variant", Variant); + return; + end if; + + Direction := First (Choices (Variant)); + Expr := Expression (Variant); + + -- Each variant must have exactly one direction + + Extra_Direction := Next (Direction); + + if Present (Extra_Direction) then + Error_Msg_N + ("subprogram variant case must have exactly one direction", + Extra_Direction); + end if; + + -- Check placement of OTHERS if available (SPARK RM 6.1.3(1)) + + if Nkind (Direction) = N_Identifier then + if Chars (Direction) /= Name_Decreases + and then + Chars (Direction) /= Name_Increases + then + Error_Msg_N ("wrong direction", Direction); + end if; + else + Error_Msg_N ("wrong syntax", Direction); + end if; + + Errors := Serious_Errors_Detected; + Preanalyze_Assert_Expression (Expr, Any_Discrete); + + -- Emit a clarification message when the variant expression + -- contains at least one undefined reference, possibly due + -- to contract freezing. + + if Errors /= Serious_Errors_Detected + and then Present (Freeze_Id) + and then Has_Undefined_Reference (Expr) + then + Contract_Freeze_Error (Spec_Id, Freeze_Id); + end if; + end Analyze_Variant; + + -- Local variables + + Variants : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); + + Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; + Saved_IGR : constant Node_Id := Ignored_Ghost_Region; + -- Save the Ghost-related attributes to restore on exit + + Variant : Node_Id; + Restore_Scope : Boolean := False; + + -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part + + begin + -- Do not analyze the pragma multiple times + + if Is_Analyzed_Pragma (N) then + return; + end if; + + -- Set the Ghost mode in effect from the pragma. Due to the delayed + -- analysis of the pragma, the Ghost mode at point of declaration and + -- point of analysis may not necessarily be the same. Use the mode in + -- effect at the point of declaration. + + Set_Ghost_Mode (N); + + -- Single and multiple contract cases must appear in aggregate form. If + -- this is not the case, then either the parser of the analysis of the + -- pragma failed to produce an aggregate. + + pragma Assert (Nkind (Variants) = N_Aggregate); + + -- Only "change_direction => discrete_expression" clauses are allowed + + if Present (Component_Associations (Variants)) + and then No (Expressions (Variants)) + then + + -- Ensure that the formal parameters are visible when analyzing all + -- clauses. This falls out of the general rule of aspects pertaining + -- to subprogram declarations. + + if not In_Open_Scopes (Spec_Id) then + Restore_Scope := True; + Push_Scope (Spec_Id); + + if Is_Generic_Subprogram (Spec_Id) then + Install_Generic_Formals (Spec_Id); + else + Install_Formals (Spec_Id); + end if; + end if; + + Variant := First (Component_Associations (Variants)); + while Present (Variant) loop + Analyze_Variant (Variant); + Next (Variant); + end loop; + + if Restore_Scope then + End_Scope; + end if; + + -- Otherwise the pragma is illegal + + else + Error_Msg_N ("wrong syntax for subprogram variant", N); + end if; + + Set_Is_Analyzed_Pragma (N); + + Restore_Ghost_Region (Saved_GM, Saved_IGR); + end Analyze_Subprogram_Variant_In_Decl_Part; + ------------------------------------ -- Analyze_Test_Case_In_Decl_Part -- ------------------------------------ @@ -29295,44 +29474,38 @@ package body Sem_Prag is ER : Boolean; EW : Boolean) is - begin - -- All properties enabled - - if AR and AW and ER and EW then - null; - - -- Async_Readers + Effective_Writes - -- Async_Readers + Async_Writers + Effective_Writes - - elsif AR and EW and not ER then - null; - - -- Async_Writers + Effective_Reads - -- Async_Readers + Async_Writers + Effective_Reads - - elsif AW and ER and not EW then - null; + type Properties is array (Positive range 1 .. 4) of Boolean; + type Combinations is array (Positive range <>) of Properties; + -- Arrays of Async_Readers, Async_Writers, Effective_Writes and + -- Effective_Reads properties and their combinations, respectively. + + Specified : constant Properties := (AR, AW, EW, ER); + -- External properties, as given by the Item pragma + + Allowed : constant Combinations := + (1 => (True, False, True, False), + 2 => (False, True, False, True), + 3 => (True, False, False, False), + 4 => (False, True, False, False), + 5 => (True, True, True, False), + 6 => (True, True, False, True), + 7 => (True, True, False, False), + 8 => (True, True, True, True)); + -- Allowed combinations, as listed in the SPARK RM 7.1.2(6) table - -- Async_Readers + Async_Writers - - elsif AR and AW and not ER and not EW then - null; - - -- Async_Readers - - elsif AR and not AW and not ER and not EW then - null; - - -- Async_Writers + begin + -- Check if the specified properties match any of the allowed + -- combination; if not, then emit an error. - elsif AW and not AR and not ER and not EW then - null; + for J in Allowed'Range loop + if Specified = Allowed (J) then + return; + end if; + end loop; - else - SPARK_Msg_N - ("illegal combination of external properties (SPARK RM 7.1.2(6))", - Item); - end if; + SPARK_Msg_N + ("illegal combination of external properties (SPARK RM 7.1.2(6))", + Item); end Check_External_Properties; ---------------- @@ -30928,7 +31101,6 @@ package body Sem_Prag is Pragma_Partition_Elaboration_Policy => 0, Pragma_Passive => 0, Pragma_Persistent_BSS => 0, - Pragma_Polling => 0, Pragma_Post => -1, Pragma_Postcondition => -1, Pragma_Post_Class => -1, @@ -30981,6 +31153,7 @@ package body Sem_Prag is Pragma_Storage_Unit => 0, Pragma_Stream_Convert => 0, Pragma_Style_Checks => 0, + Pragma_Subprogram_Variant => -1, Pragma_Subtitle => 0, Pragma_Suppress => 0, Pragma_Suppress_All => 0, @@ -31272,6 +31445,7 @@ package body Sem_Prag is | Name_Predicate | Name_Refined_Post | Name_Statement_Assertions + | Name_Subprogram_Variant => return True; diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 460fc9c..fd7a0cd 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -265,6 +265,13 @@ package Sem_Prag is -- the entity of [generic] package body or [generic] subprogram body which -- caused "freezing" of the related contract where the pragma resides. + procedure Analyze_Subprogram_Variant_In_Decl_Part + (N : Node_Id; + Freeze_Id : Entity_Id := Empty); + -- Perform full analysis of delayed pragma Subprogram_Variant. Freeze_Id is + -- the entity of [generic] package body or [generic] subprogram body which + -- caused "freezing" of the related contract where the pragma resides. + procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id); -- Perform preanalysis of pragma Test_Case diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 50a4287..a24c9c2 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2097,7 +2097,8 @@ package body Sem_Res is then Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg)); - -- Could use comments on what is going on here??? + -- Examine possible interpretations, and adapt the message + -- for inherited subprograms declared by a type derivation. Get_First_Interp (Name (Arg), I, It); while Present (It.Nam) loop @@ -2112,6 +2113,11 @@ package body Sem_Res is Get_Next_Interp (I, It); end loop; end if; + + -- Additional message and hint if the ambiguity involves an Ada2020 + -- container aggregate. + + Check_Ambiguous_Aggregate (N); end Report_Ambiguous_Argument; ----------------------- @@ -3428,7 +3434,7 @@ package body Sem_Res is procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id); -- Emit an error concerning the illegal usage of an effectively volatile - -- object in interfering context (SPARK RM 7.1.3(10)). + -- object for reading in interfering context (SPARK RM 7.1.3(10)). procedure Insert_Default; -- If the actual is missing in a call, insert in the actuals list @@ -3473,13 +3479,13 @@ package body Sem_Res is elsif Has_Discriminants (F_Typ) and then not Is_Constrained (F_Typ) - and then not Has_Constrained_Partial_View (F_Typ) - and then not Is_Generic_Type (F_Typ) + and then not Object_Type_Has_Constrained_Partial_View + (Typ => F_Typ, Scop => Current_Scope) then null; else - Error_Msg_NE ("untagged actual does not match " + Error_Msg_NE ("untagged actual does not statically match " & "aliased formal&", A, F); end if; @@ -3493,16 +3499,16 @@ package body Sem_Res is elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then if Nkind (Parent (N)) = N_Type_Conversion - and then Type_Access_Level (Etype (Parent (N))) < - Object_Access_Level (A) + and then Type_Access_Level (Etype (Parent (N))) + < Static_Accessibility_Level (A, Object_Decl_Level) then Error_Msg_N ("aliased actual has wrong accessibility", A); end if; elsif Nkind (Parent (N)) = N_Qualified_Expression and then Nkind (Parent (Parent (N))) = N_Allocator - and then Type_Access_Level (Etype (Parent (Parent (N)))) < - Object_Access_Level (A) + and then Type_Access_Level (Etype (Parent (Parent (N)))) + < Static_Accessibility_Level (A, Object_Decl_Level) then Error_Msg_N ("aliased actual in allocator has wrong accessibility", A); @@ -3687,7 +3693,7 @@ package body Sem_Res is procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id) is function Flag_Object (N : Node_Id) return Traverse_Result; -- Determine whether arbitrary node N denotes an effectively volatile - -- object and if it does, emit an error. + -- object for reading and if it does, emit an error. ----------------- -- Flag_Object -- @@ -3707,9 +3713,7 @@ package body Sem_Res is Id := Entity (N); if Is_Object (Id) - and then Is_Effectively_Volatile (Id) - and then (Async_Writers_Enabled (Id) - or else Effective_Reads_Enabled (Id)) + and then Is_Effectively_Volatile_For_Reading (Id) then Error_Msg_N ("volatile object cannot appear in this context (SPARK " @@ -4145,11 +4149,11 @@ package body Sem_Res is -- types. if Is_By_Reference_Type (Etype (F)) - or else Is_By_Reference_Type (Expr_Typ) + or else Is_By_Reference_Type (Expr_Typ) then Error_Msg_N ("view conversion between unrelated by reference " - & "array types not allowed (\'A'I-00246)", A); + & "array types not allowed ('A'I-00246)", A); -- In Ada 2005 mode, check view conversion component -- type cannot be private, tagged, or volatile. Note @@ -4722,7 +4726,7 @@ package body Sem_Res is end if; end if; - -- Check illegal cases of atomic/volatile actual (RM C.6(12,13)) + -- Check illegal cases of atomic/volatile/VFA actual (RM C.6(12)) if (Is_By_Reference_Type (Etype (F)) or else Is_Aliased (F)) and then Comes_From_Source (N) @@ -4744,17 +4748,29 @@ package body Sem_Res is A, F); Error_Msg_N ("\which is passed by reference (RM C.6(12))", A); + + elsif Is_Volatile_Full_Access_Object (A) + and then not Is_Volatile_Full_Access (Etype (F)) + then + Error_Msg_NE + ("cannot pass full access object to nonfull access " + & "formal&", A, F); + Error_Msg_N + ("\which is passed by reference (RM C.6(12))", A); end if; + -- Check for nonatomic subcomponent of a full access object + -- in Ada 2020 (RM C.6 (12)). + if Ada_Version >= Ada_2020 - and then Is_Subcomponent_Of_Atomic_Object (A) + and then Is_Subcomponent_Of_Full_Access_Object (A) and then not Is_Atomic_Object (A) then Error_Msg_N - ("cannot pass nonatomic subcomponent of atomic object", - A); + ("cannot pass nonatomic subcomponent of full access " + & "object", A); Error_Msg_NE - ("\to formal & which is passed by reference (RM C.6(13))", + ("\to formal & which is passed by reference (RM C.6(12))", A, F); end if; end if; @@ -4876,17 +4892,17 @@ package body Sem_Res is if SPARK_Mode = On and then Comes_From_Source (A) then - -- An effectively volatile object may act as an actual when the - -- corresponding formal is of a non-scalar effectively volatile - -- type (SPARK RM 7.1.3(10)). + -- An effectively volatile object for reading may act as an + -- actual when the corresponding formal is of a non-scalar + -- effectively volatile type for reading (SPARK RM 7.1.3(10)). if not Is_Scalar_Type (Etype (F)) - and then Is_Effectively_Volatile (Etype (F)) + and then Is_Effectively_Volatile_For_Reading (Etype (F)) then null; - -- An effectively volatile object may act as an actual in a - -- call to an instance of Unchecked_Conversion. + -- An effectively volatile object for reading may act as an + -- actual in a call to an instance of Unchecked_Conversion. -- (SPARK RM 7.1.3(10)). elsif Is_Unchecked_Conversion_Instance (Nam) then @@ -4894,18 +4910,18 @@ package body Sem_Res is -- The actual denotes an object - elsif Is_Effectively_Volatile_Object (A) then + elsif Is_Effectively_Volatile_Object_For_Reading (A) then Error_Msg_N ("volatile object cannot act as actual in a call (SPARK " & "RM 7.1.3(10))", A); -- Otherwise the actual denotes an expression. Inspect the - -- expression and flag each effectively volatile object with - -- enabled property Async_Writers or Effective_Reads as illegal - -- because it apprears within an interfering context. Note that - -- this is usually done in Resolve_Entity_Name, but when the - -- effectively volatile object appears as an actual in a call, - -- the call must be resolved first. + -- expression and flag each effectively volatile object + -- for reading as illegal because it apprears within an + -- interfering context. Note that this is usually done in + -- Resolve_Entity_Name, but when the effectively volatile + -- object for reading appears as an actual in a call, the + -- call must be resolved first. else Flag_Effectively_Volatile_Objects (A); @@ -4923,7 +4939,7 @@ package body Sem_Res is A_Id := Entity (A); if Ekind (A_Id) = E_Variable - and then Is_Effectively_Volatile (Etype (A_Id)) + and then Is_Effectively_Volatile_For_Reading (Etype (A_Id)) and then Effective_Reads_Enabled (A_Id) then Error_Msg_NE @@ -5045,8 +5061,9 @@ package body Sem_Res is elsif Nkind (Disc_Exp) = N_Attribute_Reference and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) = Attribute_Access - and then Object_Access_Level (Prefix (Disc_Exp)) > - Deepest_Type_Access_Level (Alloc_Typ) + and then Static_Accessibility_Level + (Disc_Exp, Zero_On_Dynamic_Level) + > Deepest_Type_Access_Level (Alloc_Typ) then Error_Msg_N ("prefix of attribute has deeper level than allocator type", @@ -5057,8 +5074,9 @@ package body Sem_Res is elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type and then Nkind (Disc_Exp) = N_Selected_Component - and then Object_Access_Level (Prefix (Disc_Exp)) > - Deepest_Type_Access_Level (Alloc_Typ) + and then Static_Accessibility_Level + (Disc_Exp, Zero_On_Dynamic_Level) + > Deepest_Type_Access_Level (Alloc_Typ) then Error_Msg_N ("access discriminant has deeper level than allocator type", @@ -6126,27 +6144,6 @@ package body Sem_Res is ------------------ procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is - function Same_Or_Aliased_Subprograms - (S : Entity_Id; - E : Entity_Id) return Boolean; - -- Returns True if the subprogram entity S is the same as E or else - -- S is an alias of E. - - --------------------------------- - -- Same_Or_Aliased_Subprograms -- - --------------------------------- - - function Same_Or_Aliased_Subprograms - (S : Entity_Id; - E : Entity_Id) return Boolean - is - Subp_Alias : constant Entity_Id := Alias (S); - begin - return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); - end Same_Or_Aliased_Subprograms; - - -- Local variables - Loc : constant Source_Ptr := Sloc (N); Subp : constant Node_Id := Name (N); Body_Id : Entity_Id; @@ -6159,8 +6156,6 @@ package body Sem_Res is Rtype : Entity_Id; Scop : Entity_Id; - -- Start of processing for Resolve_Call - begin -- Preserve relevant elaboration-related attributes of the context which -- are no longer available or very expensive to recompute once analysis, @@ -7042,6 +7037,7 @@ package body Sem_Res is if not Checking_Potentially_Static_Expression and then Is_Static_Function_Call (N) + and then not Is_Intrinsic_Subprogram (Ultimate_Alias (Nam)) and then not Error_Posted (Ultimate_Alias (Nam)) then Inline_Static_Function_Call (N, Ultimate_Alias (Nam)); @@ -7442,11 +7438,14 @@ package body Sem_Res is -- Install the scope created for local declarations, if -- any. The syntax allows a Declare_Expression with no -- declarations, in analogy with block statements. + -- Note that that scope has no explicit declaration, but + -- appears as the scope of all entities declared therein. Decl := First (Actions (N)); while Present (Decl) loop - exit when Nkind (Decl) = N_Object_Declaration; + exit when Nkind (Decl) + in N_Object_Declaration | N_Object_Renaming_Declaration; Next (Decl); end loop; @@ -7769,14 +7768,11 @@ package body Sem_Res is if SPARK_Mode = On then - -- An effectively volatile object subject to enabled properties - -- Async_Writers or Effective_Reads must appear in non-interfering - -- context (SPARK RM 7.1.3(10)). + -- An effectively volatile object for reading must appear in + -- non-interfering context (SPARK RM 7.1.3(10)). if Is_Object (E) - and then Is_Effectively_Volatile (E) - and then (Async_Writers_Enabled (E) - or else Effective_Reads_Enabled (E)) + and then Is_Effectively_Volatile_For_Reading (E) and then not Is_OK_Volatile_Context (Par, N) then SPARK_Msg_N @@ -11642,12 +11638,12 @@ package body Sem_Res is -- to apply checks required for a subtype conversion. -- Skip these type conversion checks if universal fixed operands - -- operands involved, since range checks are handled separately for + -- are involved, since range checks are handled separately for -- these cases (in the appropriate Expand routines in unit Exp_Fixd). if Nkind (N) = N_Type_Conversion and then not Is_Generic_Type (Root_Type (Target_Typ)) - and then Target_Typ /= Universal_Fixed + and then Target_Typ /= Universal_Fixed and then Operand_Typ /= Universal_Fixed then Apply_Type_Conversion_Checks (N); @@ -11887,19 +11883,13 @@ package body Sem_Res is (N, Target_Typ, Static_Failure_Is_Error => True); end if; - -- If at this stage we have a real to integer conversion, make sure that - -- the Do_Range_Check flag is set, because such conversions in general - -- need a range check. We only need this if expansion is off. - -- In GNATprove mode, we only do that when converting from fixed-point - -- (as floating-point to integer conversions are now handled in - -- GNATprove mode). + -- If at this stage we have a fixed point to integer conversion, make + -- sure that the Do_Range_Check flag is set which is not always done + -- by exp_fixd.adb. if Nkind (N) = N_Type_Conversion - and then not Expander_Active and then Is_Integer_Type (Target_Typ) - and then (Is_Fixed_Point_Type (Operand_Typ) - or else (not GNATprove_Mode - and then Is_Floating_Point_Type (Operand_Typ))) + and then Is_Fixed_Point_Type (Operand_Typ) and then not Range_Checks_Suppressed (Target_Typ) and then not Range_Checks_Suppressed (Operand_Typ) then @@ -13363,12 +13353,13 @@ package body Sem_Res is then -- When the operand is a selected access discriminant the check -- needs to be made against the level of the object denoted by - -- the prefix of the selected name (Object_Access_Level handles + -- the prefix of the selected name (Accessibility_Level handles -- checking the prefix of the operand for this case). if Nkind (Operand) = N_Selected_Component - and then Object_Access_Level (Operand) > - Deepest_Type_Access_Level (Target_Type) + and then Static_Accessibility_Level + (Operand, Zero_On_Dynamic_Level) + > Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -13452,11 +13443,21 @@ package body Sem_Res is -- rewritten. The Comes_From_Source test isn't sufficient because -- nodes in inlined calls to predefined library routines can have -- Comes_From_Source set to False. (Is there a better way to test - -- for implicit conversions???) + -- for implicit conversions???). + -- + -- Do not treat a rewritten 'Old attribute reference like other + -- rewrite substitutions. This makes a difference, for example, + -- in the case where we are generating the expansion of a + -- membership test of the form + -- Saooaaat'Old in Named_Access_Type + -- because in this case Valid_Conversion needs to return True + -- (otherwise the expansion will be False - see the call site + -- in exp_ch4.adb). if Ada_Version >= Ada_2012 and then not Comes_From_Source (N) and then Is_Rewrite_Substitution (N) + and then not Is_Attribute_Old (Original_Node (N)) and then Ekind (Base_Type (Target_Type)) = E_General_Access_Type and then Ekind (Opnd_Type) = E_Anonymous_Access_Type then @@ -13526,6 +13527,13 @@ package body Sem_Res is N_Function_Specification or else Ekind (Target_Type) in Anonymous_Access_Kind) + + -- Check we are not in a return value ??? + + and then (not In_Return_Value (N) + or else + Nkind (Associated_Node_For_Itype (Target_Type)) + = N_Component_Declaration) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -13560,12 +13568,13 @@ package body Sem_Res is then -- When the operand is a selected access discriminant the check -- needs to be made against the level of the object denoted by - -- the prefix of the selected name (Object_Access_Level handles + -- the prefix of the selected name (Accessibility_Level handles -- checking the prefix of the operand for this case). if Nkind (Operand) = N_Selected_Component - and then Object_Access_Level (Operand) > - Deepest_Type_Access_Level (Target_Type) + and then Static_Accessibility_Level + (Operand, Zero_On_Dynamic_Level) + > Deepest_Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb index f8ad56b..56902b0 100644 --- a/gcc/ada/sem_scil.adb +++ b/gcc/ada/sem_scil.adb @@ -135,7 +135,7 @@ package body Sem_SCIL is pragma Assert (Nkind (N) in N_Identifier | N_And_Then | N_Or_Else | - N_Expression_With_Actions + N_Expression_With_Actions | N_Function_Call and then Etype (N) = Standard_Boolean); -- Check the entity identifier of the associated tagged type (that diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index a5e62a7..3b1f48e 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1009,6 +1009,15 @@ package body Sem_Type is elsif T2 = Any_Composite and then Is_Aggregate_Type (T1) then return True; + -- In Ada_2020, an aggregate is compatible with the type that + -- as the ccorrespoding aspect. + + elsif Ada_Version >= Ada_2020 + and then T2 = Any_Composite + and then Present (Find_Aspect (T1, Aspect_Aggregate)) + then + return True; + -- If the expected type is an anonymous access, the designated type must -- cover that of the expression. Use the base type for this check: even -- though access subtypes are rare in sources, they are generated for diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a80cc5c..0eb4905 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -25,13 +25,13 @@ with Treepr; -- ???For debugging code below -with Aspects; use Aspects; with Casing; use Casing; with Checks; use Checks; with Debug; use Debug; with Elists; use Elists; with Errout; use Errout; with Erroutc; use Erroutc; +with Exp_Ch3; use Exp_Ch3; with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; with Fname; use Fname; @@ -49,8 +49,10 @@ with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Attr; use Sem_Attr; +with Sem_Cat; use Sem_Cat; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; @@ -116,7 +118,7 @@ package body Sem_Util is (Item_Id : Entity_Id; Property : Name_Id) return Boolean; -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled. - -- Determine whether the state abstraction, variable, or type denoted by + -- Determine whether the state abstraction, object, or type denoted by -- entity Item_Id has enabled property Property. function Has_Null_Extension (T : Entity_Id) return Boolean; @@ -127,6 +129,18 @@ package body Sem_Util is -- Determine whether arbitrary entity Id denotes an atomic object as per -- RM C.6(7). + function Is_Container_Aggregate (Exp : Node_Id) return Boolean; + -- Is the given expression a container aggregate? + + generic + with function Is_Effectively_Volatile_Entity + (Id : Entity_Id) return Boolean; + -- Function to use on object and type entities + function Is_Effectively_Volatile_Object_Shared + (N : Node_Id) return Boolean; + -- Shared function used to detect effectively volatile objects and + -- effectively volatile objects for reading. + function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type -- with discriminants whose default values are static, examine only the @@ -256,6 +270,614 @@ package body Sem_Util is return Interface_List (Nod); end Abstract_Interface_List; + ------------------------- + -- Accessibility_Level -- + ------------------------- + + function Accessibility_Level + (Expr : Node_Id; + Level : Accessibility_Level_Kind; + In_Return_Context : Boolean := False) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Expr); + + function Accessibility_Level (Expr : Node_Id) return Node_Id + is (Accessibility_Level (Expr, Level, In_Return_Context)); + -- Renaming of the enclosing function to facilitate recursive calls + + function Make_Level_Literal (Level : Uint) return Node_Id; + -- Construct an integer literal representing an accessibility level + -- with its type set to Natural. + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint; + -- Returns the scope depth of the given node's innermost + -- enclosing dynamic scope (effectively the accessibility + -- level of the innermost enclosing master). + + function Function_Call_Or_Allocator_Level + (N : Node_Id) return Node_Id; + -- Centralized processing of subprogram calls which may appear in + -- prefix notation. + + ---------------------------------- + -- Innermost_Master_Scope_Depth -- + ---------------------------------- + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint + is + Encl_Scop : Entity_Id; + Node_Par : Node_Id := Parent (N); + Master_Lvl_Modifier : Int := 0; + + begin + -- Locate the nearest enclosing node (by traversing Parents) + -- that Defining_Entity can be applied to, and return the + -- depth of that entity's nearest enclosing dynamic scope. + + -- The rules that define what a master are defined in + -- RM 7.6.1 (3), and include statements and conditions for loops + -- among other things. These cases are detected properly ??? + + while Present (Node_Par) loop + + if Present (Defining_Entity + (Node_Par, Empty_On_Errors => True)) + then + Encl_Scop := Nearest_Dynamic_Scope + (Defining_Entity (Node_Par)); + + -- Ignore transient scopes made during expansion + + if Comes_From_Source (Node_Par) then + return Scope_Depth (Encl_Scop) + Master_Lvl_Modifier; + end if; + + -- For a return statement within a function, return + -- the depth of the function itself. This is not just + -- a small optimization, but matters when analyzing + -- the expression in an expression function before + -- the body is created. + + elsif Nkind (Node_Par) in N_Extended_Return_Statement + | N_Simple_Return_Statement + and then Ekind (Current_Scope) = E_Function + then + return Scope_Depth (Current_Scope); + + -- Statements are counted as masters + + elsif Is_Master (Node_Par) then + Master_Lvl_Modifier := Master_Lvl_Modifier + 1; + + end if; + + Node_Par := Parent (Node_Par); + end loop; + + -- Should never reach the following return + + pragma Assert (False); + + return Scope_Depth (Current_Scope) + 1; + end Innermost_Master_Scope_Depth; + + ------------------------ + -- Make_Level_Literal -- + ------------------------ + + function Make_Level_Literal (Level : Uint) return Node_Id is + Result : constant Node_Id := Make_Integer_Literal (Loc, Level); + + begin + Set_Etype (Result, Standard_Natural); + return Result; + end Make_Level_Literal; + + -------------------------------------- + -- Function_Call_Or_Allocator_Level -- + -------------------------------------- + + function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id is + Par : Node_Id; + Prev_Par : Node_Id; + begin + -- Results of functions are objects, so we either get the + -- accessibility of the function or, in case of a call which is + -- indirect, the level of the access-to-subprogram type. + + -- This code looks wrong ??? + + if Nkind (N) = N_Function_Call + and then Ada_Version < Ada_2005 + then + if Is_Entity_Name (Name (N)) then + return Make_Level_Literal + (Subprogram_Access_Level (Entity (Name (N)))); + else + return Make_Level_Literal + (Type_Access_Level (Etype (Prefix (Name (N))))); + end if; + + -- We ignore coextensions as they cannot be implemented under the + -- "small-integer" model. + + elsif Nkind (N) = N_Allocator + and then (Is_Static_Coextension (N) + or else Is_Dynamic_Coextension (N)) + then + return Make_Level_Literal + (Scope_Depth (Standard_Standard)); + end if; + + -- Named access types have a designated level + + if Is_Named_Access_Type (Etype (N)) then + return Make_Level_Literal (Type_Access_Level (Etype (N))); + + -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3) + + else + if Nkind (N) = N_Function_Call then + -- Dynamic checks are generated when we are within a return + -- value or we are in a function call within an anonymous + -- access discriminant constraint of a return object (signified + -- by In_Return_Context) on the side of the callee. + + -- So, in this case, return library accessibility level to null + -- out the check on the side of the caller. + + if In_Return_Value (N) + or else In_Return_Context + then + return Make_Level_Literal + (Subprogram_Access_Level (Current_Subprogram)); + end if; + end if; + + -- Find any relevant enclosing parent nodes that designate an + -- object being initialized. + + -- Note: The above is only relevant if the result is used "in its + -- entirety" as RM 3.10.2 (10.2/3) states. However, this is + -- accounted for in the case statement in the main body of + -- Accessibility_Level for N_Selected_Component. + + Par := Parent (Expr); + Prev_Par := Empty; + while Present (Par) loop + -- Detect an expanded implicit conversion, typically this + -- occurs on implicitly converted actuals in calls. + + -- Does this catch all implicit conversions ??? + + if Nkind (Par) = N_Type_Conversion + and then Is_Named_Access_Type (Etype (Par)) + then + return Make_Level_Literal + (Type_Access_Level (Etype (Par))); + end if; + + -- Jump out when we hit an object declaration or the right-hand + -- side of an assignment, or a construct such as an aggregate + -- subtype indication which would be the result is not used + -- "in its entirety." + + exit when Nkind (Par) in N_Object_Declaration + or else (Nkind (Par) = N_Assignment_Statement + and then Name (Par) /= Prev_Par); + + Prev_Par := Par; + Par := Parent (Par); + end loop; + + -- Assignment statements are handled in a similar way in + -- accordance to the left-hand part. However, strictly speaking, + -- this is illegal according to the RM, but this change is needed + -- to pass an ACATS C-test and is useful in general ??? + + case Nkind (Par) is + when N_Object_Declaration => + return Make_Level_Literal + (Scope_Depth + (Scope (Defining_Identifier (Par)))); + + when N_Assignment_Statement => + -- Return the accessiblity level of the left-hand part + + return Accessibility_Level + (Expr => Name (Par), + Level => Object_Decl_Level, + In_Return_Context => In_Return_Context); + + when others => + return Make_Level_Literal + (Innermost_Master_Scope_Depth (Expr)); + end case; + end if; + end Function_Call_Or_Allocator_Level; + + -- Local variables + + E : Entity_Id := Original_Node (Expr); + Pre : Node_Id; + + -- Start of processing for Accessibility_Level + + begin + -- We could be looking at a reference to a formal due to the expansion + -- of entries and other cases, so obtain the renaming if necessary. + + if Present (Param_Entity (Expr)) then + E := Param_Entity (Expr); + end if; + + -- Extract the entity + + if Nkind (E) in N_Has_Entity and then Present (Entity (E)) then + E := Entity (E); + + -- Deal with a possible renaming of a private protected component + + if Ekind (E) in E_Constant | E_Variable and then Is_Prival (E) then + E := Prival_Link (E); + end if; + end if; + + -- Perform the processing on the expression + + case Nkind (E) is + -- The level of an aggregate is that of the innermost master that + -- evaluates it as defined in RM 3.10.2 (10/4). + + when N_Aggregate => + return Make_Level_Literal (Innermost_Master_Scope_Depth (Expr)); + + -- The accessibility level is that of the access type, except for an + -- anonymous allocators which have special rules defined in RM 3.10.2 + -- (14/3). + + when N_Allocator => + return Function_Call_Or_Allocator_Level (E); + + -- We could reach this point for two reasons. Either the expression + -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or + -- we are looking at the access attributes directly ('Access, + -- 'Address, or 'Unchecked_Access). + + when N_Attribute_Reference => + Pre := Original_Node (Prefix (E)); + + -- Regular 'Access attribute presence means we have to look at the + -- prefix. + + if Attribute_Name (E) = Name_Access then + return Accessibility_Level (Prefix (E)); + + -- Unchecked or unrestricted attributes have unlimited depth + + elsif Attribute_Name (E) in Name_Address + | Name_Unchecked_Access + | Name_Unrestricted_Access + then + return Make_Level_Literal (Scope_Depth (Standard_Standard)); + + -- 'Access can be taken further against other special attributes, + -- so handle these cases explicitly. + + elsif Attribute_Name (E) + in Name_Old | Name_Loop_Entry | Name_Result + then + -- Named access types + + if Is_Named_Access_Type (Etype (Pre)) then + return Make_Level_Literal + (Type_Access_Level (Etype (Pre))); + + -- Anonymous access types + + elsif Nkind (Pre) in N_Has_Entity + and then Present (Get_Dynamic_Accessibility (Entity (Pre))) + and then Level = Dynamic_Level + then + return New_Occurrence_Of + (Get_Dynamic_Accessibility (Entity (Pre)), Loc); + + -- Otherwise the level is treated in a similar way as + -- aggregates according to RM 6.1.1 (35.1/4) which concerns + -- an implicit constant declaration - in turn defining the + -- accessibility level to be that of the implicit constant + -- declaration. + + else + return Make_Level_Literal + (Innermost_Master_Scope_Depth (Expr)); + end if; + + else + raise Program_Error; + end if; + + -- This is the "base case" for accessibility level calculations which + -- means we are near the end of our recursive traversal. + + when N_Defining_Identifier => + -- A dynamic check is performed on the side of the callee when we + -- are within a return statement, so return a library-level + -- accessibility level to null out checks on the side of the + -- caller. + + if Is_Explicitly_Aliased (E) + and then Level /= Dynamic_Level + and then (In_Return_Value (Expr) + or else In_Return_Context) + then + return Make_Level_Literal (Scope_Depth (Standard_Standard)); + + -- Something went wrong and an extra accessibility formal has not + -- been generated when one should have ??? + + elsif Is_Formal (E) + and then not Present (Get_Dynamic_Accessibility (E)) + and then Ekind (Etype (E)) = E_Anonymous_Access_Type + then + return Make_Level_Literal (Scope_Depth (Standard_Standard)); + + -- Stand-alone object of an anonymous access type "SAOAAT" + + elsif (Is_Formal (E) + or else Ekind (E) in E_Variable + | E_Constant) + and then Present (Get_Dynamic_Accessibility (E)) + and then (Level = Dynamic_Level + or else Level = Zero_On_Dynamic_Level) + then + if Level = Zero_On_Dynamic_Level then + return Make_Level_Literal + (Scope_Depth (Standard_Standard)); + end if; + + return + New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc); + + -- Initialization procedures have a special extra accessitility + -- parameter associated with the level at which the object + -- begin initialized exists + + elsif Ekind (E) = E_Record_Type + and then Is_Limited_Record (E) + and then Current_Scope = Init_Proc (E) + and then Present (Init_Proc_Level_Formal (Current_Scope)) + then + return New_Occurrence_Of + (Init_Proc_Level_Formal (Current_Scope), Loc); + + -- Current instance of the type is deeper than that of the type + -- according to RM 3.10.2 (21). + + elsif Is_Type (E) then + return Make_Level_Literal + (Type_Access_Level (E) + 1); + + -- Move up the renamed entity if it came from source since + -- expansion may have created a dummy renaming under certain + -- circumstances. + + elsif Present (Renamed_Object (E)) + and then Comes_From_Source (Renamed_Object (E)) + then + return Accessibility_Level (Renamed_Object (E)); + + -- Named access types get their level from their associated type + + elsif Is_Named_Access_Type (Etype (E)) then + return Make_Level_Literal + (Type_Access_Level (Etype (E))); + + -- When E is a component of the current instance of a + -- protected type, we assume the level to be deeper than that of + -- the type itself. + + elsif not Is_Overloadable (E) + and then Ekind (Scope (E)) = E_Protected_Type + and then Comes_From_Source (Scope (E)) + then + return Make_Level_Literal + (Scope_Depth (Enclosing_Dynamic_Scope (E)) + 1); + + -- Normal object - get the level of the enclosing scope + + else + return Make_Level_Literal + (Scope_Depth (Enclosing_Dynamic_Scope (E))); + end if; + + -- Handle indexed and selected components including the special cases + -- whereby there is an implicit dereference, a component of a + -- composite type, or a function call in prefix notation. + + -- We don't handle function calls in prefix notation correctly ??? + + when N_Indexed_Component | N_Selected_Component => + Pre := Original_Node (Prefix (E)); + + -- When E is an indexed component or selected component and + -- the current Expr is a function call, we know that we are + -- looking at an expanded call in prefix notation. + + if Nkind (Expr) = N_Function_Call then + return Function_Call_Or_Allocator_Level (Expr); + + -- If the prefix is a named access type, then we are dealing + -- with an implicit deferences. In that case the level is that + -- of the named access type in the prefix. + + elsif Is_Named_Access_Type (Etype (Pre)) then + return Make_Level_Literal + (Type_Access_Level (Etype (Pre))); + + -- The current expression is a named access type, so there is no + -- reason to look at the prefix. Instead obtain the level of E's + -- named access type. + + elsif Is_Named_Access_Type (Etype (E)) then + return Make_Level_Literal + (Type_Access_Level (Etype (E))); + + -- A non-discriminant selected component where the component + -- is an anonymous access type means that its associated + -- level is that of the containing type - see RM 3.10.2 (16). + + elsif Nkind (E) = N_Selected_Component + and then Ekind (Etype (E)) = E_Anonymous_Access_Type + and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type + and then not (Nkind (Selector_Name (E)) in N_Has_Entity + and then Ekind (Entity (Selector_Name (E))) + = E_Discriminant) + then + return Make_Level_Literal + (Type_Access_Level (Etype (Prefix (E)))); + + -- Similar to the previous case - arrays featuring components of + -- anonymous access components get their corresponding level from + -- their containing type's declaration. + + elsif Nkind (E) = N_Indexed_Component + and then Ekind (Etype (E)) = E_Anonymous_Access_Type + and then Ekind (Etype (Pre)) in Array_Kind + and then Ekind (Component_Type (Base_Type (Etype (Pre)))) + = E_Anonymous_Access_Type + then + return Make_Level_Literal + (Type_Access_Level (Etype (Prefix (E)))); + + -- The accessibility calculation routine that handles function + -- calls (Function_Call_Level) assumes, in the case the + -- result is of an anonymous access type, that the result will be + -- used "in its entirety" when the call is present within an + -- assignment or object declaration. + + -- To properly handle cases where the result is not used in its + -- entirety, we test if the prefix of the component in question is + -- a function call, which tells us that one of its components has + -- been identified and is being accessed. Therefore we can + -- conclude that the result is not used "in its entirety" + -- according to RM 3.10.2 (10.2/3). + + elsif Nkind (Pre) = N_Function_Call + and then not Is_Named_Access_Type (Etype (Pre)) + then + -- Dynamic checks are generated when we are within a return + -- value or we are in a function call within an anonymous + -- access discriminant constraint of a return object (signified + -- by In_Return_Context) on the side of the callee. + + -- So, in this case, return a library accessibility level to + -- null out the check on the side of the caller. + + if (In_Return_Value (E) + or else In_Return_Context) + and then Level /= Dynamic_Level + then + return Make_Level_Literal + (Scope_Depth (Standard_Standard)); + end if; + + return Make_Level_Literal + (Innermost_Master_Scope_Depth (Expr)); + + -- Otherwise, continue recursing over the expression prefixes + + else + return Accessibility_Level (Prefix (E)); + end if; + + -- Qualified expressions + + when N_Qualified_Expression => + if Is_Named_Access_Type (Etype (E)) then + return Make_Level_Literal + (Type_Access_Level (Etype (E))); + else + return Accessibility_Level (Expression (E)); + end if; + + -- Handle function calls + + when N_Function_Call => + return Function_Call_Or_Allocator_Level (E); + + -- Explicit dereference accessibility level calculation + + when N_Explicit_Dereference => + Pre := Original_Node (Prefix (E)); + + -- The prefix is a named access type so the level is taken from + -- its type. + + if Is_Named_Access_Type (Etype (Pre)) then + return Make_Level_Literal (Type_Access_Level (Etype (Pre))); + + -- Otherwise, recurse deeper + + else + return Accessibility_Level (Prefix (E)); + end if; + + -- Type conversions + + when N_Type_Conversion | N_Unchecked_Type_Conversion => + -- View conversions are special in that they require use to + -- inspect the expression of the type conversion. + + -- Allocators of anonymous access types are internally generated, + -- so recurse deeper in that case as well. + + if Is_View_Conversion (E) + or else Ekind (Etype (E)) = E_Anonymous_Access_Type + then + return Accessibility_Level (Expression (E)); + + -- We don't care about the master if we are looking at a named + -- access type. + + elsif Is_Named_Access_Type (Etype (E)) then + return Make_Level_Literal + (Type_Access_Level (Etype (E))); + + -- In section RM 3.10.2 (10/4) the accessibility rules for + -- aggregates and value conversions are outlined. Are these + -- followed in the case of initialization of an object ??? + + -- Should use Innermost_Master_Scope_Depth ??? + + else + return Accessibility_Level (Current_Scope); + end if; + + -- Default to the type accessibility level for the type of the + -- expression's entity. + + when others => + return Make_Level_Literal (Type_Access_Level (Etype (E))); + end case; + end Accessibility_Level; + + -------------------------------- + -- Static_Accessibility_Level -- + -------------------------------- + + function Static_Accessibility_Level + (Expr : Node_Id; + Level : Static_Accessibility_Level_Kind; + In_Return_Context : Boolean := False) return Uint + is + begin + return Intval + (Accessibility_Level (Expr, Level, In_Return_Context)); + end Static_Accessibility_Level; + ---------------------------------- -- Acquire_Warning_Match_String -- ---------------------------------- @@ -314,7 +936,6 @@ package body Sem_Util is procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is Loc : constant Source_Ptr := Sloc (N); - begin pragma Assert (Nkind (N) = N_Block_Statement); @@ -419,14 +1040,13 @@ package body Sem_Util is -- Addressable -- ----------------- - -- For now, just 8/16/32/64 - function Addressable (V : Uint) return Boolean is begin return V = Uint_8 or else V = Uint_16 or else V = Uint_32 or else - V = Uint_64; + V = Uint_64 or else + (V = Uint_128 and then System_Max_Integer_Size = 128); end Addressable; function Addressable (V : Int) return Boolean is @@ -434,7 +1054,8 @@ package body Sem_Util is return V = 8 or else V = 16 or else V = 32 or else - V = 64; + V = 64 or else + V = System_Max_Integer_Size; end Addressable; --------------------------------- @@ -982,7 +1603,7 @@ package body Sem_Util is Reason => PE_Bad_Predicated_Generic_Type)); else - Error_Msg_FE (Msg & "<<", N, Typ); + Error_Msg_FE (Msg, N, Typ); end if; else @@ -2416,6 +3037,27 @@ package body Sem_Util is end if; end Cannot_Raise_Constraint_Error; + ------------------------------- + -- Check_Ambiguous_Aggregate -- + ------------------------------- + + procedure Check_Ambiguous_Aggregate (Call : Node_Id) is + Actual : Node_Id; + + begin + if Extensions_Allowed then + Actual := First_Actual (Call); + while Present (Actual) loop + if Nkind (Actual) = N_Aggregate then + Error_Msg_N + ("\add type qualification to aggregate actual", Actual); + exit; + end if; + Next_Actual (Actual); + end loop; + end if; + end Check_Ambiguous_Aggregate; + ----------------------------------------- -- Check_Dynamically_Tagged_Expression -- ----------------------------------------- @@ -2535,10 +3177,6 @@ package body Sem_Util is -- second occurrence, the error is reported, and the tree traversal -- is abandoned. - procedure Preanalyze_Without_Errors (N : Node_Id); - -- Preanalyze N without reporting errors. Very dubious, you can't just - -- go analyzing things more than once??? - ------------------------- -- Collect_Identifiers -- ------------------------- @@ -2765,18 +3403,6 @@ package body Sem_Util is Do_Traversal (N); end Collect_Identifiers; - ------------------------------- - -- Preanalyze_Without_Errors -- - ------------------------------- - - procedure Preanalyze_Without_Errors (N : Node_Id) is - Status : constant Boolean := Get_Ignore_Errors; - begin - Set_Ignore_Errors (True); - Preanalyze (N); - Set_Ignore_Errors (Status); - end Preanalyze_Without_Errors; - -- Start of processing for Check_Function_Writable_Actuals begin @@ -3614,6 +4240,132 @@ package body Sem_Util is end if; end Check_No_Hidden_State; + --------------------------------------------- + -- Check_Nonoverridable_Aspect_Consistency -- + --------------------------------------------- + + procedure Check_Inherited_Nonoverridable_Aspects + (Inheritor : Entity_Id; + Interface_List : List_Id; + Parent_Type : Entity_Id) is + + -- array needed for iterating over subtype values + Nonoverridable_Aspects : constant array (Positive range <>) of + Nonoverridable_Aspect_Id := + (Aspect_Default_Iterator, + Aspect_Iterator_Element, + Aspect_Implicit_Dereference, + Aspect_Constant_Indexing, + Aspect_Variable_Indexing, + Aspect_Aggregate, + Aspect_Max_Entry_Queue_Length + -- , Aspect_No_Controlled_Parts + ); + + -- Note that none of these 8 aspects can be specified (for a type) + -- via a pragma. For 7 of them, the corresponding pragma does not + -- exist. The Pragma_Id enumeration type does include + -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to + -- specify the aspect for a protected entry or entry family, not for + -- a type, and therefore cannot introduce the sorts of inheritance + -- issues that we are concerned with in this procedure. + + type Entity_Array is array (Nat range <>) of Entity_Id; + + function Ancestor_Entities return Entity_Array; + -- Returns all progenitors (including parent type, if present) + + procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors + (Aspect : Nonoverridable_Aspect_Id; + Ancestor_1 : Entity_Id; + Aspect_Spec_1 : Node_Id; + Ancestor_2 : Entity_Id; + Aspect_Spec_2 : Node_Id); + -- A given aspect has been specified for each of two ancestors; + -- check that the two aspect specifications are compatible (see + -- RM 13.1.1(18.5) and AI12-0211). + + ----------------------- + -- Ancestor_Entities -- + ----------------------- + + function Ancestor_Entities return Entity_Array is + Ifc_Count : constant Nat := List_Length (Interface_List); + Ifc_Ancestors : Entity_Array (1 .. Ifc_Count); + Ifc : Node_Id := First (Interface_List); + begin + for Idx in Ifc_Ancestors'Range loop + Ifc_Ancestors (Idx) := Entity (Ifc); + pragma Assert (Present (Ifc_Ancestors (Idx))); + Ifc := Next (Ifc); + end loop; + pragma Assert (not Present (Ifc)); + if Present (Parent_Type) then + return Parent_Type & Ifc_Ancestors; + else + return Ifc_Ancestors; + end if; + end Ancestor_Entities; + + ------------------------------------------------------- + -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors -- + ------------------------------------------------------- + + procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors + (Aspect : Nonoverridable_Aspect_Id; + Ancestor_1 : Entity_Id; + Aspect_Spec_1 : Node_Id; + Ancestor_2 : Entity_Id; + Aspect_Spec_2 : Node_Id) is + begin + if not Is_Confirming (Aspect, Aspect_Spec_1, Aspect_Spec_2) then + Error_Msg_Name_1 := Aspect_Names (Aspect); + Error_Msg_Name_2 := Chars (Ancestor_1); + Error_Msg_Name_3 := Chars (Ancestor_2); + + Error_Msg ( + "incompatible % aspects inherited from ancestors % and %", + Sloc (Inheritor)); + end if; + end Check_Consistency_For_One_Aspect_Of_Two_Ancestors; + + Ancestors : constant Entity_Array := Ancestor_Entities; + + -- start of processing for Check_Inherited_Nonoverridable_Aspects + begin + -- No Ada_Version check here; AI12-0211 is a binding interpretation. + + if Ancestors'Length < 2 then + return; -- Inconsistency impossible; it takes 2 to disagree. + elsif In_Instance_Body then + return; -- No legality checking in an instance body. + end if; + + for Aspect of Nonoverridable_Aspects loop + declare + First_Ancestor_With_Aspect : Entity_Id := Empty; + First_Aspect_Spec, Current_Aspect_Spec : Node_Id := Empty; + begin + for Ancestor of Ancestors loop + Current_Aspect_Spec := Find_Aspect (Ancestor, Aspect); + if Present (Current_Aspect_Spec) then + if Present (First_Ancestor_With_Aspect) then + Check_Consistency_For_One_Aspect_Of_Two_Ancestors + (Aspect => Aspect, + Ancestor_1 => First_Ancestor_With_Aspect, + Aspect_Spec_1 => First_Aspect_Spec, + Ancestor_2 => Ancestor, + Aspect_Spec_2 => Current_Aspect_Spec); + else + First_Ancestor_With_Aspect := Ancestor; + First_Aspect_Spec := Current_Aspect_Spec; + end if; + end if; + end loop; + end; + end loop; + end Check_Inherited_Nonoverridable_Aspects; + ---------------------------------------- -- Check_Nonvolatile_Function_Profile -- ---------------------------------------- @@ -3626,7 +4378,7 @@ package body Sem_Util is Formal := First_Formal (Func_Id); while Present (Formal) loop - if Is_Effectively_Volatile (Etype (Formal)) then + if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then Error_Msg_NE ("nonvolatile function & cannot have a volatile parameter", Formal, Func_Id); @@ -3637,7 +4389,7 @@ package body Sem_Util is -- Inspect the return type - if Is_Effectively_Volatile (Etype (Func_Id)) then + if Is_Effectively_Volatile_For_Reading (Etype (Func_Id)) then Error_Msg_NE ("nonvolatile function & cannot have a volatile return type", Result_Definition (Parent (Func_Id)), Func_Id); @@ -4754,8 +5506,9 @@ package body Sem_Util is if Present (Pref_Encl_Typ) and then No (Cont_Encl_Typ) and then Is_Public_Operation - and then Scope_Depth (Pref_Encl_Typ) >= - Object_Access_Level (Context) + and then Scope_Depth (Pref_Encl_Typ) + >= Static_Accessibility_Level + (Context, Object_Decl_Level) then Error_Msg_N ("??possible unprotected access to protected data", Expr); @@ -6229,9 +6982,9 @@ package body Sem_Util is end if; end Current_Subprogram; - ---------------------------------- + ------------------------------- -- Deepest_Type_Access_Level -- - ---------------------------------- + ------------------------------- function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is begin @@ -6262,7 +7015,10 @@ package body Sem_Util is -- Defining_Entity -- --------------------- - function Defining_Entity (N : Node_Id) return Entity_Id is + function Defining_Entity + (N : Node_Id; + Empty_On_Errors : Boolean := False) return Entity_Id + is begin case Nkind (N) is when N_Abstract_Subprogram_Declaration @@ -6361,6 +7117,10 @@ package body Sem_Util is return Entity (Identifier (N)); when others => + if Empty_On_Errors then + return Empty; + end if; + raise Program_Error; end case; end Defining_Entity; @@ -6764,6 +7524,71 @@ package body Sem_Util is return Denotes_Discriminant (L) or else Denotes_Discriminant (H); end Depends_On_Discriminant; + ------------------------------------- + -- Derivation_Too_Early_To_Inherit -- + ------------------------------------- + + function Derivation_Too_Early_To_Inherit + (Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean is + Btyp : constant Entity_Id := Implementation_Base_Type (Typ); + Parent_Type : Entity_Id; + begin + if Is_Derived_Type (Btyp) then + Parent_Type := Implementation_Base_Type (Etype (Btyp)); + pragma Assert (Parent_Type /= Btyp); + if Has_Stream_Attribute_Definition + (Parent_Type, Streaming_Op) + and then In_Same_Extended_Unit (Btyp, Parent_Type) + and then Instantiation (Get_Source_File_Index (Sloc (Btyp))) = + Instantiation (Get_Source_File_Index (Sloc (Parent_Type))) + then + declare + -- ??? Avoid code duplication here with + -- Sem_Cat.Has_Stream_Attribute_Definition by introducing a + -- new function to be called from both places? + + Rep_Item : Node_Id := First_Rep_Item (Parent_Type); + Real_Rep : Node_Id; + Found : Boolean := False; + begin + while Present (Rep_Item) loop + Real_Rep := Rep_Item; + + if Nkind (Rep_Item) = N_Aspect_Specification then + Real_Rep := Aspect_Rep_Item (Rep_Item); + end if; + + if Nkind (Real_Rep) = N_Attribute_Definition_Clause then + case Chars (Real_Rep) is + when Name_Read => + Found := Streaming_Op = TSS_Stream_Read; + + when Name_Write => + Found := Streaming_Op = TSS_Stream_Write; + + when Name_Input => + Found := Streaming_Op = TSS_Stream_Input; + + when Name_Output => + Found := Streaming_Op = TSS_Stream_Output; + + when others => + null; + end case; + end if; + + if Found then + return Earlier_In_Extended_Unit (Btyp, Real_Rep); + end if; + + Next_Rep_Item (Rep_Item); + end loop; + end; + end if; + end if; + return False; + end Derivation_Too_Early_To_Inherit; + ------------------------- -- Designate_Same_Unit -- ------------------------- @@ -6878,203 +7703,6 @@ package body Sem_Util is Analyze (N); end Diagnose_Iterated_Component_Association; - --------------------------------- - -- Dynamic_Accessibility_Level -- - --------------------------------- - - function Dynamic_Accessibility_Level (N : Node_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (N); - - function Make_Level_Literal (Level : Uint) return Node_Id; - -- Construct an integer literal representing an accessibility level - -- with its type set to Natural. - - ------------------------ - -- Make_Level_Literal -- - ------------------------ - - function Make_Level_Literal (Level : Uint) return Node_Id is - Result : constant Node_Id := Make_Integer_Literal (Loc, Level); - - begin - Set_Etype (Result, Standard_Natural); - return Result; - end Make_Level_Literal; - - -- Local variables - - Expr : Node_Id := Original_Node (N); - -- Expr references the original node because at this stage N may be the - -- reference to a variable internally created by the frontend to remove - -- side effects of an expression. - - E : Entity_Id; - - -- Start of processing for Dynamic_Accessibility_Level - - begin - if Is_Entity_Name (Expr) then - E := Entity (Expr); - - if Present (Renamed_Object (E)) then - return Dynamic_Accessibility_Level (Renamed_Object (E)); - end if; - - if (Is_Formal (E) - or else Ekind (E) in E_Variable | E_Constant) - and then Present (Get_Accessibility (E)) - then - return New_Occurrence_Of (Get_Accessibility (E), Loc); - end if; - end if; - - -- Handle a constant-folded conditional expression by avoiding use of - -- the original node. - - if Nkind (Expr) in N_Case_Expression | N_If_Expression then - Expr := N; - end if; - - -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? - - case Nkind (Expr) is - -- It may be possible that we have an access object denoted by an - -- attribute reference for 'Loop_Entry which may, in turn, have an - -- indexed component representing a loop identifier. - - -- In this case we must climb up the indexed component and set expr - -- to the attribute reference so the rest of the machinery can - -- operate as expected. - - when N_Indexed_Component => - if Nkind (Prefix (Expr)) = N_Attribute_Reference - and then Get_Attribute_Id (Attribute_Name (Prefix (Expr))) - = Attribute_Loop_Entry - then - Expr := Prefix (Expr); - end if; - - -- For access discriminant, the level of the enclosing object - - when N_Selected_Component => - if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant - and then Ekind (Etype (Entity (Selector_Name (Expr)))) = - E_Anonymous_Access_Type - then - return Make_Level_Literal (Object_Access_Level (Expr)); - end if; - - when N_Attribute_Reference => - case Get_Attribute_Id (Attribute_Name (Expr)) is - - -- Ignore 'Loop_Entry, 'Result, and 'Old as they can be used to - -- identify access objects and do not have an effect on - -- accessibility level. - - when Attribute_Loop_Entry | Attribute_Old | Attribute_Result => - null; - - -- For X'Access, the level of the prefix X - - when Attribute_Access => - return Make_Level_Literal - (Object_Access_Level (Prefix (Expr))); - - -- Treat the unchecked attributes as library-level - - when Attribute_Unchecked_Access - | Attribute_Unrestricted_Access - => - return Make_Level_Literal (Scope_Depth (Standard_Standard)); - - -- No other access-valued attributes - - when others => - raise Program_Error; - end case; - - when N_Allocator => - - -- This is not fully implemented since it depends on context (see - -- 3.10.2(14/3-14.2/3). More work is needed in the following cases - -- - -- 1) For an anonymous allocator defining the value of an access - -- parameter, the accessibility level is that of the innermost - -- master of the call; however currently we pass the level of - -- execution of the called subprogram, which is one greater - -- than the current scope level (see Expand_Call_Helper). - -- - -- For example, a statement is a master and a declaration is - -- not a master; so we should not pass in the same level for - -- the following cases: - -- - -- function F (X : access Integer) return T is ... ; - -- Decl : T := F (new Integer); -- level is off by one - -- begin - -- Decl := F (new Integer); -- we get this case right - -- - -- 2) For an anonymous allocator that defines the result of a - -- function with an access result, the accessibility level is - -- determined as though the allocator were in place of the call - -- of the function. In the special case of a call that is the - -- operand of a type conversion the level is that of the target - -- access type of the conversion. - -- - -- 3) For an anonymous allocator defining an access discriminant - -- the accessibility level is determined as follows: - -- * for an allocator used to define the discriminant of an - -- object, the level of the object - -- * for an allocator used to define the constraint in a - -- subtype_indication in any other context, the level of - -- the master that elaborates the subtype_indication. - - case Nkind (Parent (N)) is - when N_Object_Declaration => - - -- For an anonymous allocator whose type is that of a - -- stand-alone object of an anonymous access-to-object type, - -- the accessibility level is that of the declaration of the - -- stand-alone object. - - return - Make_Level_Literal - (Object_Access_Level - (Defining_Identifier (Parent (N)))); - - when N_Assignment_Statement => - return - Make_Level_Literal - (Object_Access_Level (Name (Parent (N)))); - - when others => - declare - S : constant String := - Node_Kind'Image (Nkind (Parent (N))); - begin - Error_Msg_Strlen := S'Length; - Error_Msg_String (1 .. Error_Msg_Strlen) := S; - Error_Msg_N - ("unsupported context for anonymous allocator (~)", - Parent (N)); - end; - end case; - - when N_Type_Conversion => - if not Is_Local_Anonymous_Access (Etype (Expr)) then - - -- Handle type conversions introduced for a rename of an - -- Ada 2012 stand-alone object of an anonymous access type. - - return Dynamic_Accessibility_Level (Expression (Expr)); - end if; - - when others => - null; - end case; - - return Make_Level_Literal (Type_Access_Level (Etype (Expr))); - end Dynamic_Accessibility_Level; - ------------------------ -- Discriminated_Size -- ------------------------ @@ -7825,18 +8453,9 @@ package body Sem_Util is Set_Etype (Def_Id, Any_Type); end if; - -- Inherited discriminants and components in derived record types are - -- immediately visible. Itypes are not. - - -- Unless the Itype is for a record type with a corresponding remote - -- type (what is that about, it was not commented ???) + -- All entities except Itypes are immediately visible - if Ekind (Def_Id) in E_Discriminant | E_Component - or else - ((not Is_Record_Type (Def_Id) - or else No (Corresponding_Remote_Type (Def_Id))) - and then not Is_Itype (Def_Id)) - then + if not Is_Itype (Def_Id) then Set_Is_Immediately_Visible (Def_Id); Set_Current_Entity (Def_Id); end if; @@ -8451,7 +9070,7 @@ package body Sem_Util is if Has_Own_DIC (Typ) then DIC_Typ := Typ; - -- Otherwise the DIC pragma is inherited from a parent type + -- Otherwise the DIC pragma is inherited from a parent type else pragma Assert (Has_Inherited_DIC (Typ)); @@ -9580,11 +10199,11 @@ package body Sem_Util is end if; end Gather_Components; - ----------------------- - -- Get_Accessibility -- - ----------------------- + ------------------------------- + -- Get_Dynamic_Accessibility -- + ------------------------------- - function Get_Accessibility (E : Entity_Id) return Node_Id is + function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id is begin -- When minimum accessibility is set for E then we utilize it - except -- in a few edge cases like the expansion of select statements where @@ -9594,7 +10213,7 @@ package body Sem_Util is -- To avoid these situations where expansion may get complex we verify -- that the minimum accessibility object is within scope. - if Ekind (E) in Formal_Kind + if Is_Formal (E) and then Present (Minimum_Accessibility (E)) and then In_Open_Scopes (Scope (Minimum_Accessibility (E))) then @@ -9602,7 +10221,7 @@ package body Sem_Util is end if; return Extra_Accessibility (E); - end Get_Accessibility; + end Get_Dynamic_Accessibility; ------------------------ -- Get_Actual_Subtype -- @@ -10800,6 +11419,31 @@ package body Sem_Util is end if; end Has_Access_Values; + --------------------------------------- + -- Has_Anonymous_Access_Discriminant -- + --------------------------------------- + + function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean + is + Disc : Node_Id; + + begin + if not Has_Discriminants (Typ) then + return False; + end if; + + Disc := First_Discriminant (Typ); + while Present (Disc) loop + if Ekind (Etype (Disc)) = E_Anonymous_Access_Type then + return True; + end if; + + Next_Discriminant (Disc); + end loop; + + return False; + end Has_Anonymous_Access_Discriminant; + ------------------------------ -- Has_Compatible_Alignment -- ------------------------------ @@ -11231,11 +11875,11 @@ package body Sem_Util is begin -- Inspect the formal parameters looking for an effectively volatile - -- type. + -- type for reading. Formal := First_Formal (Subp_Id); while Present (Formal) loop - if Is_Effectively_Volatile (Etype (Formal)) then + if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then return True; end if; @@ -11245,7 +11889,7 @@ package body Sem_Util is -- Inspect the return type of functions if Ekind (Subp_Id) in E_Function | E_Generic_Function - and then Is_Effectively_Volatile (Etype (Subp_Id)) + and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id)) then return True; end if; @@ -11619,7 +12263,7 @@ package body Sem_Util is if Ekind (Item_Id) = E_Abstract_State then return State_Has_Enabled_Property; - elsif Ekind (Item_Id) = E_Variable then + elsif Ekind (Item_Id) in E_Variable | E_Constant then return Type_Or_Variable_Has_Enabled_Property (Item_Id); -- Other objects can only inherit properties through their type. We @@ -11960,6 +12604,39 @@ package body Sem_Util is (Directly_Designated_Type (Etype (Formal))) = E; end Is_Access_Subprogram_Wrapper; + --------------------------- + -- Is_Explicitly_Aliased -- + --------------------------- + + function Is_Explicitly_Aliased (N : Node_Id) return Boolean is + begin + return Is_Formal (N) + and then Present (Parent (N)) + and then Nkind (Parent (N)) = N_Parameter_Specification + and then Aliased_Present (Parent (N)); + end Is_Explicitly_Aliased; + + ---------------------------- + -- Is_Container_Aggregate -- + ---------------------------- + + function Is_Container_Aggregate (Exp : Node_Id) return Boolean is + + function Is_Record_Aggregate return Boolean is (False); + -- ??? Unimplemented. Given an aggregate whose type is a + -- record type with specified Aggregate aspect, how do we + -- determine whether it is a record aggregate or a container + -- aggregate? If the code where the aggregate occurs can see only + -- a partial view of the aggregate's type then the aggregate + -- cannot be a record type; an aggregate of a private type has to + -- be a container aggregate. + + begin + return Nkind (Exp) = N_Aggregate + and then Present (Find_Aspect (Etype (Exp), Aspect_Aggregate)) + and then not Is_Record_Aggregate; + end Is_Container_Aggregate; + --------------------------------- -- Side_Effect_Free_Statements -- --------------------------------- @@ -13541,6 +14218,96 @@ package body Sem_Util is end In_Subtree; --------------------- + -- In_Return_Value -- + --------------------- + + function In_Return_Value (Expr : Node_Id) return Boolean is + Par : Node_Id; + Prev_Par : Node_Id; + Pre : Node_Id; + In_Function_Call : Boolean := False; + + begin + -- Move through parent nodes to determine if Expr contributes to the + -- return value of the current subprogram. + + Par := Expr; + Prev_Par := Empty; + while Present (Par) loop + + case Nkind (Par) is + -- Ignore ranges and they don't contribute to the result + + when N_Range => + return False; + + -- An object declaration whose parent is an extended return + -- statement is a return object. + + when N_Object_Declaration => + if Present (Parent (Par)) + and then Nkind (Parent (Par)) = N_Extended_Return_Statement + then + return True; + end if; + + -- We hit a simple return statement, so we know we are in one + + when N_Simple_Return_Statement => + return True; + + -- Only include one nexting level of function calls + + when N_Function_Call => + if not In_Function_Call then + In_Function_Call := True; + else + return False; + end if; + + -- Check if we are on the right-hand side of an assignment + -- statement to a return object. + + -- This is not specified in the RM ??? + + when N_Assignment_Statement => + if Prev_Par = Name (Par) then + return False; + end if; + + Pre := Name (Par); + while Present (Pre) loop + if Is_Entity_Name (Pre) + and then Is_Return_Object (Entity (Pre)) + then + return True; + end if; + + exit when Nkind (Pre) not in N_Selected_Component + | N_Indexed_Component + | N_Slice; + + Pre := Prefix (Pre); + end loop; + + -- Otherwise, we hit a master which was not relevant + + when others => + if Is_Master (Par) then + return False; + end if; + end case; + + -- Iterate up to the next parent, keeping track of the previous one + + Prev_Par := Par; + Par := Parent (Par); + end loop; + + return False; + end In_Return_Value; + + --------------------- -- In_Visible_Part -- --------------------- @@ -13951,7 +14718,7 @@ package body Sem_Util is -- ^ -- Item - if Has_Rep_Item (From_Typ, Next_Item) then + if Present_In_Rep_Item (From_Typ, Next_Item) then exit; end if; @@ -14297,10 +15064,20 @@ package body Sem_Util is Name_Signed_16 => RTE (RE_IS_Is2), Name_Signed_32 => RTE (RE_IS_Is4), Name_Signed_64 => RTE (RE_IS_Is8), + Name_Signed_128 => Empty, Name_Unsigned_8 => RTE (RE_IS_Iu1), Name_Unsigned_16 => RTE (RE_IS_Iu2), Name_Unsigned_32 => RTE (RE_IS_Iu4), - Name_Unsigned_64 => RTE (RE_IS_Iu8)); + Name_Unsigned_64 => RTE (RE_IS_Iu8), + Name_Unsigned_128 => Empty); + + if System_Max_Integer_Size < 128 then + Invalid_Binder_Values (Name_Signed_128) := RTE (RE_IS_Is8); + Invalid_Binder_Values (Name_Unsigned_128) := RTE (RE_IS_Iu8); + else + Invalid_Binder_Values (Name_Signed_128) := RTE (RE_IS_Is16); + Invalid_Binder_Values (Name_Unsigned_128) := RTE (RE_IS_Iu16); + end if; end if; end Set_Invalid_Binder_Values; @@ -14337,6 +15114,16 @@ package body Sem_Util is return Nkind (Par) in N_Subprogram_Call; end Is_Anonymous_Access_Actual; + ------------------------ + -- Is_Access_Variable -- + ------------------------ + + function Is_Access_Variable (E : Entity_Id) return Boolean is + begin + return Is_Access_Object_Type (E) + and then not Is_Access_Constant (E); + end Is_Access_Variable; + ----------------------------- -- Is_Actual_Out_Parameter -- ----------------------------- @@ -14553,15 +15340,6 @@ package body Sem_Util is end Is_Atomic_Object_Entity; ----------------------------- - -- Is_Atomic_Or_VFA_Object -- - ----------------------------- - - function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is - begin - return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N); - end Is_Atomic_Or_VFA_Object; - - ----------------------------- -- Is_Attribute_Loop_Entry -- ----------------------------- @@ -14821,6 +15599,120 @@ package body Sem_Util is return False; end Is_Child_Or_Sibling; + ------------------- + -- Is_Confirming -- + ------------------- + + function Is_Confirming (Aspect : Nonoverridable_Aspect_Id; + Aspect_Spec_1, Aspect_Spec_2 : Node_Id) + return Boolean is + function Names_Match (Nm1, Nm2 : Node_Id) return Boolean; + function Names_Match (Nm1, Nm2 : Node_Id) return Boolean is + begin + if Nkind (Nm1) /= Nkind (Nm2) then + return False; + end if; + case Nkind (Nm1) is + when N_Identifier => + return Name_Equals (Chars (Nm1), Chars (Nm2)); + when N_Expanded_Name => + return Names_Match (Prefix (Nm1), Prefix (Nm2)) + and then Names_Match (Selector_Name (Nm1), + Selector_Name (Nm2)); + when N_Empty => + return True; -- needed for Aggregate aspect checking + + when others => + -- e.g., 'Class attribute references + if Is_Entity_Name (Nm1) and Is_Entity_Name (Nm2) then + return Entity (Nm1) = Entity (Nm2); + end if; + + raise Program_Error; + end case; + end Names_Match; + begin + -- allow users to disable "shall be confirming" check, at least for now + if Relaxed_RM_Semantics then + return True; + end if; + + -- ??? Type conversion here (along with "when others =>" below) is a + -- workaround for a bootstrapping problem related to casing on a + -- static-predicate-bearing subtype. + + case Aspect_Id (Aspect) is + -- name-valued aspects; compare text of names, not resolution. + when Aspect_Default_Iterator + | Aspect_Iterator_Element + | Aspect_Constant_Indexing + | Aspect_Variable_Indexing + | Aspect_Implicit_Dereference => + declare + Item_1 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_1); + Item_2 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_2); + begin + if (Nkind (Item_1) /= N_Attribute_Definition_Clause) + or (Nkind (Item_2) /= N_Attribute_Definition_Clause) + then + pragma Assert (Serious_Errors_Detected > 0); + return True; + end if; + + return Names_Match (Expression (Item_1), + Expression (Item_2)); + end; + + -- one of a kind + when Aspect_Aggregate => + declare + Empty_1, + Add_Named_1, + Add_Unnamed_1, + New_Indexed_1, + Assign_Indexed_1, + Empty_2, + Add_Named_2, + Add_Unnamed_2, + New_Indexed_2, + Assign_Indexed_2 : Node_Id := Empty; + begin + Parse_Aspect_Aggregate + (N => Expression (Aspect_Spec_1), + Empty_Subp => Empty_1, + Add_Named_Subp => Add_Named_1, + Add_Unnamed_Subp => Add_Unnamed_1, + New_Indexed_Subp => New_Indexed_1, + Assign_Indexed_Subp => Assign_Indexed_1); + Parse_Aspect_Aggregate + (N => Expression (Aspect_Spec_2), + Empty_Subp => Empty_2, + Add_Named_Subp => Add_Named_2, + Add_Unnamed_Subp => Add_Unnamed_2, + New_Indexed_Subp => New_Indexed_2, + Assign_Indexed_Subp => Assign_Indexed_2); + return + Names_Match (Empty_1, Empty_2) and then + Names_Match (Add_Named_1, Add_Named_2) and then + Names_Match (Add_Unnamed_1, Add_Unnamed_2) and then + Names_Match (New_Indexed_1, New_Indexed_2) and then + Names_Match (Assign_Indexed_1, Assign_Indexed_2); + end; + + -- scalar-valued aspects; compare (static) values. + when Aspect_Max_Entry_Queue_Length -- | Aspect_No_Controlled_Parts + => + -- This should be unreachable. No_Controlled_Parts is + -- not yet supported at all in GNAT and Max_Entry_Queue_Length + -- is supported only for protected entries, not for types. + pragma Assert (Serious_Errors_Detected /= 0); + return True; + + when others => + raise Program_Error; + end case; + end Is_Confirming; + ----------------------------- -- Is_Concurrent_Interface -- ----------------------------- @@ -15756,35 +16648,115 @@ package body Sem_Util is end if; end Is_Effectively_Volatile; + ----------------------------------------- + -- Is_Effectively_Volatile_For_Reading -- + ----------------------------------------- + + function Is_Effectively_Volatile_For_Reading + (Id : Entity_Id) return Boolean + is + begin + -- A concurrent type is effectively volatile for reading + + if Is_Concurrent_Type (Id) then + return True; + + elsif Is_Effectively_Volatile (Id) then + + -- Other volatile types and objects are effectively volatile for + -- reading when they have property Async_Writers or Effective_Reads + -- set to True. This includes the case of an array type whose + -- Volatile_Components aspect is True (hence it is effectively + -- volatile) which does not have the properties Async_Writers + -- and Effective_Reads set to False. + + if Async_Writers_Enabled (Id) + or else Effective_Reads_Enabled (Id) + then + return True; + + -- In addition, an array type is effectively volatile for reading + -- when its component type is effectively volatile for reading. + + elsif Is_Array_Type (Id) then + declare + Anc : Entity_Id := Base_Type (Id); + begin + if Is_Private_Type (Anc) then + Anc := Full_View (Anc); + end if; + + -- Test for presence of ancestor, as the full view of a + -- private type may be missing in case of error. + + return + Present (Anc) + and then Is_Effectively_Volatile_For_Reading + (Component_Type (Anc)); + end; + end if; + end if; + + return False; + + end Is_Effectively_Volatile_For_Reading; + ------------------------------------ -- Is_Effectively_Volatile_Object -- ------------------------------------ function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is + function Is_Effectively_Volatile_Object_Inst + is new Is_Effectively_Volatile_Object_Shared (Is_Effectively_Volatile); + begin + return Is_Effectively_Volatile_Object_Inst (N); + end Is_Effectively_Volatile_Object; + + ------------------------------------------------ + -- Is_Effectively_Volatile_Object_For_Reading -- + ------------------------------------------------ + + function Is_Effectively_Volatile_Object_For_Reading + (N : Node_Id) return Boolean + is + function Is_Effectively_Volatile_Object_For_Reading_Inst + is new Is_Effectively_Volatile_Object_Shared + (Is_Effectively_Volatile_For_Reading); + begin + return Is_Effectively_Volatile_Object_For_Reading_Inst (N); + end Is_Effectively_Volatile_Object_For_Reading; + + ------------------------------------------- + -- Is_Effectively_Volatile_Object_Shared -- + ------------------------------------------- + + function Is_Effectively_Volatile_Object_Shared + (N : Node_Id) return Boolean + is begin if Is_Entity_Name (N) then return Is_Object (Entity (N)) - and then Is_Effectively_Volatile (Entity (N)); + and then Is_Effectively_Volatile_Entity (Entity (N)); elsif Nkind (N) in N_Indexed_Component | N_Slice then - return Is_Effectively_Volatile_Object (Prefix (N)); + return Is_Effectively_Volatile_Object_Shared (Prefix (N)); elsif Nkind (N) = N_Selected_Component then return - Is_Effectively_Volatile_Object (Prefix (N)) + Is_Effectively_Volatile_Object_Shared (Prefix (N)) or else - Is_Effectively_Volatile_Object (Selector_Name (N)); + Is_Effectively_Volatile_Object_Shared (Selector_Name (N)); elsif Nkind (N) in N_Qualified_Expression | N_Unchecked_Type_Conversion | N_Type_Conversion then - return Is_Effectively_Volatile_Object (Expression (N)); + return Is_Effectively_Volatile_Object_Shared (Expression (N)); else return False; end if; - end Is_Effectively_Volatile_Object; + end Is_Effectively_Volatile_Object_Shared; ------------------- -- Is_Entry_Body -- @@ -15968,6 +16940,15 @@ package body Sem_Util is return R; end Is_Fixed_Model_Number; + ----------------------------- + -- Is_Full_Access_Object -- + ----------------------------- + + function Is_Full_Access_Object (N : Node_Id) return Boolean is + begin + return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N); + end Is_Full_Access_Object; + ------------------------------- -- Is_Fully_Initialized_Type -- ------------------------------- @@ -16609,6 +17590,62 @@ package body Sem_Util is end if; end Is_Local_Variable_Reference; + --------------- + -- Is_Master -- + --------------- + + function Is_Master (N : Node_Id) return Boolean is + Disable_Subexpression_Masters : constant Boolean := True; + + begin + if Nkind (N) in N_Subprogram_Body | N_Task_Body | N_Entry_Body + or else Is_Statement (N) + then + return True; + end if; + + -- We avoid returning True when the master is a subexpression described + -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation + -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ??? + + if not Disable_Subexpression_Masters + and then Nkind (N) in N_Subexpr + then + declare + Par : Node_Id := N; + + subtype N_Simple_Statement_Other_Than_Simple_Return + is Node_Kind with Static_Predicate => + N_Simple_Statement_Other_Than_Simple_Return + in N_Abort_Statement + | N_Assignment_Statement + | N_Code_Statement + | N_Delay_Statement + | N_Entry_Call_Statement + | N_Free_Statement + | N_Goto_Statement + | N_Null_Statement + | N_Raise_Statement + | N_Requeue_Statement + | N_Exit_Statement + | N_Procedure_Call_Statement; + begin + while Present (Par) loop + Par := Parent (Par); + if Nkind (Par) in N_Subexpr | + N_Simple_Statement_Other_Than_Simple_Return + then + return False; + end if; + end loop; + + return True; + end; + end if; + + return False; + end Is_Master; + ----------------------- -- Is_Name_Reference -- ----------------------- @@ -17906,6 +18943,7 @@ package body Sem_Util is is Par : constant Node_Id := Parent (Expr); + function Aggregate_Type return Node_Id is (Etype (Parent (Par))); begin if Nkind (Par) = N_If_Expression then return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); @@ -17933,55 +18971,69 @@ package body Sem_Util is elsif Nkind (Par) = N_Quantified_Expression then return Expr = Condition (Par); - elsif Nkind (Par) = N_Aggregate - and then Present (Etype (Par)) - and then Etype (Par) /= Any_Composite - and then Is_Array_Type (Etype (Par)) - and then Nkind (Expr) = N_Component_Association + elsif Nkind (Par) = N_Component_Association + and then Expr = Expression (Par) + and then Nkind (Parent (Par)) + in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate + and then Present (Aggregate_Type) + and then Aggregate_Type /= Any_Composite then - declare - Choice : Node_Id; - In_Others_Choice : Boolean := False; - - begin - -- The expression of an array_component_association is - -- potentially unevaluated if the associated choice is a - -- subtype_indication or range that defines a nonstatic or - -- null range. + if Is_Array_Type (Aggregate_Type) then + if Ada_Version >= Ada_2020 then + -- For Ada_2020, this predicate returns True for + -- any "repeatedly evaluated" expression. + return True; + end if; - Choice := First (Choices (Expr)); - while Present (Choice) loop - if Nkind (Choice) = N_Range - and then Non_Static_Or_Null_Range (Choice) - then - return True; + declare + Choice : Node_Id; + In_Others_Choice : Boolean := False; + Array_Agg : constant Node_Id := Parent (Par); + begin + -- The expression of an array_component_association is + -- potentially unevaluated if the associated choice is a + -- subtype_indication or range that defines a nonstatic or + -- null range. + + Choice := First (Choices (Par)); + while Present (Choice) loop + if Nkind (Choice) = N_Range + and then Non_Static_Or_Null_Range (Choice) + then + return True; - elsif Nkind (Choice) = N_Identifier - and then Present (Scalar_Range (Etype (Choice))) - and then - Non_Static_Or_Null_Range (Scalar_Range (Etype (Choice))) - then - return True; + elsif Nkind (Choice) = N_Identifier + and then Present (Scalar_Range (Etype (Choice))) + and then + Non_Static_Or_Null_Range + (Scalar_Range (Etype (Choice))) + then + return True; - elsif Nkind (Choice) = N_Others_Choice then - In_Others_Choice := True; - end if; + elsif Nkind (Choice) = N_Others_Choice then + In_Others_Choice := True; + end if; - Next (Choice); - end loop; + Next (Choice); + end loop; - -- It is also potentially unevaluated if the associated choice - -- is an others choice and the applicable index constraint is - -- nonstatic or null. + -- It is also potentially unevaluated if the associated + -- choice is an others choice and the applicable index + -- constraint is nonstatic or null. - if In_Others_Choice then - if not Compile_Time_Known_Bounds (Etype (Par)) then - return True; - else - return Has_Null_Others_Choice (Par); + if In_Others_Choice then + if not Compile_Time_Known_Bounds (Aggregate_Type) then + return True; + else + return Has_Null_Others_Choice (Array_Agg); + end if; end if; - end if; - end; + end; + + elsif Is_Container_Aggregate (Parent (Par)) then + -- a component of a container aggregate + return True; + end if; return False; @@ -18765,8 +19817,10 @@ package body Sem_Util is -------------------------------------- function Is_Special_Aliased_Formal_Access - (Exp : Node_Id; - Scop : Entity_Id) return Boolean is + (Exp : Node_Id; + In_Return_Context : Boolean := False) return Boolean + is + Scop : constant Entity_Id := Current_Subprogram; begin -- Verify the expression is an access reference to 'Access within a -- return statement as this is the only time an explicitly aliased @@ -18774,7 +19828,9 @@ package body Sem_Util is if Nkind (Exp) /= N_Attribute_Reference or else Get_Attribute_Id (Attribute_Name (Exp)) /= Attribute_Access - or else Nkind (Parent (Exp)) /= N_Simple_Return_Statement + or else not (In_Return_Value (Exp) + or else In_Return_Context) + or else not Needs_Result_Accessibility_Level (Scop) then return False; end if; @@ -18784,17 +19840,8 @@ package body Sem_Util is -- that Scop returns an anonymous access type, otherwise the special -- rules dictating a need for a dynamic check are not in effect. - declare - P_Ult : constant Node_Id := Ultimate_Prefix (Prefix (Exp)); - begin - return Is_Entity_Name (P_Ult) - and then Is_Aliased (Entity (P_Ult)) - and then Is_Formal (Entity (P_Ult)) - and then Scope (Entity (P_Ult)) = Scop - and then Ekind (Scop) in - E_Function | E_Operator | E_Subprogram_Type - and then Needs_Result_Accessibility_Level (Scop); - end; + return Is_Entity_Name (Prefix (Exp)) + and then Is_Explicitly_Aliased (Entity (Prefix (Exp))); end Is_Special_Aliased_Formal_Access; ----------------------------- @@ -18835,16 +19882,21 @@ package body Sem_Util is function Is_Static_Function (Subp : Entity_Id) return Boolean is begin - return Has_Aspect (Subp, Aspect_Static) + -- Always return False for pre Ada 2020 to e.g. ignore the Static + -- aspect in package Interfaces for Ada_Version < 2020 and also + -- for efficiency. + + return Ada_Version >= Ada_2020 + and then Has_Aspect (Subp, Aspect_Static) and then (No (Find_Value_Of_Aspect (Subp, Aspect_Static)) or else Is_True (Static_Boolean (Find_Value_Of_Aspect (Subp, Aspect_Static)))); end Is_Static_Function; - ------------------------------ - -- Is_Static_Function_Call -- - ------------------------------ + ----------------------------- + -- Is_Static_Function_Call -- + ----------------------------- function Is_Static_Function_Call (Call : Node_Id) return Boolean is function Has_All_Static_Actuals (Call : Node_Id) return Boolean; @@ -18897,11 +19949,12 @@ package body Sem_Util is and then Has_All_Static_Actuals (Call); end Is_Static_Function_Call; - ---------------------------------------- - -- Is_Subcomponent_Of_Atomic_Object -- - ---------------------------------------- + ------------------------------------------- + -- Is_Subcomponent_Of_Full_Access_Object -- + ------------------------------------------- - function Is_Subcomponent_Of_Atomic_Object (N : Node_Id) return Boolean is + function Is_Subcomponent_Of_Full_Access_Object (N : Node_Id) return Boolean + is R : Node_Id; begin @@ -18914,19 +19967,19 @@ package body Sem_Util is -- If the prefix is an access value, only the designated type matters if Is_Access_Type (Etype (R)) then - if Is_Atomic (Designated_Type (Etype (R))) then + if Is_Full_Access (Designated_Type (Etype (R))) then return True; end if; else - if Is_Atomic_Object (R) then + if Is_Full_Access_Object (R) then return True; end if; end if; end loop; return False; - end Is_Subcomponent_Of_Atomic_Object; + end Is_Subcomponent_Of_Full_Access_Object; --------------------------------------- -- Is_Subprogram_Contract_Annotation -- @@ -18958,6 +20011,7 @@ package body Sem_Util is or else Nam = Name_Refined_Depends or else Nam = Name_Refined_Global or else Nam = Name_Refined_Post + or else Nam = Name_Subprogram_Variant or else Nam = Name_Test_Case; end Is_Subprogram_Contract_Annotation; @@ -19064,9 +20118,12 @@ package body Sem_Util is then return True; - -- A constant is a synchronized object by default + -- A constant is a synchronized object by default, unless its type is + -- access-to-variable type. - elsif Ekind (Id) = E_Constant then + elsif Ekind (Id) = E_Constant + and then not Is_Access_Variable (Etype (Id)) + then return True; -- A variable is a synchronized object if it is subject to pragma @@ -19158,7 +20215,7 @@ package body Sem_Util is function Is_True (U : Uint) return Boolean is begin - return (U /= 0); + return U /= 0; end Is_True; -------------------------------------- @@ -19556,7 +20613,7 @@ package body Sem_Util is function Is_View_Conversion (N : Node_Id) return Boolean is begin if Nkind (N) = N_Type_Conversion - and then Nkind (Unqual_Conv (N)) = N_Identifier + and then Nkind (Unqual_Conv (N)) in N_Has_Etype then if Is_Tagged_Type (Etype (N)) and then Is_Tagged_Type (Etype (Unqual_Conv (N))) @@ -24304,350 +25361,6 @@ package body Sem_Util is return Num; end Number_Of_Elements_In_Array; - ------------------------- - -- Object_Access_Level -- - ------------------------- - - -- Returns the static accessibility level of the view denoted by Obj. Note - -- that the value returned is the result of a call to Scope_Depth. Only - -- scope depths associated with dynamic scopes can actually be returned. - -- Since only relative levels matter for accessibility checking, the fact - -- that the distance between successive levels of accessibility is not - -- always one is immaterial (invariant: if level(E2) is deeper than - -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). - - function Object_Access_Level (Obj : Node_Id) return Uint is - function Is_Interface_Conversion (N : Node_Id) return Boolean; - -- Determine whether N is a construct of the form - -- Some_Type (Operand._tag'Address) - -- This construct appears in the context of dispatching calls. - - function Reference_To (Obj : Node_Id) return Node_Id; - -- An explicit dereference is created when removing side effects from - -- expressions for constraint checking purposes. In this case a local - -- access type is created for it. The correct access level is that of - -- the original source node. We detect this case by noting that the - -- prefix of the dereference is created by an object declaration whose - -- initial expression is a reference. - - ----------------------------- - -- Is_Interface_Conversion -- - ----------------------------- - - function Is_Interface_Conversion (N : Node_Id) return Boolean is - begin - return Nkind (N) = N_Unchecked_Type_Conversion - and then Nkind (Expression (N)) = N_Attribute_Reference - and then Attribute_Name (Expression (N)) = Name_Address; - end Is_Interface_Conversion; - - ------------------ - -- Reference_To -- - ------------------ - - function Reference_To (Obj : Node_Id) return Node_Id is - Pref : constant Node_Id := Prefix (Obj); - begin - if Is_Entity_Name (Pref) - and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration - and then Present (Expression (Parent (Entity (Pref)))) - and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference - then - return (Prefix (Expression (Parent (Entity (Pref))))); - else - return Empty; - end if; - end Reference_To; - - -- Local variables - - E : Entity_Id; - Orig_Obj : Node_Id := Original_Node (Obj); - Orig_Pre : Node_Id; - - -- Start of processing for Object_Access_Level - - begin - -- In the case of an expanded implicit dereference we swap the original - -- object to be the expanded conversion. - - if Nkind (Obj) = N_Explicit_Dereference - and then Nkind (Orig_Obj) /= N_Explicit_Dereference - then - Orig_Obj := Obj; - end if; - - -- Calculate the object node's accessibility level - - if Nkind (Orig_Obj) = N_Defining_Identifier - or else Is_Entity_Name (Orig_Obj) - then - if Nkind (Orig_Obj) = N_Defining_Identifier then - E := Orig_Obj; - else - E := Entity (Orig_Obj); - end if; - - if Is_Prival (E) then - E := Prival_Link (E); - end if; - - -- If E is a type then it denotes a current instance. For this case - -- we add one to the normal accessibility level of the type to ensure - -- that current instances are treated as always being deeper than - -- than the level of any visible named access type (see 3.10.2(21)). - - if Is_Type (E) then - return Type_Access_Level (E) + 1; - - elsif Present (Renamed_Object (E)) then - return Object_Access_Level (Renamed_Object (E)); - - -- Similarly, if E is a component of the current instance of a - -- protected type, any instance of it is assumed to be at a deeper - -- level than the type. For a protected object (whose type is an - -- anonymous protected type) its components are at the same level - -- as the type itself. - - elsif not Is_Overloadable (E) - and then Ekind (Scope (E)) = E_Protected_Type - and then Comes_From_Source (Scope (E)) - then - return Type_Access_Level (Scope (E)) + 1; - - -- An object of a named access type gets its level from its - -- associated type. - - elsif Is_Named_Access_Type (Etype (E)) then - return Type_Access_Level (Etype (E)); - - else - return Scope_Depth (Enclosing_Dynamic_Scope (E)); - end if; - - elsif Nkind (Orig_Obj) in N_Indexed_Component | N_Selected_Component then - Orig_Pre := Original_Node (Prefix (Orig_Obj)); - - if Is_Access_Type (Etype (Orig_Pre)) then - return Type_Access_Level (Etype (Orig_Pre)); - else - return Object_Access_Level (Prefix (Orig_Obj)); - end if; - - elsif Nkind (Orig_Obj) = N_Explicit_Dereference then - Orig_Pre := Original_Node (Prefix (Orig_Obj)); - - -- If the prefix is a selected access discriminant then we make a - -- recursive call on the prefix, which will in turn check the level - -- of the prefix object of the selected discriminant. - - -- In Ada 2012, if the discriminant has implicit dereference and - -- the context is a selected component, treat this as an object of - -- unknown scope (see below). This is necessary in compile-only mode; - -- otherwise expansion will already have transformed the prefix into - -- a temporary. - - if Nkind (Orig_Pre) = N_Selected_Component - and then Ekind (Etype (Orig_Pre)) = E_Anonymous_Access_Type - and then - Ekind (Entity (Selector_Name (Orig_Pre))) = E_Discriminant - and then - (not Has_Implicit_Dereference - (Entity (Selector_Name (Orig_Pre))) - or else Nkind (Parent (Obj)) /= N_Selected_Component) - then - return Object_Access_Level (Prefix (Orig_Obj)); - - -- Detect an interface conversion in the context of a dispatching - -- call. Use the original form of the conversion to find the access - -- level of the operand. - - elsif Is_Interface (Etype (Orig_Obj)) - and then Is_Interface_Conversion (Orig_Pre) - and then Nkind (Orig_Obj) = N_Type_Conversion - then - return Object_Access_Level (Orig_Obj); - - elsif not Comes_From_Source (Orig_Obj) then - declare - Ref : constant Node_Id := Reference_To (Orig_Obj); - begin - if Present (Ref) then - return Object_Access_Level (Ref); - else - return Type_Access_Level (Etype (Prefix (Orig_Obj))); - end if; - end; - - else - return Type_Access_Level (Etype (Prefix (Orig_Obj))); - end if; - - elsif Nkind (Orig_Obj) in N_Type_Conversion | N_Unchecked_Type_Conversion - then - return Object_Access_Level (Expression (Orig_Obj)); - - elsif Nkind (Orig_Obj) = N_Function_Call then - - -- Function results are objects, so we get either the access level of - -- the function or, in the case of an indirect call, the level of the - -- access-to-subprogram type. (This code is used for Ada 95, but it - -- looks wrong, because it seems that we should be checking the level - -- of the call itself, even for Ada 95. However, using the Ada 2005 - -- version of the code causes regressions in several tests that are - -- compiled with -gnat95. ???) - - if Ada_Version < Ada_2005 then - if Is_Entity_Name (Name (Orig_Obj)) then - return Subprogram_Access_Level (Entity (Name (Orig_Obj))); - else - return Type_Access_Level (Etype (Prefix (Name (Orig_Obj)))); - end if; - - -- For Ada 2005, the level of the result object of a function call is - -- defined to be the level of the call's innermost enclosing master. - -- We determine that by querying the depth of the innermost enclosing - -- dynamic scope. - - else - Return_Master_Scope_Depth_Of_Call : declare - function Innermost_Master_Scope_Depth - (N : Node_Id) return Uint; - -- Returns the scope depth of the given node's innermost - -- enclosing dynamic scope (effectively the accessibility - -- level of the innermost enclosing master). - - ---------------------------------- - -- Innermost_Master_Scope_Depth -- - ---------------------------------- - - function Innermost_Master_Scope_Depth - (N : Node_Id) return Uint - is - Node_Par : Node_Id := Parent (N); - - begin - -- Locate the nearest enclosing node (by traversing Parents) - -- that Defining_Entity can be applied to, and return the - -- depth of that entity's nearest enclosing dynamic scope. - - while Present (Node_Par) loop - case Nkind (Node_Par) is - when N_Abstract_Subprogram_Declaration - | N_Block_Statement - | N_Body_Stub - | N_Component_Declaration - | N_Entry_Body - | N_Entry_Declaration - | N_Exception_Declaration - | N_Formal_Object_Declaration - | N_Formal_Package_Declaration - | N_Formal_Subprogram_Declaration - | N_Formal_Type_Declaration - | N_Full_Type_Declaration - | N_Function_Specification - | N_Generic_Declaration - | N_Generic_Instantiation - | N_Implicit_Label_Declaration - | N_Incomplete_Type_Declaration - | N_Loop_Parameter_Specification - | N_Number_Declaration - | N_Object_Declaration - | N_Package_Declaration - | N_Package_Specification - | N_Parameter_Specification - | N_Private_Extension_Declaration - | N_Private_Type_Declaration - | N_Procedure_Specification - | N_Proper_Body - | N_Protected_Type_Declaration - | N_Renaming_Declaration - | N_Single_Protected_Declaration - | N_Single_Task_Declaration - | N_Subprogram_Declaration - | N_Subtype_Declaration - | N_Subunit - | N_Task_Type_Declaration - => - return Scope_Depth - (Nearest_Dynamic_Scope - (Defining_Entity (Node_Par))); - - -- For a return statement within a function, return - -- the depth of the function itself. This is not just - -- a small optimization, but matters when analyzing - -- the expression in an expression function before - -- the body is created. - - when N_Simple_Return_Statement => - if Ekind (Current_Scope) = E_Function then - return Scope_Depth (Current_Scope); - end if; - - when others => - null; - end case; - - Node_Par := Parent (Node_Par); - end loop; - - pragma Assert (False); - - -- Should never reach the following return - - return Scope_Depth (Current_Scope) + 1; - end Innermost_Master_Scope_Depth; - - -- Start of processing for Return_Master_Scope_Depth_Of_Call - - begin - -- Expanded code may have clobbered the scoping data from the - -- original object node - so use the expanded one. - - return Innermost_Master_Scope_Depth (Obj); - end Return_Master_Scope_Depth_Of_Call; - end if; - - -- For convenience we handle qualified expressions, even though they - -- aren't technically object names. - - elsif Nkind (Orig_Obj) = N_Qualified_Expression then - return Object_Access_Level (Expression (Orig_Obj)); - - -- Ditto for aggregates. They have the level of the temporary that - -- will hold their value. - - elsif Nkind (Orig_Obj) = N_Aggregate then - return Object_Access_Level (Current_Scope); - - -- Treat an Old/Loop_Entry attribute reference like an aggregate. - -- AARM 6.1.1(27.d) says "... the implicit constant declaration - -- defines the accessibility level of X'Old", so that is what - -- we are trying to implement here. - - elsif Nkind (Orig_Obj) = N_Attribute_Reference - and then Attribute_Name (Orig_Obj) in Name_Old | Name_Loop_Entry - then - return Object_Access_Level (Current_Scope); - - -- Move up the attribute reference when we encounter a 'Access variation - - elsif Nkind (Orig_Obj) = N_Attribute_Reference - and then Attribute_Name (Orig_Obj) in Name_Access - | Name_Unchecked_Access - | Name_Unrestricted_Access - then - return Object_Access_Level (Prefix (Orig_Obj)); - - -- Otherwise return the scope level of Standard. (If there are cases - -- that fall through to this point they will be treated as having - -- global accessibility for now. ???) - - else - return Scope_Depth (Standard_Standard); - end if; - end Object_Access_Level; - ---------------------------------- -- Old_Requires_Transient_Scope -- ---------------------------------- @@ -24874,6 +25587,100 @@ package body Sem_Util is Write_Eol; end Output_Name; + ------------------ + -- Param_Entity -- + ------------------ + + -- This would be trivial, simply a test for an identifier that was a + -- reference to a formal, if it were not for the fact that a previous call + -- to Expand_Entry_Parameter will have modified the reference to the + -- identifier. A formal of a protected entity is rewritten as + + -- typ!(recobj).rec.all'Constrained + + -- where rec is a selector whose Entry_Formal link points to the formal + + -- If the type of the entry parameter has a representation clause, then an + -- extra temp is involved (see below). + + -- For a formal of a task entity, the formal is rewritten as a local + -- renaming. + + -- In addition, a formal that is marked volatile because it is aliased + -- through an address clause is rewritten as dereference as well. + + function Param_Entity (N : Node_Id) return Entity_Id is + Renamed_Obj : Node_Id; + + begin + -- Simple reference case + + if Nkind (N) in N_Identifier | N_Expanded_Name then + if Is_Formal (Entity (N)) then + return Entity (N); + + -- Handle renamings of formal parameters and formals of tasks that + -- are rewritten as renamings. + + elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then + Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); + + if Is_Entity_Name (Renamed_Obj) + and then Is_Formal (Entity (Renamed_Obj)) + then + return Entity (Renamed_Obj); + + elsif + Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement + then + return Entity (N); + end if; + end if; + + else + if Nkind (N) = N_Explicit_Dereference then + declare + P : Node_Id := Prefix (N); + S : Node_Id; + E : Entity_Id; + Decl : Node_Id; + + begin + -- If the type of an entry parameter has a representation + -- clause, then the prefix is not a selected component, but + -- instead a reference to a temp pointing at the selected + -- component. In this case, set P to be the initial value of + -- that temp. + + if Nkind (P) = N_Identifier then + E := Entity (P); + + if Ekind (E) = E_Constant then + Decl := Parent (E); + + if Nkind (Decl) = N_Object_Declaration then + P := Expression (Decl); + end if; + end if; + end if; + + if Nkind (P) = N_Selected_Component then + S := Selector_Name (P); + + if Present (Entry_Formal (Entity (S))) then + return Entry_Formal (Entity (S)); + end if; + + elsif Nkind (Original_Node (N)) = N_Identifier then + return Param_Entity (Original_Node (N)); + end if; + end; + end if; + end if; + + return (Empty); + end Param_Entity; + ---------------------- -- Policy_In_Effect -- ---------------------- @@ -24959,6 +25766,18 @@ package body Sem_Util is return Kind; end Policy_In_Effect; + ------------------------------- + -- Preanalyze_Without_Errors -- + ------------------------------- + + procedure Preanalyze_Without_Errors (N : Node_Id) is + Status : constant Boolean := Get_Ignore_Errors; + begin + Set_Ignore_Errors (True); + Preanalyze (N); + Set_Ignore_Errors (Status); + end Preanalyze_Without_Errors; + ----------------------- -- Predicate_Enabled -- ----------------------- @@ -26148,6 +26967,19 @@ package body Sem_Util is end if; end Same_Object; + --------------------------------- + -- Same_Or_Aliased_Subprograms -- + --------------------------------- + + function Same_Or_Aliased_Subprograms + (S : Entity_Id; + E : Entity_Id) return Boolean + is + Subp_Alias : constant Entity_Id := Alias (S); + begin + return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); + end Same_Or_Aliased_Subprograms; + --------------- -- Same_Type -- --------------- @@ -29590,6 +30422,911 @@ package body Sem_Util is end Interval_Lists; + package body Old_Attr_Util is + package body Conditional_Evaluation is + type Determining_Expr_Context is + (No_Context, If_Expr, Case_Expr, Short_Circuit_Op, Membership_Test); + + -- Determining_Expr_Context enumeration elements (except for + -- No_Context) correspond to the list items in RM 6.1.1 definition + -- of "determining expression". + + type Determining_Expr + (Context : Determining_Expr_Context := No_Context) + is record + Expr : Node_Id := Empty; + case Context is + when Short_Circuit_Op => + Is_And_Then : Boolean; + when If_Expr => + Is_Then_Part : Boolean; + when Case_Expr => + Alternatives : Node_Id; + when Membership_Test => + -- Given a subexpression of <exp4> in a membership test + -- <exp1> in <exp2> | <exp3> | <exp4> | <exp5> + -- the corresponding determining expression value would + -- have First_Non_Preceding = <exp4> (See RM 6.1.1). + First_Non_Preceding : Node_Id; + when No_Context => + null; + end case; + end record; + + type Determining_Expression_List is + array (Positive range <>) of Determining_Expr; + + function Determining_Condition (Det : Determining_Expr) + return Node_Id; + -- Given a determining expression, build a Boolean-valued + -- condition that incorporates that expression into condition + -- suitable for deciding whether to initialize a 'Old constant. + -- Polarity is "True => initialize the constant". + + function Determining_Expressions + (Expr : Node_Id; Expr_Trailer : Node_Id := Empty) + return Determining_Expression_List; + -- Given a conditionally evaluated expression, return its + -- determining expressions. + -- See RM 6.1.1 for definition of term "determining expressions". + -- Tests should be performed in the order they occur in the + -- array, with short circuiting. + -- A determining expression need not be of a boolean type (e.g., + -- it might be the determining expression of a case expression). + -- The Expr_Trailer parameter should be defaulted for nonrecursive + -- calls. + + function Is_Conditionally_Evaluated (Expr : Node_Id) return Boolean; + -- See RM 6.1.1 for definition of term "conditionally evaluated". + + function Is_Known_On_Entry (Expr : Node_Id) return Boolean; + -- See RM 6.1.1 for definition of term "known on entry". + + -------------------------------------- + -- Conditional_Evaluation_Condition -- + -------------------------------------- + + function Conditional_Evaluation_Condition + (Expr : Node_Id) return Node_Id + is + Determiners : constant Determining_Expression_List := + Determining_Expressions (Expr); + Loc : constant Source_Ptr := Sloc (Expr); + Result : Node_Id := + New_Occurrence_Of (Standard_True, Loc); + begin + pragma Assert (Determiners'Length > 0 or else + Is_Anonymous_Access_Type (Etype (Expr))); + + for I in Determiners'Range loop + Result := Make_And_Then + (Loc, + Left_Opnd => Result, + Right_Opnd => + Determining_Condition (Determiners (I))); + end loop; + return Result; + end Conditional_Evaluation_Condition; + + --------------------------- + -- Determining_Condition -- + --------------------------- + + function Determining_Condition (Det : Determining_Expr) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Det.Expr); + begin + case Det.Context is + when Short_Circuit_Op => + if Det.Is_And_Then then + return New_Copy_Tree (Det.Expr); + else + return Make_Op_Not (Loc, New_Copy_Tree (Det.Expr)); + end if; + + when If_Expr => + if Det.Is_Then_Part then + return New_Copy_Tree (Det.Expr); + else + return Make_Op_Not (Loc, New_Copy_Tree (Det.Expr)); + end if; + + when Case_Expr => + declare + Alts : List_Id := Discrete_Choices (Det.Alternatives); + begin + if Nkind (First (Alts)) = N_Others_Choice then + Alts := Others_Discrete_Choices (First (Alts)); + end if; + + return Make_In (Loc, + Left_Opnd => New_Copy_Tree (Det.Expr), + Right_Opnd => Empty, + Alternatives => New_Copy_List (Alts)); + end; + + when Membership_Test => + declare + function Copy_Prefix + (List : List_Id; Suffix_Start : Node_Id) + return List_Id; + -- Given a list and a member of that list, returns + -- a copy (similar to Nlists.New_Copy_List) of the + -- prefix of the list up to but not including + -- Suffix_Start. + + ----------------- + -- Copy_Prefix -- + ----------------- + + function Copy_Prefix + (List : List_Id; Suffix_Start : Node_Id) + return List_Id + is + Result : constant List_Id := New_List; + Elem : Node_Id := First (List); + begin + while Elem /= Suffix_Start loop + Append (New_Copy (Elem), Result); + Next (Elem); + pragma Assert (Present (Elem)); + end loop; + return Result; + end Copy_Prefix; + + begin + return Make_In (Loc, + Left_Opnd => New_Copy_Tree (Left_Opnd (Det.Expr)), + Right_Opnd => Empty, + Alternatives => Copy_Prefix + (Alternatives (Det.Expr), + Det.First_Non_Preceding)); + end; + + when No_Context => + raise Program_Error; + end case; + end Determining_Condition; + + ----------------------------- + -- Determining_Expressions -- + ----------------------------- + + function Determining_Expressions + (Expr : Node_Id; Expr_Trailer : Node_Id := Empty) + return Determining_Expression_List + is + Par : Node_Id := Expr; + Trailer : Node_Id := Expr_Trailer; + Next_Element : Determining_Expr; + begin + -- We want to stop climbing up the tree when we reach the + -- postcondition expression. An aspect_specification is + -- transformed into a pragma, so reaching a pragma is our + -- termination condition. This relies on the fact that + -- pragmas are not allowed in declare expressions (or any + -- other kind of expression). + + loop + Next_Element.Expr := Empty; + + case Nkind (Par) is + when N_Short_Circuit => + if Trailer = Right_Opnd (Par) then + Next_Element := + (Expr => Left_Opnd (Par), + Context => Short_Circuit_Op, + Is_And_Then => Nkind (Par) = N_And_Then); + end if; + + when N_If_Expression => + -- For an expression like + -- (if C1 then ... elsif C2 then ... else Foo'Old) + -- the RM says are two determining expressions, + -- C1 and C2. Our treatment here (where we only add + -- one determining expression to the list) is ok because + -- we will see two if-expressions, one within the other. + + if Trailer /= First (Expressions (Par)) then + Next_Element := + (Expr => First (Expressions (Par)), + Context => If_Expr, + Is_Then_Part => + Trailer = Next (First (Expressions (Par)))); + end if; + + when N_Case_Expression_Alternative => + pragma Assert (Nkind (Parent (Par)) = N_Case_Expression); + + Next_Element := + (Expr => Expression (Parent (Par)), + Context => Case_Expr, + Alternatives => Par); + + when N_Membership_Test => + if Trailer /= Left_Opnd (Par) + and then Is_Non_Empty_List (Alternatives (Par)) + and then Trailer /= First (Alternatives (Par)) + then + pragma Assert (not Present (Right_Opnd (Par))); + pragma Assert + (Is_List_Member (Trailer) + and then List_Containing (Trailer) + = Alternatives (Par)); + + -- This one is different than the others + -- because one element in the array result + -- may represent multiple determining + -- expressions (i.e. every member of the list + -- Alternatives (Par) + -- up to but not including Trailer). + + Next_Element := + (Expr => Par, + Context => Membership_Test, + First_Non_Preceding => Trailer); + end if; + + when N_Pragma => + declare + Previous : constant Node_Id := Prev (Par); + Prev_Expr : Node_Id; + begin + if Nkind (Previous) = N_Pragma and then + Split_PPC (Previous) + then + -- A source-level postcondition of + -- A and then B and then C + -- results in + -- pragma Postcondition (A); + -- pragma Postcondition (B); + -- pragma Postcondition (C); + -- with Split_PPC set to True on all but the + -- last pragma. We account for that here. + + Prev_Expr := + Expression (First + (Pragma_Argument_Associations (Previous))); + + -- This Analyze call is needed in the case when + -- Sem_Attr.Analyze_Attribute calls + -- Eligible_For_Conditional_Evaluation. Without + -- it, we end up passing an unanalyzed expression + -- to Is_Known_On_Entry and that doesn't work. + + Analyze (Prev_Expr); + + Next_Element := + (Expr => Prev_Expr, + Context => Short_Circuit_Op, + Is_And_Then => True); + + return Determining_Expressions (Prev_Expr) + & Next_Element; + else + pragma Assert + (Get_Pragma_Id (Pragma_Name (Par)) in + Pragma_Post | Pragma_Postcondition + | Pragma_Post_Class | Pragma_Refined_Post + | Pragma_Check | Pragma_Contract_Cases); + + return (1 .. 0 => <>); -- recursion terminates here + end if; + end; + + when N_Empty => + -- This case should be impossible, but if it does + -- happen somehow then we don't want an infinite loop. + raise Program_Error; + + when others => + null; + end case; + + Trailer := Par; + Par := Parent (Par); + + if Present (Next_Element.Expr) then + return Determining_Expressions + (Expr => Par, Expr_Trailer => Trailer) + & Next_Element; + end if; + end loop; + end Determining_Expressions; + + ----------------------------------------- + -- Eligible_For_Conditional_Evaluation -- + ----------------------------------------- + + function Eligible_For_Conditional_Evaluation + (Expr : Node_Id) return Boolean + is + begin + if Is_Anonymous_Access_Type (Etype (Expr)) then + -- The code in exp_attr.adb that also builds declarations + -- for 'Old constants doesn't handle the anonymous access + -- type case correctly, so we avoid that problem by + -- returning True here. + return True; + elsif Ada_Version < Ada_2020 then + return False; + elsif not Is_Conditionally_Evaluated (Expr) then + return False; + else + declare + Determiners : constant Determining_Expression_List := + Determining_Expressions (Expr); + begin + pragma Assert (Determiners'Length > 0); + + for Idx in Determiners'Range loop + if not Is_Known_On_Entry (Determiners (Idx).Expr) then + return False; + end if; + end loop; + end; + return True; + end if; + end Eligible_For_Conditional_Evaluation; + + -------------------------------- + -- Is_Conditionally_Evaluated -- + -------------------------------- + + function Is_Conditionally_Evaluated (Expr : Node_Id) return Boolean + is + -- There are three possibilities - the expression is + -- unconditionally evaluated, repeatedly evaluated, or + -- conditionally evaluated (see RM 6.1.1). So we implement + -- this test by testing for the other two. + + function Is_Repeatedly_Evaluated (Expr : Node_Id) return Boolean; + -- See RM 6.1.1 for definition of "repeatedly evaluated". + + ----------------------------- + -- Is_Repeatedly_Evaluated -- + ----------------------------- + + function Is_Repeatedly_Evaluated (Expr : Node_Id) return Boolean is + Par : Node_Id := Expr; + Trailer : Node_Id := Empty; + + -- There are three ways that an expression can be repeatedly + -- evaluated. + begin + -- An aspect_specification is transformed into a pragma, so + -- reaching a pragma is our termination condition. We want to + -- stop when we reach the postcondition expression. + + while Nkind (Par) /= N_Pragma loop + pragma Assert (Present (Par)); + + -- test for case 1: + -- A subexpression of a predicate of a + -- quantified_expression. + + if Nkind (Par) = N_Quantified_Expression + and then Trailer = Condition (Par) + then + return True; + end if; + + -- test for cases 2 and 3: + -- A subexpression of the expression of an + -- array_component_association or of + -- a container_element_associatiation. + + if Nkind (Par) = N_Component_Association + and then Trailer = Expression (Par) + then + -- determine whether Par is part of an array aggregate + -- or a container aggregate + declare + Rover : Node_Id := Par; + begin + while Nkind (Rover) not in N_Has_Etype loop + pragma Assert (Present (Rover)); + Rover := Parent (Rover); + end loop; + if Present (Etype (Rover)) then + if Is_Array_Type (Etype (Rover)) + or else Is_Container_Aggregate (Rover) + then + return True; + end if; + end if; + end; + end if; + + Trailer := Par; + Par := Parent (Par); + end loop; + + return False; + end Is_Repeatedly_Evaluated; + + begin + if not Is_Potentially_Unevaluated (Expr) then + -- the expression is unconditionally evaluated + return False; + elsif Is_Repeatedly_Evaluated (Expr) then + return False; + end if; + + return True; + end Is_Conditionally_Evaluated; + + ----------------------- + -- Is_Known_On_Entry -- + ----------------------- + + function Is_Known_On_Entry (Expr : Node_Id) return Boolean is + -- ??? This implementation is incomplete. See RM 6.1.1 + -- for details. In particular, this function *should* return + -- True for a function call (or a user-defined literal, which + -- is equivalent to a function call) if all actual parameters + -- (including defaulted params) are known on entry and the + -- function has "Globals => null" specified; the current + -- implementation will incorrectly return False in this case. + + function All_Exps_Known_On_Entry + (Expr_List : List_Id) return Boolean; + -- Given a list of expressions, returns False iff + -- Is_Known_On_Entry is False for at least one list element. + + ----------------------------- + -- All_Exps_Known_On_Entry -- + ----------------------------- + + function All_Exps_Known_On_Entry + (Expr_List : List_Id) return Boolean + is + Expr : Node_Id := First (Expr_List); + begin + while Present (Expr) loop + if not Is_Known_On_Entry (Expr) then + return False; + end if; + Next (Expr); + end loop; + return True; + end All_Exps_Known_On_Entry; + + begin + if Is_Static_Expression (Expr) then + return True; + end if; + + if Is_Attribute_Old (Expr) then + return True; + end if; + + declare + Pref : Node_Id := Expr; + begin + loop + case Nkind (Pref) is + when N_Selected_Component => + null; + + when N_Indexed_Component => + if not All_Exps_Known_On_Entry (Expressions (Pref)) + then + return False; + end if; + + when N_Slice => + return False; -- just to be clear about this case + + when others => + exit; + end case; + + Pref := Prefix (Pref); + end loop; + + if Is_Entity_Name (Pref) + and then Is_Constant_Object (Entity (Pref)) + then + declare + Obj : constant Entity_Id := Entity (Pref); + Obj_Typ : constant Entity_Id := Etype (Obj); + begin + case Ekind (Obj) is + when E_In_Parameter => + if not Is_Elementary_Type (Obj_Typ) then + return False; + elsif Is_Aliased (Obj) then + return False; + end if; + + when E_Constant => + -- return False for a deferred constant + if Present (Full_View (Obj)) then + return False; + end if; + + -- return False if not "all views are constant". + if Is_Immutably_Limited_Type (Obj_Typ) + or Needs_Finalization (Obj_Typ) + then + return False; + end if; + + when others => + null; + end case; + end; + + return True; + end if; + + -- ??? Cope with a malformed tree. Code to cope with a + -- nonstatic use of an enumeration literal should not be + -- necessary. + if Is_Entity_Name (Pref) + and then Ekind (Entity (Pref)) = E_Enumeration_Literal + then + return True; + end if; + end; + + case Nkind (Expr) is + when N_Unary_Op => + return Is_Known_On_Entry (Right_Opnd (Expr)); + + when N_Binary_Op => + return Is_Known_On_Entry (Left_Opnd (Expr)) + and then Is_Known_On_Entry (Right_Opnd (Expr)); + + when N_Type_Conversion | N_Qualified_Expression => + return Is_Known_On_Entry (Expression (Expr)); + + when N_If_Expression => + if not All_Exps_Known_On_Entry (Expressions (Expr)) then + return False; + end if; + + when N_Case_Expression => + if not Is_Known_On_Entry (Expression (Expr)) then + return False; + end if; + + declare + Alt : Node_Id := First (Alternatives (Expr)); + begin + while Present (Alt) loop + if not Is_Known_On_Entry (Expression (Alt)) then + return False; + end if; + Next (Alt); + end loop; + end; + + return True; + + when others => + null; + end case; + + return False; + end Is_Known_On_Entry; + + end Conditional_Evaluation; + + package body Indirect_Temps is + + Indirect_Temp_Access_Type_Char : constant Character := 'K'; + -- The character passed to Make_Temporary when declaring + -- the access type that is used in the implementation of an + -- indirect temporary. + + -------------------------- + -- Indirect_Temp_Needed -- + -------------------------- + + function Indirect_Temp_Needed (Typ : Entity_Id) return Boolean is + begin + -- There should be no correctness issues if the only cases where + -- this function returns False are cases where Typ is an + -- anonymous access type and we need to generate a saooaaat (a + -- stand-alone object of an anonymous access type) in order get + -- accessibility right. In other cases where this function + -- returns False, there would be no correctness problems with + -- returning True instead; however, returning False when we can + -- generally results in simpler code. + + return False + + -- If Typ is not definite, then we cannot generate + -- Temp : Typ; + + or else not Is_Definite_Subtype (Typ) + + -- If Typ is tagged, then generating + -- Temp : Typ; + -- might generate an object with the wrong tag. If we had + -- a predicate that indicated whether the nominal tag is + -- trustworthy, we could use that predicate here. + + or else Is_Tagged_Type (Typ) + + -- If Typ needs finalization, then generating an implicit + -- Temp : Typ; + -- declaration could have user-visible side effects. + + or else Needs_Finalization (Typ) + + -- In the anonymous access type case, we need to + -- generate a saooaaat. We don't want the code in + -- in exp_attr.adb that deals with the case where this + -- function returns False to have to deal with that case + -- (just to avoid code duplication). So we cheat a little + -- bit and return True here for an anonymous access type. + + or else Is_Anonymous_Access_Type (Typ); + + -- ??? Unimplemented - spec description says: + -- For an unconstrained-but-definite discriminated subtype, + -- returns True if the potential difference in size between an + -- unconstrained object and a constrained object is large. + -- + -- For example, + -- type Typ (Len : Natural := 0) is + -- record F : String (1 .. Len); end record; + -- + -- See Large_Max_Size_Mutable function elsewhere in this + -- file (currently declared inside of + -- New_Requires_Transient_Scope, so it would have to be + -- moved if we want it to be callable from here). + + end Indirect_Temp_Needed; + + --------------------------- + -- Declare_Indirect_Temp -- + --------------------------- + + procedure Declare_Indirect_Temp + (Attr_Prefix : Node_Id; Indirect_Temp : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Attr_Prefix); + Prefix_Type : constant Entity_Id := Etype (Attr_Prefix); + Temp_Id : constant Entity_Id := + Make_Temporary (Loc, 'P', Attr_Prefix); + + procedure Declare_Indirect_Temp_Via_Allocation; + -- Handle the usual case. + + ------------------------------------------- + -- Declare_Indirect_Temp_Via_Allocation -- + ------------------------------------------- + + procedure Declare_Indirect_Temp_Via_Allocation is + Access_Type_Id : constant Entity_Id + := Make_Temporary + (Loc, Indirect_Temp_Access_Type_Char, Attr_Prefix); + + Temp_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => + New_Occurrence_Of (Access_Type_Id, Loc)); + + Allocate_Class_Wide : constant Boolean := + Is_Specific_Tagged_Type (Prefix_Type); + -- If True then access type designates the class-wide type in + -- order to preserve (at run time) the value of the underlying + -- tag. + -- ??? We could do better here (in the case where Prefix_Type + -- is tagged and specific) if we had a predicate which takes an + -- expression and returns True iff the expression is of + -- a specific tagged type and the underlying tag (at run time) + -- is statically known to match that of the specific type. + -- In that case, Allocate_Class_Wide could safely be False. + + function Designated_Subtype_Mark return Node_Id; + -- Usually, a subtype mark indicating the subtype of the + -- attribute prefix. If that subtype is a specific tagged + -- type, then returns the corresponding class-wide type. + -- If the prefix is of an anonymous access type, then returns + -- the designated type of that type. + + ----------------------------- + -- Designated_Subtype_Mark -- + ----------------------------- + + function Designated_Subtype_Mark return Node_Id is + Typ : Entity_Id := Prefix_Type; + begin + if Allocate_Class_Wide then + if Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + Typ := Class_Wide_Type (Typ); + end if; + + return New_Occurrence_Of (Typ, Loc); + end Designated_Subtype_Mark; + + Access_Type_Def : constant Node_Id + := Make_Access_To_Object_Definition + (Loc, Subtype_Indication => Designated_Subtype_Mark); + + Access_Type_Decl : constant Node_Id + := Make_Full_Type_Declaration + (Loc, Access_Type_Id, + Type_Definition => Access_Type_Def); + begin + Set_Ekind (Temp_Id, E_Variable); + Set_Etype (Temp_Id, Access_Type_Id); + Set_Ekind (Access_Type_Id, E_Access_Type); + + if Append_Decls_In_Reverse_Order then + Append_Item (Temp_Decl, Is_Eval_Stmt => False); + Append_Item (Access_Type_Decl, Is_Eval_Stmt => False); + else + Append_Item (Access_Type_Decl, Is_Eval_Stmt => False); + Append_Item (Temp_Decl, Is_Eval_Stmt => False); + end if; + + Analyze (Access_Type_Decl); + Analyze (Temp_Decl); + + pragma Assert + (Is_Access_Type_For_Indirect_Temp (Access_Type_Id)); + + declare + Expression : Node_Id := Attr_Prefix; + Allocator : Node_Id; + begin + if Allocate_Class_Wide then + -- generate T'Class'(T'Class (<prefix>)) + Expression := + Make_Type_Conversion (Loc, + Subtype_Mark => Designated_Subtype_Mark, + Expression => Expression); + end if; + + Allocator := + Make_Allocator (Loc, + Make_Qualified_Expression + (Loc, + Subtype_Mark => Designated_Subtype_Mark, + Expression => Expression)); + + -- Allocate saved prefix value on the secondary stack + -- in order to avoid introducing a storage leak. This + -- allocated object is never explicitly reclaimed. + -- + -- ??? Emit storage leak warning if RE_SS_Pool + -- unavailable? + + if RTE_Available (RE_SS_Pool) then + Set_Storage_Pool (Allocator, RTE (RE_SS_Pool)); + Set_Procedure_To_Call + (Allocator, RTE (RE_SS_Allocate)); + Set_Uses_Sec_Stack (Current_Scope); + end if; + + Append_Item + (Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp_Id, Loc), + Expression => Allocator), + Is_Eval_Stmt => True); + end; + end Declare_Indirect_Temp_Via_Allocation; + + begin + Indirect_Temp := Temp_Id; + + if Is_Anonymous_Access_Type (Prefix_Type) then + -- In the anonymous access type case, we do not want a level + -- indirection (which would result in declaring an + -- access-to-access type); that would result in correctness + -- problems - the accessibility level of the type of the + -- 'Old constant would be wrong (See 6.1.1.). So in that case, + -- we do not generate an allocator. Instead we generate + -- Temp : access Designated := null; + -- which is unconditionally elaborated and then + -- Temp := <attribute prefix>; + -- which is conditionally executed. + + declare + Temp_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Object_Definition => + Make_Access_Definition + (Loc, + Constant_Present => + Is_Access_Constant (Prefix_Type), + Subtype_Mark => + New_Occurrence_Of + (Designated_Type (Prefix_Type), Loc))); + begin + Append_Item (Temp_Decl, Is_Eval_Stmt => False); + Analyze (Temp_Decl); + Append_Item + (Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Temp_Id, Loc), + Expression => Attr_Prefix), + Is_Eval_Stmt => True); + end; + else + -- the usual case + Declare_Indirect_Temp_Via_Allocation; + end if; + end Declare_Indirect_Temp; + + ------------------------- + -- Indirect_Temp_Value -- + ------------------------- + + function Indirect_Temp_Value + (Temp : Entity_Id; + Typ : Entity_Id; + Loc : Source_Ptr) return Node_Id + is + Result : Node_Id; + begin + if Is_Anonymous_Access_Type (Typ) then + -- No indirection in this case; just evaluate the temp. + Result := New_Occurrence_Of (Temp, Loc); + Set_Etype (Result, Etype (Temp)); + + else + Result := Make_Explicit_Dereference (Loc, + New_Occurrence_Of (Temp, Loc)); + + Set_Etype (Result, Designated_Type (Etype (Temp))); + + if Is_Specific_Tagged_Type (Typ) then + -- The designated type of the access type is class-wide, so + -- convert to the specific type. + + Result := + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Expression => Result); + + Set_Etype (Result, Typ); + end if; + end if; + + return Result; + end Indirect_Temp_Value; + + function Is_Access_Type_For_Indirect_Temp + (T : Entity_Id) return Boolean is + begin + if Is_Access_Type (T) + and then not Comes_From_Source (T) + and then Is_Internal_Name (Chars (T)) + and then Nkind (Scope (T)) in N_Entity + and then Ekind (Scope (T)) + in E_Entry | E_Entry_Family | E_Function | E_Procedure + and then + (Present (Postconditions_Proc (Scope (T))) + or else Present (Contract (Scope (T)))) + then + -- ??? Should define a flag for this. We could incorrectly + -- return True if other clients of Make_Temporary happen to + -- pass in the same character. + declare + Name : constant String := Get_Name_String (Chars (T)); + begin + if Name (Name'First) = Indirect_Temp_Access_Type_Char then + return True; + end if; + end; + end if; + return False; + end Is_Access_Type_For_Indirect_Temp; + + end Indirect_Temps; + end Old_Attr_Util; begin Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access; end Sem_Util; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e2147e0..1b993f9 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -25,6 +25,7 @@ -- Package containing utility procedures used throughout the semantics +with Aspects; use Aspects; with Atree; use Atree; with Einfo; use Einfo; with Exp_Tss; use Exp_Tss; @@ -42,6 +43,36 @@ package Sem_Util is -- including the cases where there can't be any because e.g. the type is -- not tagged. + type Accessibility_Level_Kind is + (Dynamic_Level, + Object_Decl_Level, + Zero_On_Dynamic_Level); + -- Accessibility_Level_Kind is an enumerated type which captures the + -- different modes in which an accessibility level could be obtained for + -- a given expression. + + -- When in the context of the function Accessibility_Level, + -- Accessibility_Level_Kind signals what type of accessibility level to + -- obtain. For example, when Level is Dynamic_Level, a defining identifier + -- associated with a SAOOAAT may be returned or an N_Integer_Literal node. + -- When the level is Object_Decl_Level, an N_Integer_Literal node is + -- returned containing the level of the declaration of the object if + -- relevant (be it a SAOOAAT or otherwise). Finally, Zero_On_Dynamic_Level + -- returns library level for all cases where the accessibility level is + -- dynamic (used to bypass static accessibility checks in dynamic cases). + + function Accessibility_Level + (Expr : Node_Id; + Level : Accessibility_Level_Kind; + In_Return_Context : Boolean := False) return Node_Id; + -- Centralized accessibility level calculation routine for finding the + -- accessibility level of a given expression Expr. + + -- In_Return_Context forcing the Accessibility_Level calculations to be + -- carried out "as if" Expr existed in a return value. This is useful for + -- calculating the accessibility levels for discriminant associations + -- and return aggregates. + function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String; -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to get -- the given string argument, adding leading and trailing asterisks if they @@ -80,7 +111,7 @@ package Sem_Util is function Addressable (V : Int) return Boolean; pragma Inline (Addressable); -- Returns True if the value of V is the word size or an addressable factor - -- of the word size (typically 8, 16, 32 or 64). + -- or multiple of the word size (typically 8, 16, 32, 64 or 128). procedure Aggregate_Constraint_Checks (Exp : Node_Id; @@ -157,11 +188,11 @@ package Sem_Util is -- force an error). function Async_Readers_Enabled (Id : Entity_Id) return Boolean; - -- Id should be the entity of a state abstraction, a variable, or a type. + -- Id should be the entity of a state abstraction, an object, or a type. -- Returns True iff Id is subject to external property Async_Readers. function Async_Writers_Enabled (Id : Entity_Id) return Boolean; - -- Id should be the entity of a state abstraction, a variable, or a type. + -- Id should be the entity of a state abstraction, an object, or a type. -- Returns True iff Id is subject to external property Async_Writers. function Available_Full_View_Of_Component (T : Entity_Id) return Boolean; @@ -349,6 +380,13 @@ package Sem_Util is -- not necessarily mean that CE could be raised, but a response of True -- means that for sure CE cannot be raised. + procedure Check_Ambiguous_Aggregate (Call : Node_Id); + -- Additional information on an ambiguous call in Ada_2020 when a + -- subprogram call has an actual that is an aggregate, and the + -- presence of container aggregates (or types with the correwponding + -- aspect) provides an additional interpretation. Message indicates + -- that an aggregate actual should carry a type qualification. + procedure Check_Dynamically_Tagged_Expression (Expr : Node_Id; Typ : Entity_Id; @@ -406,9 +444,20 @@ package Sem_Util is -- Determine whether object or state Id introduces a hidden state. If this -- is the case, emit an error. + procedure Check_Inherited_Nonoverridable_Aspects + (Inheritor : Entity_Id; + Interface_List : List_Id; + Parent_Type : Entity_Id); + -- Verify consistency of inherited nonoverridable aspects + -- when aspects are inherited from more than one source. + -- Parent_Type may be void (e.g., for a tagged task/protected type + -- whose declaration includes a non-empty interface list). + -- In the error case, error message is associate with Inheritor; + -- Inheritor parameter is otherwise unused. + procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id); -- Verify that the profile of nonvolatile function Func_Id does not contain - -- effectively volatile parameters or return type. + -- effectively volatile parameters or return type for reading. procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id); -- Verify the legality of reference Ref to variable Var_Id when the @@ -603,7 +652,9 @@ package Sem_Util is -- in the case of a descendant of a generic formal type (returns Int'Last -- instead of 0). - function Defining_Entity (N : Node_Id) return Entity_Id; + function Defining_Entity + (N : Node_Id; + Empty_On_Errors : Boolean := False) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the -- specification. If the declaration has a defining unit name, then the @@ -614,6 +665,16 @@ package Sem_Util is -- local entities declared during loop expansion. These entities need -- debugging information, generated through Qualify_Entity_Names, and -- the loop declaration must be placed in the table Name_Qualify_Units. + -- + -- Set flag Empty_On_Errors to change the behavior of this routine as + -- follows: + -- + -- * True - A declaration that lacks a defining entity returns Empty. + -- A node that does not allow for a defining entity returns Empty. + -- + -- * False - A declaration that lacks a defining entity is given a new + -- internally generated entity which is subsequently returned. A node + -- that does not allow for a defining entity raises Program_Error -- WARNING: There is a matching C declaration of this subprogram in fe.h @@ -646,6 +707,14 @@ package Sem_Util is -- indication or a scalar subtype where one of the bounds is a -- discriminant. + function Derivation_Too_Early_To_Inherit + (Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean; + -- Returns True if Typ is a derived type, the given Streaming_Op + -- (one of Read, Write, Input, or Output) is explicitly specified + -- for Typ's parent type, and that attribute specification is *not* + -- inherited by Typ because the declaration of Typ precedes that + -- of the attribute specification. + function Designate_Same_Unit (Name1 : Node_Id; Name2 : Node_Id) return Boolean; @@ -665,22 +734,16 @@ package Sem_Util is -- private components of protected objects, but is generally useful when -- restriction No_Implicit_Heap_Allocation is active. - function Dynamic_Accessibility_Level (N : Node_Id) return Node_Id; - -- N should be an expression of an access type. Builds an integer literal - -- except in cases involving anonymous access types, where accessibility - -- levels are tracked at run time (access parameters and Ada 2012 stand- - -- alone objects). - function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id; -- Same as Einfo.Extra_Accessibility except thtat object renames -- are looked through. function Effective_Reads_Enabled (Id : Entity_Id) return Boolean; - -- Id should be the entity of a state abstraction, a variable, or a type. + -- Id should be the entity of a state abstraction, an object, or a type. -- Returns True iff Id is subject to external property Effective_Reads. function Effective_Writes_Enabled (Id : Entity_Id) return Boolean; - -- Id should be the entity of a state abstraction, a variable, or a type. + -- Id should be the entity of a state abstraction, an object, or a type. -- Returns True iff Id is subject to external property Effective_Writes. function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id; @@ -1015,7 +1078,7 @@ package Sem_Util is -- discriminants. Otherwise all components of the parent must be included -- in the subtype for semantic analysis. - function Get_Accessibility (E : Entity_Id) return Node_Id; + function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id; -- Obtain the accessibility level for a given entity formal taking into -- account both extra and minimum accessibility. @@ -1243,6 +1306,9 @@ package Sem_Util is -- as an access type internally, this function tests only for access types -- known to the programmer. See also Has_Tagged_Component. + function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean; + -- Returns True if Typ has one or more anonymous access discriminants + type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); -- Result of Has_Compatible_Alignment test, description found below. Note -- that the values are arranged in increasing order of problematicness. @@ -1289,7 +1355,8 @@ package Sem_Util is function Has_Effectively_Volatile_Profile (Subp_Id : Entity_Id) return Boolean; -- Determine whether subprogram Subp_Id has an effectively volatile formal - -- parameter or returns an effectively volatile value. + -- parameter for reading or returns an effectively volatile value for + -- reading. function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean; -- Determine whether type Typ defines "full default initialization" as @@ -1370,6 +1437,20 @@ package Sem_Util is -- Return True if the loop has no side effect and can therefore be -- marked for removal. Return False if N is not a N_Loop_Statement. + subtype Static_Accessibility_Level_Kind + is Accessibility_Level_Kind range Object_Decl_Level + .. Zero_On_Dynamic_Level; + -- Restrict the reange of Accessibility_Level_Kind to be non-dynamic for + -- use in the static version of Accessibility_Level below. + + function Static_Accessibility_Level + (Expr : Node_Id; + Level : Static_Accessibility_Level_Kind; + In_Return_Context : Boolean := False) return Uint; + -- Overloaded version of Accessibility_Level which returns a universal + -- integer for use in compile-time checking. Note: Level is restricted to + -- be non-dynamic. + function Has_Overriding_Initialize (T : Entity_Id) return Boolean; -- Predicate to determine whether a controlled type has a user-defined -- Initialize primitive (and, in Ada 2012, whether that primitive is @@ -1491,6 +1572,11 @@ package Sem_Util is function In_Quantified_Expression (N : Node_Id) return Boolean; -- Returns true if the expression N occurs within a quantified expression + function In_Return_Value (Expr : Node_Id) return Boolean; + -- Returns true if the expression Expr occurs within a simple return + -- statement or is part of an assignment to the return object in an + -- extended return statement. + 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. @@ -1595,9 +1681,12 @@ package Sem_Util is -- True if E is the constructed wrapper for an access_to_subprogram -- type with Pre/Postconditions. + function Is_Access_Variable (E : Entity_Id) return Boolean; + -- Determines if type E is an access-to-variable + function Is_Actual_In_Out_Parameter (N : Node_Id) return Boolean; -- Determines if N is an actual parameter of in-out mode in a subprogram - -- call + -- call. function Is_Actual_Out_Parameter (N : Node_Id) return Boolean; -- Determines if N is an actual parameter of out mode in a subprogram call @@ -1627,10 +1716,6 @@ package Sem_Util is -- Determine whether arbitrary node N denotes a reference to an atomic -- object as per RM C.6(7) and the crucial remark in RM C.6(8). - function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean; - -- Determine whether arbitrary node N denotes a reference to an object - -- which is either atomic or Volatile_Full_Access. - function Is_Attribute_Loop_Entry (N : Node_Id) return Boolean; -- Determine whether node N denotes attribute 'Loop_Entry @@ -1654,6 +1739,12 @@ package Sem_Util is -- Determine whether entity Id denotes a procedure with synchronization -- kind By_Protected_Procedure. + function Is_Confirming (Aspect : Nonoverridable_Aspect_Id; + Aspect_Spec_1, Aspect_Spec_2 : Node_Id) + return Boolean; + -- Returns true if the two specifications of the given + -- nonoverridable aspect are compatible. + function Is_Constant_Bound (Exp : Node_Id) return Boolean; -- Exp is the expression for an array bound. Determines whether the -- bound is a compile-time known value, or a constant entity, or an @@ -1797,16 +1888,39 @@ package Sem_Util is -- * A protected type -- * Descendant of type Ada.Synchronous_Task_Control.Suspension_Object - function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean; + function Is_Effectively_Volatile_For_Reading + (Id : Entity_Id) return Boolean; + -- Determine whether a type or object denoted by entity Id is effectively + -- volatile for reading (SPARK RM 7.1.2). To qualify as such, the entity + -- must be either + -- * Volatile without No_Caching and have Async_Writers or + -- Effective_Reads set to True + -- * An array type subject to aspect Volatile_Components, unless it has + -- Async_Writers and Effective_Reads set to False + -- * An array type whose component type is effectively volatile for + -- reading + -- * A protected type + -- * Descendant of type Ada.Synchronous_Task_Control.Suspension_Object + + function Is_Effectively_Volatile_Object + (N : Node_Id) return Boolean; -- Determine whether an arbitrary node denotes an effectively volatile -- object (SPARK RM 7.1.2). + function Is_Effectively_Volatile_Object_For_Reading + (N : Node_Id) return Boolean; + -- Determine whether an arbitrary node denotes an effectively volatile + -- object for reading (SPARK RM 7.1.2). + function Is_Entry_Body (Id : Entity_Id) return Boolean; -- Determine whether entity Id is the body entity of an entry [family] function Is_Entry_Declaration (Id : Entity_Id) return Boolean; -- Determine whether entity Id is the spec entity of an entry [family] + function Is_Explicitly_Aliased (N : Node_Id) return Boolean; + -- Determine if a given node N is an explicitly aliased formal parameter. + function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean; -- Check whether a function in a call is an expanded priority attribute, -- which is transformed into an Rtsfind call to Get_Ceiling. This expansion @@ -1840,6 +1954,10 @@ package Sem_Util is -- Returns True iff the number U is a model number of the fixed-point type -- T, i.e. if it is an exact multiple of Small. + function Is_Full_Access_Object (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N denotes a reference to a full access + -- object as per Ada 2020 RM C.6(8.2). + function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean; -- Typ is a type entity. This function returns true if this type is fully -- initialized, meaning that an object of the type is fully initialized. @@ -1915,6 +2033,9 @@ package Sem_Util is -- parameter of the current enclosing subprogram. -- Why are OUT parameters not considered here ??? + function Is_Master (N : Node_Id) return Boolean; + -- Determine if the given node N constitutes a finalization master + function Is_Name_Reference (N : Node_Id) return Boolean; -- Determine whether arbitrary node N is a reference to a name. This is -- similar to Is_Object_Reference but returns True only if N can be renamed @@ -2075,11 +2196,15 @@ package Sem_Util is -- created for a single task type. function Is_Special_Aliased_Formal_Access - (Exp : Node_Id; - Scop : Entity_Id) return Boolean; + (Exp : Node_Id; + In_Return_Context : Boolean := False) return Boolean; -- Determines whether a dynamic check must be generated for explicitly -- aliased formals within a function Scop for the expression Exp. + -- In_Return_Context forces Is_Special_Aliased_Formal_Access to assume + -- that Exp is within a return value which is useful for checking + -- expressions within discriminant associations of return objects. + -- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a -- 'Access attribute reference within a return statement where the ultimate -- prefix is an aliased formal of Scop and that Scop returns an anonymous @@ -2104,9 +2229,9 @@ package Sem_Util is -- meaning that the name of the call denotes a static function -- and all of the call's actual parameters are given by static expressions. - function Is_Subcomponent_Of_Atomic_Object (N : Node_Id) return Boolean; + function Is_Subcomponent_Of_Full_Access_Object (N : Node_Id) return Boolean; -- Determine whether arbitrary node N denotes a reference to a subcomponent - -- of an atomic object as per RM C.6(7). + -- of a full access object as per RM C.6(7). function Is_Subprogram_Contract_Annotation (Item : Node_Id) return Boolean; -- Determine whether aspect specification or pragma Item is one of the @@ -2124,6 +2249,7 @@ package Sem_Util is -- Refined_Depends -- Refined_Global -- Refined_Post + -- Subprogram_Variant -- Test_Case function Is_Subprogram_Stub_Without_Prior_Declaration @@ -2145,7 +2271,7 @@ package Sem_Util is -- such, the object must be -- * Of a type that yields a synchronized object -- * An atomic object with enabled Async_Writers - -- * A constant + -- * A constant not of access-to-variable type -- * A variable subject to pragma Constant_After_Elaboration function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean; @@ -2578,11 +2704,6 @@ package Sem_Util is -- is known at compile time. If the bounds are not known at compile time, -- the function returns the value zero. - function Object_Access_Level (Obj : Node_Id) return Uint; - -- Return the accessibility level of the view of the object Obj. For - -- convenience, qualified expressions applied to object names are also - -- allowed as actuals for this function. - function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id; -- Retrieve the name of aspect or pragma N, taking into account a possible -- rewrite and whether the pragma is generated from an aspect as the names @@ -2617,6 +2738,12 @@ package Sem_Util is -- WARNING: this routine should be used in debugging scenarios such as -- tracking down undefined symbols as it is fairly low level. + function Param_Entity (N : Node_Id) return Entity_Id; + -- Given an expression N, determines if the expression is a reference + -- to a formal (of a subprogram or entry), and if so returns the Id + -- of the corresponding formal entity, otherwise returns Empty. Also + -- handles the case of references to renamings of formals. + function Policy_In_Effect (Policy : Name_Id) return Name_Id; -- Given a policy, return the policy identifier associated with it. If no -- such policy is in effect, the value returned is No_Name. @@ -2800,6 +2927,12 @@ package Sem_Util is -- mean that different objects are designated, just that this could not -- be reliably determined at compile time. + function Same_Or_Aliased_Subprograms + (S : Entity_Id; + E : Entity_Id) return Boolean; + -- Returns True if the subprogram entity S is the same as E or else S is an + -- alias of E. + function Same_Type (T1, T2 : Entity_Id) return Boolean; -- Determines if T1 and T2 represent exactly the same type. Two types -- are the same if they are identical, or if one is an unconstrained @@ -3132,6 +3265,9 @@ package Sem_Util is function Yields_Universal_Type (N : Node_Id) return Boolean; -- Determine whether unanalyzed node N yields a universal type + procedure Preanalyze_Without_Errors (N : Node_Id); + -- Preanalyze N without reporting errors + package Interval_Lists is type Discrete_Interval is record @@ -3171,11 +3307,97 @@ package Sem_Util is -- correctly for real types with static predicates, we may need -- an analogous Real_Interval_List type. Most of the language -- rules that reference "is statically compatible" pertain to - -- discriminants and therefore do require support for real types; + -- discriminants and therefore do not require support for real types; -- the exception is 12.5.1(8). Intervals_Error : exception; -- Raised when the list of non-empty pair-wise disjoint intervals cannot -- be built. end Interval_Lists; + + package Old_Attr_Util is + -- Operations related to 'Old attribute evaluation. This + -- includes cases where a level of indirection is needed due to + -- conditional evaluation as well as support for the + -- "known on entry" rules. + + package Conditional_Evaluation is + function Eligible_For_Conditional_Evaluation + (Expr : Node_Id) return Boolean; + -- Given a subexpression of a Postcondition expression + -- (typically a 'Old attribute reference), returns True if + -- - the expression is conditionally evaluated; and + -- - its determining expressions are all known on entry; and + -- - Ada_Version >= Ada_2020. + -- See RM 6.1.1 for definitions of these terms. + -- + -- Also returns True if Expr is of an anonymous access type; + -- this is just because we want the code that knows how to build + -- 'Old temps in that case to reside in only one place. + + function Conditional_Evaluation_Condition + (Expr : Node_Id) return Node_Id; + -- Given an expression which is eligible for conditional evaluation, + -- build a Boolean expression whose value indicates whether the + -- expression should be evaluated. + end Conditional_Evaluation; + + package Indirect_Temps is + generic + with procedure Append_Item (N : Node_Id; Is_Eval_Stmt : Boolean); + -- If Is_Eval_Stmt is True, then N is a statement that should + -- only be executed in the case where the 'Old prefix is to be + -- evaluated. If Is_Eval_Stmt is False, then N is a declaration + -- which should be elaborated unconditionally. + -- Client is responsible for ensuring that any appended + -- Eval_Stmt nodes are eventually analyzed. + + Append_Decls_In_Reverse_Order : Boolean := False; + -- This parameter is for the convenience of exp_prag.adb, where we + -- want to Prepend rather than Append so it is better to get the + -- Append calls in reverse order. + + procedure Declare_Indirect_Temp + (Attr_Prefix : Node_Id; -- prefix of 'Old attribute (or similar?) + Indirect_Temp : out Entity_Id); + -- Indirect_Temp is of an access type; it is unconditionally + -- declared but only conditionally initialized to reference the + -- saved value of Attr_Prefix. + + function Indirect_Temp_Needed (Typ : Entity_Id) return Boolean; + -- Returns True for a specific tagged type because the temp must + -- be of the class-wide type in order to preserve the underlying tag. + -- + -- Also returns True in the case of an anonymous access type + -- because we want the code that knows how to deal with + -- this case to reside in only one place. + -- + -- For an unconstrained-but-definite discriminated subtype, returns + -- True if the potential difference in size between an + -- unconstrained object and a constrained object is large. + -- [This part is not implemented yet.] + -- + -- Otherwise, returns False if a declaration of the form + -- Temp : Typ; + -- is legal and side-effect-free (assuming that default + -- initialization is suppressed). For example, returns True if Typ is + -- indefinite, or if Typ has a controlled part. + -- + + function Indirect_Temp_Value + (Temp : Entity_Id; + Typ : Entity_Id; + Loc : Source_Ptr) return Node_Id; + -- Evaluate a temp declared by Declare_Indirect_Temp. + + function Is_Access_Type_For_Indirect_Temp + (T : Entity_Id) return Boolean; + -- True for an access type that was declared via a call + -- to Declare_Indirect_Temp. + -- Indicates that the given access type should be treated + -- the same with respect to finalization as a + -- user-defined "comes from source" access type. + + end Indirect_Temps; + end Old_Attr_Util; end Sem_Util; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index b67bb7d..d1acf2f 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1416,8 +1416,14 @@ package body Sem_Warn is and then not Warnings_Off_E1 and then not Has_Junk_Name (E1) then - Output_Reference_Error - ("?v?variable& is read but never assigned!"); + if Is_Access_Type (E1T) + or else + not Is_Partially_Initialized_Type (E1T, False) + then + Output_Reference_Error + ("?v?variable& is read but never assigned!"); + end if; + May_Need_Initialized_Actual (E1); end if; @@ -2248,10 +2254,6 @@ package body Sem_Warn is ------------------------ procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit) is - Cnode : Node_Id; - Item : Node_Id; - Lunit : Node_Id; - Ent : Entity_Id; Munite : constant Entity_Id := Cunit_Entity (Main_Unit); -- This is needed for checking the special renaming case @@ -2264,8 +2266,9 @@ package body Sem_Warn is -------------------- procedure Check_One_Unit (Unit : Unit_Number_Type) is + Cnode : constant Node_Id := Cunit (Unit); + Is_Visible_Renaming : Boolean := False; - Pack : Entity_Id; procedure Check_Inner_Package (Pack : Entity_Id); -- Pack is a package local to a unit in a with_clause. Both the unit @@ -2273,7 +2276,7 @@ package body Sem_Warn is -- referenced, then the only occurrence of Pack is in a USE clause -- or a pragma, and a warning is worthwhile as well. - function Check_System_Aux return Boolean; + function Check_System_Aux (Lunit : Entity_Id) return Boolean; -- Before giving a warning on a with_clause for System, check whether -- a system extension is present. @@ -2352,7 +2355,7 @@ package body Sem_Warn is -- Check_System_Aux -- ---------------------- - function Check_System_Aux return Boolean is + function Check_System_Aux (Lunit : Entity_Id) return Boolean is Ent : Entity_Id; begin @@ -2447,11 +2450,16 @@ package body Sem_Warn is return False; end Has_Visible_Entities; + -- Local variables + + Ent : Entity_Id; + Item : Node_Id; + Lunit : Entity_Id; + Pack : Entity_Id; + -- Start of processing for Check_One_Unit begin - Cnode := Cunit (Unit); - -- Only do check in units that are part of the extended main unit. -- This is actually a necessary restriction, because in the case of -- subprogram acting as its own specification, there can be with's in @@ -2501,7 +2509,7 @@ package body Sem_Warn is -- package with only a linker options pragma and nothing -- else or a pragma elaborate with a body library task). - elsif Has_Visible_Entities (Entity (Name (Item))) then + elsif Has_Visible_Entities (Lunit) then Error_Msg_N -- CODEFIX ("?u?unit& is not referenced!", Name (Item)); end if; @@ -2570,64 +2578,56 @@ package body Sem_Warn is if Unit = Spec_Unit then Set_No_Entities_Ref_In_Spec (Item); - elsif Check_System_Aux then + elsif Check_System_Aux (Lunit) then null; -- Else the warning may be needed else - declare - Eitem : constant Entity_Id := - Entity (Name (Item)); - - begin - -- Warn if we unreferenced flag set and we - -- have not had serious errors. The reason we - -- inhibit the message if there are errors is - -- to prevent false positives from disabling - -- expansion. - - if not Has_Unreferenced (Eitem) - and then Serious_Errors_Detected = 0 + -- Warn if we unreferenced flag set and we have + -- not had serious errors. The reason we inhibit + -- the message if there are errors is to prevent + -- false positives from disabling expansion. + + if not Has_Unreferenced (Lunit) + and then Serious_Errors_Detected = 0 + then + -- Get possible package renaming + + Pack := Find_Package_Renaming (Munite, Lunit); + + -- No warning if either the package or its + -- renaming is used as a generic actual. + + if Used_As_Generic_Actual (Lunit) + or else + (Present (Pack) + and then + Used_As_Generic_Actual (Pack)) + then + exit; + end if; + + -- Here we give the warning + + Error_Msg_N -- CODEFIX + ("?u?no entities of & are referenced!", + Name (Item)); + + -- Flag renaming of package as well. If + -- the original package has warnings off, + -- we suppress the warning on the renaming + -- as well. + + if Present (Pack) + and then not Has_Warnings_Off (Lunit) + and then not Has_Unreferenced (Pack) then - -- Get possible package renaming - - Pack := - Find_Package_Renaming (Munite, Lunit); - - -- No warning if either the package or its - -- renaming is used as a generic actual. - - if Used_As_Generic_Actual (Eitem) - or else - (Present (Pack) - and then - Used_As_Generic_Actual (Pack)) - then - exit; - end if; - - -- Here we give the warning - - Error_Msg_N -- CODEFIX - ("?u?no entities of & are referenced!", - Name (Item)); - - -- Flag renaming of package as well. If - -- the original package has warnings off, - -- we suppress the warning on the renaming - -- as well. - - if Present (Pack) - and then not Has_Warnings_Off (Lunit) - and then not Has_Unreferenced (Pack) - then - Error_Msg_NE -- CODEFIX - ("?u?no entities of& are referenced!", - Unit_Declaration_Node (Pack), Pack); - end if; + Error_Msg_NE -- CODEFIX + ("?u?no entities of& are referenced!", + Unit_Declaration_Node (Pack), Pack); end if; - end; + end if; end if; exit; diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb index d707c12..b8578f5 100644 --- a/gcc/ada/set_targ.adb +++ b/gcc/ada/set_targ.adb @@ -55,6 +55,7 @@ package body Set_Targ is S_Float_Words_BE : constant Str := "Float_Words_BE"; S_Int_Size : constant Str := "Int_Size"; S_Long_Double_Size : constant Str := "Long_Double_Size"; + S_Long_Long_Long_Size : constant Str := "Long_Long_Long_Size"; S_Long_Long_Size : constant Str := "Long_Long_Size"; S_Long_Size : constant Str := "Long_Size"; S_Maximum_Alignment : constant Str := "Maximum_Alignment"; @@ -84,6 +85,7 @@ package body Set_Targ is S_Float_Words_BE 'Unrestricted_Access, S_Int_Size 'Unrestricted_Access, S_Long_Double_Size 'Unrestricted_Access, + S_Long_Long_Long_Size 'Unrestricted_Access, S_Long_Long_Size 'Unrestricted_Access, S_Long_Size 'Unrestricted_Access, S_Maximum_Alignment 'Unrestricted_Access, @@ -111,6 +113,7 @@ package body Set_Targ is Float_Words_BE 'Address, Int_Size 'Address, Long_Double_Size 'Address, + Long_Long_Long_Size 'Address, Long_Long_Size 'Address, Long_Size 'Address, Maximum_Alignment 'Address, @@ -745,8 +748,15 @@ package body Set_Targ is for J in DTR'Range loop if not DTR (J) then - Fail ("missing entry for " & DTN (J).all & " in file " - & File_Name); + -- Make an exception for Long_Long_Long_Size??? + + if DTN (J) = S_Long_Long_Long_Size'Unrestricted_Access then + Long_Long_Long_Size := Long_Long_Size; + + else + Fail ("missing entry for " & DTN (J).all & " in file " + & File_Name); + end if; end if; end loop; @@ -934,6 +944,7 @@ begin Double_Scalar_Alignment := Get_Double_Scalar_Alignment; Float_Words_BE := Get_Float_Words_BE; Int_Size := Get_Int_Size; + Long_Long_Long_Size := Get_Long_Long_Long_Size; Long_Long_Size := Get_Long_Long_Size; Long_Size := Get_Long_Size; Maximum_Alignment := Get_Maximum_Alignment; diff --git a/gcc/ada/set_targ.ads b/gcc/ada/set_targ.ads index aa37770..e25f351 100644 --- a/gcc/ada/set_targ.ads +++ b/gcc/ada/set_targ.ads @@ -71,6 +71,7 @@ package Set_Targ is Float_Words_BE : Nat; -- Float words stored big-endian? Int_Size : Pos; -- Standard.Integer'Size Long_Double_Size : Pos; -- Standard.Long_Long_Float'Size + Long_Long_Long_Size : Pos; -- Standard.Long_Long_Long_Integer'Size Long_Long_Size : Pos; -- Standard.Long_Long_Integer'Size Long_Size : Pos; -- Standard.Long_Integer'Size Maximum_Alignment : Pos; -- Maximum permitted alignment diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb index 1283abc..660d64f 100644 --- a/gcc/ada/sfn_scan.adb +++ b/gcc/ada/sfn_scan.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 082f06f..c88d9a9 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -13,25 +13,16 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -pragma Style_Checks (All_Checks); --- No subprogram ordering check, due to logical grouping - with Atree; use Atree; package body Sinfo is @@ -371,7 +362,8 @@ package body Sinfo is or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Generic_Association - or else NT (N).Nkind = N_Iterated_Component_Association); + or else NT (N).Nkind = N_Iterated_Component_Association + or else NT (N).Nkind = N_Iterated_Element_Association); return Flag15 (N); end Box_Present; @@ -3876,7 +3868,8 @@ package body Sinfo is or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Generic_Association - or else NT (N).Nkind = N_Iterated_Component_Association); + or else NT (N).Nkind = N_Iterated_Component_Association + or else NT (N).Nkind = N_Iterated_Element_Association); Set_Flag15 (N, Val); end Set_Box_Present; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 2583f91..439eef4 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -4251,6 +4245,7 @@ package Sinfo is -- Expression (Node3) -- Loop_Parameter_Specification (Node4) -- Loop_Actions (List5-Sem) + -- Box_Present (Flag15) -- Exactly one of Iterator_Specification or Loop_Parameter_ -- specification is present. If the Key_Expression is absent, @@ -5414,9 +5409,9 @@ package Sinfo is -- PARAMETER_SPECIFICATION ::= -- DEFINING_IDENTIFIER_LIST : [ALIASED] MODE [NULL_EXCLUSION] - -- SUBTYPE_MARK [:= DEFAULT_EXPRESSION] + -- SUBTYPE_MARK [:= DEFAULT_EXPRESSION] [ASPECT_SPECIFICATIONS] -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION - -- [:= DEFAULT_EXPRESSION] + -- [:= DEFAULT_EXPRESSION] [ASPECT_SPECIFICATIONS] -- Although the syntax allows multiple identifiers in the list, the -- semantics is as though successive specifications were given with @@ -7945,8 +7940,8 @@ package Sinfo is -- operation) are also in this list. -- Contract_Test_Cases contains a collection of pragmas that correspond - -- to aspects/pragmas Contract_Cases and Test_Case. The ordering in the - -- list is in LIFO fashion. + -- to aspects/pragmas Contract_Cases, Test_Case and Subprogram_Variant. + -- The ordering in the list is in LIFO fashion. -- Classifications contains pragmas that either declare, categorize, or -- establish dependencies between subprogram or package inputs and diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 9f2669e..08db0cf 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index 28c080d..9e66d09 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index ce9c63d..132c2ca 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 6310442..a9fd7c5 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -148,6 +142,8 @@ package Snames is Name_Dimension_System : constant Name_Id := N + $; Name_Disable_Controlled : constant Name_Id := N + $; Name_Dynamic_Predicate : constant Name_Id := N + $; + Name_Exclusive_Functions : constant Name_Id := N + $; + Name_Full_Access_Only : constant Name_Id := N + $; Name_Integer_Literal : constant Name_Id := N + $; Name_Real_Literal : constant Name_Id := N + $; Name_Relaxed_Initialization : constant Name_Id := N + $; @@ -173,6 +169,7 @@ package Snames is Name_uFinalizer : constant Name_Id := N + $; Name_uIdepth : constant Name_Id := N + $; Name_uInit : constant Name_Id := N + $; + Name_uInit_Level : constant Name_Id := N + $; Name_uInvariant : constant Name_Id := N + $; Name_uMaster : constant Name_Id := N + $; Name_uObject : constant Name_Id := N + $; @@ -195,6 +192,7 @@ package Snames is Name_uTask_Name : constant Name_Id := N + $; Name_uTrace_Sp : constant Name_Id := N + $; Name_uType_Invariant : constant Name_Id := N + $; + Name_uVariants : constant Name_Id := N + $; -- Names of predefined primitives used in the expansion of dispatching -- requeue and select statements, Abort, 'Callable and 'Terminated. @@ -453,7 +451,6 @@ package Snames is Name_Overriding_Renamings : constant Name_Id := N + $; -- GNAT Name_Partition_Elaboration_Policy : constant Name_Id := N + $; -- Ada 05 Name_Persistent_BSS : constant Name_Id := N + $; -- GNAT - Name_Polling : constant Name_Id := N + $; -- GNAT Name_Prefix_Exception_Messages : constant Name_Id := N + $; -- GNAT Name_Priority_Specific_Dispatching : constant Name_Id := N + $; -- Ada 05 Name_Profile : constant Name_Id := N + $; -- Ada 05 @@ -668,6 +665,7 @@ package Snames is Name_Source_Reference : constant Name_Id := N + $; -- GNAT Name_Static_Elaboration_Desired : constant Name_Id := N + $; -- GNAT Name_Stream_Convert : constant Name_Id := N + $; -- GNAT + Name_Subprogram_Variant : constant Name_Id := N + $; -- GNAT Name_Subtitle : constant Name_Id := N + $; -- GNAT Name_Suppress_All : constant Name_Id := N + $; -- GNAT Name_Suppress_Debug_Info : constant Name_Id := N + $; -- GNAT @@ -983,6 +981,7 @@ package Snames is Name_Machine_Size : constant Name_Id := N + $; -- GNAT Name_Mantissa : constant Name_Id := N + $; -- Ada 83 Name_Max_Alignment_For_Allocation : constant Name_Id := N + $; -- Ada 12 + Name_Max_Integer_Size : constant Name_Id := N + $; -- GNAT Name_Max_Size_In_Storage_Elements : constant Name_Id := N + $; Name_Maximum_Alignment : constant Name_Id := N + $; -- GNAT Name_Mechanism_Code : constant Name_Id := N + $; -- GNAT @@ -1188,19 +1187,21 @@ package Snames is Name_Signed_16 : constant Name_Id := N + $; -- GNAT Name_Signed_32 : constant Name_Id := N + $; -- GNAT Name_Signed_64 : constant Name_Id := N + $; -- GNAT + Name_Signed_128 : constant Name_Id := N + $; -- GNAT Name_Unsigned_8 : constant Name_Id := N + $; -- GNAT Name_Unsigned_16 : constant Name_Id := N + $; -- GNAT Name_Unsigned_32 : constant Name_Id := N + $; -- GNAT Name_Unsigned_64 : constant Name_Id := N + $; -- GNAT + Name_Unsigned_128 : constant Name_Id := N + $; -- GNAT subtype Scalar_Id is Name_Id - range Name_Short_Float .. Name_Unsigned_64; + range Name_Short_Float .. Name_Unsigned_128; subtype Float_Scalar_Id is Name_Id range Name_Short_Float .. Name_Long_Long_Float; subtype Integer_Scalar_Id is Name_Id - range Name_Signed_8 .. Name_Unsigned_64; + range Name_Signed_8 .. Name_Unsigned_128; -- Names of recognized checks for pragma Suppress @@ -1676,6 +1677,7 @@ package Snames is Attribute_Machine_Size, Attribute_Mantissa, Attribute_Max_Alignment_For_Allocation, + Attribute_Max_Integer_Size, Attribute_Max_Size_In_Storage_Elements, Attribute_Maximum_Alignment, Attribute_Mechanism_Code, @@ -1940,7 +1942,6 @@ package Snames is Pragma_Overriding_Renamings, Pragma_Partition_Elaboration_Policy, Pragma_Persistent_BSS, - Pragma_Polling, Pragma_Prefix_Exception_Messages, Pragma_Priority_Specific_Dispatching, Pragma_Profile, @@ -2101,6 +2102,7 @@ package Snames is Pragma_Source_Reference, Pragma_Static_Elaboration_Desired, Pragma_Stream_Convert, + Pragma_Subprogram_Variant, Pragma_Subtitle, Pragma_Suppress_All, Pragma_Suppress_Debug_Info, diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 3aeb95f..d71c415 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -420,6 +420,8 @@ package body Sprint is Dump_Original_Only := False; Dump_Freeze_Null := True; Current_Source_File := No_Source_File; + Push_Output; + Set_Standard_Output; if Arg in List_Range then Sprint_Node_List (List_Id (Arg), New_Lines => True); @@ -432,6 +434,7 @@ package body Sprint is end if; Write_Eol; + Pop_Output; end pg; -------- @@ -441,8 +444,11 @@ package body Sprint is procedure po (Arg : Union_Id) is begin Dump_Generated_Only := False; - Dump_Original_Only := True; + Dump_Original_Only := True; + Dump_Freeze_Null := False; Current_Source_File := No_Source_File; + Push_Output; + Set_Standard_Output; if Arg in List_Range then Sprint_Node_List (List_Id (Arg), New_Lines => True); @@ -455,6 +461,7 @@ package body Sprint is end if; Write_Eol; + Pop_Output; end po; ---------------------- @@ -473,8 +480,11 @@ package body Sprint is procedure ps (Arg : Union_Id) is begin Dump_Generated_Only := False; - Dump_Original_Only := False; + Dump_Original_Only := False; + Dump_Freeze_Null := False; Current_Source_File := No_Source_File; + Push_Output; + Set_Standard_Output; if Arg in List_Range then Sprint_Node_List (List_Id (Arg), New_Lines => True); @@ -487,6 +497,7 @@ package body Sprint is end if; Write_Eol; + Pop_Output; end ps; -------------------- diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads index 57b4d55..5742e51 100644 --- a/gcc/ada/stand.ads +++ b/gcc/ada/stand.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -440,8 +434,8 @@ package Stand is Universal_Integer : Entity_Id; -- Entity for universal integer type. The bounds of this type correspond - -- to the largest supported integer type (i.e. Long_Long_Integer). It is - -- the type used for runtime calculations in type universal integer. + -- to the largest supported integer type (i.e. Long_Long_Long_Integer). + -- It is the type used for runtime calculations in type universal integer. Universal_Real : Entity_Id; -- Entity for universal real type. The bounds of this type correspond to @@ -464,11 +458,12 @@ package Stand is -- These are signed integer types with the indicated sizes. Used for the -- underlying implementation types for fixed-point and enumeration types. - Standard_Short_Short_Unsigned : Entity_Id; - Standard_Short_Unsigned : Entity_Id; - Standard_Unsigned : Entity_Id; - Standard_Long_Unsigned : Entity_Id; - Standard_Long_Long_Unsigned : Entity_Id; + Standard_Short_Short_Unsigned : Entity_Id; + Standard_Short_Unsigned : Entity_Id; + Standard_Unsigned : Entity_Id; + Standard_Long_Unsigned : Entity_Id; + Standard_Long_Long_Unsigned : Entity_Id; + Standard_Long_Long_Long_Unsigned : Entity_Id; -- Unsigned types with same Esize as corresponding signed integer types Standard_Unsigned_64 : Entity_Id; diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb index 35e9028..5cdf12c 100644 --- a/gcc/ada/stringt.adb +++ b/gcc/ada/stringt.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads index ede7bfd..77a794e 100644 --- a/gcc/ada/stringt.ads +++ b/gcc/ada/stringt.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index c5f2e1c..e086a5d 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -673,6 +673,13 @@ package body Switch.C is new String'(Switch_Chars (Ptr .. Max)); return; + -- -gnaten (memory to allocate for nodes) + + when 'n' => + Ptr := Ptr + 1; + Scan_Pos + (Switch_Chars, Max, Ptr, Nodes_Size_In_Meg, C); + -- -gnateO= (object path file) -- This is an internal switch @@ -723,6 +730,7 @@ package body Switch.C is when 'P' => Treat_Categorization_Errors_As_Warnings := True; + Ptr := Ptr + 1; -- -gnates=file (specify extra file switches for gnat2why) @@ -808,8 +816,8 @@ package body Switch.C is -- -gnateu (unrecognized y,V,w switches) when 'u' => - Ptr := Ptr + 1; Ignore_Unrecognized_VWY_Switches := True; + Ptr := Ptr + 1; -- -gnateV (validity checks on parameters) @@ -1154,12 +1162,6 @@ package body Switch.C is Suppress_Options.Overflow_Mode_Assertions := Strict; end if; - -- -gnatP (periodic poll) - - when 'P' => - Ptr := Ptr + 1; - Polling_Required := True; - -- -gnatq (don't quit) when 'q' => diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb index cd7cbef..316d35e 100644 --- a/gcc/ada/table.adb +++ b/gcc/ada/table.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads index e8cbe81..8d1b8d7 100644 --- a/gcc/ada/table.ads +++ b/gcc/ada/table.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 9e15710..0be05ae 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -655,12 +655,6 @@ package body Targparm is Opt.Partition_Elaboration_Policy_Sloc := System_Location; goto Line_Loop_Continue; - -- Polling (On) - - elsif Looking_At_Skip ("pragma Polling (On);") then - Opt.Polling_Required := True; - goto Line_Loop_Continue; - -- Queuing Policy elsif Looking_At_Skip ("pragma Queuing_Policy (") then diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index 7f98a1d..60b2367 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -101,9 +101,6 @@ package Targparm is -- policy name, and Opt.Task_Dispatching_Policy_Sloc is set to -- System_Location. - -- If a pragma Polling (On) appears, then the flag Opt.Polling_Required - -- is set to True. - -- If a pragma Detect_Blocking appears, then the flag Opt.Detect_Blocking -- is set to True. diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index e76b138..ee1b3ba 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -264,6 +264,9 @@ package body Treepr is Lid : Int; begin + Push_Output; + Set_Standard_Output; + if L < 0 then Lid := L; @@ -292,6 +295,7 @@ package body Treepr is -- Now output the list Print_Tree_List (List_Id (Lid)); + Pop_Output; end pl; -------- @@ -300,6 +304,9 @@ package body Treepr is procedure pn (N : Union_Id) is begin + Push_Output; + Set_Standard_Output; + case N is when List_Low_Bound .. List_High_Bound - 1 => pl (Int (N)); @@ -332,6 +339,8 @@ package body Treepr is Write_Int (Int (N)); Write_Eol; end case; + + Pop_Output; end pn; -------- @@ -869,6 +878,8 @@ package body Treepr is ---------------- procedure Print_Init is + Max_Hash_Entries : constant Nat := + Approx_Num_Nodes_And_Entities + Num_Lists + Num_Elists; begin Printing_Descendants := True; Write_Eol; @@ -877,7 +888,7 @@ package body Treepr is -- the maximum possible number of entries, so that the hash table -- cannot get significantly overloaded. - Hash_Table_Len := (150 * (Num_Nodes + Num_Lists + Num_Elists)) / 100; + Hash_Table_Len := (150 * Max_Hash_Entries) / 100; Hash_Table := new Hash_Table_Type (0 .. Hash_Table_Len - 1); for J in Hash_Table'Range loop diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads index 88542c8..ebd02b3 100644 --- a/gcc/ada/ttypes.ads +++ b/gcc/ada/ttypes.ads @@ -130,6 +130,12 @@ package Ttypes is Get_Targ.Width_From_Size (Standard_Long_Long_Integer_Size); + Standard_Long_Long_Long_Integer_Size : Pos := + Set_Targ.Long_Long_Long_Size; + Standard_Long_Long_Long_Integer_Width : Pos := + Get_Targ.Width_From_Size + (Standard_Long_Long_Long_Integer_Size); + Standard_Short_Float_Size : constant Pos := Set_Targ.Float_Size; Standard_Short_Float_Digits : constant Pos := @@ -176,8 +182,10 @@ package Ttypes is System_Address_Size : constant Pos := Set_Targ.Pointer_Size; -- System.Address'Size (also size of all thin pointers) - System_Max_Binary_Modulus_Power : constant Pos := - Standard_Long_Long_Integer_Size; + System_Max_Integer_Size : Pos := Standard_Long_Long_Long_Integer_Size; + + System_Max_Binary_Modulus_Power : Pos := + Standard_Long_Long_Long_Integer_Size; System_Max_Nonbinary_Modulus_Power : constant Pos := Standard_Integer_Size; diff --git a/gcc/ada/types.adb b/gcc/ada/types.adb index 732e070..a6d829e 100644 --- a/gcc/ada/types.adb +++ b/gcc/ada/types.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 6a1d94d..175ffb2 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -265,97 +259,86 @@ package Types is -- These types are represented as integer indices into various tables. -- However, they should be treated as private, except in a few documented - -- cases. In particular it is never appropriate to perform arithmetic - -- operations using these types. + -- cases. In particular it is usually inappropriate to perform arithmetic + -- operations using these types. One exception is in computing hash + -- functions of these types. -- In most contexts, the strongly typed interface determines which of these -- types is present. However, there are some situations (involving untyped -- traversals of the tree), where it is convenient to be easily able to -- distinguish these values. The underlying representation in all cases is -- an integer type Union_Id, and we ensure that the range of the various - -- possible values for each of the above types is disjoint so that this - -- distinction is possible. + -- possible values for each of the above types is disjoint (except that + -- List_Id and Node_Id overlap at Empty) so that this distinction is + -- possible. -- Note: it is also helpful for debugging purposes to make these ranges -- distinct. If a bug leads to misidentification of a value, then it will -- typically result in an out of range value and a Constraint_Error. + -- The range of Node_Id is most of the nonnegative integers. The other + -- ranges are negative. Uint has a very large range, because a substantial + -- part of this range is used to store direct values; see Uintp for + -- details. The other types have 100 million values, which should be + -- plenty. + type Union_Id is new Int; -- The type in the tree for a union of possible ID values - List_Low_Bound : constant := -100_000_000; + -- Following are the Low and High bounds of the various ranges. + + List_Low_Bound : constant := -099_999_999; -- The List_Id values are subscripts into an array of list headers which - -- has List_Low_Bound as its lower bound. This value is chosen so that all - -- List_Id values are negative, and the value zero is in the range of both - -- List_Id and Node_Id values (see further description below). + -- has List_Low_Bound as its lower bound. List_High_Bound : constant := 0; - -- Maximum List_Id subscript value. This allows up to 100 million list Id - -- values, which is in practice infinite, and there is no need to check the - -- range. The range overlaps the node range by one element (with value - -- zero), which is used both for the Empty node, and for indicating no - -- list. The fact that the same value is used is convenient because it - -- means that the default value of Empty applies to both nodes and lists, - -- and also is more efficient to test for. + -- Maximum List_Id subscript value. The ranges of List_Id and Node_Id + -- overlap by one element (with value zero), which is used both for the + -- Empty node, and for No_List. The fact that the same value is used is + -- convenient because it means that the default value of Empty applies to + -- both nodes and lists, and also is more efficient to test for. Node_Low_Bound : constant := 0; -- The tree Id values start at zero, because we use zero for Empty (to - -- allow a zero test for Empty). Actual tree node subscripts start at 0 - -- since Empty is a legitimate node value. + -- allow a zero test for Empty). - Node_High_Bound : constant := 099_999_999; - -- Maximum number of nodes that can be allocated is 100 million, which - -- is in practice infinite, and there is no need to check the range. + Node_High_Bound : constant := + (if Standard'Address_Size = 32 then 299_999_999 else 1_999_999_999); - Elist_Low_Bound : constant := 100_000_000; + Elist_Low_Bound : constant := -199_999_999; -- The Elist_Id values are subscripts into an array of elist headers which -- has Elist_Low_Bound as its lower bound. - Elist_High_Bound : constant := 199_999_999; - -- Maximum Elist_Id subscript value. This allows up to 100 million Elists, - -- which is in practice infinite and there is no need to check the range. + Elist_High_Bound : constant := -100_000_000; - Elmt_Low_Bound : constant := 200_000_000; + Elmt_Low_Bound : constant := -299_999_999; -- Low bound of element Id values. The use of these values is internal to -- the Elists package, but the definition of the range is included here -- since it must be disjoint from other Id values. The Elmt_Id values are -- subscripts into an array of list elements which has this as lower bound. - Elmt_High_Bound : constant := 299_999_999; - -- Upper bound of Elmt_Id values. This allows up to 100 million element - -- list members, which is in practice infinite (no range check needed). + Elmt_High_Bound : constant := -200_000_000; - Names_Low_Bound : constant := 300_000_000; - -- Low bound for name Id values + Names_Low_Bound : constant := -399_999_999; - Names_High_Bound : constant := 399_999_999; - -- Maximum number of names that can be allocated is 100 million, which is - -- in practice infinite and there is no need to check the range. + Names_High_Bound : constant := -300_000_000; - Strings_Low_Bound : constant := 400_000_000; - -- Low bound for string Id values + Strings_Low_Bound : constant := -499_999_999; - Strings_High_Bound : constant := 499_999_999; - -- Maximum number of strings that can be allocated is 100 million, which - -- is in practice infinite and there is no need to check the range. + Strings_High_Bound : constant := -400_000_000; - Ureal_Low_Bound : constant := 500_000_000; - -- Low bound for Ureal values + Ureal_Low_Bound : constant := -599_999_999; - Ureal_High_Bound : constant := 599_999_999; - -- Maximum number of Ureal values stored is 100_000_000 which is in - -- practice infinite so that no check is required. + Ureal_High_Bound : constant := -500_000_000; - Uint_Low_Bound : constant := 600_000_000; + Uint_Low_Bound : constant := -2_100_000_000; -- Low bound for Uint values - Uint_Table_Start : constant := 2_000_000_000; + Uint_Table_Start : constant := -699_999_999; -- Location where table entries for universal integers start (see -- Uintp spec for details of the representation of Uint values). - Uint_High_Bound : constant := 2_099_999_999; - -- The range of Uint values is very large, since a substantial part - -- of this range is used to store direct values, see Uintp for details. + Uint_High_Bound : constant := -600_000_000; -- The following subtype definitions are used to provide convenient names -- for membership tests on Int values to see what data type range they diff --git a/gcc/ada/types.h b/gcc/ada/types.h index e7eeae0..76cf950 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -150,30 +150,32 @@ typedef int Union_Id; /* Range definitions for Tree Data: */ -#define List_Low_Bound -100000000 +#define List_Low_Bound -99999999 #define List_High_Bound 0 #define Node_Low_Bound 0 -#define Node_High_Bound 99999999 +#define Node_High_Bound 1999999999 +/* Above is the correct value of Node_High_Bound for 64-bit machines. It is + wrong for 32-bit machines, but that doesn't matter. */ -#define Elist_Low_Bound 100000000 -#define Elist_High_Bound 199999999 +#define Elist_Low_Bound -199999999 +#define Elist_High_Bound -100000000 -#define Elmt_Low_Bound 200000000 -#define Elmt_High_Bound 299999999 +#define Elmt_Low_Bound -299999999 +#define Elmt_High_Bound -200000000 -#define Names_Low_Bound 300000000 -#define Names_High_Bound 399999999 +#define Names_Low_Bound -399999999 +#define Names_High_Bound -300000000 -#define Strings_Low_Bound 400000000 -#define Strings_High_Bound 499999999 +#define Strings_Low_Bound -499999999 +#define Strings_High_Bound -400000000 -#define Ureal_Low_Bound 500000000 -#define Ureal_High_Bound 599999999 +#define Ureal_Low_Bound -599999999 +#define Ureal_High_Bound -500000000 -#define Uint_Low_Bound 600000000 -#define Uint_Table_Start 2000000000 -#define Uint_High_Bound 2099999999 +#define Uint_Low_Bound -2100000000 +#define Uint_Table_Start -699999999 +#define Uint_High_Bound -600000000 SUBTYPE (List_Range, Int, List_Low_Bound, List_High_Bound) SUBTYPE (Node_Range, Int, Node_Low_Bound, Node_High_Bound) diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 5f479b4..10adaaa 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -49,7 +43,7 @@ package body Uintp is Uint_Int_Last : Uint; -- Uint value containing Int'Last value set by Initialize - UI_Power_2 : array (Int range 0 .. 64) of Uint; + UI_Power_2 : array (Int range 0 .. 128) of Uint; -- This table is used to memoize exponentiations by powers of 2. The Nth -- entry, if set, contains the Uint value 2**N. Initially UI_Power_2_Set -- is zero and only the 0'th entry is set, the invariant being that all @@ -58,7 +52,7 @@ package body Uintp is UI_Power_2_Set : Nat; -- Number of entries set in UI_Power_2; - UI_Power_10 : array (Int range 0 .. 64) of Uint; + UI_Power_10 : array (Int range 0 .. 128) of Uint; -- This table is used to memoize exponentiations by powers of 10 in the -- same manner as described above for UI_Power_2. @@ -1317,9 +1311,9 @@ package body Uintp is -- Cases which can be done by table lookup - elsif Right <= Uint_64 then + elsif Right <= Uint_128 then - -- 2**N for N in 2 .. 64 + -- 2**N for N in 2 .. 128 if Left = Uint_2 then declare @@ -1339,7 +1333,7 @@ package body Uintp is return UI_Power_2 (Right_Int); end; - -- 10**N for N in 2 .. 64 + -- 10**N for N in 2 .. 128 elsif Left = Uint_10 then declare diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index 652145e..648ee31 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -73,6 +67,7 @@ package Uintp is Uint_63 : constant Uint; Uint_64 : constant Uint; Uint_80 : constant Uint; + Uint_127 : constant Uint; Uint_128 : constant Uint; Uint_Minus_1 : constant Uint; @@ -479,6 +474,7 @@ private Uint_63 : constant Uint := Uint (Uint_Direct_Bias + 63); Uint_64 : constant Uint := Uint (Uint_Direct_Bias + 64); Uint_80 : constant Uint := Uint (Uint_Direct_Bias + 80); + Uint_127 : constant Uint := Uint (Uint_Direct_Bias + 127); Uint_128 : constant Uint := Uint (Uint_Direct_Bias + 128); Uint_Minus_1 : constant Uint := Uint (Uint_Direct_Bias - 1); diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb index 203d1c7..a9b9947 100644 --- a/gcc/ada/uname.adb +++ b/gcc/ada/uname.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/uname.ads b/gcc/ada/uname.ads index 2a55c84..a7ede02 100644 --- a/gcc/ada/uname.ads +++ b/gcc/ada/uname.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb index 31151c5..f45f261 100644 --- a/gcc/ada/urealp.adb +++ b/gcc/ada/urealp.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads index 394bfed..5c511ef 100644 --- a/gcc/ada/urealp.ads +++ b/gcc/ada/urealp.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 2afd3fc..f986484 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -378,11 +378,6 @@ begin Write_Switch_Char ("p"); Write_Line ("Suppress all checks"); - -- Line for -gnatP switch - - Write_Switch_Char ("P"); - Write_Line ("Generate periodic calls to System.Polling.Poll"); - -- Line for -gnatq switch Write_Switch_Char ("q"); diff --git a/gcc/ada/vast.adb b/gcc/ada/vast.adb index 87de26e..16519c8 100644 --- a/gcc/ada/vast.adb +++ b/gcc/ada/vast.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/vast.ads b/gcc/ada/vast.ads index 01dfbfd..5c8226a 100644 --- a/gcc/ada/vast.ads +++ b/gcc/ada/vast.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/widechar.adb b/gcc/ada/widechar.adb index 3d3ebaf..0c31b75 100644 --- a/gcc/ada/widechar.adb +++ b/gcc/ada/widechar.adb @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- diff --git a/gcc/ada/widechar.ads b/gcc/ada/widechar.ads index f81a19b..b0b593e 100644 --- a/gcc/ada/widechar.ads +++ b/gcc/ada/widechar.ads @@ -13,16 +13,10 @@ -- 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/>. -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- |